c1cd201 · Idris-dev · git.iko.soy

.gitignore+1

@@ -2,6 +2,7 @@ dist

22cabal-dev/

33.cabal-sandbox

44cabal.sandbox.config

5+cabal.config

56.hsenv

67*.ibc

78*.o

CHANGELOG+15

@@ -1,6 +1,10 @@

11New in 0.9.18:

22--------------

3+* GHC 7.10 compatibility

4+* Add support for bundled toolchains.

35* Strings are now UTF8 encoded in the default back end

6+* Idris source files are now assumed to be in UTF8, regardless of locale

7+ settings.

48* Some reorganisation of primitives:

59 + Buffer and BitVector primitives have been removed (they were not

610 tested sufficiently, and lack a maintainer)

@@ -21,6 +25,17 @@ New in 0.9.18:

2125 requiring a separate lemma.

2226* Case alternatives are allowed to be impossible:

2327 case Vect.Nil {a=Nat} of { (x::xs) impossible ; [] => True }

28+* The default Semigroup and Monoid instances for Maybe are now prioritised

29+ choice, keeping the first success as Alternative does. The version that

30+ collects successes is now a named instance.

31+* :exec REPL command now takes an optional expression to compile and run/show

32+* The return types of `Vect.findIndex`, `Vect.elemIndex` and

33+ `Vect.elemIndexBy` were changed from `Maybe Nat` to `Maybe (Fin n)`

34+* A new :browse command shows the contents of a namespace

35+* `{n} is syntax for a quotation of the reflected representation of the name

36+ "n". If "n" is lexically bound, then the resulting quotation will be for it,

37+ whereas if it is not, then it will succeed with a quotation of the unique

38+ global name that matches.

2439

2540New in 0.9.17:

2641--------------

CONTRIBUTORS+2

@@ -17,6 +17,7 @@ Google

1717Cezar Ionescu

1818Irene Knapp

1919Paul Koerbitz

20+Niklas Larsson

2021Shea Levy

2122Mathnerd314

2223Hannes Mehnert

@@ -32,6 +33,7 @@ Adam Sandberg Eriksson

3233Seo Sanghyeon

3334Benjamin Saunders

3435Alexander Shabalin

36+JP Smith

3537startling

3638Chetan T

3739Matúš Tejiščák

Setup.hs+24−7

@@ -62,7 +62,7 @@ execOnly flags =

6262 case lookup (FlagName "execonly") (S.configConfigurationsFlags flags) of

6363 Just True -> True

6464 Just False -> False

65− Nothing -> True

65+ Nothing -> False

6666

6767isRelease :: S.ConfigFlags -> Bool

6868isRelease flags =

@@ -137,17 +137,33 @@ generateTargetModule verbosity dir targetDir = do

137137 ++ " dir <- getDataDir\n"

138138 ++ " return (dir ++ \"/\" ++ name)"

139139

140+-- a module that has info about existence and location of a bundled toolchain

141+generateToolchainModule verbosity srcDir toolDir = do

142+ let commonContent = "module Tools_idris where\n\n"

143+ let toolContent = case toolDir of

144+ Just dir -> "hasBundledToolchain = True\n" ++

145+ "getToolchainDir = \"" ++ dir ++ "\"\n"

146+ Nothing -> "hasBundledToolchain = False\n" ++

147+ "getToolchainDir = \"\""

148+ let toolPath = srcDir </> "Tools_idris" Px.<.> "hs"

149+ createDirectoryIfMissingVerbose verbosity True srcDir

150+ rewriteFile toolPath (commonContent ++ toolContent)

140151

141152idrisConfigure _ flags _ local = do

142− configureRTS

143− generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))

144− when (isFreestanding $ configFlags local) (do

145− targetDir <- lookupEnv "IDRIS_INSTALL_DIR"

153+ configureRTS

154+ generateVersionModule verbosity (autogenModulesDir local) (isRelease (configFlags local))

155+ if (isFreestanding $ configFlags local)

156+ then (do

157+ toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR"

158+ generateToolchainModule verbosity (autogenModulesDir local) toolDir

159+ targetDir <- lookupEnv "IDRIS_LIB_DIR"

146160 case targetDir of

147161 Just d -> generateTargetModule verbosity (autogenModulesDir local) d

148162 Nothing -> error $ "Trying to build freestanding without a target directory."

149− ++ " Set it by defining IDRIS_INSTALL_DIR.")

150− where

163+ ++ " Set it by defining IDRIS_LIB_DIR.")

164+ else

165+ generateToolchainModule verbosity (autogenModulesDir local) Nothing

166+ where

151167 verbosity = S.fromFlag $ S.configVerbosity flags

152168 version = pkgVersion . package $ localPkgDescr local

153169

@@ -162,6 +178,7 @@ idrisPreSDist args flags = do

162178 let verb = S.fromFlag (S.sDistVerbosity flags)

163179 generateVersionModule verb ("src") True

164180 generateTargetModule verb "src" "./libs"

181+ generateToolchainModule verb "src" Nothing

165182 preSDist simpleUserHooks args flags

166183

167184idrisPostSDist args flags desc lbi = do

codegen/idris-c/Main.hs+4−1

@@ -14,6 +14,8 @@ import Control.Monad

1414

1515import Paths_idris

1616

17+import Util.System

18+

1719data Opts = Opts { inputs :: [FilePath],

1820 interface :: Bool,

1921 output :: FilePath }

@@ -31,7 +33,8 @@ getOpts = do xs <- getArgs

3133 process opts [] = opts

3234

3335c_main :: Opts -> Idris ()

34−c_main opts = do elabPrims

36+c_main opts = do runIO setupBundledCC

37+ elabPrims

3538 loadInputs (inputs opts) Nothing

3639 mainProg <- if interface opts

3740 then liftM Just elabMain

contribs/gtksourceview-2.0-language-spec/idris.langdeleted−254

@@ -1,254 +0,0 @@

1−<?xml version="1.0" encoding="UTF-8"?>

2−<!--

3−

4− Author: Dominic Mulligan

6−

7− Lexemes taken from src/Idris/Parser.hs.

8−

9− Based on the gtksourceview-2.0 Haskell style by:

10−

11− Authors: Duncan Coutts, Anders Carlsson

14−

15− This library is free software; you can redistribute it and/or

16− modify it under the terms of the GNU Library General Public

17− License as published by the Free Software Foundation; either

18− version 2 of the License, or (at your option) any later version.

19−

20− This library is distributed in the hope that it will be useful,

21− but WITHOUT ANY WARRANTY; without even the implied warranty of

22− MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

23− Library General Public License for more details.

24−

25− You should have received a copy of the GNU Library General Public

26− License along with this library; if not, write to the

27− Free Software Foundation, Inc., 59 Temple Place - Suite 330,

28− Boston, MA 02111-1307, USA.

29−

30−-->

31−<language id="idris" _name="Idris" version="2.0" _section="Sources">

32− <metadata>

33− <property name="mimetypes">text/x-idris</property>

34− <property name="globs">*.idr</property>

35− </metadata>

36−

37− <styles>

38− <style id="preprocessor" _name="Preprocessor" map-to="def:preprocessor"/>

39− <style id="comment" _name="Comment" map-to="def:comment"/>

40− <style id="variable" _name="Variable" />

41− <style id="symbol" _name="Symbol" />

42− <style id="keyword" _name="Keyword" map-to="def:keyword"/>

43− <style id="tactic" _name="Tactic" map-to="def:keyword"/>

44− <style id="type" _name="Data Type" map-to="def:type"/>

45− <style id="string" _name="String" map-to="def:string"/>

46− <style id="character" _name="Character" map-to="def:character"/>

47− <style id="char-escape" _name="Escaped Character" map-to="def:special-char"/>

48− <style id="decimal" _name="Decimal" map-to="def:decimal"/>

49− <style id="float" _name="Float" map-to="def:floating-point"/>

50− </styles>

51−

52− <definitions>

53− <define-regex id="symbolchar">[!#$%&*+./>=<?@:\\^|~-]</define-regex>

54−

55− <context id="line-comment" style-ref="comment" end-at-line-end="true" class="comment" class-disabled="no-spell-check">

56− <start>(?<!\%{symbolchar})--+(?!\%{symbolchar})</start>

57− <include>

58− <context ref="def:in-comment"/>

59− <context ref="haddock:line-paragraph"/>

60− <context ref="haddock:directive"/>

61− </include>

62− </context>

63−

64− <context id="block-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">

65− <start>\{-</start>

66− <end>-\}</end>

67− <include>

68− <context ref="def:in-comment"/>

69− <context ref="haddock:block-paragraph"/>

70− <context ref="haddock:directive"/>

71− <context ref="block-comment"/>

72− </include>

73− </context>

74−

75− <context id="variable" style-ref="variable">

76− <match>\b[a-z_][0-9a-zA-Z_'#]*</match>

77− </context>

78−

79− <context id="type-or-constructor" style-ref="type">

80− <match>\b[A-Z][0-9a-zA-Z._'#]*</match>

81− </context>

82−

83− <context id="symbol" style-ref="symbol" extend-parent="false">

84− <match>\%{symbolchar}+</match>

85− </context>

86−

87− <context id="keysymbol" style-ref="keyword">

88− <prefix>(?<!\%{symbolchar})</prefix>

89− <suffix>(?!\%{symbolchar})</suffix>

90− <keyword>\.</keyword>

91− <keyword>:</keyword>

92− <keyword>%</keyword>

93− <keyword>=</keyword>

94− <keyword>\|</keyword>

95− <keyword>\</keyword>

96− <keyword>-></keyword>

97− <keyword>@</keyword>

98− <keyword>~</keyword>

99− <keyword>=></keyword>

100− <keyword></keyword>

101− <keyword>\_\|\_</keyword>

102− <keyword>\*\*</keyword>

103− </context>

104−

105− <define-regex id="escaped-character" extended="true">

106− \\( # leading backslash

107− [abfnrtv\\"\'&] | # escaped character

108− [0-9]+ | # decimal digits

109− o[0-7]+ | # 'o' followed by octal digits

110− x[0-9A-Fa-f]+ | # 'x' followed by hex digits

111− \^[A-Z@\[\\\]^_] | # control character codes

112− NUL | SOH | STX | ETX | EOT | ENQ | ACK |

113− BEL | BS | HT | LF | VT | FF | CR | SO |

114− SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK |

115− SYN | ETB | CAN | EM | SUB | ESC | FS | GS |

116− RS | US | SP | DEL # control char names

117− )

118− </define-regex>

119−

120− <context id="string" style-ref="string" end-at-line-end="true" class="string" class-disabled="no-spell-check">

121− <start>"</start>

122− <end>"</end>

123− <include>

124− <context ref="def:line-continue"/>

125− <context style-ref="char-escape">

126− <match>\%{escaped-character}</match>

127− </context>

128− </include>

129− </context>

130−

131− <context id="char" style-ref="character" end-at-line-end="true">

132− <start>'</start>

133− <end>'</end>

134− <include>

135− <context style-ref="char-escape" once-only="true">

136− <match>\%{escaped-character}</match>

137− </context>

138− <context once-only="true" extend-parent="false">

139− <match>.</match>

140− </context>

141− <context style-ref="def:error" extend-parent="false">

142− <match>.</match>

143− </context>

144− </include>

145− </context>

146−

147− <context id="float" style-ref="float">

148− <match extended="true">

149− [0-9]+ \. [0-9]+ ([eE][+-]?[0-9]+)?

150− | [0-9]+ [eE][+-]?[0-9]+

151− </match>

152− </context>

153−

154− <context id="decimal" style-ref="decimal">

155− <match>[0-9]+</match>

156− </context>

157−

158− <context id="keyword" style-ref="keyword">

159− <keyword>Set</keyword>

160− <keyword>case</keyword>

161− <keyword>class</keyword>

162− <keyword>data</keyword>

163− <keyword>default</keyword>

164− <keyword>do</keyword>

165− <keyword>record</keyword>

166− <keyword>foreign</keyword>

167− <keyword>lib</keyword>

168− <keyword>link</keyword>

169− <keyword>include</keyword>

170− <keyword>hide</keyword>

171− <keyword>freeze</keyword>

172− <keyword>access</keyword>

173− <keyword>logging</keyword>

174− <keyword>abstract</keyword>

175− <keyword>public</keyword>

176− <keyword>private</keyword>

177− <keyword>namespace</keyword>

178− <keyword>syntax</keyword>

179− <keyword>term</keyword>

180− <keyword>pattern</keyword>

181− <keyword>params</keyword>

182− <keyword>import</keyword>

183− <keyword>using</keyword>

184− <keyword>in</keyword>

185− <keyword>infix</keyword>

186− <keyword>infixl</keyword>

187− <keyword>infixr</keyword>

188− <keyword>prefix</keyword>

189− <keyword>instance</keyword>

190− <keyword>let</keyword>

191− <keyword>module</keyword>

192− <keyword>of</keyword>

193− <keyword>if</keyword>

194− <keyword>else</keyword>

195− <keyword>then</keyword>

196− <keyword>where</keyword>

197− <keyword>with</keyword>

198− <keyword>type</keyword>

199− <keyword>proof</keyword>

200− <keyword>tactics</keyword>

201− <keyword>static</keyword>

202− <keyword>impossible</keyword>

203− <keyword>total</keyword>

204− <keyword>assert_total</keyword>

205− </context>

206−

207− <context id="tactic" style-ref="tactic">

208− <keyword>rewrite</keyword>

209− <keyword>exact</keyword>

210− <keyword>intros</keyword>

211− <keyword>intro</keyword>

212− <keyword>refine</keyword>

213− <keyword>trivial</keyword>

214− <keyword>focus</keyword>

215− <keyword>try</keyword>

216− <keyword>compute</keyword>

217− <keyword>solve</keyword>

218− <keyword>attack</keyword>

219− <keyword>Refl</keyword>

220− <keyword>state</keyword>

221− <keyword>term</keyword>

222− <keyword>undo</keyword>

223− <keyword>qed</keyword>

224− <keyword>abandon</keyword>

225− </context>

226−

227− <context id="body">

228− <include>

229− <context ref="line-comment"/>

230− <context ref="block-comment"/>

231− <context ref="keyword"/>

232− <context ref="tactic" />

233− <context ref="variable"/>

234− <context ref="type-or-constructor"/>

235− <context ref="keysymbol"/>

236− <context ref="symbol"/>

237− <context ref="string"/>

238− <context ref="char"/>

239− <context ref="float"/>

240− <context ref="decimal"/>

241− </include>

242− </context>

243−

244− <context id="idris" class="no-spell-check">

245− <include>

246− <context ref="c:if0-comment"/>

247− <context ref="c:include"/>

248− <context ref="c:preprocessor"/>

249− <context ref="body"/>

250− </include>

251− </context>

252−

253− </definitions>

254−</language>

contribs/idriscasesplit.vimdeleted−100

@@ -1,100 +0,0 @@

1−function IdrisReload()

2− let file = expand("%")

3− let tc = system("idris --client :l " . file)

4− if (! (tc is ""))

5− echo tc

6− endif

7− return tc

8−endfunction

9−

10−function IdrisShowType()

11− w

12− let word = expand("<cword>")

13− let tc = IdrisReload()

14− if (! (tc is ""))

15− echo tc

16− else

17− let ty = system("idris --client :t " . word)

18− echo ty

19− endif

20− return tc

21−endfunction

22−

23−function IdrisCaseSplit()

24− let view = winsaveview()

25− w

26− let cline = line(".")

27− let word = expand("<cword>")

28− let tc = IdrisReload()

29−

30− if (tc is "")

31− let fn = "idris --client :cs! " . cline . " " . word

32− let result = system(fn)

33− if (! (result is ""))

34− echo result

35− else

36− e

37− call winrestview(view)

38− endif

39− endif

40−endfunction

41−

42−function IdrisMakeWith()

43− let view = winsaveview()

44− w

45− let cline = line(".")

46− let word = expand("<cword>")

47− let tc = IdrisReload()

48−

49− if (tc is "")

50− let fn = "idris --client :mw! " . cline . " " . word

51− let result = system(fn)

52− if (! (result is ""))

53− echo result

54− else

55− e

56− call winrestview(view)

57− call search("_")

58− endif

59− endif

60−endfunction

61−

62−function IdrisAddClause()

63− let view = winsaveview()

64− w

65− let cline = line(".")

66− let word = expand("<cword>")

67− let tc = IdrisReload()

68−

69− if (tc is "")

70− let fn = "idris --client :ac! " . cline . " " . word

71− let result = system(fn)

72− if (! (result is ""))

73− echo result

74− else

75− e

76− call winrestview(view)

77− call search(word)

78−

79− endif

80− endif

81−endfunction

82−

83−function IdrisEval()

84− let tc = IdrisReload()

85− if (tc is "")

86− let expr = input ("Expression: ")

87− let fn = "idris --client '" . expr . "'"

88− let result = system(fn)

89− echo result

90− endif

91− echo ""

92−endfunction

93−

94−map <LocalLeader>t :call IdrisShowType()<ENTER>

95−map <LocalLeader>r :call IdrisReload()<ENTER>

96−map <LocalLeader>c :call IdrisCaseSplit()<ENTER>

97−map <LocalLeader>d ?:<ENTER>b:call IdrisAddClause()<ENTER>w

98−map <LocalLeader>w 0:call IdrisMakeWith()<ENTER>

99−map <LocalLeader>e :call IdrisEval()<ENTER>

100−

contribs/idrislang.stydeleted−159

@@ -1,159 +0,0 @@

1−%% --------------------------------------------------- [ Idris Styling Package ]

2−%%

3−%% A set of LaTeX macros and styling for working with Idris in LaTeX

4−%%

5−%% + Provides a listings bindings:

6−%% + idris :: default ascii

7−%% + literateidris :: convert ascii maths to math symbols.

8−%% + Defines a `numbers', `default', and `stdout' listings style.

9−%% + default :: Uses TT font for code and SF font for comments,

10−%% and indented by parident.

11−%% + numbers :: default but with numbers.

12−%% + beamer :: default minus parindent

13−%% + stdout :: for formatting stdout.

14−%% + Defines a `code' environment for typesetting idris.

15−%% + \begin{code}[...] ... \end{code}

16−%% + Defines an input command for externally defined idris files.

17−%% + \inputIdrisListing[...]{file.idr}

18−%% + Provides definitions (from Idris Compiler) for pretty-printing Idris

19−%% code using Fancy Verbatim and colour commands.

20−%% + Sets commandchars for latex commands.

21−%% + Defines commands typesetting the name Idris.

22−%% + \Idris{}

23−%% + \idris{}

24−%%

25−%% Options:

26−%% - literate :: turn on literate idris for code environments.

27−%%

28−%% ----------------------------------------------------------- [ Begin Package ]

29−\ProvidesPackage{idrislang}

30−

31−\RequirePackage{ifthen}

32−\RequirePackage{xcolor}

33−\RequirePackage{fancyvrb}

34−\RequirePackage{listings}

35−\RequirePackage{xspace}

36−\RequirePackage{textcomp}

37−\RequirePackage{setspace}

38−%% ----------------------------------------------------------------- [ Options ]

39−\newboolean{literate}

40−\setboolean{literate}{false}

41−

42−\DeclareOption{literate}{%

43− \setboolean{literate}{true}

44−}

45−

46−\ProcessOptions\relax

47−

48−%% ---------------------------------------------------------------- [ Commands ]

49−\newcommand{\Idris}{\textsc{Idris}\xspace}

50−\newcommand{\idris}{\textsc{Idris}\xspace}

51−\newcommand{\IdrisLineSpacing}{\singlespacing}

52−%% ---------------------------------------------------------- [ Color Commands ]

53−\newcommand{\IdrisData}[1]{\textcolor{red}{#1}}

54−\newcommand{\IdrisType}[1]{\textcolor{blue}{#1}}

55−\newcommand{\IdrisBound}[1]{\textcolor{magenta}{#1}}

56−\newcommand{\IdrisFunction}[1]{\textcolor{green}{#1}}

57−\newcommand{\IdrisKeyword}[1]{{\underline{#1}}}

58−\newcommand{\IdrisImplicit}[1]{{\itshape \IdrisBound{#1}}}

59−

60−\fvset{commandchars=\\\{\}}

61−

62−%% --------------------------------------------------- [ Define Idris Listings ]

63−\lstdefinelanguage{idris}{%

64− sensitive,%

65−%% ----------------------------------------------------------- [ Default Style ]

66− xleftmargin=1.5em,

67− tabsize=2,

68− upquote=true,

69− basicstyle=\ttfamily,

70− flexiblecolumns=false,

71− commentstyle=\footnotesize\sffamily,

72−%% ---------------------------------------------------------------- [ Keywords ]

73−%% From Idris Parser and idris-mode and vimscript

74− keywords={%

75− abstract, attack, case, compute, do, dsl, else, exact, focus, if,

76− import, in, infix, infixl, infixr, instance, intros, module,

77− mutual, namespace, of, let, parameters, partial, pattern, prefix,

78− private, public, refine, rewrite, solve, syntax, term, then,

79− total, trivial, try, using, where, with

80−},

81−%% ------------------------------------------------------- [ Prelude Functions ]

82− morekeywords={%

83− class, data, instance, record, dsl, postulate, default,

84− lambda, variable, index_first, index_next

85− },

86−%% ---------------------------------------------------------------- [ Comments ]

87− morecomment=[l]--,%

88− morecomment=[n]{\{-}{-\}}

89−}[keywords,comments,strings]%

90−

91−%% ---------------------------------------- [ Define Idris with Literate Stuff ]

92−\lstdefinelanguage{literateidris}[]{idris}{

93− literate= {+}{{$+$}}1

94− {/}{{$/$}}1

95− {*}{{$*$}}1

96− {=}{{$=$}}1

97− {>}{{$>$}}1

98− {<}{{$<$}}1

99− {\\}{{$\lambda$}}1

100− {\\\\}{{\char`\\\char`\\}}1

101− {->}{{$\rightarrow$}}2

102− {>=}{{$\geq$}}2

103− {<-}{{$\leftarrow$}}2

104− {<=}{{$\leq$}}2

105− {=>}{{$\Rightarrow$}}2

106− {==}{{$\equiv$}}2

107− {\ .}{{$\circ$}}2

108− {\ .\ }{{$\circ$}}2

109− {>>}{{>>}}2

110− {>>=}{{>>=}}2

111− {|}{{$\mid$}}1,

112−}

113−%% -------------------------------------------------- [ Default Listings Style ]

114−

115−\lstdefinestyle{default}{%

116− basicstyle=\ttfamily\normalsize,

117−}

118−

119−\lstdefinestyle{numbers}{%

120− numbers=left,

121− numbersep=10pt,

122− numberstyle=\footnotesize\sffamily,

123− frame=leftline

124−}

125−

126−\lstdefinestyle{stdout}{%

127− xleftmargin=\parindent,

128− tabsize=2,

129− basicstyle=\ttfamily\normalsize,

130− showstringspaces=false,

131− escapechar=^

132−}

133−

134−\lstdefinestyle{beamer}{%

135− basicstyle=\ttfamily\normalsize,

136− escapechar=^

137−}

138−

139−%% ------------------------------------------------------ [ A Code Environment ]

140−%% Replicate the existence of literate haskell code environments,

141−%% option to make pretty with numbers.

142−\lstnewenvironment{code}[1][]

143− {\ifthenelse{\boolean{literate}}{%

144− \lstset{language=literateidris}}{%

145− \lstset{language=idris}}

146− \IdrisLineSpacing{}

147− }{}

148−%% ---------------------------------------------------------- [ Input Listings ]

149−%% Command to add externally defined Idris code to the document.

150−\newcommand{\inputIdrisListing}[2][]{%

151−\begingroup

152− \ifthenelse{\boolean{literate}}{%

153− \lstset{language=literateidris}}{%

154− \lstset{language=idris}}

155− \lstinputlisting[#1]{#2}

156−\endgroup

157−}

158−\endinput

159−%% --------------------------------------------------------------------- [ EOF ]

contribs/lib/SQLite3/Makefiledeleted−15

@@ -1,15 +0,0 @@

1−# This makefile compiles the project

2−#

3−

4−.PHONY: all

5−

6−sqltest : testunit.idr Sqlite3.idr sqlite3api.o

7− idris testunit.idr -o sqltest

8−

9−sqlite3api.o : sqlite3api.c

10− gcc -I . -c sqlite3api.c

11−

12−sqlite3api.so: sqlite3api.c

13− gcc -I . -fPIC -o sqlite3api.so -shared sqlite3api.c

14−

15−all : sqltest sqlite3api.o

contribs/lib/SQLite3/Sqlexpr.idrdeleted−278

@@ -1,278 +0,0 @@

1−module Sqlexpr

2−import Prelude.List

3−

4−-----------------------------------------------------------------------------

5−-- |

6−-- Module : sqlexpr

7−-- Copyright : (c) The University of St Andrews, 2012

8−--

9−-- Implementations for SQLite query data type.

10−--

11−-----------------------------------------------------------------------------

12−

13−

14−-----------------------------------------------------------

15−-- | SQL data type

16−-----------------------------------------------------------

17−

18−data Value = VInt Int

19− | VStr String

20− | VFloat Float

21− | VCol String

22− | VNULL

23−

24−--Perhaps could extend this by adding

25−-- a dot operator to allow mapping

26−-- between table and column and

27−-- comparing different table columns.

28−

29−data Cond = Equals Value Value

30− | MkGT Value Value

31− | MkGTE Value Value

32− | MkLT Value Value

33− | MkLTE Value Value

34− | MkNULL Value

35−

36−data SelVar = Cols (List String)

37− | ALL

38−

39−data ColType = CInt String -- parsed as string "int"

40− | Varchar String

41−

42−

43−

44−mutual

45− data Clause = MkCond Cond

46− | AND Clause Clause

47− | OR Clause Clause

48− | Empty

49− | MkSQL SQL

50−

51− data condClause = SET Clause

52− | WHERE condClause Clause

53−

54− data Constr = NOTNULL

55− | UNIQUE Constr

56− | None

57− | PRIMARYKEY

58− | FOREIGNKEY

59− | CHECK

60− | DEFAULT

61−

62−

63− data SQL = SELECT SelVar SQL Clause

64− | TBL (List String)

65− | INSERT SQL (List Value)

66− | INSERTC SQL (List Value) (List Value)

67− | UPDATE SQL condClause

68− | CREATE SQL (List (Value, ColType , Constr))

69−

70−-- remember to remove these funcs later

71−-- foldr1 : (a -> a -> a) -> List a -> a

72−-- foldr1 f [x] = x

73−-- foldr1 f (x::xs) = f x (foldr1 f xs)

74−

75−

76−-- unwords' : List (List Char) -> List Char

77−-- unwords' [] = []

78−-- unwords' ws = (foldr1 addSpace ws)

79−-- where

80−-- addSpace : List Char -> List Char -> List Char

81−-- addSpace w s = w ++ (' ' :: s)

82−--

83−--

84−-- unwords : List String -> String

85−-- unwords = pack . unwords' . map unpack

86−

87−-----------------------------------------------------------

88−-- | This function replaces values with question mark

89−-- following by an index number. It then puts the value

90−-- replaced, in the list.

91−-----------------------------------------------------------

92−

93−valString : List (Maybe (Int, Value)) -> Value -> (String, List (Maybe (Int, Value)))

94−valString xs (VInt x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VInt x))])

95−valString xs (VStr x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VStr x))])

96−valString xs (VFloat x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VFloat x))])

97−valString xs (VCol n) = (n, xs)

98−

99−-----------------------------------------------------------

100−-- | This function calls valString on a list of Values

101−-- and separates the values by commas.

102−-----------------------------------------------------------

103−

104−listVal : List (Maybe (Int, Value)) -> List Value -> (String, List (Maybe (Int, Value)))

105−listVal xs [] = ("", xs)

106−listVal xs (v::vs) = let (str, newxs) = (valString xs v) in

107− let (str', newxs') = listVal newxs vs in

108− (unwords (intersperse "," (words (str) ++ words (str'))), newxs')

109−

110−-----------------------------------------------------------

111−-- | Parses the type of column to be created.

112−-----------------------------------------------------------

113−

114−getColType : List (Maybe (Int, Value)) -> ColType -> (String, List (Maybe (Int, Value)))

115−getColType xs (CInt x) = ("int", xs)

116−getColType xs (Varchar str) = ("varchar(255)", xs)

117−

118−-----------------------------------------------------------

119−-- | CREATE Constraints

120−-----------------------------------------------------------

121−

122−getConstr : List (Maybe (Int, Value)) -> Constr -> (String, List (Maybe (Int, Value)))

123−getConstr xs (NOTNULL) = ("NOT NULL", xs)

124−getConstr xs (UNIQUE constr) = ("NOT NULL UNIQUE", xs)

125−getConstr xs (PRIMARYKEY) = ("PRIMARY KEY", xs)

126−getConstr xs (FOREIGNKEY) = ("FOREIGN KEY", xs)

127−getConstr xs (CHECK) = ("CHECK", xs)

128−getConstr xs (DEFAULT) = ("DEFAULT", xs)

129−getConstr xs (None) = ("", xs)

130−

131−putBrackets : String -> String

132−putBrackets str = "(" ++ str ++ ")"

133−

134−-----------------------------------------------------------

135−-- | Used to detect a complex type in a nested SQLite query

136−-- This function is used for bracketing the nested queries.

137−-----------------------------------------------------------

138−complexType : SQL -> Bool

139−complexType (TBL tbl) = False

140−complexType (SELECT vars sql c) = True

141−

142−-----------------------------------------------------------

143−-- | Used in CREATE

144−-----------------------------------------------------------

145−

146−listValType : List (Maybe (Int, Value)) -> List (Value, ColType , Constr) -> (String, List (Maybe (Int, Value)))

147−listValType xs [] = ("", xs)

148−listValType xs ((val, types, constr) :: vs) =

149− let (str , newxs) = valString xs val in

150− let (str' , newxs') = getColType newxs types in

151− let (str'', newxs'') = getConstr newxs' constr in

152− let (finalstr, finalxs) = listValType newxs'' vs in

153− (unwords (intersperse " " (words str ++ words str' ++ words str'' ++ words finalstr)) , finalxs)

154−

155−

156−-----------------------------------------------------------

157−-- | Evaluates a conditional WHERE clause

158−-----------------------------------------------------------

159−

160−evalCond : List (Maybe (Int, Value)) -> Cond -> (String, List (Maybe (Int, Value)))

161−evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in

162− let (restring2, newxs') = valString newxs val2 in

163− (restring ++ " = " ++ restring2, newxs')

164−

165−evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in

166− let (restring2, newxs') = valString newxs val2 in

167− (restring ++ " > " ++ restring2, newxs')

168−

169−evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in

170− let (restring2, newxs') = valString newxs val2 in

171− (restring ++ " >= " ++ restring2, newxs')

172−

173−evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in

174− let (restring2, newxs') = valString newxs val2 in

175− (restring ++ " < " ++ restring2, newxs')

176−

177−evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in

178− let (restring2, newxs') = valString newxs val2 in

179− (restring ++ " =< " ++ restring2, newxs')

180−

181−evalCond xs (MkNULL val) = let (restring , newxs ) = valString xs val in

182− (restring ++ " IS NULL " , newxs)

183−

184−

185−-----------------------------------------------------------

186−-- | Evaluates clauses

187−-- Supports WHERE Clause

188−-- WHERE Clause And Another-Clause

189−-- WHERE Clause Or Another-Clause

190−-----------------------------------------------------------

191−clauseString : List (Maybe (Int, Value)) -> Clause -> (String, List (Maybe (Int, Value)))

192−

193−clauseString xs (Empty) = ("" , []) -- No condition

194−clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in

195− (condstr , newxs)

196−

197−clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

198− let (clausestr2, newxs') = clauseString newxs c2 in

199− (clausestr ++ " AND " ++ clausestr2 , newxs')

200−

201−clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

202− let (clausestr2, newxs') = clauseString newxs c2 in

203− (clausestr ++ " OR " ++ clausestr2 , newxs')

204−

205−

206−-----------------------------------------------------------

207−-- | Evaluates conditional clauses.

208−-----------------------------------------------------------

209−

210−condClauseStr : List (Maybe (Int, Value)) -> condClause -> (String, List (Maybe (Int, Value)))

211−condClauseStr xs (SET setcl) = let (condstr, newxs) = clauseString xs setcl in

212− (" SET " ++ condstr, newxs)

213−

214−condClauseStr xs (WHERE setcl1 setcl2) = let (condstr, newxs) = condClauseStr xs setcl1 in

215− let (condstr', newxs') = clauseString newxs setcl2 in

216− ( condstr ++ " WHERE " ++ condstr', newxs')

217−

218−

219−-----------------------------------------------------------

220−-- | Evaluates queries by calling the other functions

221−-- on each part of the query

222−-----------------------------------------------------------

223−evalSQL : List (Maybe (Int, Value)) -> SQL -> (String, List (Maybe (Int, Value)))

224−-- SELECT data from tbl1 where num > (SELECT num from tbl1 where num = 24)

225−-- evalSQL [] ((SELECT ALL)(TBL "tbl")(MkSQL ((SELECT ALL) (TBL "tbl")(MkCond (VCol "))))

226−-- NTBF

227−--clauseString xs (MkSQL sql) = (evalSQL xs sql)

228−

229−-- Separate list of tables

230−-- For complex type, return list returned by evalSQL

231−-- And add brackets

232−evalSQL xs (TBL tbl) = (unwords (intersperse "," ( tbl)), xs)

233−evalSQL xs (SELECT vars sql' c) =

234− let (sqlstring, newxs) = evalSQL xs sql' in

235− let (csstring, newxs') = clauseString newxs c in

236− case c of

237− Empty => case vars of

238− ALL => if complexType sql'

239− then ("SELECT " ++ "*" ++ " FROM " ++

240− putBrackets sqlstring ++ csstring, newxs)

241− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring ++

242− csstring, newxs')

243− Cols selvar => if complexType sql'

244− then ("SELECT " ++ unwords selvar ++

245− " FROM " ++ putBrackets sqlstring ++ csstring, newxs)

246− else ("SELECT " ++ unwords selvar ++ " FROM " ++ sqlstring ++

247− csstring, newxs')

248− _ => case vars of

249− ALL => if complexType sql'

250− then ("SELECT " ++ "*" ++ " FROM " ++

251− " WHERE " ++ csstring, newxs)

252− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

253− ++ " WHERE " ++ csstring, newxs')

254− Cols selvar => if complexType sql'

255− then ("SELECT " ++ (unwords selvar) ++ " FROM " ++

256− putBrackets sqlstring ++ " WHERE " ++

257− csstring , newxs)

258− else ("SELECT " ++ (unwords selvar) ++ " FROM " ++ sqlstring ++

259− " WHERE " ++ csstring, newxs')

260−

261−

262−evalSQL xs (INSERT sql vals) = let (tblname, newvals) = evalSQL xs sql in

263− let (str, newxs ) = listVal newvals vals in

264− ("INSERT INTO " ++ tblname ++ " VALUES (" ++ str ++ ")", newxs)

265−

266−evalSQL xs (INSERTC sql cols vals) = let (tblname, newvals) = evalSQL xs sql in

267− let (strcol, newcol) = listVal newvals cols in

268− let (strval, newcolval) = listVal newcol vals in

269− ("INSERT INTO " ++ tblname ++ "(" ++ strcol ++ ")" ++ "VALUES (" ++ strval ++ ")", newcolval)

270−

271−

272−evalSQL xs (UPDATE sql cl) = let (tblname, newxs) = evalSQL xs sql in

273− let (csstring, newxs') = condClauseStr newxs cl in

274− ("UPDATE " ++ tblname ++ csstring, newxs')

275−

276−evalSQL xs (CREATE sql details) = let (sqlstring, newxs) = evalSQL xs sql in

277− let (csstring, newxs') = listValType newxs details in

278− ("CREATE TABLE " ++ sqlstring ++ "(" ++ csstring ++ ")", newxs')

contribs/lib/SQLite3/Sqlite3.idrdeleted−419

@@ -1,419 +0,0 @@

1−module Sqlite3

2−import public Sqlexpr

3−

4−%lib C "sqlite3"

5−-- %link C "sqlite3.o"

6−-- %include C "sqlite3.h"

7−%link C "sqlite3api.o"

8−%include C "sqlite3api.h"

9−

10−-----------------------------------------------------------------------------

11−-- |

12−-- Module : sqlite3

13−-- Copyright : (c) The University of St Andrews, 2012

14−--

15−-- Library built on top of FFI supporting basic SQLite C/C++ Interface

16−-- functions.

17−--

18−-----------------------------------------------------------------------------

19−

20−-- | The types supported by Idris returned by the database functions.

21−

22−data DBVal = DBInt Int

23− | DBText String

24− | DBFloat Float

25− | DBNull

26−

27−-- Database pointer

28−data DBPointer = MkDBPointer Ptr

29−-- Table pointer

30−data TBPointer = MkTBPointer Ptr

31−-- Statement pointer

32−data StmtPtr = MkStmtPtr Ptr

33−

34−Table : Type

35−Table = List (List DBVal)

36−

37−-- ForMap used in to_list_v1

38−forM : Applicative f => List a -> (a -> f b) -> f (List b)

39−forM xs f = (sequence (map f xs))

40−

41−-- Neater error handling done using DB

42−data DB a = MkDB (IO (Either String a))

43−

44−instance Functor DB where

45− map f (MkDB action) = MkDB (do res <- action

46− return (map f res))

47−

48−

49−instance Applicative DB where

50− pure = MkDB . return . Right

51− (MkDB f) <*> (MkDB x) = MkDB (do f' <- f

52− case f' of

53− Left err => return (Left err)

54− Right op => x >>= (return . map op))

55−

56−

57−instance Monad DB where

58− (MkDB l) >>= k = MkDB (do c <- l

59− case c of

60− Left err => return (Left err)

61− Right v => case k v of

62− MkDB k' => k')

63− --return x = MkDB (return (Right x))

64−

65−fail : String -> DB a

66−fail err = MkDB (return (Left err))

67−

68−liftIO : IO a -> DB a

69−liftIO f = MkDB (do f' <- f

70− return (Right f'))

71−

72−ioError : String -> IO a

73−ioError err = do putStrLn err

74− return (believe_me ())

75−

76−runDB : DB a -> IO a

77−runDB (MkDB f) = do f' <- f

78− case f' of

79− Right v => return v

80− Left str => ioError str

81−

82−-----------------------------------------------------------------------------

83−-- | Opens an SQLite database file as specified by the String name argument.

84−-----------------------------------------------------------------------------

85−

86−open_db : String -> DB DBPointer

87−open_db name = do x <- liftIO (foreign FFI_C "sqlite3_open_idr" (String -> IO Ptr) name)

88− return (MkDBPointer x)

89−

90−-----------------------------------------------------------------------------

91−-- | Destructor for the DBPointer.

92−-----------------------------------------------------------------------------

93−

94−close_db : DBPointer -> DB Int

95−close_db (MkDBPointer pointer) = liftIO (foreign FFI_C "sqlite3_close_idr" (Ptr -> IO Int) pointer)

96−

97−-----------------------------------------------------------------------------

98−-- | Wrapper around prepare, step and finalize.

99−-----------------------------------------------------------------------------

100−

101−exec_db : DBPointer -> String -> DB Int

102−exec_db (MkDBPointer pointer) stmt = do

103− x <- liftIO (foreign FFI_C "sqlite3_exec_idr" (Ptr -> String -> IO Int) pointer stmt)

104− if (x == 1)

105− then fail "Could not execute."

106− else return x

107−

108−-----------------------------------------------------------------------------

109−-- | Executes a prepared query. Use of this version is recommended.

110−-----------------------------------------------------------------------------

111−

112−exec_db_v2 : StmtPtr -> DB Int

113−exec_db_v2 (MkStmtPtr pointer) = do

114− x <- liftIO (foreign FFI_C "exec_db" (Ptr -> IO Int) pointer)

115− if (x == 21)

116− then fail "No data returned."

117− else return x

118−

119−-----------------------------------------------------------------------------

120−-- | Returns the error stored in the buffer by exec_db function.

121−-- This function can only be used with exec_db and get_table.

122−-- Only these functions store any occured error in the buffer array.

123−-----------------------------------------------------------------------------

124−

125−get_error : DBPointer -> IO String

126−get_error (MkDBPointer pointer) = foreign FFI_C "sqlite3_get_error" (Ptr -> IO String) pointer

127−

128−-----------------------------------------------------------------------------

129−-- | Compiles the query inot a byte-code program in order to execute it.

130−-- Returns a pointer to a Statement pointer on a successful call.

131−-- Returns a null pointer on a failure.

132−-----------------------------------------------------------------------------

133−

134−prepare_db : DBPointer -> String -> DB StmtPtr

135−prepare_db (MkDBPointer pointer) cmd = do

136− result <- liftIO (foreign FFI_C "sqlite3_prepare_idr" (Ptr -> String -> IO Ptr) pointer cmd)

137− flag <- liftIO (nullPtr result)

138− if flag

139− then fail "Error occured while preparing"

140− else return (MkStmtPtr result)

141−

142−-----------------------------------------------------------------------------

143−-- | Returns the error stored in the buffer by exec_db function.

144−-- This function can only be used with exec_db and get_table.

145−-- Only these functions store any occured error in the buffer array.

146−-----------------------------------------------------------------------------

147−

148−step_db : StmtPtr -> DB Int

149−step_db (MkStmtPtr pointer)= do

150− x <- liftIO (foreign FFI_C "sqlite3_step_idr" (Ptr -> IO Int) pointer)

151− if (x == 101)

152− then fail "SQLITE_DONE"

153− else return x

154−

155−-----------------------------------------------------------------------------

156−-- | Deletes a prepared statement. This function must be called after

157−-- prepare function.

158−-----------------------------------------------------------------------------

159−

160−finalize_db : StmtPtr -> DB Int

161−finalize_db (MkStmtPtr pointer) = do

162− x <- liftIO (foreign FFI_C "sqlite3_finalize_idr" (Ptr -> IO Int) pointer)

163− if (x /= 0)

164− then fail "Could not finalize"

165− else return x

166−

167−-----------------------------------------------------------------------------

168−-- | Resets a prepared statement pointer back to its initial state.

169−-----------------------------------------------------------------------------

170−

171−reset_db : StmtPtr -> DB Int

172−reset_db (MkStmtPtr pointer) = do

173− x <- liftIO (foreign FFI_C "sqlite3_reset_idr" (Ptr -> IO Int) pointer)

174− if (x /= 0)

175− then fail "Could not reset"

176− else return x

177−

178−-----------------------------------------------------------------------------

179−-- | These routines obtain column information.

180−-----------------------------------------------------------------------------

181−

182−column_count : DBPointer -> IO (Either String Int)

183−column_count (MkDBPointer pointer) = do

184− x <- foreign FFI_C "sqlite3_column_count_idr" (Ptr -> IO Int) pointer

185− return $ if (x == 0)

186− then Left "No Data"

187− else (Right x)

188−

189−column_name : DBPointer -> Int -> IO String

190−column_name (MkDBPointer pointer) iCol =

191− foreign FFI_C "sqlite3_column_name_idr" (Ptr -> Int -> IO String) pointer iCol

192−

193−column_decltype : DBPointer -> Int -> IO String

194−column_decltype (MkDBPointer pointer) iCol =

195− foreign FFI_C "sqlite3_column_decltype_idr" (Ptr -> Int -> IO String) pointer iCol

196−

197−column_bytes : DBPointer -> Int -> IO Int

198−column_bytes (MkDBPointer pointer) iCol =

199− foreign FFI_C "sqlite3_column_bytes_idr" (Ptr -> Int -> IO Int) pointer iCol

200−

201−column_blob : DBPointer -> Int -> IO String

202−column_blob (MkDBPointer pointer) iCol =

203− foreign FFI_C "sqlite3_column_bytes_idr" (Ptr -> Int -> IO String) pointer iCol

204−

205−column_text : DBPointer -> Int -> IO String

206−column_text (MkDBPointer pointer) iCol =

207− foreign FFI_C "sqlite3_column_text_idr" (Ptr -> Int -> IO String) pointer iCol

208−

209−column_Int : DBPointer -> Int -> IO Int

210−column_Int (MkDBPointer pointer) iCol =

211− foreign FFI_C "sqlite3_column_int_idr" (Ptr -> Int -> IO Int) pointer iCol

212−

213−-----------------------------------------------------------------------------

214−-- | These routines support some of SQLite backup functions.

215−-----------------------------------------------------------------------------

216−

217−backup_init : DBPointer -> String -> DBPointer -> String -> IO DBPointer

218−backup_init (MkDBPointer des_pointer) destName (MkDBPointer src_pointer) srcName =

219− do x <- foreign FFI_C "sqlite3_backup_init_idr" (Ptr -> String -> Ptr -> String -> IO Ptr)

220− des_pointer destName src_pointer srcName

221− return (MkDBPointer x)

222−

223−backup_step : DBPointer -> Int -> IO Int

224−backup_step (MkDBPointer pointer) nPage =

225− foreign FFI_C "sqlite3_backup_step_idr" (Ptr -> Int -> IO Int) pointer nPage

226−

227−backup_finish : DBPointer -> IO Int

228−backup_finish (MkDBPointer pointer) =

229− foreign FFI_C "sqlite3_backup_finish_idr" (Ptr -> IO Int) pointer

230−

231−backup_remaining : DBPointer -> IO Int

232−backup_remaining (MkDBPointer pointer) =

233− foreign FFI_C "sqlite3_backup_remaining_idr" (Ptr -> IO Int) pointer

234−

235−-----------------------------------------------------------------------------

236−-- | Use of this interface is not recommended.

237−-- This function returns a result table. The functions num_row and num_col

238−-- are used to obtain the number of rows and columns.

239−-- These functions can be used to print the resulting table.

240−-----------------------------------------------------------------------------

241−

242−get_table : DBPointer -> String -> DB TBPointer

243−get_table (MkDBPointer pointer) name = do

244− x <- liftIO(foreign FFI_C "sqlite3_get_table_idr" (Ptr -> String -> IO Ptr) pointer name)

245− flag <- liftIO (nullPtr x)

246− if flag

247− then do x <- liftIO(get_error_table pointer) ; fail x

248− else return (MkTBPointer x)

249− where

250− get_error_table : Ptr-> IO String

251− get_error_table pointer = do x <- foreign FFI_C "sqlite3_get_error" (Ptr -> IO String) pointer

252− return x

253−

254−free_table : TBPointer -> IO ()

255−free_table (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_free_table_idr" (Ptr -> IO ()) pointer

256− return ()

257−

258−-----------------------------------------------------------------------------

259−-- | This version of these function obtain the row and column number

260−-- from the Table struct. These functions are only used with get_table.

261−-----------------------------------------------------------------------------

262−

263−num_row : TBPointer -> IO Int

264−num_row (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_row" (Ptr -> IO Int) pointer

265− return x

266−

267−num_col : TBPointer -> IO Int

268−num_col (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_col" (Ptr -> IO Int) pointer

269− return x

270−

271−-----------------------------------------------------------------------------

272−-- | This version of these function obtain the row and column number

273−-- from the Database struct.

274−-----------------------------------------------------------------------------

275−

276−num_row_v2 : DBPointer -> IO Int

277−num_row_v2 (MkDBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_row_v2" (Ptr -> IO Int) pointer

278− return x

279−

280−num_col_v2 : DBPointer -> IO Int

281−num_col_v2 (MkDBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_col_v2" (Ptr -> IO Int) pointer

282− return x

283−

284−-----------------------------------------------------------------------------

285−-- | This function prints the result of a query by checking the type

286−-- of each value returned, it then calls the appropriate function.

287−-- Ther result is one of the DBVal variants.

288−-----------------------------------------------------------------------------

289−

290−get_data : DBPointer -> Int -> Int -> IO DBVal

291−get_data (MkDBPointer pointer) row col = do

292− ty <- get_data_type pointer row col

293− helper ty

294− where get_data_type : Ptr ->Int -> Int -> IO Int

295− get_data_type pointer row col =

296− foreign FFI_C "sqlite3_get_data_type" (Ptr -> Int -> Int -> IO Int) pointer row col

297− get_data_val_int : Ptr -> Int -> IO Int

298− get_data_val_int pointer col =

299− foreign FFI_C "sqlite3_get_val_int" (Ptr -> Int -> IO Int) pointer col

300−

301− get_data_val_text : Ptr -> Int -> IO String

302− get_data_val_text pointer col =

303− foreign FFI_C "sqlite3_get_val_text" (Ptr -> Int -> IO String) pointer col

304−

305− get_data_val_float : Ptr -> Int -> IO Float

306− get_data_val_float pointer col =

307− foreign FFI_C "sqlite3_get_float" (Ptr -> Int -> IO Float) pointer col

308−

309− helper : Int -> IO DBVal

310− helper 1 = do i <- get_data_val_int pointer col ; return (DBInt i)

311− helper 2 = do i <- get_data_val_float pointer col ; return (DBFloat i)

312− helper 3 = do i <- get_data_val_text pointer col; return (DBText i)

313− helper _ = return DBNull

314−

315−-----------------------------------------------------------------------------

316−-- | This function makes use of get_data to get all the result.

317−-----------------------------------------------------------------------------

318−

319−toList_v1 : DBPointer -> DB Table

320−toList_v1 db = do nbR <- liftIO (num_row_v2 db)

321− nmC <- liftIO (num_col_v2 db)

322− res <- liftIO $ forM [0..(nbR-1)] $ \ i =>

323− forM [0..(nmC-1)] $ \ j => get_data db i j

324− return (the (List (List DBVal)) res)

325−

326−strcat : String -> String-> String

327−strcat str1 str2 = str1 ++ str2

328−

329−-----------------------------------------------------------------------------

330−-- | This version of toList retunrs result from get_table

331−-- This could be removed if not needed in the future.

332−-----------------------------------------------------------------------------

333−

334−--toList_v2 : String -> String -> DBPointer -> DB Table

335−--toList_v2 name stmt x = do

336−-- ptr <- (get_table x (stmt))

337−-- nbR <- liftIO (num_row ptr)

338−-- nmC <- liftIO (num_col ptr)

339−-- res <- forM [0..(nbR-1)] (\ i =>

340−-- forM [0..(nmC-1)] (\ j =>

341−-- liftIO(get_data x name i j)

342−--

343−-- )

344−-- )

345−-- liftIO (free_table ptr)

346−-- return res

347−

348−

349−-----------------------------------------------------------------------------

350−-- | These routines support binding the types supported by Idris.

351−-- These return a pointer to statement pointer since we want to allow

352−-- binding multiple values by implementing a recursive function.

353−-----------------------------------------------------------------------------

354−

355−bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

356−bind_int (MkStmtPtr pointer) indexval val = do

357− x <- liftIO (foreign FFI_C "sqlite3_bind_int_idr" (Ptr -> Int -> Int -> IO Ptr) pointer indexval val)

358− flag <- liftIO (nullPtr x)

359− if flag

360− then fail "Could not bind int."

361− else return (MkStmtPtr x)

362−

363−

364−bind_float : StmtPtr -> Int -> Float -> DB StmtPtr

365−bind_float (MkStmtPtr pointer) indexval val = do

366− x <- liftIO (foreign FFI_C "sqlite3_bind_float_idr" (Ptr -> Int -> Float -> IO Ptr) pointer indexval val)

367− flag <- liftIO (nullPtr x)

368− if flag

369− then fail "Could not bind float."

370− else return (MkStmtPtr x)

371−

372−bind_text : StmtPtr -> String -> Int -> Int -> DB StmtPtr

373−bind_text (MkStmtPtr pointer) text indexval lengthval = do

374− x <- liftIO (foreign FFI_C "sqlite3_bind_text_idr" (Ptr -> String -> Int -> Int -> IO Ptr)

375− pointer text indexval lengthval)

376− flag <- liftIO(nullPtr x)

377− if flag

378− then fail "Could not bind text."

379− else return (MkStmtPtr x)

380−

381−bind_null : StmtPtr -> Int -> DB StmtPtr

382−bind_null (MkStmtPtr pointer) indexval = do

383− x <- liftIO (foreign FFI_C "sqlite3_bind_null_idr" (Ptr -> Int -> IO Ptr) pointer indexval)

384− flag <- liftIO (nullPtr x)

385− if flag

386− then fail "Could not bind null."

387− else return (MkStmtPtr x)

388−

389−-----------------------------------------------------------------------------

390−-- | String Length

391−-----------------------------------------------------------------------------

392−

393−strlen : String -> DB Int

394−strlen str = liftIO (foreign FFI_C "strLength" (String -> IO Int) str)

395−

396−instance Show DBVal where

397− show (DBInt i) = "Int val: " ++ show i ++ "\n"

398− show (DBText i) = "Text val: " ++ show i ++ "\n"

399− show (DBFloat i) = "Float val: " ++ show i ++ "\n"

400− show (DBNull ) = "NULL"

401−

402−-----------------------------------------------------------------------------

403−-- | Multi bind a list of values.

404−-----------------------------------------------------------------------------

405−

406−bindMulti : StmtPtr-> List (Maybe (Int, Value)) -> DB StmtPtr

407−bindMulti pointer [] = return pointer

408−bindMulti pointer (Nothing :: vs) = bindMulti pointer vs

409−bindMulti pointer ((Just (indexs, (VInt i)))::vs) =

410− do x <- bind_int pointer indexs i

411− bindMulti x vs

412−bindMulti pointer ((Just (indexs, (VStr s)))::vs) =

413− do len <- strlen s

414− x <- bind_text pointer s indexs len

415− bindMulti x vs

416−bindMulti pointer ((Just (indexs, (VFloat f)))::vs) =

417− do x <- bind_float pointer indexs f

418− bindMulti x vs

419−

contribs/lib/SQLite3/newdb.dbdeleted

Binary file not shown.

contribs/lib/SQLite3/somedb.dbdeleted

Binary file not shown.

contribs/lib/SQLite3/sqlite3.texdeleted−157

@@ -1,157 +0,0 @@

1− \documentclass[11pt]{article}

2− \topmargin -1.5cm

3− \oddsidemargin -0.04cm

4− \evensidemargin -0.04cm

5− \textwidth 16.59cm

6− \textheight 21.94cm

7− %\pagestyle{empty}

8− \parskip 7.2pt

9− \parindent 0pt

10−

11− \begin{document}

12− \section{Introduction}

13−\label{Introduction}

14−This document provides overview on how the Idris library for SQLite3 works. The code base is written on top of the

15−SQLite3 C/C++ Interface.

16−This library supports some features of the low-level library, implemented in a higher level basis.

17−The library allows making use of queries as data types. The aim of this library is to avoid

18−SQL injections which are the most common security issues.

19−To avoid this we have defined a datatype which describes queries.

20−The queries are written using these data types and parsed as quoted string

21−while replacing values with \emph{indexed question mark} to be binded with the prepared statement.

22−This prevents the user from preparing the queries inappropriately by not allowing to pass

23−any types of values directly to the prepare function. However this is a design choice, the library

24−does not prevent the user from passing a String directly to the prepare function.

25−

26−\section{Using the library}

27−\label{Using the library}

28−Simple examples have been provided in the \emph{testunit.idr} file.

29−To open a database, use the open\_db function which takes the filename as a string.

30−This function implements the sqlite3\_open function.

31−This function returns a pointer to the database which can be used by other function

32−to access the database object.

33−Whether or not an error occurs when it is opened,

34−resources should be released by passing it to close\_db when it is no longer required.

35−A query can then be builts using the supported data types.

36−The library supports limited number of queries at the moment. The supported sql commands are :

37−\newline

38−

39−\textbf{SELECT,}

40−\textbf{INSERT,}

41−\textbf{UPDATE,}

42−\textbf{CREATE}

43−

44−\subsection{Creating Queries}

45−\label{Creating Queries}

46−

47−To create a query, use the evalSQL function which takes an empty list and the SQL query.

48−The routine evaluates the expression recrusively by dividing it into smaller parts,

49−filling up the list with the received values. For instance the following is a valid query:

50−

51−let sql = evalSQL [ ] ((SELECT ALL)(TBL ["tbl1"]) (MkCond (MkNULL (VCol "data"))))

52−\newline

53−\newline{This will be parsed as :}

54−\b{“SELECT * FROM tbl1 WHERE data IS NULL “}

55−

56−The evaluator returns a string and a list of indexed values.

57−The string part of the query could be parsed to prepare.

58−\emph{evalSQL} parses the query as a string replacing values with \emph{?} and an index starting from one,

59−storing them in the list given to it as an argument.

60−For example:

61−

62−

63−evalSQL [ ] (SELECT (Cols ["data"]) (SELECT (Cols["num","data"]) (TBL ["tbl1"])

64−\newline (MkCond(Equals(VCol "num")(VInt 2))))Empty))

65−

66−is passed to prepare as :

67−

68−SELECT * FROM tbl1 WHERE data = ?1 AND num = ?2 OR num = ?3

69−

70−and returns the list as follows:

71−\newline{(Just (1, VStr "data0")) ,(Just (2, VInt 1)) , (Just (3, VInt 2))}

72−

73−The values in the list are binded to the statement using bindMulti function.

74−This function takes the statement pointer returned by prepare and the list returned by evalSQL

75−and binds the values by calling the appropriate functions.

76−

77−The function exec\_db\_v2 executes the statement.

78−Note that the other version of exec\_db implements the sqlite3\_exec() interface which is a wrapper

79−around sqlite3\_prepare\_v2(), sqlite3\_step(), and sqlite3\_finalize(),

80−without having to use a lot of code, though the use of this function is not recommended in this case.

81−

82−The functions finalize\_db and close\_db must be called to clean up the open resources.

83−To print the result, the function toList\_v1 can be used which takes a DBPointer and returns

84−the resulting table.

85−

86−\subsection{More Examples}

87−\label{More Examples}

88−Nested expressions are also supported. You could write queries such as :

89−

90−evalSQL [ ] (SELECT (Cols ["data"]) (SELECT (Cols["num","data"]) (TBL ["tbl1"]) (MkCond (Equals (VCol "num")(VInt 2)))) Empty)

91−

92−Parsed as :

93−

94−SELECT data FROM (SELECT num data FROM tbl1 WHERE num = ?1)

95−

96−Note that in this example, the inner query must include the same column as the outer one otherwise this query will not validate.

97−

98−\subsection{SQL Data Type}

99−\label{SQL Data Type}

100−The SQL Data Types describe the queries that are supported by the library.

101−The implementation of these datatypes is similar to defining a grammar.

102−Data type Value consists of Int, String and Float.

103−The data type can be extended to further support queries.

104−The evaulator function makes use of smaller function to evaulate parts of the query.

105−For instance given a SELECT qeury, it calls \emph{evalSQL} to obtain the list of tables,

106−and clauseString to evaluate the rest of the expression which could include a WHERE clause or could be Empty.

107−

108−

109−\section{Evaluating Queries}

110−\label{Evaluating Queries}

111−The method used here is a divide and conquer manner which divides the query into smaller

112−parts and deals with each part and puts the results together to return a String representation

113−of the query and a list of values.

114−However this could result to a slow type checking process since it needs to go through all

115−the possibilities to type check. Maybe this can be improved?

116−

117−\subsection{evalSQL Function}

118−\label{evalSQL Function}

119−This is a recursive evaluator which makes a call to itself.

120−An SQL could consist of a SELECT ALL or Columns followed by another SQL

121−which could be a nested query or just the name of the table(s).

122−It then call the appropriate functions to evaluate the query.

123−It returns the well-quoted String expression and a list of indexed values which are passed to the bind function.

124−\section{Pointers passed to Idris functions}

125−\label{Pointers passed to Idris functions}

126−

127−The library uses FFI. In order to make the pointers passed to each function more explicit,

128−we have defined them as data types. For instance open\_db takes a String and returns a DBPointer

129−(Database Pointer) and prepare\_db

130−takes a DBPointer and returns a StmtPtr(Statemenet Pointer).

131−Error handling is done using the \emph {DB a} data type which

132−is either \emph {IO String} indicating an error or \emph{ IO a}.

133−To test the functions in main, you need to use runDB :

134−\begin{center}

135−\centering runDB : DB a $\rightarrow$ IO a

136−\end{center}

137−More examples on how to use the functions can be found in \emph{testunit.idr}

138−

139−\section{Using the C Functions}

140−\label{Using the C Functions}

141−The library includes some wrapper functions such as get\_table

142−and exec\_db. Using these functions mixed with prepare, step or finalize

143−inappropriately could cause segmentation faults.

144−Perhaps these functions could be removed from the library if no longer required in the future

145−since the main purpose of this library is to make use of data types.

146−However these functionalities could be implemented internally without calling

147−the C Interface wrapper functions.

148−

149−\section{Further improving the library}

150−\label{Further improving the library}

151−There are many features that could be added to this library. These include adding more useful SQL Commands,

152−extending the SQL datatype to support more complex queries and possibly improving \emph{evalSQL}

153−for a faster performance.

154−Another useful thing to implement is the dot operator(.) which is the member access operator to yield

155−the value of a field in a table. This enables comparing values in different tables and constructing

156−more complex queries.

157−\end{document}

contribs/lib/SQLite3/sqlite3api.cdeleted−543

@@ -1,543 +0,0 @@

1−/*

2− * sqlite3api.c

3− *

4− *

5− * Created by Melissa Farinaz MOZIFIAN on 22/06/2012.

7− *

8− */

9−

10−

11−#include "sqlite3api.h"

12−

13−

14−// buffer used for storing queries

15−// Used in high-level functions.

16−static char sql_query_buffer[2000];

17−// array used to store the string

18−//value obtain by get_val_text

19−unsigned char* array;

20−/*

21− open an SQLite database file as

22− specified by the filename argument.

23− Returns pointer to DB struct on success

24− Null on failure.

25− */

26−void* sqlite3_open_idr(const char *filename){

27−

28− sqlite3 *db;

29− int res =sqlite3_open(filename,&db);

30−

31− if(res != SQLITE_OK){

32− printf("Error occured while opening the databse.");

33− return NULL;

34− }

35− DBinfo *dbi = malloc(sizeof(DBinfo));

36− dbi->db_ptr = db;

37− return dbi;

38−

39−}

40−/*

41− Frees the resource and returns 0 on success

42− */

43−int sqlite3_close_idr(void* db){

44−

45− DBinfo* dbi =(DBinfo*) db;

46− int res =sqlite3_close(dbi->db_ptr);

47− if (res == SQLITE_OK){

48− free(dbi);

49− return 0;

50− }

51− else {

52− return res;

53− }

54−}

55−/*

56− SQLite wrapper around sqlite3_prepare_v2(),

57− sqlite3_step(), and sqlite3_finalize().

58− This version of exec cannot be used with prepare.

59− For executing queries, must use the exec_db function.

60− */

61−int sqlite3_exec_idr(void* db, const char *sql)

62−{

63− DBinfo* dbi =(DBinfo*) db;

64− char* err;

65− int rc;

66− rc = sqlite3_exec(dbi->db_ptr,sql,NULL, NULL, &err);

67− if (rc != SQLITE_OK && err != NULL) {

68− strncpy(dbi->buffer, err, sizeof(dbi->buffer));

69− sqlite3_free(err);

70− }

71− return rc;

72−}

73−/*

74− Gets the error store in the buffer

75− in the struct. Some certain functions

76− have the feature to store errors in a buffer.

77− */

78−char* sqlite3_get_error(void* db) {

79− DBinfo* dbi =(DBinfo*) db;

80− return dbi->buffer;

81−}

82−/*

83− Compiles the query into a byte-code program

84− Returns a pointer to the sqlite3_stmt pointer

85− and stores it in the struct.

86− */

87−void* sqlite3_prepare_idr(void *db,const char *zSql){

88− sqlite3_stmt* stmt;

89− const char *tail;

90−

91− DBinfo* dbi =(DBinfo*) db;

92−

93− int rec = sqlite3_prepare_v2(dbi->db_ptr,zSql,-1,&stmt,&tail);

94− dbi ->ppStmt =stmt;

95− dbi ->Ptr_tail = tail;

96−

97− if(rec != SQLITE_OK){

98− return NULL;

99− }

100− return dbi;

101−}

102−/*

103− Another wrapper interface that is preserved

104− for backwards compatibility.

105− Use of this interface is not recommended.

106− This was mainly used for testing within the

107− library.

108− */

109−void* sqlite3_get_table_idr(void* db,

110− const char *sql){

111−

112− DBinfo* dbi =(DBinfo*) db;

113− char* err;

114−

115− Table* tbl = malloc(sizeof(Table));

116− tbl->database = dbi;

117− int res = sqlite3_get_table(dbi->db_ptr,sql,&tbl->table_data,&tbl->num_row,&tbl->num_col,&err);

118− int array_size = sizeof(&tbl->table_data);

119−

120− if( res != SQLITE_OK && err != NULL){

121− strncpy(dbi->buffer, err, sizeof(dbi->buffer));

122− sqlite3_free(err);

123− return NULL;

124− }

125− tbl -> data_size = array_size;

126− return tbl;

127−}

128−

129−/*

130− This function executes queries.

131− This can be used after preparing a query

132− In case of error or library misuse

133− it returns 1.

134− It also calls step in order to obtain

135− the row and column number and stores them

136− in the struct. The row number is needed

137− later on in get_data_type function.

138− */

139−int exec_db(void*p){

140−

141− DBinfo* dbi =(DBinfo*) p;

142− int rc, col, row_counter;

143−

144− const char* col_name;

145−

146− rc = sqlite3_step(dbi->ppStmt);

147−

148− if( rc == SQLITE_DONE){

149− return rc;

150− }

151− if(rc == SQLITE_ERROR && rc == SQLITE_MISUSE){

152− return 1;

153− }

154− row_counter =0;

155−

156− while (rc == SQLITE_ROW) {

157−

158− rc = sqlite3_step(dbi->ppStmt);

159− row_counter++;

160− }

161−

162− col = sqlite3_column_count(dbi->ppStmt);

163− dbi->row_count = row_counter;

164− dbi->col_count = col;

165− return rc;

166−}

167−/*

168− Returns row number from DB Struct

169−

170− */

171−int sqlite3_get_num_row_v2(void* p){

172−

173− DBinfo* dbi =(DBinfo*) p;

174− int row_number =dbi->row_count;

175− return row_number;

176−}

177−

178−/*

179− Returns column number from DB Struct

180− */

181−int sqlite3_get_num_col_v2(void* p){

182−

183− DBinfo* dbi =(DBinfo*) p;

184− int col_number =dbi-> col_count;

185− return col_number;

186−}

187−

188−/*

189− Another way of obtaining row number

190− Thought this function gets the value

191− from Table struct. The value is stored

192− in the struct after calling get_table.

193− Using this version is not recommended

194− unless used with get_table

195− */

196−int sqlite3_get_num_row(void* p){

197−

198− Table* tbl =(Table*) p;

199− int row_number =tbl->num_row;

200− return row_number;

201−}

202−

203−/*

204− Another way of obtaining column number

205− Thought this function gets the value

206− from Table struct. The value is stored

207− in the struct after calling get_table.

208− Using this version is not recommended

209− unless used with get_table

210− */

211−int sqlite3_get_num_col(void* p){

212−

213− Table* tbl =(Table*) p;

214− int col_number =tbl-> num_col;

215− return col_number;

216−}

217−

218−/*

219− This routine returns the type of value

220− and must be called after prepare and exec.

221− Since exec steps through database to obtain

222− row number, this function calls reset to

223− set the pointer to its initial state

224− and then calls sqlite3_column_type

225− to get the type

226−*/

227−int sqlite3_get_data_type(void* p, int nRow, int nCol){

228−

229− DBinfo* dbi =(DBinfo*) p;

230− int rc, type, row_counter;

231− const char* char_int;

232−

233− rc = sqlite3_reset(dbi->ppStmt);

234− rc = sqlite3_step(dbi->ppStmt);

235− row_counter =0;

236−

237− while (rc == SQLITE_ROW && row_counter < nRow) {

238−

239− rc = sqlite3_step(dbi->ppStmt);

240− row_counter++;

241− }

242− type =sqlite3_column_type(dbi->ppStmt, nCol);

243− return type;

244−

245−}

246−/*

247− Obtains the integer value in a given column

248−*/

249−

250−int sqlite3_get_val_int(void* p, int nCol){

251−

252− DBinfo* dbi =(DBinfo*) p;

253− int val, col;

254− val =sqlite3_column_int(dbi->ppStmt, nCol);

255− return val;

256−}

257−

258−/*

259− Obtains the text value

260− Need to allocate memory to store the string

261− Use GC_malloc since Boehm garbage collector

262− frees the resources .

263− */

264−const unsigned char* sqlite3_get_val_text(void* p,int nCol){

265−

266−

267− DBinfo* dbi =(DBinfo*) p;

268− int rc,i, val, counter;

269− const unsigned char* text_val;

270− array =(unsigned char *) malloc(1000*sizeof(char));

271− text_val =sqlite3_column_text(dbi->ppStmt, nCol);

272− memcpy(array, text_val, strlen(text_val));

273− return array;

274−

275−}

276−float sqlite3_get_float(void* p, int nCol){

277−

278− DBinfo* dbi =(DBinfo*) p;

279− double double_val;

280−

281− double_val =sqlite3_column_double(dbi->ppStmt, nCol);

282− float float_val =(float)double_val;

283− return float_val;

284−

285−}

286−/*

287− frees the pointer returned by get_table.

288− */

289−

290−void sqlite3_free_table_idr(void* db){

291− Table* tbl =(Table*) db;

292− sqlite3_free_table(tbl->table_data);

293− free(tbl);

294−}

295−int sqlite3_step_idr(void* db){

296−

297− DBinfo* dbi =(DBinfo*) db;

298− int rc =sqlite3_step(dbi->ppStmt);

299− return rc;

300−}

301−/*

302− Binds integer. This returns a pointer

303− because of the implementation of BindMulti

304− which binds multiple values

305− */

306−void* sqlite3_bind_int_idr(void* p,int index, int val){

307−

308− DBinfo* dbi =(DBinfo*) p;

309− int rc;

310−

311− rc =sqlite3_bind_int(dbi->ppStmt,index,val);

312− if(rc != SQLITE_OK){

313− return NULL;

314− }

315−

316− return dbi;

317−}

318−

319−void* sqlite3_bind_float_idr(void* p,int index, float val){

320−

321− DBinfo* dbi =(DBinfo*) p;

322− int rc;

323− double res =(float)val;

324−

325− rc =sqlite3_bind_double(dbi->ppStmt,index,res);

326−

327− if(rc != SQLITE_OK){

328− return NULL;

329− }

330− return dbi;

331−}

332−

333−void* sqlite3_bind_null_idr(void* p,int index){

334−

335− DBinfo* dbi =(DBinfo*) p;

336− int rc;

337− rc =sqlite3_bind_null(dbi->ppStmt,index);

338− if(rc != SQLITE_OK){

339− return NULL;

340− }

341−

342− return dbi;

343−}

344−

345−void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length){

346−

347− DBinfo* dbi =(DBinfo*) p;

348− int rc;

349− rc =sqlite3_bind_text(dbi->ppStmt,index,text,length,SQLITE_STATIC);

350− if(rc != SQLITE_OK){

351− return NULL;

352− }

353−

354− return dbi;

355−}

356−/*

357− Used for testing column count function.

358− This function prepares query and by passing

359− select all, gets the count for column number

360− Could be used for testing. Not recommended to

361− be used with prepare and exec

362− */

363−

364−int sqlite3_column_count_idr(void* db, const char* tbl_name){

365− DBinfo* dbi =(DBinfo*) db;

366− sqlite3_stmt* stmt;

367− const char *tail;

368− int rc;

369−

370− strcpy(sql_query_buffer, "select * from ");

371− strcat(sql_query_buffer, tbl_name);

372−

373− rc = sqlite3_prepare_v2(dbi->db_ptr, sql_query_buffer, -1, &stmt, &tail);

374− if(rc != SQLITE_OK){

375− fprintf(stderr, "SQL Prepare error");

376− return rc;

377− }

378− printf("Prepare successful %d\n", rc);

379−

380− rc =sqlite3_column_count(stmt);

381− if(rc == 0){

382− fprintf(stderr, "SQL column count error\n");

383− return rc;

384− }

385− sqlite3_finalize(stmt);

386−

387− // rc = actual column count

388− return rc;

389−}

390−

391−int sqlite3_data_count_idr(void* db){

392−

393− DBinfo* dbi =(DBinfo*) db;

394− int rc = sqlite3_data_count(dbi->ppStmt);

395−

396− return rc;

397−}

398−/*

399− Must be called after prepare to clean up

400− the resources.

401− */

402−int sqlite3_finalize_idr(void* db){

403−

404− DBinfo* dbi=(DBinfo*) db;

405− int rc =sqlite3_finalize(dbi->ppStmt);

406− return rc;

407−}

408−

409−int sqlite3_complete_idr(const char *sql){

410−

411− int rc = sqlite3_complete(sql);

412− return rc;

413−}

414−

415−/*

416− Resets a prepared statement pointer

417− to its initial state

418− */

419−int sqlite3_reset_idr(void* db){

420−

421− DBinfo* dbi=(DBinfo*) db;

422− int rc = sqlite3_reset(dbi-> ppStmt);

423− return rc;

424−

425−}

426−/*

427− The following routines may be used to

428− obtain column related information.

429− */

430−const char *sqlite3_column_name_idr(void* db, int N){

431−

432− DBinfo* dbi=(DBinfo*) db;

433− const char *name = sqlite3_column_name(dbi->ppStmt, N);

434−

435− return name;

436−}

437−

438−const char *sqlite3_column_decltype_idr(void* db,int n){

439− DBinfo* dbi=(DBinfo*) db;

440− const char *dectype = sqlite3_column_decltype(dbi->ppStmt, n);

441−

442− return dectype;

443−

444−}

445−int sqlite3_column_bytes_idr(void* db, int n){

446−

447− DBinfo* dbi=(DBinfo*) db;

448− int res = sqlite3_column_bytes(dbi->ppStmt, n);

449− return res;

450−

451−

452−}

453−const void *sqlite3_column_blob_idr(void* db, int iCol){

454− DBinfo* dbi=(DBinfo*) db;

455− const void* data =sqlite3_column_blob(dbi-> ppStmt, iCol);

456− return data;

457−}

458−

459−const unsigned char *sqlite3_column_text_idr(void* db, int iCol){

460− DBinfo* dbi=(DBinfo*) db;

461− const unsigned char* col_text =sqlite3_column_text(dbi->ppStmt, iCol);

462− return col_text;

463−

464−}

465−

466−int sqlite3_column_int_idr(void* db, int iCol){

467− DBinfo* dbi=(DBinfo*) db;

468− int res =sqlite3_column_int(dbi-> ppStmt, iCol);

469− return res;

470−

471−}

472−/*

473− Some back up functions

474− */

475−

476−void* sqlite3_backup_init_idr(void* pDest,

477− const char *zDestName,

478− void* pSource,

479− const char *zSourceName

480− ){

481−

482− DBinfo* dbi=(DBinfo*) pDest;

483− DBbackup* dbi2=(DBbackup*) pSource;

484−

485− void* res = sqlite3_backup_init(dbi->db_ptr,zDestName,

486− dbi2->source_ptr,zSourceName);

487−

488− if(res == NULL){

489− printf("Error number in initializing backup : %d\n", sqlite3_errcode(dbi->db_ptr));

490− }

491−

492− dbi2->backup = res;

493− return dbi2;

494−

495−

496−}

497−

498−int sqlite3_backup_step_idr(void *backup, int nPage){

499−

500− DBbackup* dbi=(DBbackup*) backup;

501− int res = sqlite3_backup_step(dbi->backup, nPage);

502− return res;

503−

504−

505−}

506−int sqlite3_backup_finish_idr(void *backup){

507−

508− DBbackup* dbi=(DBbackup*) backup;

509− int res = sqlite3_backup_finish(dbi->backup);

510− return res;

511−

512−

513−}

514−

515−int sqlite3_backup_remaining_idr(void *backup){

516−

517− DBbackup* dbi=(DBbackup*) backup;

518− int res = sqlite3_backup_remaining(dbi->backup);

519−

520− return res;

521−}

522−

523−int sqlite3_backup_pagecount_idr(void *backup){

524−

525− DBbackup* dbi=(DBbackup*) backup;

526− int res =sqlite3_backup_pagecount(dbi-> backup);

527− return res;

528−

529−}

530−/*

531− Get the length of string

532− Need this in Idris since length will not

533− work on Strings.

534− */

535−int strLength(const char * str){

536−

537− int length = strlen(str);

538− return length;

539−

540−

541−}

542−

543−

contribs/lib/SQLite3/sqlite3api.hdeleted−130

@@ -1,130 +0,0 @@

1−/*

2− * sqlite3api.h

3− *

4− *

5− * Created by Melissa Farinaz MOZIFIAN on 22/06/2012.

7− *

8− */

9−#include <stdio.h>

10−#include <stdlib.h>

11−#include <string.h>

12−#include <sqlite3.h>

13−#include <ctype.h>

14−#include <gc.h>

15−

16−typedef struct {

17− sqlite3 *db_ptr; // database pointer

18− sqlite3_stmt *ppStmt; // statement pointer

19− char buffer[1000]; // bufer to store errors returned by certain functions

20− const char *Ptr_tail;

21− sqlite3_value *value;

22− int row_count; // row number store by exec function

23− int col_count;

24−

25−} DBinfo;

26−

27−// struct used for backup functions

28−typedef struct {

29− sqlite3 *source_ptr;

30− sqlite3_backup *backup;

31−}DBbackup ;

32−

33−// Table struct used by get_table function

34−// stores row and column

35−// returned by get_table

36−typedef struct {

37− int num_row;

38− int num_col;

39− char** table_data;

40− int data_size;

41− int* data_type;

42− DBinfo* database;

43−}Table;

44−

45−

46−void* sqlite3_open_idr(const char *filename);

47−

48−int exec_db(void*p);

49−

50−int sqlite3_close_idr(void* db);

51−

52−int sqlite3_exec_idr(void*, const char *sql);

53−

54−char* sqlite3_get_error(void* db);

55−

56−const unsigned char* sqlite3_get_val_text(void* p,int nCol);

57−

58−void* sqlite3_get_table_idr(void* db, const char *sql);

59−

60−void sqlite3_free_table_idr(void* db);

61−

62−int sqlite3_get_num_col(void* p);

63−

64−int sqlite3_get_num_row(void* p);

65−

66−int sqlite3_get_num_row_v2(void* p);

67−

68−int sqlite3_get_num_col_v2(void* p);

69−

70−int sqlite3_get_data_type(void* p, int nRow, int nCol);

71−

72−int sqlite3_get_val_int(void* p,int nCo);

73−

74−float sqlite3_get_float(void* p, int nCol);

75−

76−void* sqlite3_prepare_idr(

77− void *db, /* Database handle */

78− const char *zSql /* SQL statement, UTF-8 encoded */

79−);

80−

81−int sqlite3_step_idr(void* stmt);

82−

83−void* sqlite3_bind_float_idr(void* p,int index, float val);

84−

85−void* sqlite3_bind_int_idr(void* p,int index , int val);

86−

87−void* sqlite3_bind_null_idr(void* p,int index);

88−

89−void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length);

90−

91−int sqlite3_column_count_idr(void* stmt, const char* tbl_name);

92−

93−int sqlite3_data_count_idr(void* stmt);

94−

95−int sqlite3_reset_idr(void* stmt);

96−

97−int sqlite3_finalize_idr(void* stmt);

98−

99−int sqlite3_complete_idr(const char *sql);

100−

101−const char *sqlite3_column_decltype_idr(void* stmt,int n);

102−

103−const char *sqlite3_column_name_idr(void* stmt, int N);

104−

105−int sqlite3_column_bytes_idr(void* stmt, int n);

106−

107−int sqlite3_column_bytes_idr(void* stmt, int n);

108−

109−const void *sqlite3_column_blob_idr(void* stmt, int iCol);

110−

111−const unsigned char *sqlite3_column_text_idr(void* stmt, int iCol);

112−

113−int sqlite3_column_int_idr(void* stmt, int iCol);

114−

115−

116−void* sqlite3_backup_init_idr(void* pDestm,

117− const char *zDestName,

118− void* pSource,

119− const char *zSourceName

120− );

121−

122−int sqlite3_backup_finish_idr(void *backup);

123−

124−int sqlite3_backup_step_idr(void *backup, int nPage);

125−

126−int sqlite3_backup_remaining_idr(void *backup);

127−

128−int sqlite3_backup_pagecount_idr(void *backup);

129−

130−int strLength(const char * str);

contribs/lib/SQLite3/students.dbdeleted

Binary file not shown.

contribs/lib/SQLite3/testunit.idrdeleted−140

@@ -1,140 +0,0 @@

1−module Main

2−import Sqlite3

3−

4−

5−testexpr : DB()

6−testexpr = do db <- open_db "somedb.db"

7− let sql = (evalSQL [] ((SELECT ALL)(TBL ["tbl1"]) (OR (AND (MkCond (Equals (VCol "data")(VStr "data0"))) (MkCond (Equals (VCol "num")(VInt 1))) ) (MkCond (Equals (VCol "num")(VInt 2))))))

8− let x = (fst sql) -- get the string

9− let list = (snd sql) -- list of vals

10− liftIO(printLn x) -- use liftIO to turn this into DB type

11− stmt <- (prepare_db db x) -- prepare the statement

12− bindMulti stmt list -- bind the values in the list

13− exec_db_v2 stmt -- execute the prepared query

14− res <- toList_v1 db -- toList_v1 to get the result

15− liftIO(printLn res) -- print the result

16− finalize_db stmt -- Statment pointer must be finalized in the end

17− close_db db -- close the datbase

18− return ()

19−

20−testupdate : DB()

21−testupdate = do db <- open_db "somedb.db"

22− let sql = (evalSQL [] (UPDATE (TBL ["tbl1"]) (WHERE (SET (MkCond (Equals(VCol "data") (VStr "data600"))) ) (MkCond (Equals (VCol "num") (VInt 2))) ) ))

23− let x = (fst sql)

24− let list = (snd sql)

25− liftIO(printLn x)

26− stmt <- (prepare_db db x)

27− bindMulti stmt list

28− exec_db_v2 stmt

29− finalize_db stmt

30− close_db db

31− return ()

32−

33−testInsert : DB()

34−testInsert = do db <- open_db "somedb.db"

35− let sql = (evalSQL [] (INSERT (TBL ["tbl1"]) [(VInt 3),(VStr "ham")]))

36− let x = (fst sql)

37− let list = (snd sql)

38− liftIO(printLn x)

39− stmt <- (prepare_db db x)

40− bindMulti stmt list

41− exec_db_v2 stmt

42− finalize_db stmt

43− close_db db

44− return ()

45−

46−testNull : DB()

47−testNull = do db <- open_db "somedb.db"

48− let sql = (evalSQL [] ((SELECT ALL)(TBL ["tbl1"]) (MkCond (MkNULL (VCol "data")))))

49− let x = (fst sql)

50− let list = (snd sql)

51− liftIO(printLn x)

52− stmt <- (prepare_db db x)

53− bindMulti stmt list

54− exec_db_v2 stmt

55− res <- toList_v1 db

56− liftIO(printLn res)

57− finalize_db stmt

58− close_db db

59− return ()

60−

61−

62−testInsertWithCond : DB()

63−testInsertWithCond = do db <- open_db "somedb.db"

64− let sql = (evalSQL [] (INSERTC (TBL ["tbl1"]) [(VCol "data"),(VCol "num")] [(VInt 30),(VStr "inserthere")]))

65− let x = (fst sql)

66− let list = (snd sql)

67− liftIO(printLn x)

68− stmt <- (prepare_db db x)

69− bindMulti stmt list

70− exec_db_v2 stmt

71− finalize_db stmt

72− close_db db

73− return ()

74−

75−-- Nested queries need to have the same column as the outer queries.

76−testNestedSel1 : DB()

77−testNestedSel1 = do db <- open_db "somedb.db"

78− let sql = (evalSQL [] (SELECT (Cols ["data"]) (SELECT (Cols["num","data"]) (TBL ["tbl1"]) (MkCond (MkGT (VCol "num")(VInt 2))))Empty))

79− let x = (fst sql)

80− let list = (snd sql)

81− liftIO(printLn x)

82− stmt <- (prepare_db db x)

83− bindMulti stmt list

84− exec_db_v2 stmt

85− res <- toList_v1 db

86− liftIO(printLn res)

87− finalize_db stmt

88− close_db db

89− return ()

90−

91−-- Testing Create Table

92−testCreateTable : DB ()

93−testCreateTable = do db <- open_db "somedb.db"

94− let sql = (evalSQL [] (CREATE (TBL ["mynewtbl"]) [ ((VCol "col"),(CInt "int"),(None)) ] ) )

95− let x = (fst sql)

96− let list = (snd sql)

97− liftIO(printLn x)

98− stmt <- (prepare_db db x)

99− bindMulti stmt list

100− exec_db_v2 stmt

101− finalize_db stmt

102− close_db db

103− return ()

104−

105−-- This may be a bit slow

106−testMultiTable : DB ()

107−testMultiTable = do db <- open_db "somedb.db"

108− let sql = (evalSQL [] ((SELECT ALL )(TBL ["mytable","tbl1"]) (Empty) ) )

109− let x = (fst sql)

110− let list = (snd sql)

111− liftIO(printLn x)

112− stmt <- (prepare_db db x)

113− bindMulti stmt list

114− exec_db_v2 stmt

115− res <- toList_v1 db

116− liftIO(printLn res)

117− finalize_db stmt

118− close_db db

119− return ()

120−

121−testSelAll : DB ()

122−testSelAll = do db <- open_db "somedb.db"

123− let sql = (evalSQL [] ((SELECT ALL )(TBL ["tbl1"]) (Empty) ) )

124− let x = (fst sql)

125− let list = (snd sql)

126− liftIO(printLn x)

127− stmt <- (prepare_db db x)

128− bindMulti stmt list

129− exec_db_v2 stmt

130− res <- toList_v1 db

131− liftIO(printLn res)

132− finalize_db stmt

133− close_db db

134− return ()

135−

136−

137−main : IO ()

138−main = do x <- runDB (testMultiTable) -- runDB : DB a -> IO a

139− --y <- runDB (testNestedSel1)

140− return ()

contribs/lib/SimpleParser/SimpleParser.idrdeleted−190

@@ -1,190 +0,0 @@

1−{-

2− Simple monadic parser module, based heavily on that by

3− Graham Hutton.

4−-}

5−

6−module SimpleParser

7−

8−import Prelude

9−import Prelude.Monad

10−import Prelude.Applicative

11−import Prelude.List

12−import Builtins

13−

14−%access public

15−

16−

17−--------------------------------------------------------------------------------

18−-- The monad of parsers

19−--------------------------------------------------------------------------------

20−

21−data Parser a = P (String -> Either String (a, String))

22−

23−parse : Parser a -> String -> Either String (a, String)

24−parse (P p) inp = p inp

25−

26−instance Functor Parser where

27− map f p = P (\inp => case parse p inp of

28− Left err => Left err

29− Right (v, rest) => Right ((f v), rest))

30−

31−instance Applicative Parser where

32− pure v = P (\inp => Right (v, inp))

33− a <*> b = P (\inp => do (f, rest) <- parse a inp

34− (x, rest') <- parse b rest

35− pure ((f x), rest'))

36−

37−instance Monad Parser where

38− p >>= f = P (\inp => case parse p inp of

39− Left err => Left err

40− Right (v,rest) => parse (f v) rest)

41−

42−instance Alternative Parser where

43− empty = P (const (Left "empty"))

44− p <|> q = P (\inp => case parse p inp of

45− Left msg => parse q inp

46− Right (v,out) => Right (v,out))

47−

48−

49−--------------------------------------------------------------------------------

50−-- Basic parsers

51−--------------------------------------------------------------------------------

52−

53−failure : String -> Parser a

54−failure msg = P (\inp => Left msg)

55−

56−item : Parser Char

57−item = P (\inp => case choose (inp == "") of

58− Left _ => Left "Error! Parsing empty list."

59− Right p => Right (strHead' inp p, strTail' inp p))

60−

61−

62−--------------------------------------------------------------------------------

63−-- Derived primitives

64−--------------------------------------------------------------------------------

65−

66−sat : (Char -> Bool) -> Parser Char

67−sat p = do x <- item

68− guard (p x)

69− pure x

70−

71−oneof : List Char -> Parser Char

72−oneof xs = sat (\x => elem x xs)

73−

74−digit : Parser Char

75−digit = sat isDigit

76−

77−lower : Parser Char

78−lower = sat isLower

79−

80−upper : Parser Char

81−upper = sat isUpper

82−

83−letter : Parser Char

84−letter = sat isAlpha

85−

86−alphanum : Parser Char

87−alphanum = sat isAlphaNum

88−

89−char : Char -> Parser Char

90−char x = sat (== x)

91−

92−string : String -> Parser String

93−string s = map pack (traverse char (unpack s))

94−

95−mutual

96− many1 : Parser a -> Parser (List a)

97− many1 p = [| p :: many p |]

98−

99− many : Parser a -> Parser (List a)

100− many p = lazy (many1 p) <|> pure []

101−

102−bool : Parser Bool

103−bool = parseTrue <|> parseFalse

104− where parseTrue : Parser Bool

105− parseTrue = do oneof ['T', 't']

106− string "rue"

107− pure True

108− parseFalse = do oneof ['F', 'f']

109− string "alse"

110− pure False

111−

112−ident : Parser String

113−ident = map pack xs

114− where xs : Parser (List Char)

115− xs = [| letter :: many1 alphanum |]

116−

117−nat : Parser Int

118−nat = do xs <- many digit

119− pure (cast (cast xs))

120−

121−int : Parser Int

122−int = neg <|> nat

123− where neg : Parser Int

124− neg = do char '-'

125− n <- nat

126− pure (-n)

127−

128−space : Parser ()

129−space = do many (sat isSpace)

130− pure ()

131−

132−

133−--------------------------------------------------------------------------------

134−-- Ignoring spacing

135−--------------------------------------------------------------------------------

136−

137−token : Parser a -> Parser a

138−token p = space $> p <$ space

139−

140−identifier : Parser String

141−identifier = token ident

142−

143−natural : Parser Int

144−natural = token nat

145−

146−integer : Parser Int

147−integer = token int

148−

149−symbol : String -> Parser String

150−symbol xs = token (string xs)

151−

152−strToken : Parser String

153−strToken = map pack (token (many1 alphanum))

154−

155−--------------------------------------------------------------------------------

156−-- combinators

157−--------------------------------------------------------------------------------

158−

159−optional : Parser a -> Parser (Maybe a)

160−optional p = map Just p <|> pure Nothing

161−

162−sepBy1 : Parser a -> Parser b -> Parser (List a)

163−sepBy1 p s = [| p :: many (s $> p) |]

164−

165−sepBy : Parser a -> Parser b -> Parser (List a)

166−sepBy p s = sepBy1 p s <|> pure Nil

167−

168−manyTil : Parser a -> Parser b -> Parser (List a)

169−manyTil p e = (e $> pure Nil) <|> lazy [| p :: manyTil p e |] <|> pure Nil

170−

171−--------------------------------------------------------------------------------

172−-- Expressions

173−--------------------------------------------------------------------------------

174−

175−expr : Parser Int

176−factor : Parser Int

177−term : Parser Int

178−

179−expr = do t <- term

180− map (t+) (symbol "+" $> expr) <|> pure t

181−

182−factor = (symbol "(" $> expr <$ symbol ")") <|> natural

183−

184−term = do f <- factor

185− map (f*) (symbol "*" $> term) <|> pure f

186−

187−eval : String -> Maybe Int

188−eval xs = case (parse expr xs) of

189− Right (n,rest) => if rest == "" then Just n else Nothing

190− Left msg => Nothing

contribs/lib/SimpleParser/simpleparser.ipkgdeleted−4

@@ -1,4 +0,0 @@

1−package simpleparser

2−

3−opts = "-i ../lib"

4−modules = SimpleParser

contribs/tool-support/completion/idris.bashdeleted−31

@@ -1,31 +0,0 @@

1−_idris() {

2− local cur prev words opts LIBRARIES TARGETS

3− _init_completion || return

4−

5− opts=$(_parse_help "$1")

6− LIBRARIES="effects"

7− TARGETS="C Java bytecode javascript node"

8−

9− case "${prev}" in

10− -o)

11− _filedir

12− ;;

13− -i|--ibcsubdir)

14− _filedir -d

15− ;;

16− -p)

17− COMPREPLY=( $(compgen -W "${LIBRARIES}" -- ${cur}))

18− ;;

19− --target)

20− COMPREPLY=( $(compgen -W "${TARGETS}" -- ${cur}))

21− ;;

22− esac

23−

24− if [[ $cur == -* ]]; then

25− COMPREPLY=($(compgen -W "${opts}" -- ${cur}))

26− return

27− fi

28−

29− _filedir '@(idr)'

30−} &&

31−complete -o default -F _idris idris

contribs/tool-support/sublime-text/Idris/Idris.JSON-tmLanguagedeleted−70

@@ -1,70 +0,0 @@

1−{ "name": "Idris",

2− "scopeName": "source.idris",

3− "fileTypes": ["idr"],

4− "patterns": [

5− { "name": "keyword.control.idris",

7−

8− },

9− { "name": "keyword.control.idris",

11−

12− },

13− { "name": "keyword.control.idris",

15−

16− },

17− { "name": "keyword.control.idris",

18− "match": "\\b(public|private|abstract|implicit)\\b"

19−

20− },

21− { "name": "keyword.other.idris",

23− },

24− { "name": "constant.numeric.idris",

25− "match": "\\b(S|O)\\b"

26− },

27− { "match": "\\b([0-9]+|0([xX][0-9a-fA-F]+|[oO][0-7]+))\\b",

28− "name": "constant.numeric.idris",

29− "comment": "integers"

30− },

31− {

32− "match": "\\b([0-9]+\\.[0-9]+([eE][+-]?[0-9]+)?|[0-9]+[eE][+-]?[0-9]+)\\b",

33− "name": "constant.numeric.float.idris",

34− "comment": "floats"

35− },

36− {

37− "name": "comment.line.idris",

38− "match": "(--).*$\n?",

39− "comment": "Line comment"

40− },

41− { "name": "comment.block.idris",

42− "begin": "\\{-",

43− "end": "-\\}",

44− "comment": "Block comment"

45− },

46− {

47− "name": "string.quoted.idris",

48− "begin": "\"",

49− "beginCaptures": {

50− "0": { "name": "punctuation.definition.string.begin.idris"}

51− },

52− "end": "\"",

53− "endCaptures": {

54− "0": { "name": "punctuation.definition.string.end.idris"}

55− },

56− "patterns": [

57− { "name": "constant.character.escape.idris",

58− "match": "\\\\\""

59− }

60− ]

61−

62− }

63−

64−

65− ],

66− "repository": {

67−

68− },

69− "uuid": "4dd16092-ffa5-4ba4-8075-e5da9f368a72"

70−}

contribs/tool-support/sublime-text/Idris/Idris.tmLanguagedeleted−126

@@ -1,126 +0,0 @@

1−<?xml version="1.0" encoding="UTF-8"?>

2−<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">

3−<plist version="1.0">

4−<dict>

5− <key>fileTypes</key>

6− <array>

7− <string>idr</string>

8− </array>

9− <key>name</key>

10− <string>Idris</string>

11− <key>patterns</key>

12− <array>

13− <dict>

14− <key>match</key>

16− <key>name</key>

17− <string>keyword.control.idris</string>

18− </dict>

19− <dict>

20− <key>match</key>

22− <key>name</key>

23− <string>keyword.control.idris</string>

24− </dict>

25− <dict>

26− <key>match</key>

28− <key>name</key>

29− <string>keyword.control.idris</string>

30− </dict>

31− <dict>

32− <key>match</key>

33− <string>\b(public|private|abstract|implicit)\b</string>

34− <key>name</key>

35− <string>keyword.control.idris</string>

36− </dict>

37− <dict>

38− <key>match</key>

40− <key>name</key>

41− <string>keyword.other.idris</string>

42− </dict>

43− <dict>

44− <key>match</key>

45− <string>\b(S|O)\b</string>

46− <key>name</key>

47− <string>constant.numeric.idris</string>

48− </dict>

49− <dict>

50− <key>comment</key>

51− <string>integers</string>

52− <key>match</key>

53− <string>\b([0-9]+|0([xX][0-9a-fA-F]+|[oO][0-7]+))\b</string>

54− <key>name</key>

55− <string>constant.numeric.idris</string>

56− </dict>

57− <dict>

58− <key>comment</key>

59− <string>floats</string>

60− <key>match</key>

61− <string>\b([0-9]+\.[0-9]+([eE][+-]?[0-9]+)?|[0-9]+[eE][+-]?[0-9]+)\b</string>

62− <key>name</key>

63− <string>constant.numeric.float.idris</string>

64− </dict>

65− <dict>

66− <key>comment</key>

67− <string>Line comment</string>

68− <key>match</key>

69− <string>(--).*$

70−?</string>

71− <key>name</key>

72− <string>comment.line.idris</string>

73− </dict>

74− <dict>

75− <key>begin</key>

76− <string>\{-</string>

77− <key>comment</key>

78− <string>Block comment</string>

79− <key>end</key>

80− <string>-\}</string>

81− <key>name</key>

82− <string>comment.block.idris</string>

83− </dict>

84− <dict>

85− <key>begin</key>

86− <string>"</string>

87− <key>beginCaptures</key>

88− <dict>

89− <key>0</key>

90− <dict>

91− <key>name</key>

92− <string>punctuation.definition.string.begin.idris</string>

93− </dict>

94− </dict>

95− <key>end</key>

96− <string>"</string>

97− <key>endCaptures</key>

98− <dict>

99− <key>0</key>

100− <dict>

101− <key>name</key>

102− <string>punctuation.definition.string.end.idris</string>

103− </dict>

104− </dict>

105− <key>name</key>

106− <string>string.quoted.idris</string>

107− <key>patterns</key>

108− <array>

109− <dict>

110− <key>match</key>

111− <string>\\"</string>

112− <key>name</key>

113− <string>constant.character.escape.idris</string>

114− </dict>

115− </array>

116− </dict>

117− </array>

118− <key>repository</key>

119− <dict>

120− </dict>

121− <key>scopeName</key>

122− <string>source.idris</string>

123− <key>uuid</key>

124− <string>4dd16092-ffa5-4ba4-8075-e5da9f368a72</string>

125−</dict>

126−</plist>

contribs/tool-support/sublime-text/Idris/idris.sublime-builddeleted−5

@@ -1,5 +0,0 @@

1−{

2− "cmd": ["idris", "$file"],

3− "file_regex": "^(...*?):([0-9]*):?([0-9]*)",

4− "selector": "source.idris"

5−}

contribs/tool-support/sublime-text/README.mddeleted−11

@@ -1,11 +0,0 @@

1−#### Idris support for Sublime Text 2

2−

3−To install, copy the Idris directory to Sublime Text's Packages directory.

4−

5−To build a new Idris.tmLanguage file from the Idris.JSON-tmLanguage file, Sublime Text needs to have the AAAPackageDev package installed.

6−

7−Syntax Definitions tutorial: https://sublime-text-unofficial-documentation.readthedocs.org/en/latest/extensibility/syntaxdefs.html

8−

9−Syntax Definitions reference: https://sublime-text-unofficial-documentation.readthedocs.org/en/latest/reference/syntaxdefs.html

10−

11−Most used scopes: http://manual.macromates.com/en/language_grammars#naming_conventions

custom.mk-alldeps+1−2

@@ -1,2 +1 @@

1−CABALFLAGS += -f LLVM -f FFI -f curses

2−

1+CABALFLAGS += -f LLVM -f FFI -f curses --disable-documentation --disable-profiling --disable-library-profiling

docs/effects/introduction.rst+2−2

@@ -16,7 +16,7 @@ exceptions, and verified resource management.

1616

1717This tutorial assumes familiarity with pure programming in Idris,

1818as described in Sections 1–6 of the main tutorial [1]_. The examples

19−are presented are tested with Idris and can be found in the

19+presented are tested with Idris and can be found in the

2020examples directory of the Idris repository.

2121

2222Consider, for example, the following introductory function which

@@ -66,7 +66,7 @@ library:

6666 import Effects

6767 import Effect.StdIO

6868

69− hello : [STDIO] Eff ()

69+ hello : {[STDIO]} Eff ()

7070 hello = putStrLn “Hello world!”

7171

7272 main : IO ()

docs/faq/faq.rst+15

@@ -131,6 +131,21 @@ choice by the developers of Idris, Idris uses the C style convention.

131131That is, the names ``Float`` and ``Double`` are used to describe

132132single and double precision numbers.

133133

134+What is -ffreestanding?

135+=======================

136+

137+The freestanding flag is used to build Idris binaries which have their

138+libs and compiler in a relative path. This is useful for building binaries

139+where the install directory is unknown at build time. When passing this

140+flag, the IDRIS_LIB_DIR environment variable needs to be set to the path

141+where the Idris libs reside relative to the idris executable. The

142+IDRIS_TOOLCHAIN_DIR environment variable is optional, if that is set,

143+Idris will use that path to find the C compiler.

144+

145+Example:

146+.. code-block::

147+ IDRIS_LIB_DIR="./libs" IDRIS_TOOLCHAIN_DIR="./mingw/bin" CABALFLAGS="-fffi -ffreestanding -frelease" make

148+

134149What does the name ‘Idris’ mean?

135150================================

136151

docs/tutorial/classes.rst+1−1

@@ -399,7 +399,7 @@ to the following:

399399 | Add Expr Expr -- addition

400400

401401Evaluation will take place relative to a context mapping variables

402−(represented as ``String``s) to integer values, and can possibly fail.

402+(represented as ``String``\s) to integer values, and can possibly fail.

403403We define a data type ``Eval`` to wrap an evaluator:

404404

405405.. code-block:: idris

docs/tutorial/introduction.rst+10−10

@@ -25,11 +25,12 @@ lists of a given length [1]_, ``Vect n a``, where ``a`` is the element

2525type and ``n`` is the length of the list and can be an arbitrary term.

2626

2727When types can contain values, and where those values describe

28−properties (e.g. the length of a list) the type of a function can

29−begin to describe its own properties. For example, concatenating two

30−lists has the property that the resulting list’s length is the sum of

31−the lengths of the two input lists. We can therefore give the

32−following type to the ``app`` function, which concatenates vectors:

28+properties, for example the length of a list, the type of a function

29+can begin to describe its own properties. Take for example the

30+concatenatation of two lists. This operation has the property that the

31+resulting list's length is the sum of the lengths of the two input

32+lists. We can therefore give the following type to the ``app``

33+function, which concatenates vectors:

3334

3435.. code-block:: idris

3536

@@ -58,11 +59,10 @@ Example Code

5859============

5960

6061This tutorial includes some example code, which has been tested with

61−Idris version . The files are available in the Idris

62−distribution, and provided along side the tutorial source, so that you

63−can try them out easily, under ``tutorial/examples``. However, it is

64−strongly recommended that you can type them in yourself, rather than

65−simply loading and reading them.

62+against Idris. These files are available with the Idris distribution,

63+so that you can try them out easily. They can be found under

64+``samples``. It is, however, strongly recommended that you type

65+them in yourself, rather than simply loading and reading them.

6666

6767.. [1]

6868 Typically, and perhaps confusingly, referred to in the dependently

docs/tutorial/modules.rst+14−12

@@ -10,11 +10,11 @@ module, a list of ``import`` statements giving the other modules which

1010are to be imported, and a collection of declarations and definitions of

1111types, classes and functions. For example, the listing below gives a

1212module which defines a binary tree type ``BTree`` (in a file

13−``btree.idr``):

13+``Btree.idr``):

1414

1515.. code-block:: idris

1616

17− module btree

17+ module Btree

1818

1919 data BTree a = Leaf

2020 | Node (BTree a) a (BTree a)

@@ -40,23 +40,24 @@ Then, this gives a main program (in a file

4040

4141 module Main

4242

43− import btree

43+ import Btree

4444

4545 main : IO ()

4646 main = do let t = toTree [1,8,2,7,9,3]

4747 print (btree.toList t)

4848

4949

50+

5051The same names can be defined in multiple modules. This is possible

5152because in practice names are *qualified* with the name of the module.

5253The names defined in the ``btree`` module are, in full:

5354

54−+ ``btree.BTree``

55−+ ``btree.Leaf``

56−+ ``btree.Node``

57−+ ``btree.insert``

58−+ ``btree.toList``

59−+ ``btree.toTree``

55++ ``Btree.BTree``

56++ ``Btree.Leaf``

57++ ``Btree.Node``

58++ ``Btree.insert``

59++ ``Btree.toList``

60++ ``Btree.toTree``

6061

6162If names are otherwise unambiguous, there is no need to give the fully

6263qualified name. Names can be disambiguated either by giving an explicit

@@ -103,7 +104,7 @@ functions to be exported as ``abstract``, as we see below:

103104

104105.. code-block:: idris

105106

106− module btree

107+ module Btree

107108

108109 abstract data BTree a = Leaf

109110 | Node (BTree a) a (BTree a)

@@ -137,7 +138,8 @@ the ``public`` modifier on an ``import``. For example:

137138

138139 module A

139140

140− import B import public C

141+ import B

142+ import public C

141143

142144 public a : AType a = ...

143145

@@ -154,7 +156,7 @@ wish to overload names within the same module:

154156

155157.. code-block:: idris

156158

157− module foo

159+ module Foo

158160

159161 namespace x

160162 test : Int -> Int

docs/tutorial/starting.rst+10−14

@@ -10,12 +10,9 @@ Prerequisites

1010Before installing Idris, you will need to make sure you have all

1111of the necessary libraries and tools. You will need:

1212

13−- A fairly recent Haskell platform. Version 2013.2.0.0 should be

14− sufficiently recent, though it is better to be completely up to

15− date.

13+- A fairly recent Haskell platform. Version ``2013.2.0.0`` should be sufficiently recent, though it is better to be completely up to date.

1614

17−- The *GNU Multiple Precision Arithmetic Library* (GMP) is available

18− from MacPorts/Homebrew and all major Linux distributions.

15+- The *GNU Multiple Precision Arithmetic Library* (GMP) is available from MacPorts/Homebrew and all major Linux distributions.

1916

2017Downloading and Installing

2118==========================

@@ -29,11 +26,11 @@ prerequisites, is to type:

2926

3027This will install the latest version released on Hackage, along with

3128any dependencies. If, however, you would like the most up to date

32−development version you can find it, as well as build intructions, on

29+development version you can find it, as well as build instructions, on

3330GitHub at: https://github.com/idris-lang/Idris-dev.

3431

3532To check that installation has succeeded, and to write your first

36−Idris program, create a file called “``hello.idr``” containing the

33+Idris program, create a file called ``hello.idr`` containing the

3734following text:

3835

3936.. code-block:: idris

@@ -55,18 +52,17 @@ create an executable called ``hello``, which you can run:

5552 $ ./hello

5653 Hello world

5754

58−Note that the ``$`` indicates the shell prompt! Should the Idris

59−executable not be found please ensure that you have added

60−``~/.cabal/bin`` to your ``$PATH`` environment variable. Mac OS X

61−users may find they need to use ``~/Library/Haskell/bin``

55+Please note that the dollar sign ``$`` indicates the shell prompt!

56+Should the Idris executable not be found please ensure that you have

57+added ``~/.cabal/bin`` to your ``$PATH`` environment variable. Mac OS

58+X users may find they need to add ``~/Library/Haskell/bin``

6259instead. Some useful options to the Idris command are:

6360

6461- ``-o prog`` to compile to an executable called ``prog``.

6562

66−- ``--check`` type check the file and its dependencies without

67− starting the interactive environment.

63+- ``--check`` type check the file and its dependencies without starting the interactive environment.

6864

69−- ``--help`` display usage summary and command line options

65+- ``--help`` display usage summary and command line options.

7066

7167The Interactive Environment

7268===========================

docs/tutorial/typesfuns.rst+43−38

@@ -12,13 +12,13 @@ Idris defines several primitive types: ``Int``, ``Integer`` and

1212manipulation, and ``Ptr`` which represents foreign pointers. There are

1313also several data types declared in the library, including ``Bool``,

1414with values ``True`` and ``False``. We can declare some constants with

15−these types. Enter the following into a file ``prims.idr`` and load it

15+these types. Enter the following into a file ``Prims.idr`` and load it

1616into the Idris interactive environment by typing ``idris

17−prims.idr``:

17+Prims.idr``:

1818

1919.. code-block:: idris

2020

21− module prims

21+ module Prims

2222

2323 x : Int

2424 x = 42

@@ -33,17 +33,18 @@ prims.idr``:

3333 quux = False

3434

3535An Idris file consists of an optional module declaration (here

36−``module prims``) followed by an optional list of imports (none here,

37−however Idris programs can consist of several modules, and the

38−definitions in each module each have their own namespace, as we will

39−discuss in Section :ref:`sect-namespaces`) and a collection of

40−declarations and definitions. The order of definitions is significant

41−— functions and data types must be defined before use. Each definition

42−must have a type declaration, for example see ``x : Int``, ``foo :

43−String``, from the above listing. Indentation is significant — a new

44−declaration begins at the same level of indentation as the preceding

45−declaration. Alternatively, declarations may be terminated with a

46−semicolon.

36+``module Prims``) followed by an optional list of imports and a

37+collection of declarations and definitions. In this example no imports

38+have been specified. However Idris programs can consist of several

39+modules and the definitions in each module each have their own

40+namespace. This is discussed further in Section

41+:ref:`sect-namespaces`). When writing Idris programs both the order in which

42+definitions are given and indentation are significant. Functions and

43+data types must be defined before use, incidently each definition must

44+have a type declaration, for example see ``x : Int``, ``foo :

45+String``, from the above listing. New declarations must begin at the

46+same level of indentation as the preceding declaration.

47+Alternatively, a semicolon ``;`` can be used to terminate declarations.

4748

4849A library module ``prelude`` is automatically imported by every

4950Idris program, including facilities for IO, arithmetic, data

@@ -63,7 +64,7 @@ All of the usual arithmetic and comparison operators are defined for

6364the primitive types. They are overloaded using type classes, as we

6465will discuss in Section :ref:`sect-classes` and can be extended to

6566work on user defined types. Boolean expressions can be tested with the

66−``if...then...else`` construct:

67+``if...then...else`` construct, for example:

6768

6869::

6970

@@ -73,9 +74,9 @@ work on user defined types. Boolean expressions can be tested with the

7374Data Types

7475==========

7576

76−Data types are declared in a similar way to Haskell data types, with a

77−similar syntax. Natural numbers and lists, for example, can be

78−declared as follows:

77+Data types are declared in a similar way and with similar syntax to

78+Haskell. Natural numbers and lists, for example, can be declared as

79+follows:

7980

8081.. code-block:: idris

8182

@@ -193,11 +194,13 @@ does not need to be visible globally:

193194Indentation is significant — functions in the ``where`` block must be

194195indented further than the outer function.

195196

196−**Scope:** Any names which are visible in the outer scope are also

197−visible in the ``where`` clause (unless they have been redefined, such

198−as ``xs`` here). A name which appears only in the type will be in scope

199−in the ``where`` clause if it is a *parameter* to one of the types,

200−i.e. it is fixed across the entire structure.

197+.. note:: Scope

198+

199+ Any names which are visible in the outer scope are also visible in

200+ the ``where`` clause (unless they have been redefined, such as ``xs``

201+ here). A name which appears only in the type will be in scope in the

202+ ``where`` clause if it is a *parameter* to one of the types, i.e. it

203+ is fixed across the entire structure.

201204

202205As well as functions, ``where`` blocks can include local data

203206declarations, such as the following where ``MyLT`` is not accessible

@@ -306,16 +309,17 @@ following:

306309 $ idris vbroken.idr --check

307310 vbroken.idr:9:23:When elaborating right hand side of Vect.++:

308311 When elaborating an application of constructor Vect.:::

309− Can't unify

310− Vect (k + k) a

311− with

312− Vect (plus k m) a

312+ Can't unify

313+ Vect (k + k) a (Type of xs ++ xs)

314+ with

315+ Vect (plus k m) a (Expected type)

316+

317+ Specifically:

318+ Can't unify

319+ plus k k

320+ with

321+ plus k m

313322

314− Specifically:

315− Can't unify

316− plus k k

317− with

318− plus k m

319323

320324This error message suggests that there is a length mismatch between

321325two vectors — we needed a vector of length ``k + m``, but provided a

@@ -398,8 +402,9 @@ names, ``n`` and ``a``, which are not declared explicitly. These are

398402Implicit arguments, given in braces ``{}`` in the type declaration,

399403are not given in applications of ``index``; their values can be

400404inferred from the types of the ``Fin n`` and ``Vect n a``

401−arguments. Any name with a which appears as a parameter or index in a

402−type declaration, but which is otherwise free, will be automatically

405+arguments. Any name beginning with a lower case letter which appears

406+as a parameter or index in a

407+type declaration, but which is otherwise unbound, will be automatically

403408bound as an implicit argument. Implicit arguments can still be given

404409explicitly in applications, using ``{a=value}`` and ``{n=value}``, for

405410example:

@@ -782,8 +787,8 @@ as “sigma types”:

782787

783788.. code-block:: idris

784789

785− data Sigma : (A : Type) -> (P : A -> Type) -> Type where

786− MkSigma : {P : A -> Type} -> (a : A) -> P a -> Sigma A P

790+ data Sigma : (a : Type) -> (P : a -> Type) -> Type where

791+ MkSigma : {P : a -> Type} -> (x : a) -> P x -> Sigma a P

787792

788793Again, there is syntactic sugar for this. ``(a : A ** P)`` is the type

789794of a pair of A and P, where the name ``a`` can occur inside ``P``.

@@ -969,8 +974,8 @@ Dependent Records

969974

970975*Records* are data types which collect several values (the record's

971976*fields*) together. Idris provides syntax for defining records and

972−*automatically generating field access and update functions. For

973−*example, we can represent a person's name and age in a record:

977+*automatically generating field access and update functions*. For

978+example, we can represent a person's name and age in a record:

974979

975980.. code-block:: idris

976981

docs/tutorial/views.rst+2−2

@@ -83,8 +83,8 @@ rule:

8383The value of the result of ``parity k`` affects the form of ``k``,

8484because the result of ``parity k`` depends on ``k``. So, as well as

8585the patterns for the result of the intermediate computation (``Even``

86−and ``odd``) right of the ``\mid``, we also write how the results

87−affect the other patterns left of the :math:`\mid`. Note that there is

86+and ``odd``) right of the ``|``, we also write how the results

87+affect the other patterns left of the ``|``. Note that there is

8888a function in the patterns (``+``) and repeated occurrences of

8989``j``—this is allowed because another argument has determined the form

9090of these patterns.

idris.cabal+37−4

@@ -114,6 +114,7 @@ Extra-source-files:

114114 libs/contrib/Classes/*.idr

115115 libs/contrib/Control/*.idr

116116 libs/contrib/Control/Isomorphism/*.idr

117+ libs/contrib/Control/Algebra/*.idr

117118 libs/contrib/Data/*.idr

118119 libs/contrib/Decidable/*.idr

119120 libs/contrib/Network/*.idr

@@ -304,6 +305,9 @@ Extra-source-files:

304305 test/reg061/run

305306 test/reg061/*.idr

306307 test/reg061/expected

308+ test/reg062/run

309+ test/reg062/*.idr

310+ test/reg062/expected

307311

308312 test/basic001/run

309313 test/basic001/*.idr

@@ -346,6 +350,13 @@ Extra-source-files:

346350 test/basic013/*.idr

347351 test/basic013/expected

348352

353+ test/bignum001/run

354+ test/bignum001/*.idr

355+ test/bignum001/expected

356+ test/bignum002/run

357+ test/bignum002/*.idr

358+ test/bignum002/expected

359+

349360 test/delab001/*.idr

350361 test/delab001/run

351362 test/delab001/expected

@@ -373,6 +384,10 @@ Extra-source-files:

373384 test/effects003/*.idr

374385 test/effects003/expected

375386 test/effects003/input

387+ test/effects004/run

388+ test/effects004/*.idr

389+ test/effects004/expected

390+ test/effects004/input

376391

377392 test/error001/run

378393 test/error001/*.idr

@@ -413,6 +428,10 @@ Extra-source-files:

413428 test/ffi006/run

414429 test/ffi006/expected

415430

431+ test/folding001/*.idr

432+ test/folding001/run

433+ test/folding001/expected

434+

416435 test/idrisdoc001/run

417436 test/idrisdoc001/expected

418437 test/idrisdoc001/*.idr

@@ -494,6 +513,13 @@ Extra-source-files:

494513 test/literate001/*.lidr

495514 test/literate001/expected

496515

516+ test/meta001/run

517+ test/meta001/*.idr

518+ test/meta001/expected

519+ test/meta002/run

520+ test/meta002/*.idr

521+ test/meta002/expected

522+

497523 test/primitives001/run

498524 test/primitives001/*.idr

499525 test/primitives001/expected

@@ -550,7 +576,9 @@ Extra-source-files:

550576 test/quasiquote005/run

551577 test/quasiquote005/*.idr

552578 test/quasiquote005/expected

553−

579+ test/quasiquote006/run

580+ test/quasiquote006/*.idr

581+ test/quasiquote006/expected

554582

555583 test/records001/run

556584 test/records001/*.idr

@@ -726,6 +754,9 @@ Library

726754 , Idris.Elab.Provider

727755 , Idris.Elab.Transform

728756 , Idris.Elab.Value

757+ , Idris.Elab.Term

758+

759+ , Idris.REPL.Browse

729760

730761 , Idris.AbsSyntax

731762 , Idris.AbsSyntaxTree

@@ -740,11 +771,11 @@ Library

740771 , Idris.DataOpts

741772 , Idris.DeepSeq

742773 , Idris.Delaborate

774+ , Idris.Directives

743775 , Idris.Docs

744776 , Idris.Docstrings

745777 , Idris.ElabDecls

746778 , Idris.ElabQuasiquote

747− , Idris.ElabTerm

748779 , Idris.Erasure

749780 , Idris.Error

750781 , Idris.ErrReverse

@@ -806,9 +837,10 @@ Library

806837 -- Auto Generated

807838 , Paths_idris

808839 , Version_idris

840+ , Tools_idris

809841

810842 Build-depends: base >=4 && <5

811− , annotated-wl-pprint >= 0.5.3 && < 0.6

843+ , annotated-wl-pprint >= 0.5.3 && < 0.7

812844 , ansi-terminal < 0.7

813845 , ansi-wl-pprint < 0.7

814846 , base64-bytestring < 1.1

@@ -823,7 +855,7 @@ Library

823855 , filepath < 1.5

824856 , fingertree >= 0.1 && < 0.2

825857 , haskeline >= 0.7 && < 0.8

826− , lens >= 4.1.1 && < 4.9

858+ , lens >= 4.1.1 && < 4.10

827859 , mtl >= 2.1 && < 2.3

828860 , network < 2.7

829861 , optparse-applicative >= 0.11 && < 0.12

@@ -842,6 +874,7 @@ Library

842874 , vector < 0.11

843875 , vector-binary-instances < 0.3

844876 , xml < 1.4

877+ , zip-archive > 0.2.3.5 && < 0.2.4

845878 , zlib < 0.6

846879 , safe

847880 Extensions: MultiParamTypeClasses

libs/base/Control/Arrow.idr+2−7

@@ -16,9 +16,7 @@ class Category arr => Arrow (arr : Type -> Type -> Type) where

1616 first : arr a b -> arr (a, c) (b, c)

1717

1818 second : arr a b -> arr (c, a) (c, b)

19− second f = arrow swap >>> first f >>> arrow swap where

20− swap : (x,y) -> (y,x)

21− swap (x,y) = (y,x)

19+ second f = arrow swap >>> first f >>> arrow swap

2220

2321 (***) : arr a b -> arr a' b' -> arr (a, a') (b, b')

2422 f *** g = first f >>> second g

@@ -61,10 +59,7 @@ class Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where

6159 left : arr a b -> arr (Either a c) (Either b c)

6260

6361 right : arr a b -> arr (Either c a) (Either c b)

64− right f = arrow swap >>> left f >>> arrow swap where

65− swap : Either a b -> Either b a

66− swap (Left x) = Right x

67− swap (Right x) = Left x

62+ right f = arrow mirror >>> left f >>> arrow mirror

6863

6964 (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)

7065 f +++ g = left f >>> right g

libs/base/Control/Isomorphism.idr+5−11

@@ -39,13 +39,10 @@ isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom

3939

4040||| Disjunction is commutative

4141eitherComm : Iso (Either a b) (Either b a)

42−eitherComm = MkIso swap swap swapSwap swapSwap

43− where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!

44− swap (Left x) = Right x

45− swap (Right x) = Left x

46− swapSwap : (e : Either a' b') -> swap (swap e) = e

47− swapSwap (Left x) = Refl

48− swapSwap (Right x) = Refl

42+eitherComm = MkIso mirror mirror mirrorMirror mirrorMirror

43+ where mirrorMirror : (e : Either a' b') -> mirror (mirror e) = e

44+ mirrorMirror (Left x) = Refl

45+ mirrorMirror (Right x) = Refl

4946

5047||| Disjunction is associative

5148eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))

@@ -116,10 +113,7 @@ eitherCongRight i = eitherCong isoRefl i

116113||| Conjunction is commutative

117114pairComm : Iso (a, b) (b, a)

118115pairComm = MkIso swap swap swapSwap swapSwap

119− where swap : (a', b') -> (b', a')

120− swap (x, y) = (y, x)

121−

122− swapSwap : (x : (a', b')) -> swap (swap x) = x

116+ where swapSwap : (x : (a', b')) -> swap (swap x) = x

123117 swapSwap (x, y) = Refl

124118

125119||| Conjunction is associative

libs/base/Control/Monad/State.idr+18−2

@@ -1,6 +1,6 @@

11module Control.Monad.State

22

3−import Control.Monad.Identity

3+import public Control.Monad.Identity

44import Control.Monad.Trans

55

66%access public

@@ -15,7 +15,10 @@ class Monad m => MonadState s (m : Type -> Type) | m where

1515||| The transformer on which the State monad is based

1616record StateT (s : Type) (m : Type -> Type) (a : Type) where

1717 constructor ST

18− runStateT : s -> m (a, s)

18+ runStateT' : s -> m (a, s)

19+

20+runStateT : StateT s m a -> s -> m (a, s)

21+runStateT (ST run) = run

1922

2023instance Functor f => Functor (StateT s f) where

2124 map f (ST g) = ST (\st => map (mapFst f) (g st)) where

@@ -55,3 +58,16 @@ gets f = do s <- get

5558||| The State monad. See the MonadState class

5659State : Type -> Type -> Type

5760State s a = StateT s Identity a

61+

62+||| Unwrap a State monad computation.

63+runState : StateT s Identity a -> s -> (a,s)

64+runState (ST fun) init = case fun init of

65+ Id x => x

66+

67+||| Unwrap a State monad computation, but discard the final state.

68+evalState : State s a -> s -> a

69+evalState m = fst . runState m

70+

71+||| Unwrap a State monad computation, but discard the resulting value.

72+execState : State s a -> s -> s

73+execState m = snd . runState m

libs/base/Data/Bits.idr+5−10

@@ -4,21 +4,16 @@ import Data.Fin

44

55%default total

66

7−divCeil : Nat -> Nat -> Nat

8−divCeil x y = case x `mod` y of

9− Z => x `div` y

10− S _ => S (x `div` y)

11−

127nextPow2 : Nat -> Nat

138nextPow2 Z = Z

14−nextPow2 x = if x == (2 `power` l2x)

15− then l2x

16− else S l2x

9+nextPow2 (S x) = if (S x) == (2 `power` l2x)

10+ then l2x

11+ else S l2x

1712 where

18− l2x = log2 x

13+ l2x = log2NZ (S x) SIsNotZ

1914

2015nextBytes : Nat -> Nat

21−nextBytes bits = (nextPow2 (bits `divCeil` 8))

16+nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ))

2217

2318machineTy : Nat -> Type

2419machineTy Z = Bits8

libs/base/Data/List.idr+13

@@ -36,3 +36,16 @@ isElem x (y :: xs) with (decEq x y)

3636 Elem x' (y' :: xs') -> Void

3737 mkNo f g Here = f Refl

3838 mkNo f g (There x) = g x

39+

40+||| The intersectBy function returns the intersect of two lists by user-supplied equality predicate.

41+intersectBy : (a -> a -> Bool) -> List a -> List a -> List a

42+intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]

43+

44+||| Compute the intersection of two lists according to their `Eq` instance.

45+|||

46+||| ```idris example

47+||| intersect [1, 2, 3, 4] [2, 4, 6, 8]

48+||| ```

49+|||

50+intersect : (Eq a) => List a -> List a -> List a

51+intersect = intersectBy (==)

libs/base/Data/VectType.idr+7−10

@@ -372,14 +372,11 @@ find p (x::xs) with (p x)

372372 | False = find p xs

373373

374374||| Find the index of the first element of the vector that satisfies some test

375−findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

376−findIndex = findIndex' 0

377− where

378− findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat

379− findIndex' cnt p [] = Nothing

380− findIndex' cnt p (x::xs) with (p x)

381− | True = Just cnt

382− | False = findIndex' (S cnt) p xs

375+findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n)

376+findIndex p [] = Nothing

377+findIndex p (x :: xs) with (p x)

378+ | True = Just 0

379+ | False = map FS (findIndex p xs)

383380

384381||| Find the indices of all elements that satisfy some test

385382total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

@@ -394,10 +391,10 @@ findIndices = findIndices' 0

394391 else

395392 (_ ** tail)

396393

397−elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat

394+elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m)

398395elemIndexBy p e = findIndex $ p e

399396

400−elemIndex : Eq a => a -> Vect m a -> Maybe Nat

397+elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m)

401398elemIndex = elemIndexBy (==)

402399

403400total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)

libs/base/Language/Reflection/Utils.idr+49−12

@@ -61,18 +61,46 @@ binderTy (Guess t1 t2) = t1

6161binderTy (PVar t) = t

6262binderTy (PVTy t) = t

6363

64−instance Show TTName where

65− show (UN str) = "(UN " ++ str ++ ")"

66− show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"

67− show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"

68− show NErased = "NErased"

69−

70−instance Eq TTName where

71− (UN str1) == (UN str2) = str1 == str2

72− (NS n ns) == (NS n' ns') = n == n' && ns == ns'

73− (MN i str) == (MN i' str') = i == i' && str == str'

74− NErased == NErased = True

75− x == y = False

64+mutual

65+ instance Show SpecialName where

66+ show (WhereN i n1 n2) = "(WhereN " ++ show i ++ " " ++

67+ show n1 ++ " " ++ show n2 ++ ")"

68+ show (WithN i n) = "(WithN " ++ show i ++ " " ++ show n ++ ")"

69+ show (InstanceN i ss) = "(InstanceN " ++ show i ++ " " ++ show ss ++ ")"

70+ show (ParentN n s) = "(ParentN " ++ show n ++ " " ++ show s ++ ")"

71+ show (MethodN n) = "(MethodN " ++ show n ++ ")"

72+ show (CaseN n) = "(CaseN " ++ show n ++ ")"

73+ show (ElimN n) = "(ElimN " ++ show n ++ ")"

74+ show (InstanceCtorN n) = "(InstanceCtorN " ++ show n ++ ")"

75+ show (MetaN parent meta) = "(MetaN " ++ show parent ++ " " ++ show meta ++ ")"

76+

77+ instance Show TTName where

78+ show (UN str) = "(UN " ++ str ++ ")"

79+ show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"

80+ show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"

81+ show (SN sn) = "(SN " ++ assert_total (show sn) ++ ")"

82+ show NErased = "NErased"

83+

84+mutual

85+ instance Eq TTName where

86+ (UN str1) == (UN str2) = str1 == str2

87+ (NS n ns) == (NS n' ns') = n == n' && ns == ns'

88+ (MN i str) == (MN i' str') = i == i' && str == str'

89+ NErased == NErased = True

90+ (SN sn) == (SN sn') = assert_total $ sn == sn'

91+ x == y = False

92+

93+ instance Eq SpecialName where

94+ (WhereN i n1 n2) == (WhereN i' n1' n2') = i == i' && n1 == n1' && n2 == n2'

95+ (WithN i n) == (WithN i' n') = i == i' && n == n'

96+ (InstanceN i ss) == (InstanceN i' ss') = i == i' && ss == ss'

97+ (ParentN n s) == (ParentN n' s') = n == n' && s == s'

98+ (MethodN n) == (MethodN n') = n == n'

99+ (CaseN n) == (CaseN n') = n == n'

100+ (ElimN n) == (ElimN n') = n == n'

101+ (InstanceCtorN n) == (InstanceCtorN n') = n == n'

102+ (MetaN parent meta) == (MetaN parent' meta') = parent == parent' && meta == meta'

103+ _ == _ = False

76104

77105instance Show TTUExp where

78106 show (UVar i) = "(UVar " ++ show i ++ ")"

@@ -269,3 +297,12 @@ instance Show Err where

269297 show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""

270298 show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"

271299

300+-------------------------

301+-- Idiom brackets for Raw

302+-------------------------

303+

304+(<*>) : Raw -> Raw -> Raw

305+(<*>) = RApp

306+

307+pure : Raw -> Raw

308+pure = id

libs/contrib/Classes/Verified.idr+13−10

@@ -1,6 +1,8 @@

11module Classes.Verified

22

33import Control.Algebra

4+import Control.Algebra.Lattice

5+import Control.Algebra.VectorSpace

46

57-- Due to these being basically unused and difficult to implement,

68-- they're in contrib for a bit. Once a design is found that lets them

@@ -78,6 +80,11 @@ class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where

7880 total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l

7981 total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r

8082

83+--class (VerifiedRingWithUnity a, Field a) => VerifiedField a where

84+-- total fieldInverseIsInverseL : (l : a) -> (notId : Not (l = neutral)) -> l <.> (inverseM l notId) = unity

85+-- total fieldInverseIsInverseR : (r : a) -> (notId : Not (r = neutral)) -> (inverseM r notId) <.> r = unity

86+

87+

8188class JoinSemilattice a => VerifiedJoinSemilattice a where

8289 total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

8390 total joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

@@ -100,15 +107,11 @@ class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice

100107

101108class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

102109

103−class (VerifiedRing a, Field a) => VerifiedField a where

104− total fieldInverseIsInverseL : (l : a) -> l <.> inverseM l = unity

105− total fieldInverseIsInverseR : (r : a) -> inverseM r <.> r = unity

106−

107−-- class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where

108−-- total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v

109−-- total moduleScalarUnityIsUnity : (v : b) -> unity <#> v = v

110−-- total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)

111−-- total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

112110

113−-- class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

111+--class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where

112+-- total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <.> y) <#> v

113+-- total moduleScalarUnityIsUnity : (v : b) -> unity {a} <#> v = v

114+-- total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w)

115+-- total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

114116

117+--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

libs/contrib/Control/Algebra.idr+17−159

@@ -1,11 +1,8 @@

11module Control.Algebra

22

3−import Data.Heap

4−

5−-- XXX: change?

63infixl 6 <->

7−infixl 6 <.>

8−infixl 5 <#>

4+infixl 7 <.>

5+

96

107||| Sets equipped with a single binary operation that is associative, along with

118||| a neutral element for that binary operation and inverses for all elements.

@@ -40,7 +37,6 @@ class Monoid a => Group a where

4037||| forall a, inverse a <+> a == neutral

4138class Group a => AbelianGroup a where { }

4239

43−

4440||| Sets equipped with two binary operations, one associative and commutative

4541||| supplied with a neutral element, and the other associative, with

4642||| distributivity laws relating the two operations. Must satisfy the following

@@ -64,7 +60,6 @@ class Group a => AbelianGroup a where { }

6460class AbelianGroup a => Ring a where

6561 (<.>) : a -> a -> a

6662

67−

6863||| Sets equipped with two binary operations, one associative and commutative

6964||| supplied with a neutral element, and the other associative supplied with a

7065||| neutral element, with distributivity laws relating the two operations. Must

@@ -91,137 +86,10 @@ class AbelianGroup a => Ring a where

9186class Ring a => RingWithUnity a where

9287 unity : a

9388

94−

95−||| Sets equipped with a binary operation that is commutative, associative and

96−||| idempotent. Must satisfy the following laws:

97−|||

98−||| + Associativity of join:

99−||| forall a b c, join a (join b c) == join (join a b) c

100−||| + Commutativity of join:

101−||| forall a b, join a b == join b a

102−||| + Idempotency of join:

103−||| forall a, join a a == a

104−|||

105−||| Join semilattices capture the notion of sets with a "least upper bound".

106−class JoinSemilattice a where

107− join : a -> a -> a

108−

109−instance JoinSemilattice Nat where

110− join = maximum

111−

112−instance Ord a => JoinSemilattice (MaxiphobicHeap a) where

113− join = merge

114−

115−||| Sets equipped with a binary operation that is commutative, associative and

116−||| idempotent. Must satisfy the following laws:

117−|||

118−||| + Associativity of meet:

119−||| forall a b c, meet a (meet b c) == meet (meet a b) c

120−||| + Commutativity of meet:

121−||| forall a b, meet a b == meet b a

122−||| + Idempotency of meet:

123−||| forall a, meet a a == a

124−|||

125−||| Meet semilattices capture the notion of sets with a "greatest lower bound".

126−class MeetSemilattice a where

127− meet : a -> a -> a

128−

129−instance MeetSemilattice Nat where

130− meet = minimum

131−

132−

133−||| Sets equipped with a binary operation that is commutative, associative and

134−||| idempotent and supplied with a unitary element. Must satisfy the following

135−||| laws:

136−|||

137−||| + Associativity of join:

138−||| forall a b c, join a (join b c) == join (join a b) c

139−||| + Commutativity of join:

140−||| forall a b, join a b == join b a

141−||| + Idempotency of join:

142−||| forall a, join a a == a

143−||| + Bottom (Unitary Element):

144−||| forall a, join a bottom == a

145−|||

146−||| Join semilattices capture the notion of sets with a "least upper bound"

147−||| equipped with a "bottom" element.

148−class JoinSemilattice a => BoundedJoinSemilattice a where

149− bottom : a

150−

151−

152−instance BoundedJoinSemilattice Nat where

153− bottom = Z

154−

155−

156−||| Sets equipped with a binary operation that is commutative, associative and

157−||| idempotent and supplied with a unitary element. Must satisfy the following

158−||| laws:

159−|||

160−||| + Associativity of meet:

161−||| forall a b c, meet a (meet b c) == meet (meet a b) c

162−||| + Commutativity of meet:

163−||| forall a b, meet a b == meet b a

164−||| + Idempotency of meet:

165−||| forall a, meet a a == a

166−||| + Top (Unitary Element):

167−||| forall a, meet a top == a

168−|||

169−||| Meet semilattices capture the notion of sets with a "greatest lower bound"

170−||| equipped with a "top" element.

171−class MeetSemilattice a => BoundedMeetSemilattice a where

172− top : a

173−

174−

175−

176−||| Sets equipped with two binary operations that are both commutative,

177−||| associative and idempotent, along with absorbtion laws for relating the two

178−||| binary operations. Must satisfy the following:

179−|||

180−||| + Associativity of meet and join:

181−||| forall a b c, meet a (meet b c) == meet (meet a b) c

182−||| forall a b c, join a (join b c) == join (join a b) c

183−||| + Commutativity of meet and join:

184−||| forall a b, meet a b == meet b a

185−||| forall a b, join a b == join b a

186−||| + Idempotency of meet and join:

187−||| forall a, meet a a == a

188−||| forall a, join a a == a

189−||| + Absorbtion laws for meet and join:

190−||| forall a b, meet a (join a b) == a

191−||| forall a b, join a (meet a b) == a

192−class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }

193−

194−

195−instance Lattice Nat where { }

196−

197−||| Sets equipped with two binary operations that are both commutative,

198−||| associative and idempotent and supplied with neutral elements, along with

199−||| absorbtion laws for relating the two binary operations. Must satisfy the

200−||| following:

201−|||

202−||| + Associativity of meet and join:

203−||| forall a b c, meet a (meet b c) == meet (meet a b) c

204−||| forall a b c, join a (join b c) == join (join a b) c

205−||| + Commutativity of meet and join:

206−||| forall a b, meet a b == meet b a

207−||| forall a b, join a b == join b a

208−||| + Idempotency of meet and join:

209−||| forall a, meet a a == a

210−||| forall a, join a a == a

211−||| + Absorbtion laws for meet and join:

212−||| forall a b, meet a (join a b) == a

213−||| forall a b, join a (meet a b) == a

214−||| + Neutral for meet and join:

215−||| forall a, meet a top == top

216−||| forall a, join a bottom == bottom

217−class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

218−

219−

220−-- Fields.

221−||| Sets equipped with two binary operations, both associative and commutative

222−||| supplied with a neutral element, with

223−||| distributivity laws relating the two operations. Must satisfy the following

224−||| laws:

89+||| Sets equipped with two binary operations – both associative, commutative and

90+||| possessing a neutral element – and distributivity laws relating the two

91+||| operations. All elements except the additive identity must have a

92+||| multiplicative inverse. Must satisfy the following laws:

22593|||

22694||| + Associativity of `<+>`:

22795||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

@@ -238,34 +106,24 @@ class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a w

238106||| + Unity for `<.>`:

239107||| forall a, a <.> unity == a

240108||| forall a, unity <.> a == a

241−||| + InverseM of `<.>`:

242−||| forall a, a <.> inverseM a == unity

243−||| forall a, inverseM a <.> a == unity

109+||| + InverseM of `<.>`, except for neutral

110+||| forall a /= neutral, a <.> inverseM a == unity

111+||| forall a /= neutral, inverseM a <.> a == unity

244112||| + Distributivity of `<.>` and `<->`:

245113||| forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)

246114||| forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)

247115class RingWithUnity a => Field a where

248− inverseM : a -> a

249−

116+ inverseM : (x : a) -> Not (x = neutral) -> a

250117

251−||| A module over a ring is an additive abelian group of 'vectors' endowed with a

252−||| scale operation multiplying vectors by ring elements, and distributivity laws

253−||| relating the scale operation to both ring addition and module addition.

254−||| Must satisfy the following laws:

255−|||

256−||| + Compatibility of scalar multiplication with ring multiplication:

257−||| forall a b v, a <#> (b <#> v) = (a <.> b) <#> v

258−||| + Ring unity is the identity element of scalar multiplication:

259−||| forall v, unity <#> v = v

260−||| + Distributivity of `<#>` and `<+>`:

261−||| forall a v w, a <#> (v <+> w) == (a <#> v) <+> (a <#> w)

262−||| forall a b v, (a <+> b) <#> v == (a <#> v) <+> (b <#> v)

263−class (RingWithUnity a, AbelianGroup b) => Module a b where

264− (<#>) : a -> b -> b

118+sum : (Foldable t, Monoid a) => t a -> a

119+sum = foldr (<+>) neutral

265120

121+product : (Foldable t, RingWithUnity a) => t a -> a

122+product = foldr (<.>) unity

266123

267−||| A vector space is a module over a ring that is also a field

268−class (Field a, Module a b) => VectorSpace a b where {}

124+power : RingWithUnity a => a -> Nat -> a

125+power _ Z = unity

126+power x (S n) = x <.> (Algebra.power x n)

269127

270128

271129-- XXX todo:

libs/contrib/Control/Algebra/Lattice.idrnew file+123

@@ -0,0 +1,123 @@

1+module Control.Algebra.Lattice

2+

3+import Control.Algebra

4+import Data.Heap

5+

6+

7+||| Sets equipped with a binary operation that is commutative, associative and

8+||| idempotent. Must satisfy the following laws:

9+|||

10+||| + Associativity of join:

11+||| forall a b c, join a (join b c) == join (join a b) c

12+||| + Commutativity of join:

13+||| forall a b, join a b == join b a

14+||| + Idempotency of join:

15+||| forall a, join a a == a

16+|||

17+||| Join semilattices capture the notion of sets with a "least upper bound".

18+class JoinSemilattice a where

19+ join : a -> a -> a

20+

21+instance JoinSemilattice Nat where

22+ join = maximum

23+

24+instance Ord a => JoinSemilattice (MaxiphobicHeap a) where

25+ join = merge

26+

27+||| Sets equipped with a binary operation that is commutative, associative and

28+||| idempotent. Must satisfy the following laws:

29+|||

30+||| + Associativity of meet:

31+||| forall a b c, meet a (meet b c) == meet (meet a b) c

32+||| + Commutativity of meet:

33+||| forall a b, meet a b == meet b a

34+||| + Idempotency of meet:

35+||| forall a, meet a a == a

36+|||

37+||| Meet semilattices capture the notion of sets with a "greatest lower bound".

38+class MeetSemilattice a where

39+ meet : a -> a -> a

40+

41+instance MeetSemilattice Nat where

42+ meet = minimum

43+

44+||| Sets equipped with a binary operation that is commutative, associative and

45+||| idempotent and supplied with a unitary element. Must satisfy the following

46+||| laws:

47+|||

48+||| + Associativity of join:

49+||| forall a b c, join a (join b c) == join (join a b) c

50+||| + Commutativity of join:

51+||| forall a b, join a b == join b a

52+||| + Idempotency of join:

53+||| forall a, join a a == a

54+||| + Bottom (Unitary Element):

55+||| forall a, join a bottom == a

56+|||

57+||| Join semilattices capture the notion of sets with a "least upper bound"

58+||| equipped with a "bottom" element.

59+class JoinSemilattice a => BoundedJoinSemilattice a where

60+ bottom : a

61+

62+instance BoundedJoinSemilattice Nat where

63+ bottom = Z

64+

65+||| Sets equipped with a binary operation that is commutative, associative and

66+||| idempotent and supplied with a unitary element. Must satisfy the following

67+||| laws:

68+|||

69+||| + Associativity of meet:

70+||| forall a b c, meet a (meet b c) == meet (meet a b) c

71+||| + Commutativity of meet:

72+||| forall a b, meet a b == meet b a

73+||| + Idempotency of meet:

74+||| forall a, meet a a == a

75+||| + Top (Unitary Element):

76+||| forall a, meet a top == a

77+|||

78+||| Meet semilattices capture the notion of sets with a "greatest lower bound"

79+||| equipped with a "top" element.

80+class MeetSemilattice a => BoundedMeetSemilattice a where

81+ top : a

82+

83+||| Sets equipped with two binary operations that are both commutative,

84+||| associative and idempotent, along with absorbtion laws for relating the two

85+||| binary operations. Must satisfy the following:

86+|||

87+||| + Associativity of meet and join:

88+||| forall a b c, meet a (meet b c) == meet (meet a b) c

89+||| forall a b c, join a (join b c) == join (join a b) c

90+||| + Commutativity of meet and join:

91+||| forall a b, meet a b == meet b a

92+||| forall a b, join a b == join b a

93+||| + Idempotency of meet and join:

94+||| forall a, meet a a == a

95+||| forall a, join a a == a

96+||| + Absorbtion laws for meet and join:

97+||| forall a b, meet a (join a b) == a

98+||| forall a b, join a (meet a b) == a

99+class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }

100+

101+instance Lattice Nat where { }

102+

103+||| Sets equipped with two binary operations that are both commutative,

104+||| associative and idempotent and supplied with neutral elements, along with

105+||| absorbtion laws for relating the two binary operations. Must satisfy the

106+||| following:

107+|||

108+||| + Associativity of meet and join:

109+||| forall a b c, meet a (meet b c) == meet (meet a b) c

110+||| forall a b c, join a (join b c) == join (join a b) c

111+||| + Commutativity of meet and join:

112+||| forall a b, meet a b == meet b a

113+||| forall a b, join a b == join b a

114+||| + Idempotency of meet and join:

115+||| forall a, meet a a == a

116+||| forall a, join a a == a

117+||| + Absorbtion laws for meet and join:

118+||| forall a b, meet a (join a b) == a

119+||| forall a b, join a (meet a b) == a

120+||| + Neutral for meet and join:

121+||| forall a, meet a top == top

122+||| forall a, join a bottom == bottom

123+class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

libs/contrib/Control/Algebra/NumericInstances.idrnew file+104

@@ -0,0 +1,104 @@

1+module Control.Algebra.NumericInstances

2+

3+import Control.Algebra

4+import Data.Complex

5+import Data.ZZ

6+

7+

8+instance Semigroup Integer where

9+ (<+>) = (+)

10+

11+instance Monoid Integer where

12+ neutral = 0

13+

14+instance Group Integer where

15+ inverse = (* -1)

16+

17+instance AbelianGroup Integer

18+

19+instance Ring Integer where

20+ (<.>) = (*)

21+

22+instance RingWithUnity Integer where

23+ unity = 1

24+

25+

26+instance Semigroup Int where

27+ (<+>) = (+)

28+

29+instance Monoid Int where

30+ neutral = 0

31+

32+instance Group Int where

33+ inverse = (* -1)

34+

35+instance AbelianGroup Int

36+

37+instance Ring Int where

38+ (<.>) = (*)

39+

40+instance RingWithUnity Int where

41+ unity = 1

42+

43+

44+instance Semigroup Float where

45+ (<+>) = (+)

46+

47+instance Monoid Float where

48+ neutral = 0

49+

50+instance Group Float where

51+ inverse = (* -1)

52+

53+instance AbelianGroup Float

54+

55+instance Ring Float where

56+ (<.>) = (*)

57+

58+instance RingWithUnity Float where

59+ unity = 1

60+

61+instance Field Float where

62+ inverseM f _ = 1 / f

63+

64+

65+instance Semigroup Nat where

66+ (<+>) = (+)

67+

68+instance Monoid Nat where

69+ neutral = 0

70+

71+instance Semigroup ZZ where

72+ (<+>) = (+)

73+

74+instance Monoid ZZ where

75+ neutral = 0

76+

77+instance Group ZZ where

78+ inverse = (* -1)

79+

80+instance AbelianGroup ZZ

81+

82+instance Ring ZZ where

83+ (<.>) = (*)

84+

85+instance RingWithUnity ZZ where

86+ unity = 1

87+

88+

89+instance Semigroup a => Semigroup (Complex a) where

90+ (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)

91+

92+instance Monoid a => Monoid (Complex a) where

93+ neutral = (neutral :+ neutral)

94+

95+instance Group a => Group (Complex a) where

96+ inverse (r :+ i) = (inverse r :+ inverse i)

97+

98+instance Ring a => AbelianGroup (Complex a) where {}

99+

100+instance Ring a => Ring (Complex a) where

101+ (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c)

102+

103+instance RingWithUnity a => RingWithUnity (Complex a) where

104+ unity = (unity :+ neutral)

libs/contrib/Control/Algebra/VectorSpace.idrnew file+30

@@ -0,0 +1,30 @@

1+module Control.Algebra.VectorSpace

2+

3+import Control.Algebra

4+

5+infixl 5 <#>

6+infixr 2 <||>

7+

8+

9+||| A module over a ring is an additive abelian group of 'vectors' endowed with a

10+||| scale operation multiplying vectors by ring elements, and distributivity laws

11+||| relating the scale operation to both ring addition and module addition.

12+||| Must satisfy the following laws:

13+|||

14+||| + Compatibility of scalar multiplication with ring multiplication:

15+||| forall a b v, a <#> (b <#> v) = (a <.> b) <#> v

16+||| + Ring unity is the identity element of scalar multiplication:

17+||| forall v, unity <#> v = v

18+||| + Distributivity of `<#>` and `<+>`:

19+||| forall a v w, a <#> (v <+> w) == (a <#> v) <+> (a <#> w)

20+||| forall a b v, (a <+> b) <#> v == (a <#> v) <+> (b <#> v)

21+class (RingWithUnity a, AbelianGroup b) => Module a b where

22+ (<#>) : a -> b -> b

23+

24+||| A vector space is a module over a ring that is also a field

25+class (Field a, Module a b) => VectorSpace a b where {}

26+

27+||| An inner product space is a module – or vector space – over a ring, with a binary function

28+||| associating a ring value to each pair of vectors.

29+class Module a b => InnerProductSpace a b where

30+ (<||>) : b -> b -> a

libs/contrib/Control/Partial.idrnew file+14

@@ -0,0 +1,14 @@

1+||| Control structures that are fundamentally partial

2+module Control.Partial

3+

4+

5+||| Repeatedly apply `f` to `v` until `p` is `True`.

6+|||

7+||| @ p the predicate to wait for

8+||| @ f the function to repeatedly apply

9+||| @ v the starting value

10+partial

11+until : (p : a -> Bool) -> (f : a -> a) -> (v : a) -> a

12+until p f v with (p v)

13+ | False = until p f (f v)

14+ | True = v

libs/contrib/Data/CoList.idrnew file+54

@@ -0,0 +1,54 @@

1+module Data.CoList

2+

3+%access public

4+%default total

5+

6+||| Idris will know that it always can produce a new element in finite time

7+codata CoList : Type -> Type where

8+ Nil : CoList a

9+ (::) : a -> CoList a -> CoList a

10+

11+||| Append two CoLists

12+(++) : CoList a -> CoList a -> CoList a

13+(++) [] right = right

14+(++) (x::xs) right = x :: (xs ++ right)

15+

16+instance Semigroup (CoList a) where

17+ (<+>) = (++)

18+

19+instance Monoid (CoList a) where

20+ neutral = []

21+

22+instance Functor CoList where

23+ map f [] = []

24+ map f (x::xs) = f x :: map f xs

25+

26+instance Show a => Show (CoList a) where

27+ show xs = "[" ++ show' "" 20 xs ++ "]" where

28+ show' : String -> (n : Nat) -> (xs : CoList a) -> String

29+ show' acc Z _ = acc ++ "..."

30+ show' acc (S n) [] = acc

31+ show' acc (S n) [x] = acc ++ show x

32+ show' acc (S n) (x :: xs) = show' (acc ++ (show x) ++ ", ") n xs

33+

34+||| Take the first `n` elements of `xs`

35+|||

36+||| If there are not enough elements, return the whole coList.

37+||| @ n how many elements to take

38+||| @ xs the coList to take them from

39+takeCo : (n : Nat) -> (xs : CoList a) -> List a

40+takeCo Z _ = []

41+takeCo (S n) [] = []

42+takeCo (S n) (x::xs) = x :: takeCo n xs

43+

44+||| The unfoldr builds a list from a seed value. In some cases, unfoldr can undo a foldr operation.

45+|||

46+||| ``` idris example

47+||| unfoldr (\b => if b == 0 then Nothing else Just (b, b-1)) 10

48+||| ```

49+|||

50+unfoldr : (a -> Maybe (a, a)) -> a -> CoList a

51+unfoldr f x =

52+ case f x of

53+ Just (y, new_x) => y :: (unfoldr f new_x)

54+ _ => []

libs/contrib/Data/Matrix.idr+4−104

@@ -1,6 +1,8 @@

11module Data.Matrix

22

3−import Control.Algebra

3+import Control.Algebra

4+import Control.Algebra.VectorSpace

5+import public Control.Algebra.NumericInstances

46

57import Data.Complex

68import Data.ZZ

@@ -40,8 +42,7 @@ instance Ring a => Ring (Vect n a) where

4042instance RingWithUnity a => RingWithUnity (Vect n a) where

4143 unity {n} = replicate n unity

4244

43−instance Field a => Field (Vect n a) where

44− inverseM = map inverseM

45+--instance Field a => Field (Vect n a) where

4546

4647instance RingWithUnity a => Module a (Vect n a) where

4748 (<#>) r v = map (r <.>) v

@@ -147,104 +148,3 @@ Id {d} = map (\n => basis n) $ allN d

147148

148149-- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes

149150

150−-----------------------------------------------------------------------

151−-- Numberic data types as rings

152−-----------------------------------------------------------------------

153−

154−instance Semigroup Integer where

155− (<+>) = (+)

156−

157−instance Monoid Integer where

158− neutral = 0

159−

160−instance Group Integer where

161− inverse = (* -1)

162−

163−instance AbelianGroup Integer

164−

165−instance Ring Integer where

166− (<.>) = (*)

167−

168−instance RingWithUnity Integer where

169− unity = 1

170−

171−

172−instance Semigroup Int where

173− (<+>) = (+)

174−

175−instance Monoid Int where

176− neutral = 0

177−

178−instance Group Int where

179− inverse = (* -1)

180−

181−instance AbelianGroup Int

182−

183−instance Ring Int where

184− (<.>) = (*)

185−

186−instance RingWithUnity Int where

187− unity = 1

188−

189−

190−instance Semigroup Float where

191− (<+>) = (+)

192−

193−instance Monoid Float where

194− neutral = 0

195−

196−instance Group Float where

197− inverse = (* -1)

198−

199−instance AbelianGroup Float

200−

201−instance Ring Float where

202− (<.>) = (*)

203−

204−instance RingWithUnity Float where

205− unity = 1

206−

207−instance Field Float where

208− inverseM f = 1 / f

209−

210−

211−instance Semigroup Nat where

212− (<+>) = (+)

213−

214−instance Monoid Nat where

215− neutral = 0

216−

217−instance Semigroup ZZ where

218− (<+>) = (+)

219−

220−instance Monoid ZZ where

221− neutral = 0

222−

223−instance Group ZZ where

224− inverse = (* -1)

225−

226−instance AbelianGroup ZZ

227−

228−instance Ring ZZ where

229− (<.>) = (*)

230−

231−instance RingWithUnity ZZ where

232− unity = 1

233−

234−

235−instance Semigroup a => Semigroup (Complex a) where

236− (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d)

237−

238−instance Monoid a => Monoid (Complex a) where

239− neutral = (neutral :+ neutral)

240−

241−instance Group a => Group (Complex a) where

242− inverse (r :+ i) = (inverse r :+ inverse i)

243−

244−instance Ring a => AbelianGroup (Complex a) where {}

245−

246−instance Ring a => Ring (Complex a) where

247− (<.>) (a :+ b) (c :+ d) = (a <.> c <-> b <.> d) :+ (a <.> d <+> b <.> c)

248−

249−instance RingWithUnity a => RingWithUnity (Complex a) where

250− unity = (unity :+ neutral)

libs/contrib/Data/Nat.idr+1

@@ -7,6 +7,7 @@ import Data.So

77import Control.WellFounded

88

99%default total

10+%access public

1011

1112||| A strict less-than relation on `Nat`.

1213|||

libs/contrib/Data/SortedMap.idr+64−53

@@ -2,72 +2,73 @@ module Data.SortedMap

22

33-- TODO: write merge and split

44

5−data Tree : Nat -> Type -> Type -> Type where

6− Leaf : k -> v -> Tree Z k v

7− Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v

8− Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v

5+private

6+data Tree : Nat -> (k : Type) -> Type -> Ord k -> Type where

7+ Leaf : k -> v -> Tree Z k v o

8+ Branch2 : Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o

9+ Branch3 : Tree n k v o -> k -> Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o

910

1011branch4 :

11− Tree n k v -> k ->

12− Tree n k v -> k ->

13− Tree n k v -> k ->

14− Tree n k v ->

15− Tree (S (S n)) k v

12+ Tree n k v o -> k ->

13+ Tree n k v o -> k ->

14+ Tree n k v o -> k ->

15+ Tree n k v o ->

16+ Tree (S (S n)) k v o

1617branch4 a b c d e f g =

1718 Branch2 (Branch2 a b c) d (Branch2 e f g)

1819

1920branch5 :

20− Tree n k v -> k ->

21− Tree n k v -> k ->

22− Tree n k v -> k ->

23− Tree n k v -> k ->

24− Tree n k v ->

25− Tree (S (S n)) k v

21+ Tree n k v o -> k ->

22+ Tree n k v o -> k ->

23+ Tree n k v o -> k ->

24+ Tree n k v o -> k ->

25+ Tree n k v o ->

26+ Tree (S (S n)) k v o

2627branch5 a b c d e f g h i =

2728 Branch2 (Branch2 a b c) d (Branch3 e f g h i)

2829

2930branch6 :

30− Tree n k v -> k ->

31− Tree n k v -> k ->

32− Tree n k v -> k ->

33− Tree n k v -> k ->

34− Tree n k v -> k ->

35− Tree n k v ->

36− Tree (S (S n)) k v

31+ Tree n k v o -> k ->

32+ Tree n k v o -> k ->

33+ Tree n k v o -> k ->

34+ Tree n k v o -> k ->

35+ Tree n k v o -> k ->

36+ Tree n k v o ->

37+ Tree (S (S n)) k v o

3738branch6 a b c d e f g h i j k =

3839 Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

3940

4041branch7 :

41− Tree n k v -> k ->

42− Tree n k v -> k ->

43− Tree n k v -> k ->

44− Tree n k v -> k ->

45− Tree n k v -> k ->

46− Tree n k v -> k ->

47− Tree n k v ->

48− Tree (S (S n)) k v

42+ Tree n k v o -> k ->

43+ Tree n k v o -> k ->

44+ Tree n k v o -> k ->

45+ Tree n k v o -> k ->

46+ Tree n k v o -> k ->

47+ Tree n k v o -> k ->

48+ Tree n k v o ->

49+ Tree (S (S n)) k v o

4950branch7 a b c d e f g h i j k l m =

5051 Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

5152

52−merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v

53+merge1 : Tree n k v o -> k -> Tree (S n) k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o

5354merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i

5455merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k

5556merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k

5657merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

5758

58−merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v

59+merge2 : Tree (S n) k v o -> k -> Tree n k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o

5960merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i

6061merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k

6162merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k

6263merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

6364

64−merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v

65+merge3 : Tree (S n) k v o -> k -> Tree (S n) k v o -> k -> Tree n k v o -> Tree (S (S n)) k v o

6566merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i

6667merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k

6768merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k

6869merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

6970

70−treeLookup : Ord k => k -> Tree n k v -> Maybe v

71+treeLookup : k -> Tree n k v o -> Maybe v

7172treeLookup k (Leaf k' v) =

7273 if k == k' then

7374 Just v

@@ -86,7 +87,7 @@ treeLookup k (Branch3 t1 k1 t2 k2 t3) =

8687 else

8788 treeLookup k t3

8889

89−treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)

90+treeInsert' : k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree n k v o, k, Tree n k v o)

9091treeInsert' k v (Leaf k' v') =

9192 case compare k k' of

9293 LT => Right (Leaf k v, k, Leaf k' v')

@@ -116,17 +117,17 @@ treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =

116117 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

117118 Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

118119

119−treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v)

120+treeInsert : k -> v -> Tree n k v o -> Either (Tree n k v o) (Tree (S n) k v o)

120121treeInsert k v t =

121122 case treeInsert' k v t of

122123 Left t' => Left t'

123124 Right (a, b, c) => Right (Branch2 a b c)

124125

125−delType : Nat -> Type -> Type -> Type

126−delType Z k v = ()

127−delType (S n) k v = Tree n k v

126+delType : Nat -> (k : Type) -> Type -> Ord k -> Type

127+delType Z k v o = ()

128+delType (S n) k v o = Tree n k v o

128129

129−treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)

130+treeDelete : k -> Tree n k v o -> Either (Tree n k v o) (delType n k v o)

130131treeDelete k (Leaf k' v) =

131132 if k == k' then

132133 Right ()

@@ -183,33 +184,38 @@ treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =

183184 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

184185 Right t3' => Left (merge3 t1 k1 t2 k2 t3')

185186

186−treeToList : Tree n k v -> List (k, v)

187+treeToList : Tree n k v o -> List (k, v)

187188treeToList = treeToList' (:: [])

188189 where

189− treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)

190+ treeToList' : ((k, v) -> List (k, v)) -> Tree n k v o -> List (k, v)

190191 treeToList' cont (Leaf k v) = cont (k, v)

191192 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

192193 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

193194

195+abstract

194196data SortedMap : Type -> Type -> Type where

195− Empty : SortedMap k v

196− M : (n:Nat) -> Tree n k v -> SortedMap k v

197+ Empty : Ord k => SortedMap k v

198+ M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v

197199

198−empty : SortedMap k v

200+public

201+empty : Ord k => SortedMap k v

199202empty = Empty

200203

201−lookup : Ord k => k -> SortedMap k v -> Maybe v

204+public

205+lookup : k -> SortedMap k v -> Maybe v

202206lookup _ Empty = Nothing

203207lookup k (M _ t) = treeLookup k t

204208

205−insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v

209+public

210+insert : k -> v -> SortedMap k v -> SortedMap k v

206211insert k v Empty = M Z (Leaf k v)

207212insert k v (M _ t) =

208213 case treeInsert k v t of

209214 Left t' => (M _ t')

210215 Right t' => (M _ t')

211216

212−delete : Ord k => k -> SortedMap k v -> SortedMap k v

217+public

218+delete : k -> SortedMap k v -> SortedMap k v

213219delete _ Empty = Empty

214220delete k (M Z t) =

215221 case treeDelete k t of

@@ -220,18 +226,23 @@ delete k (M (S _) t) =

220226 Left t' => (M _ t')

221227 Right t' => (M _ t')

222228

229+public

223230fromList : Ord k => List (k, v) -> SortedMap k v

224231fromList l = foldl (flip (uncurry insert)) empty l

225232

233+public

226234toList : SortedMap k v -> List (k, v)

227235toList Empty = []

228236toList (M _ t) = treeToList t

229237

230−instance Functor (Tree n k) where

231− map f (Leaf k v) = Leaf k (f v)

232− map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2)

233− map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3)

238+public

239+treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

240+treeMap f (Leaf k v) = Leaf k (f v)

241+treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

242+treeMap f (Branch3 t1 k1 t2 k2 t3)

243+ = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

234244

235245instance Functor (SortedMap k) where

236246 map _ Empty = Empty

237− map f (M n t) = M _ (map f t)

247+ map f (M n t) = M _ (treeMap f t)

248+

libs/contrib/Data/SortedSet.idr+11−4

@@ -4,23 +4,30 @@ import Data.SortedMap

44

55-- TODO: add intersection, union, difference

66

7+abstract

78data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

89

9−empty : SortedSet k

10+public

11+empty : Ord k => SortedSet k

1012empty = SetWrapper Data.SortedMap.empty

1113

12−insert : Ord k => k -> SortedSet k -> SortedSet k

14+public

15+insert : k -> SortedSet k -> SortedSet k

1316insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

1417

15−delete : Ord k => k -> SortedSet k -> SortedSet k

18+public

19+delete : k -> SortedSet k -> SortedSet k

1620delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

1721

18−contains : Ord k => k -> SortedSet k -> Bool

22+public

23+contains : k -> SortedSet k -> Bool

1924contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

2025

26+public

2127fromList : Ord k => List k -> SortedSet k

2228fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

2329

30+public

2431toList : SortedSet k -> List k

2532toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

2633

libs/contrib/Data/String.idrnew file+31

@@ -0,0 +1,31 @@

1+module Data.String

2+

3+infixl 5 +>

4+infixr 5 <+

5+

6+||| Adds a character to the end of the specified string.

7+|||

8+||| ```idris example

9+||| strSnoc "AB" 'C'

10+||| ```

11+||| ```idris example

12+||| strSnoc "" 'A'

13+||| ```

14+strSnoc : String -> Char -> String

15+strSnoc s c = s ++ (singleton c)

16+

17+||| Alias of `strSnoc`

18+|||

19+||| ```idris example

20+||| "AB" +> 'C'

21+||| ```

22+(+>) : String -> Char -> String

23+(+>) = strSnoc

24+

25+||| Alias of `strCons`

26+|||

27+||| ```idris example

28+||| 'A' <+ "AB"

29+||| ```

30+(<+) : Char -> String -> String

31+(<+) = strCons

libs/contrib/Network/Cgi.idr+1−1

@@ -109,7 +109,7 @@ getVars seps query = mapMaybe readVar (split (\x => elem x seps) query)

109109 | _ = Nothing

110110

111111getContent : Int -> IO String

112−getContent x = getC (toNat x) "" where

112+getContent x = getC (cast x) "" where

113113 getC : Nat -> String -> IO String

114114 getC Z acc = return $ reverse acc

115115 getC (S k) acc = do x <- getChar

libs/contrib/contrib.ipkg+5−1

@@ -2,16 +2,20 @@ package contrib

22

33opts = "--nobasepkgs --total -i ../prelude -i ../base"

44modules = Control.Algebra,

5+ Control.Algebra.Lattice, Control.Algebra.VectorSpace,

6+ Control.Algebra.NumericInstances,

57 Control.Isomorphism.Primitives,

8+ Control.Partial,

69 Control.WellFounded,

710 Classes.Verified,

8− Data.Fun, Data.Rel,

11+ Data.Fun, Data.Rel,

912 Data.Hash, Data.Matrix,

1013 Data.Nat,

1114 Data.ZZ, Data.Sign,

1215 Data.BoundedList,

1316 Data.Heap,

1417 Data.SortedMap, Data.SortedSet,

18+ Data.CoList,

1519

1620 Decidable.Decidable, Decidable.Order,

1721

libs/effects/Effect/Exception.idr+2−13

@@ -5,7 +5,7 @@ import System

55import Control.IOExcept

66

77data Exception : Type -> Effect where

8− Raise : a -> { () } Exception a b

8+ Raise : a -> sig (Exception a) b

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

@@ -26,16 +26,5 @@ instance Handler (Exception a) (Either a) where

2626EXCEPTION : Type -> EFFECT

2727EXCEPTION t = MkEff () (Exception t)

2828

29−raise : a -> { [EXCEPTION a ] } Eff b

29+raise : a -> Eff b [EXCEPTION a]

3030raise err = call $ Raise err

31−

32−

33−

34−

35−

36−

37−-- TODO: Catching exceptions mid program?

38−-- probably need to invoke a new interpreter

39−

40−-- possibly add a 'handle' to the Eff language so that an alternative

41−-- handler can be introduced mid interpretation?

libs/effects/Effect/File.idr+16−16

@@ -46,29 +46,29 @@ data FileIO : Effect where

4646 ||| @ m The file mode.

4747 Open : (fname: String)

4848 -> (m : Mode)

49− -> {() ==> {res} if res

50− then OpenFile m

51− else ()} FileIO Bool

49+ -> sig FileIO Bool () (\res => case res of

50+ True => OpenFile m

51+ False => ())

5252

5353 ||| Close a file.

5454 |||

5555 ||| Closing a file moves the state from Open to closed.

56− Close : {OpenFile m ==> ()} FileIO ()

56+ Close : sig FileIO () (OpenFile m) ()

5757

5858 ||| Read a line from the file.

5959 |||

6060 ||| Only files that are open for reading can be read.

61− ReadLine : {OpenFile Read} FileIO String

61+ ReadLine : sig FileIO String (OpenFile Read)

6262

6363 ||| Write a string to a file.

6464 |||

6565 ||| Only file that are open for writing can be written to.

66− WriteString : String -> {OpenFile Write} FileIO ()

66+ WriteString : String -> sig FileIO () (OpenFile Write)

6767

6868 ||| End of file?

6969 |||

7070 ||| Only files open for reading can be tested for EOF

71− EOF : {OpenFile Read} FileIO Bool

71+ EOF : sig FileIO Bool (OpenFile Read)

7272

7373-- ------------------------------------------------------------ [ The Handlers ]

7474

@@ -117,31 +117,31 @@ FILE_IO t = MkEff t FileIO

117117||| @ m The file mode.

118118open : (fname : String)

119119 -> (m : Mode)

120− -> { [FILE_IO ()] ==> {result}

121− [FILE_IO (if result

122− then OpenFile m

123− else ())] } Eff Bool

120+ -> Eff Bool [FILE_IO ()]

121+ (\res => [FILE_IO (case res of

122+ True => OpenFile m

123+ False => ())])

124124open f m = call $ Open f m

125125

126126

127127||| Close a file.

128−close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff ()

128+close : Eff () [FILE_IO (OpenFile m)] [FILE_IO ()]

129129close = call $ Close

130130

131131||| Read a line from the file.

132−readLine : { [FILE_IO (OpenFile Read)] } Eff String

132+readLine : Eff String [FILE_IO (OpenFile Read)]

133133readLine = call $ ReadLine

134134

135135||| Write a string to a file.

136−writeString : String -> { [FILE_IO (OpenFile Write)] } Eff ()

136+writeString : String -> Eff () [FILE_IO (OpenFile Write)]

137137writeString str = call $ WriteString str

138138

139139||| Write a line to a file.

140−writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff ()

140+writeLine : String -> Eff () [FILE_IO (OpenFile Write)]

141141writeLine str = call $ WriteString (str ++ "\n")

142142

143143||| End of file?

144−eof : { [FILE_IO (OpenFile Read)] } Eff Bool

144+eof : Eff Bool [FILE_IO (OpenFile Read)]

145145eof = call $ EOF

146146

147147-- --------------------------------------------------------------------- [ EOF ]

libs/effects/Effect/Random.idr+12−13

@@ -5,28 +5,27 @@ import Data.Vect

55import Data.Fin

66

77data Random : Effect where

8− getRandom : { Integer } Random Integer

9− setSeed : Integer -> { Integer } Random ()

8+ getRandom : sig Random Integer Integer

9+ setSeed : Integer -> sig Random () Integer

1010

11−using (m : Type -> Type)

12− instance Handler Random m where

13− handle seed getRandom k

14− = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in

15− k seed' seed'

16− handle seed (setSeed n) k = k () n

11+instance Handler Random m where

12+ handle seed getRandom k

13+ = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in

14+ k seed' seed'

15+ handle seed (setSeed n) k = k () n

1716

1817RND : EFFECT

1918RND = MkEff Integer Random

2019

2120||| Generates a random Integer in a given range

22−rndInt : Integer -> Integer -> { [RND] } Eff Integer

21+rndInt : Integer -> Integer -> Eff Integer [RND]

2322rndInt lower upper = do v <- call $ getRandom

2423 return ((v `prim__sremBigInt` (upper - lower)) + lower)

2524

2625||| Generate a random number in Fin (S `k`)

2726|||

2827||| Note that rndFin k takes values 0, 1, ..., k.

29−rndFin : (k : Nat) -> { [RND] } Eff (Fin (S k))

28+rndFin : (k : Nat) -> Eff (Fin (S k)) [RND]

3029rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))

3130 return (toFin v)

3231 where toFin : Integer -> Fin (S k)

@@ -35,15 +34,15 @@ rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast

3534 Nothing => toFin (assert_smaller x (x - cast (S k)))

3635

3736||| Select a random element from a vector

38−rndSelect' : Vect (S k) a -> { [RND] } Eff a

37+rndSelect' : Vect (S k) a -> Eff a [RND]

3938rndSelect' {k} xs = return (Vect.index !(rndFin k) xs)

4039

4140||| Select a random element from a list, or Nothing if the list is empty

42−rndSelect : List a -> { [RND] } Eff (Maybe a)

41+rndSelect : List a -> Eff (Maybe a) [RND]

4342rndSelect [] = return Nothing

4443rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))

4544

4645||| Sets the random seed

47−srand : Integer -> { [RND] } Eff ()

46+srand : Integer -> Eff () [RND]

4847srand n = call $ setSeed n

4948

libs/effects/Effect/Select.idr+2−2

@@ -3,7 +3,7 @@ module Effect.Select

33import Effects

44

55data Selection : Effect where

6− Select : List a -> { () } Selection a

6+ Select : List a -> sig Selection a ()

77

88instance Handler Selection Maybe where

99 handle _ (Select xs) k = tryAll xs where

@@ -18,6 +18,6 @@ instance Handler Selection List where

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

21−select : List a -> { [SELECT] } Eff a

21+select : List a -> Eff a [SELECT]

2222select xs = call $ Select xs

2323

libs/effects/Effect/State.idr+8−8

@@ -5,8 +5,8 @@ import Effects

55%access public

66

77data State : Effect where

8− Get : { a } State a

9− Put : b -> { a ==> b } State ()

8+ Get : sig State a a

9+ Put : b -> sig State () a b

1010

1111-- using (m : Type -> Type)

1212instance Handler State m where

@@ -16,22 +16,22 @@ instance Handler State m where

1616STATE : Type -> EFFECT

1717STATE t = MkEff t State

1818

19−get : { [STATE x] } Eff x

19+get : Eff x [STATE x]

2020get = call $ Get

2121

22−put : x -> { [STATE x] } Eff ()

22+put : x -> Eff () [STATE x]

2323put val = call $ Put val

2424

25−putM : y -> { [STATE x] ==> [STATE y] } Eff ()

25+putM : y -> Eff () [STATE x] [STATE y]

2626putM val = call $ Put val

2727

28−update : (x -> x) -> { [STATE x] } Eff ()

28+update : (x -> x) -> Eff () [STATE x]

2929update f = put (f !get)

3030

31−updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff ()

31+updateM : (x -> y) -> Eff () [STATE x] [STATE y]

3232updateM f = putM (f !get)

3333

34−locally : x -> ({ [STATE x] } Eff t) -> { [STATE y] } Eff t

34+locally : x -> (Eff t [STATE x]) -> Eff t [STATE y]

3535locally newst prog = do st <- get

3636 putM newst

3737 val <- prog

libs/effects/Effect/StdIO.idr+12−12

@@ -9,10 +9,10 @@ import Control.IOExcept

99

1010||| The internal representation of StdIO effects

1111data StdIO : Effect where

12− PutStr : String -> { () } StdIO ()

13− GetStr : { () } StdIO String

14− PutCh : Char -> { () } StdIO ()

15− GetCh : { () } StdIO Char

12+ PutStr : String -> sig StdIO ()

13+ GetStr : sig StdIO String

14+ PutCh : Char -> sig StdIO ()

15+ GetCh : sig StdIO Char

1616

1717

1818-------------------------------------------------------------

@@ -39,33 +39,33 @@ STDIO : EFFECT

3939STDIO = MkEff () StdIO

4040

4141||| Write a string to standard output.

42−putStr : String -> { [STDIO] } Eff ()

42+putStr : String -> Eff () [STDIO]

4343putStr s = call $ PutStr s

4444

4545||| Write a string to standard output, terminating with a newline.

46−putStrLn : String -> { [STDIO] } Eff ()

46+putStrLn : String -> Eff () [STDIO]

4747putStrLn s = putStr (s ++ "\n")

4848

4949||| Write a character to standard output.

50−putChar : Char -> { [STDIO] } Eff ()

50+putChar : Char -> Eff () [STDIO]

5151putChar c = call $ PutCh c

5252

5353||| Write a character to standard output, terminating with a newline.

54−putCharLn : Char -> { [STDIO] } Eff ()

54+putCharLn : Char -> Eff () [STDIO]

5555putCharLn c = putStrLn (singleton c)

5656

5757||| Read a string from standard input.

58−getStr : { [STDIO] } Eff String

58+getStr : Eff String [STDIO]

5959getStr = call $ GetStr

6060

6161||| Read a character from standard input.

62−getChar : { [STDIO] } Eff Char

62+getChar : Eff Char [STDIO]

6363getChar = call $ GetCh

6464

6565||| Given a parameter `a` 'show' `a` to standard output.

66−print : Show a => a -> { [STDIO] } Eff ()

66+print : Show a => a -> Eff () [STDIO]

6767print a = putStr (show a)

6868

6969||| Given a parameter `a` 'show' `a` to a standard output, terminating with a newline

70−printLn : Show a => a -> { [STDIO] } Eff ()

70+printLn : Show a => a -> Eff () [STDIO]

7171printLn a = putStrLn (show a)

libs/effects/Effect/System.idr+8−8

@@ -8,10 +8,10 @@ import System

88import Control.IOExcept

99

1010data System : Effect where

11− Args : { () } System (List String)

12− Time : { () } System Int

13− GetEnv : String -> { () } System (Maybe String)

14− CSystem : String -> { () } System Int

11+ Args : sig System (List String)

12+ Time : sig System Int

13+ GetEnv : String -> sig System (Maybe String)

14+ CSystem : String -> sig System Int

1515

1616instance Handler System IO where

1717 handle () Args k = do x <- getArgs; k x ()

@@ -30,14 +30,14 @@ instance Handler System (IOExcept a) where

3030SYSTEM : EFFECT

3131SYSTEM = MkEff () System

3232

33−getArgs : { [SYSTEM] } Eff (List String)

33+getArgs : Eff (List String) [SYSTEM]

3434getArgs = call Args

3535

36−time : { [SYSTEM] } Eff Int

36+time : Eff Int [SYSTEM]

3737time = call Time

3838

39−getEnv : String -> { [SYSTEM] } Eff (Maybe String)

39+getEnv : String -> Eff (Maybe String) [SYSTEM]

4040getEnv s = call $ GetEnv s

4141

42−system : String -> { [SYSTEM] } Eff Int

42+system : String -> Eff Int [SYSTEM]

4343system s = call $ CSystem s

libs/effects/Effects.idr+93−33

@@ -24,6 +24,28 @@ Effect = (x : Type) -> Type -> (x -> Type) -> Type

2424data EFFECT : Type where

2525 MkEff : Type -> Effect -> EFFECT

2626

27+-- 'sig' gives the signature for an effect. There are four versions

28+-- depending on whether there is no resource needed,

29+-- no state change, a non-dependent change,

30+-- or a dependent change. These are easily disambiguated by type.

31+

32+namespace NoResourceEffect

33+ sig : Effect -> Type -> Type

34+ sig e r = e r () (\v => ())

35+

36+namespace NoUpdateEffect

37+ sig : Effect -> (ret : Type) -> (resource : Type) -> Type

38+ sig e r e_in = e r e_in (\v => e_in)

39+

40+namespace UpdateEffect

41+ sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

42+ sig e r e_in e_out = e r e_in (\v => e_out)

43+

44+namespace DepUpdateEffect

45+ sig : Effect ->

46+ (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

47+ sig e r e_in e_out = e r e_in e_out

48+

2749||| Handler classes describe how an effect `e` is translated to the

2850||| underlying computation context `m` for execution.

2951class Handler (e : Effect) (m : Type -> Type) where

@@ -60,6 +82,7 @@ data SubList : List a -> List a -> Type where

6082 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

6183 Drop : SubList xs ys -> SubList xs (x :: ys)

6284

85+%hint

6386subListId : SubList xs xs

6487subListId {xs = Nil} = SubNil

6588subListId {xs = x :: xs} = Keep subListId

@@ -133,26 +156,61 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

133156||| @ x The return type of the result.

134157||| @ es The list of allowed side-effects.

135158||| @ ce Function to compute a new list of allowed side-effects.

136−data Eff : (x : Type)

137− -> (es : List EFFECT)

138− -> (ce : x -> List EFFECT) -> Type where

139− value : (val : a) -> Eff a (xs val) xs

140− ebind : Eff a xs xs' ->

141− ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''

159+data EffM : (m : Type -> Type) -> (x : Type)

160+ -> (es : List EFFECT)

161+ -> (ce : x -> List EFFECT) -> Type where

162+ value : (val : a) -> EffM m a (xs val) xs

163+ ebind : EffM m a xs xs' ->

164+ ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

142165 callP : (prf : EffElem e a xs) ->

143166 (eff : e t a b) ->

144− Eff t xs (\v => updateResTy v xs prf eff)

167+ EffM m t xs (\v => updateResTy v xs prf eff)

145168

146169 liftP : (prf : SubList ys xs) ->

147− Eff t ys ys' -> Eff t xs (\v => updateWith (ys' v) xs prf)

170+ EffM m t ys ys' -> EffM m t xs (\v => updateWith (ys' v) xs prf)

171+

172+ new : Handler e' m => (e : EFFECT) -> resTy ->

173+ {auto prf : e = MkEff resTy e'} ->

174+ EffM m t (e :: es) (\v => e :: es) ->

175+ EffM m t es (\v => es)

148176

149177 (:-) : (l : ty) ->

150− Eff t [x] xs' -> -- [x] (\v => xs) ->

151− Eff t [l ::: x] (\v => map (l :::) (xs' v))

178+ EffM m t [x] xs' -> -- [x] (\v => xs) ->

179+ EffM m t [l ::: x] (\v => map (l :::) (xs' v))

180+

181+-- Some type synonyms, so we don't always have to write EffM in full

182+

183+namespace SimpleEff

184+ -- Simple effects, no updates

185+ Eff : (x : Type) -> (es : List EFFECT) -> Type

186+ Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

187+

188+ EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

189+ EffT m x es = EffM m x es (\v => es)

190+

191+namespace TransEff

192+ -- Dependent effects, updates not dependent on result

193+ Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

194+ Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

195+

196+ EffT : (m : Type -> Type) ->

197+ (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

198+ EffT m x es ce = EffM m x es (\_ => ce)

199+

200+namespace DepEff

201+ -- Dependent effects, updates dependent on result

202+ Eff : (x : Type) -> (es : List EFFECT)

203+ -> (ce : x -> List EFFECT) -> Type

204+ Eff x es ce = {m : Type -> Type} -> EffM m x es ce

205+

206+ EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

207+ -> (ce : x -> List EFFECT) -> Type

208+ EffT m x es ce = EffM m x es ce

209+

152210

153211%no_implicit

154−(>>=) : Eff a xs xs' ->

155− ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''

212+(>>=) : EffM m a xs xs' ->

213+ ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

156214(>>=) = ebind

157215

158216-- namespace SimpleBind

@@ -161,29 +219,29 @@ data Eff : (x : Type)

161219-- (>>=) = ebind

162220

163221||| Run a subprogram which results in an effect state the same as the input.

164−staticEff : Eff a xs (\v => xs) -> Eff a xs (\v => xs)

222+staticEff : EffM m a xs (\v => xs) -> EffM m a xs (\v => xs)

165223staticEff = id

166224

167225||| Explicitly give the expected set of result effects for an effectful

168226||| operation.

169−toEff : .(xs' : List EFFECT) -> Eff a xs (\v => xs') -> Eff a xs (\v => xs')

227+toEff : .(xs' : List EFFECT) -> EffM m a xs (\v => xs') -> EffM m a xs (\v => xs')

170228toEff xs' = id

171229

172−return : a -> Eff a xs (\v => xs)

230+return : a -> EffM m a xs (\v => xs)

173231return x = value x

174232

175233-- ------------------------------------------------------ [ for idiom brackets ]

176234

177235infixl 2 <*>

178236

179−pure : a -> Eff a xs (\v => xs)

237+pure : a -> EffM m a xs (\v => xs)

180238pure = value

181239

182−pureM : (val : a) -> Eff a (xs val) xs

240+pureM : (val : a) -> EffM m a (xs val) xs

183241pureM = value

184242

185−(<*>) : Eff (a -> b) xs (\v => xs) ->

186− Eff a xs (\v => xs) -> Eff b xs (\v => xs)

243+(<*>) : EffM m (a -> b) xs (\v => xs) ->

244+ EffM m a xs (\v => xs) -> EffM m b xs (\v => xs)

187245(<*>) prog v = do fn <- prog

188246 arg <- v

189247 return (fn arg)

@@ -203,7 +261,7 @@ execEff {e} {a} {res} {resk} (val :: env) (There p) eff k

203261-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

204262-- updates can be propagated even through failing computations?

205263

206−eff : Env m xs -> Eff a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

264+eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

207265eff env (value x) k = k x env

208266eff env (prog `ebind` c) k

209267 = eff env prog (\p', env' => eff env' (c p') k)

@@ -211,6 +269,8 @@ eff env (callP prf effP) k = execEff env prf effP k

211269eff env (liftP prf effP) k

212270 = let env' = dropEnv env prf in

213271 eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

272+eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k

273+ = eff (res :: env) effP (\p', (val :: envk) => k p' envk)

214274-- FIXME:

215275-- xs is needed explicitly because otherwise the pattern binding for

216276-- 'l' appears too late. Solution seems to be to reorder patterns at the

@@ -235,14 +295,14 @@ call : {a, b: _} -> {e : Effect} ->

235295 (eff : e t a b) ->

236296 {default tactics { search 100; }

237297 prf : EffElem e a xs} ->

238− Eff t xs (\v => updateResTy v xs prf eff)

298+ EffM m t xs (\v => updateResTy v xs prf eff)

239299call e {prf} = callP prf e

240300

241301implicit

242−lift : Eff t ys ys' ->

302+lift : EffM m t ys ys' ->

243303 {default tactics { search 100; }

244304 prf : SubList ys xs} ->

245− Eff t xs (\v => updateWith (ys' v) xs prf)

305+ EffM m t xs (\v => updateWith (ys' v) xs prf)

246306lift e {prf} = liftP prf e

247307

248308

@@ -255,7 +315,7 @@ lift e {prf} = liftP prf e

255315|||

256316||| @prog The effectful program to run.

257317run : Applicative m => {default MkDefaultEnv env : Env m xs}

258− -> (prog : Eff a xs xs') -> m a

318+ -> (prog : EffM m a xs xs') -> m a

259319run {env} prog = eff env prog (\r, env => pure r)

260320

261321||| Run an effectful program in the identity context.

@@ -264,7 +324,7 @@ run {env} prog = eff env prog (\r, env => pure r)

264324||| The `env` argument is implicit and initialised automatically.

265325|||

266326||| @prog The effectful program to run.

267−runPure : {default MkDefaultEnv env : Env id xs} -> (prog : Eff a xs xs') -> a

327+runPure : {default MkDefaultEnv env : Env id xs} -> (prog : EffM id a xs xs') -> a

268328runPure {env} prog = eff env prog (\r, env => r)

269329

270330||| Run an effectful program in a given context `m` with a default value for the environment.

@@ -273,7 +333,7 @@ runPure {env} prog = eff env prog (\r, env => r)

273333|||

274334||| @env The environment to use.

275335||| @prog The effectful program to run.

276−runInit : Applicative m => (env : Env m xs) -> (prog : Eff a xs xs') -> m a

336+runInit : Applicative m => (env : Env m xs) -> (prog : EffM m a xs xs') -> m a

277337runInit env prog = eff env prog (\r, env => pure r)

278338

279339||| Run an effectful program with a given default value for the environment.

@@ -282,31 +342,31 @@ runInit env prog = eff env prog (\r, env => pure r)

282342|||

283343||| @env The environment to use.

284344||| @prog The effectful program to run.

285−runPureInit : (env : Env id xs) -> (prog : Eff a xs xs') -> a

345+runPureInit : (env : Env id xs) -> (prog : EffM id a xs xs') -> a

286346runPureInit env prog = eff env prog (\r, env => r)

287347

288−runWith : (a -> m a) -> Env m xs -> Eff a xs xs' -> m a

348+runWith : (a -> m a) -> Env m xs -> EffM m a xs xs' -> m a

289349runWith inj env prog = eff env prog (\r, env => inj r)

290350

291−runEnv : Applicative m => Env m xs -> Eff a xs xs' ->

351+runEnv : Applicative m => Env m xs -> EffM m a xs xs' ->

292352 m (x : a ** Env m (xs' x))

293353runEnv env prog = eff env prog (\r, env => pure (r ** env))

294354

295355-- ----------------------------------------------- [ some higher order things ]

296356

297−mapE : (a -> {xs} Eff b) -> List a -> {xs} Eff (List b)

357+mapE : (a -> {xs} EffM m b) -> List a -> {xs} EffM m (List b)

298358mapE f [] = pure []

299359mapE f (x :: xs) = [| f x :: mapE f xs |]

300360

301361

302−mapVE : (a -> {xs} Eff b) ->

362+mapVE : (a -> {xs} EffM m b) ->

303363 Vect n a ->

304− {xs} Eff (Vect n b)

364+ {xs} EffM m (Vect n b)

305365mapVE f [] = pure []

306366mapVE f (x :: xs) = [| f x :: mapVE f xs |]

307367

308368

309−when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff ()

369+when : Bool -> Lazy ({xs} EffM m ()) -> {xs} EffM m ()

310370when True e = Force e

311371when False e = pure ()

312372

libs/prelude/Builtins.idr+4−3

@@ -23,11 +23,11 @@ namespace Builtins

2323 ||| UniqueTypes.

2424 ||| @A the type of the left elements in the pair

2525 ||| @B the type of the left elements in the pair

26− data UPair : (A : Type*) -> (B : Type*) -> Type where

26+ data UPair : (A : AnyType) -> (B : AnyType) -> AnyType where

2727 ||| A pair of elements

2828 ||| @a the left element of the pair

2929 ||| @b the right element of the pair

30− MkUPair : {A, B : Type*} -> (a : A) -> (b : B) -> UPair A B

30+ MkUPair : {A, B : AnyType} -> (a : A) -> (b : B) -> UPair A B

3131

3232 ||| Dependent pairs

3333 |||

@@ -36,7 +36,8 @@ namespace Builtins

3636 ||| it. Another way to see dependent pairs is as just data - for instance, the

3737 ||| length of a vector paired with that vector.

3838 |||

39− ||| @ a the type of the witness @ P the type of the proof

39+ ||| @ a the type of the witness

40+ ||| @ P the type of the proof

4041 data Sigma : (a : Type) -> (P : a -> Type) -> Type where

4142 MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

4243

libs/prelude/IO.idr+32−30

@@ -120,46 +120,48 @@ prim_fwrite h s

120120 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

121121

122122--------- The C FFI

123−

124−data Raw : Type -> Type where

125− -- code generated can assume it's compiled just as 't'

126− MkRaw : (x : t) -> Raw t

127−

128−-- Tell erasure analysis not to erase the argument

129−%used MkRaw x

130−

131−-- Supported C integer types

132−data C_IntTypes : Type -> Type where

133− C_IntChar : C_IntTypes Char

134− C_IntNative : C_IntTypes Int

135− C_IntBits8 : C_IntTypes Bits8

136− C_IntBits16 : C_IntTypes Bits16

137− C_IntBits32 : C_IntTypes Bits32

138− C_IntBits64 : C_IntTypes Bits64

139−

140−-- Supported C foreign types

141−data C_Types : Type -> Type where

142− C_Str : C_Types String

143− C_Float : C_Types Float

144− C_Ptr : C_Types Ptr

145− C_MPtr : C_Types ManagedPtr

146− C_Unit : C_Types ()

147− C_Any : C_Types (Raw a)

148− C_IntT : C_IntTypes i -> C_Types i

149−

150−FFI_C : FFI

151−FFI_C = MkFFI C_Types String String

123+namespace FFI_C

124+ data Raw : Type -> Type where

125+ -- code generated can assume it's compiled just as 't'

126+ MkRaw : (x : t) -> Raw t

127+

128+ -- Tell erasure analysis not to erase the argument

129+ %used MkRaw x

130+

131+ -- Supported C integer types

132+ data C_IntTypes : Type -> Type where

133+ C_IntChar : C_IntTypes Char

134+ C_IntNative : C_IntTypes Int

135+ C_IntBits8 : C_IntTypes Bits8

136+ C_IntBits16 : C_IntTypes Bits16

137+ C_IntBits32 : C_IntTypes Bits32

138+ C_IntBits64 : C_IntTypes Bits64

139+

140+ -- Supported C foreign types

141+ data C_Types : Type -> Type where

142+ C_Str : C_Types String

143+ C_Float : C_Types Float

144+ C_Ptr : C_Types Ptr

145+ C_MPtr : C_Types ManagedPtr

146+ C_Unit : C_Types ()

147+ C_Any : C_Types (Raw a)

148+ C_IntT : C_IntTypes i -> C_Types i

149+

150+ FFI_C : FFI

151+ FFI_C = MkFFI C_Types String String

152152

153153IO : Type -> Type

154154IO = IO' FFI_C

155155

156+-- Cannot be relaxed as is used by type providers and they expect IO a

157+-- in the first argument.

156158run__provider : IO a -> PrimIO a

157159run__provider (MkIO f) = f (TheWorld prim__TheWorld)

158160

159161prim_fork : PrimIO () -> PrimIO Ptr

160162prim_fork x = prim_io_return prim__vm -- compiled specially

161163

162−fork : IO () -> IO Ptr

164+fork : IO' l () -> IO' l Ptr

163165fork (MkIO f) = MkIO (\w => prim_io_bind

164166 (prim_fork (prim_io_bind (f w)

165167 (\ x => prim_io_return x)))

libs/prelude/Language/Reflection.idr+71−25

@@ -11,18 +11,35 @@ import Prelude.Traversable

1111

1212%access public

1313

14−data TTName =

15− ||| A user-provided name

16− UN String |

17− ||| A name in some namespace.

18− |||

19− ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo`

20− NS TTName (List String) |

21− ||| Machine-chosen names

22− MN Int String |

23− ||| Name of something which is never used in scope

24− NErased

25−%name TTName n, n'

14+mutual

15+ data TTName =

16+ ||| A user-provided name

17+ UN String |

18+ ||| A name in some namespace.

19+ |||

20+ ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])`

21+ ||| represents the name `A.B.foo`

22+ NS TTName (List String) |

23+ ||| Machine-chosen names

24+ MN Int String |

25+ ||| Special names, to make conflicts impossible and language features

26+ ||| predictable

27+ SN SpecialName |

28+ ||| Name of something which is never used in scope

29+ NErased

30+ %name TTName n, n'

31+

32+ data SpecialName = WhereN Int TTName TTName

33+ | WithN Int TTName

34+ | InstanceN TTName (List String)

35+ | ParentN TTName String

36+ | MethodN TTName

37+ | CaseN TTName

38+ | ElimN TTName

39+ | InstanceCtorN TTName

40+ | MetaN TTName TTName

41+

42+

2643

2744implicit

2845userSuppliedName : String -> TTName

@@ -390,19 +407,48 @@ instance Quotable a Raw => Quotable (List a) Raw where

390407 quote [] = `(List.Nil {a=~(quotedTy {a})})

391408 quote (x :: xs) = `(List.(::) {a=~(quotedTy {a})} ~(quote x) ~(quote xs))

392409

393−instance Quotable TTName TT where

394− quotedTy = `(TTName)

395− quote (UN x) = `(UN ~(quote x))

396− quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

397− quote (MN x y) = `(MN ~(quote x) ~(quote y))

398− quote NErased = `(NErased)

399−

400−instance Quotable TTName Raw where

401− quotedTy = `(TTName)

402− quote (UN x) = `(UN ~(quote {t=Raw} x))

403− quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))

404− quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))

405− quote NErased = `(NErased)

410+mutual

411+ instance Quotable TTName TT where

412+ quotedTy = `(TTName)

413+ quote (UN x) = `(UN ~(quote x))

414+ quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

415+ quote (MN x y) = `(MN ~(quote x) ~(quote y))

416+ quote (SN sn) = `(SN ~(assert_total $ quote sn))

417+ quote NErased = `(NErased)

418+

419+ instance Quotable SpecialName TT where

420+ quotedTy = `(SpecialName)

421+ quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))

422+ quote (WithN i n) = `(WithN ~(quote i) ~(quote n))

423+ quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

424+ quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

425+ quote (MethodN n) = `(MethodN ~(quote n))

426+ quote (CaseN n) = `(CaseN ~(quote n))

427+ quote (ElimN n) = `(ElimN ~(quote n))

428+ quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

429+ quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

430+

431+mutual

432+ instance Quotable TTName Raw where

433+ quotedTy = `(TTName)

434+ quote (UN x) = `(UN ~(quote {t=Raw} x))

435+ quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))

436+ quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))

437+ quote (SN sn) = `(SN ~(assert_total $ quote sn))

438+ quote NErased = `(NErased)

439+

440+ instance Quotable SpecialName Raw where

441+ quotedTy = `(SpecialName)

442+ quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))

443+ quote (WithN i n) = `(WithN ~(quote i) ~(quote n))

444+ quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

445+ quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

446+ quote (MethodN n) = `(MethodN ~(quote n))

447+ quote (CaseN n) = `(CaseN ~(quote n))

448+ quote (ElimN n) = `(ElimN ~(quote n))

449+ quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

450+ quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

451+

406452

407453instance Quotable NativeTy TT where

408454 quotedTy = `(NativeTy)

libs/prelude/Language/Reflection/Elab.idrnew file+214

@@ -0,0 +1,214 @@

1+module Language.Reflection.Elab

2+

3+import Builtins

4+import Prelude.Applicative

5+import Prelude.Functor

6+import Prelude.List

7+import Prelude.Maybe

8+import Prelude.Monad

9+import Language.Reflection

10+

11+data Arg : Type where

12+ Explicit : TTName -> Raw -> Arg

13+ Implicit : TTName -> Raw -> Arg

14+ Constraint : TTName -> Raw -> Arg

15+

16+data TyDecl : Type where

17+ Declare : TTName -> List Arg -> Raw -> TyDecl

18+

19+data FunClause : Type where

20+ MkFunClause : (lhs, rhs : Raw) -> FunClause

21+ MkImpossibleClause : (lhs : Raw) -> FunClause

22+

23+data FunDefn : Type where

24+ DefineFun : TTName -> List FunClause -> FunDefn

25+

26+data TyConArg : Type where

27+ Parameter : TTName -> Raw -> TyConArg

28+ Index : TTName -> Raw -> TyConArg

29+

30+data Datatype : Type where

31+ MkDatatype : (familyName : TTName) ->

32+ (tyConArgs : List TyConArg) -> (tyConRes : Raw) ->

33+ (constrs : List (TTName, Raw)) ->

34+ Datatype

35+

36+abstract

37+data Elab : Type -> Type where

38+ -- obligatory control stuff

39+ prim__PureElab : a -> Elab a

40+ prim__BindElab : {a, b : Type} -> Elab a -> (a -> Elab b) -> Elab b

41+

42+ prim__Try : {a : Type} -> Elab a -> Elab a -> Elab a

43+ prim__Fail : {a : Type} -> List ErrorReportPart -> Elab a

44+

45+ prim__Env : Elab (List (TTName, Binder TT))

46+ prim__Goal : Elab (TTName, TT)

47+ prim__Holes : Elab (List TTName)

48+ prim__Guess : Elab (Maybe TT)

49+ prim__LookupTy : TTName -> Elab (List (TTName, NameType, TT))

50+ prim__LookupDatatype : TTName -> Elab (List Datatype)

51+

52+ prim__SourceLocation : Elab SourceLocation

53+

54+ prim__Forget : TT -> Elab Raw

55+

56+ prim__Gensym : String -> Elab TTName

57+

58+ prim__Solve : Elab ()

59+ prim__Fill : Raw -> Elab ()

60+ prim__Apply : Raw -> Elab ()

61+ prim__Focus : TTName -> Elab ()

62+ prim__Unfocus : TTName -> Elab ()

63+ prim__Attack : Elab ()

64+

65+ prim__Rewrite : Raw -> Elab ()

66+

67+ prim__Claim : TTName -> Raw -> Elab ()

68+ prim__Intro : Maybe TTName -> Elab ()

69+ prim__Forall : TTName -> Raw -> Elab ()

70+ prim__PatVar : TTName -> Elab ()

71+ prim__PatBind : TTName -> Elab ()

72+

73+ prim__Compute : Elab ()

74+

75+ prim__DeclareType : TyDecl -> Elab ()

76+ prim__DefineFunction : FunDefn -> Elab ()

77+

78+ prim__RecursiveElab : Raw -> Elab () -> Elab (TT, TT)

79+

80+ prim__Debug : {a : Type} -> Maybe String -> Elab a

81+

82+

83+-------------

84+-- Public API

85+-------------

86+%access public

87+

88+instance Functor Elab where

89+ map f t = prim__BindElab t (\x => prim__PureElab (f x))

90+

91+instance Applicative Elab where

92+ pure x = prim__PureElab x

93+ f <*> x = prim__BindElab f $ \g =>

94+ prim__BindElab x $ \y =>

95+ prim__PureElab $ g y

96+

97+instance Alternative Elab where

98+ empty = prim__Fail [TextPart "empty"]

99+ x <|> y = prim__Try x y

100+

101+instance Monad Elab where

102+ x >>= f = prim__BindElab x f

103+

104+fail : List ErrorReportPart -> Elab a

105+fail err = prim__Fail err

106+

107+getEnv : Elab (List (TTName, Binder TT))

108+getEnv = prim__Env

109+

110+getGoal : Elab (TTName, TT)

111+getGoal = prim__Goal

112+

113+getHoles : Elab (List TTName)

114+getHoles = prim__Holes

115+

116+getGuess : Elab (Maybe TT)

117+getGuess = prim__Guess

118+

119+lookupTy : TTName -> Elab (List (TTName, NameType, TT))

120+lookupTy n = prim__LookupTy n

121+

122+lookupTyExact : TTName -> Elab (TTName, NameType, TT)

123+lookupTyExact n = case !(lookupTy n) of

124+ [res] => return res

125+ [] => fail [NamePart n, TextPart "is not defined."]

126+ xs => fail [NamePart n, TextPart "is ambiguous."]

127+

128+lookupDatatype : TTName -> Elab (List Datatype)

129+lookupDatatype n = prim__LookupDatatype n

130+

131+lookupDatatypeExact : TTName -> Elab Datatype

132+lookupDatatypeExact n = case !(lookupDatatype n) of

133+ [res] => return res

134+ [] => fail [TextPart "No datatype named", NamePart n]

135+ xs => fail [TextPart "More than one datatype named", NamePart n]

136+

137+forgetTypes : TT -> Elab Raw

138+forgetTypes tt = prim__Forget tt

139+

140+gensym : (hint : String) -> Elab TTName

141+gensym hint = prim__Gensym hint

142+

143+solve : Elab ()

144+solve = prim__Solve

145+

146+fill : Raw -> Elab ()

147+fill tm = prim__Fill tm

148+

149+||| Fill with unification

150+apply : Raw -> Elab ()

151+apply tm = prim__Apply tm

152+

153+focus : (hole : TTName) -> Elab ()

154+focus hole = prim__Focus hole

155+

156+unfocus : TTName -> Elab ()

157+unfocus hole = prim__Unfocus hole

158+

159+attack : Elab ()

160+attack = prim__Attack

161+

162+claim : TTName -> Raw -> Elab ()

163+claim n ty = prim__Claim n ty

164+

165+||| Introduce a lambda binding around the current hole and focus on

166+||| the body. Requires that the hole be in binding form (use

167+||| `attack`).

168+|||

169+||| @ n the name to use for the argument, or `Nothing` to use the name

170+||| in the corresponding hole type (a dependent function)

171+intro : (n : Maybe TTName) -> Elab ()

172+intro n = prim__Intro n

173+

174+||| Introduce a dependent function type binding into the current hole,

175+||| and focus on the body.

176+forall : TTName -> Raw -> Elab ()

177+forall n ty = prim__Forall n ty

178+

179+patvar : TTName -> Elab ()

180+patvar n = prim__PatVar n

181+

182+patbind : TTName -> Elab ()

183+patbind n = prim__PatBind n

184+

185+compute : Elab ()

186+compute = prim__Compute

187+

188+||| Find out the present source context for the tactic script

189+getSourceLocation : Elab SourceLocation

190+getSourceLocation = prim__SourceLocation

191+

192+||| Attempt to solve the current goal with the source code location

193+sourceLocation : Elab ()

194+sourceLocation = do loc <- getSourceLocation

195+ fill (quote loc)

196+ solve

197+

198+rewriteWith : Raw -> Elab ()

199+rewriteWith rule = prim__Rewrite rule

200+

201+declareType : TyDecl -> Elab ()

202+declareType decl = prim__DeclareType decl

203+

204+defineFunction : FunDefn -> Elab ()

205+defineFunction defun = prim__DefineFunction defun

206+

207+debug : Elab a

208+debug = prim__Debug Nothing

209+

210+runElab : Raw -> Elab () -> Elab (TT, TT)

211+runElab goal script = prim__RecursiveElab goal script

212+

213+debugMessage : String -> Elab a

214+debugMessage msg = prim__Debug (Just msg)

libs/prelude/Language/Reflection/Tactical.idrdeleted−138

@@ -1,138 +0,0 @@

1−module Language.Reflection.Tactical

2−

3−import Builtins

4−import Prelude.Applicative

5−import Prelude.Functor

6−import Prelude.List

7−import Prelude.Maybe

8−import Prelude.Monad

9−import Language.Reflection

10−

11−data Arg : Type where

12− Explicit : TTName -> Raw -> Arg

13− Implicit : TTName -> Raw -> Arg

14− Constraint : TTName -> Raw -> Arg

15−

16−data TyDecl : Type where

17− Declare : TTName -> List Arg -> Raw -> TyDecl

18−

19−abstract

20−data Tactical : Type -> Type where

21− -- obligatory control stuff

22− prim__PureTactical : a -> Tactical a

23− prim__BindTactical : {a, b : Type} -> Tactical a -> (a -> Tactical b) -> Tactical b

24−

25− prim__Try : {a : Type} -> Tactical a -> Tactical a -> Tactical a

26− prim__Fail : {a : Type} -> List ErrorReportPart -> Tactical a

27−

28− prim__Env : Tactical (List (TTName, Binder TT))

29− prim__Goal : Tactical (TTName, TT)

30− prim__Holes : Tactical (List TTName)

31− prim__Guess : Tactical (Maybe TT)

32−

33− prim__SourceLocation : Tactical SourceLocation

34−

35− prim__Forget : TT -> Tactical Raw

36−

37− prim__Gensym : String -> Tactical TTName

38−

39− prim__Solve : Tactical ()

40− prim__Fill : Raw -> Tactical ()

41− prim__Focus : TTName -> Tactical ()

42− prim__Unfocus : TTName -> Tactical ()

43− prim__Attack : Tactical ()

44−

45− prim__Rewrite : Raw -> Tactical ()

46−

47− prim__Claim : TTName -> Raw -> Tactical ()

48− prim__Intro : Maybe TTName -> Tactical ()

49−

50− prim__DeclareType : TyDecl -> Tactical ()

51−

52− prim__Debug : {a : Type} -> Maybe String -> Tactical a

53−

54−

55−-------------

56−-- Public API

57−-------------

58−%access public

59−

60−instance Functor Tactical where

61− map f t = prim__BindTactical t (\x => prim__PureTactical (f x))

62−

63−instance Applicative Tactical where

64− pure x = prim__PureTactical x

65− f <*> x = prim__BindTactical f $ \g =>

66− prim__BindTactical x $ \y =>

67− prim__PureTactical $ g y

68−

69−instance Alternative Tactical where

70− empty = prim__Fail [TextPart "empty"]

71− x <|> y = prim__Try x y

72−

73−instance Monad Tactical where

74− x >>= f = prim__BindTactical x f

75−

76−fail : List ErrorReportPart -> Tactical a

77−fail err = prim__Fail err

78−

79−getEnv : Tactical (List (TTName, Binder TT))

80−getEnv = prim__Env

81−

82−getGoal : Tactical (TTName, TT)

83−getGoal = prim__Goal

84−

85−getHoles : Tactical (List TTName)

86−getHoles = prim__Holes

87−

88−getGuess : Tactical (Maybe TT)

89−getGuess = prim__Guess

90−

91−forgetTypes : TT -> Tactical Raw

92−forgetTypes tt = prim__Forget tt

93−

94−gensym : (hint : String) -> Tactical TTName

95−gensym hint = prim__Gensym hint

96−

97−solve : Tactical ()

98−solve = prim__Solve

99−

100−fill : Raw -> Tactical ()

101−fill tm = prim__Fill tm

102−

103−focus : (hole : TTName) -> Tactical ()

104−focus hole = prim__Focus hole

105−

106−unfocus : TTName -> Tactical ()

107−unfocus hole = prim__Unfocus hole

108−

109−attack : Tactical ()

110−attack = prim__Attack

111−

112−claim : TTName -> Raw -> Tactical ()

113−claim n ty = prim__Claim n ty

114−

115−intro : Maybe TTName -> Tactical ()

116−intro n = prim__Intro n

117−

118−||| Find out the present source context for the tactic script

119−getSourceLocation : Tactical SourceLocation

120−getSourceLocation = prim__SourceLocation

121−

122−||| Attempt to solve the current goal with the source code location

123−sourceLocation : Tactical ()

124−sourceLocation = do loc <- getSourceLocation

125− fill (quote loc)

126− solve

127−

128−rewriteWith : Raw -> Tactical ()

129−rewriteWith rule = prim__Rewrite rule

130−

131−declareType : TyDecl -> Tactical ()

132−declareType decl = prim__DeclareType decl

133−

134−debug : Tactical a

135−debug = prim__Debug Nothing

136−

137−debugMessage : String -> Tactical a

138−debugMessage msg = prim__Debug (Just msg)

libs/prelude/Prelude.idr+12−7

@@ -134,6 +134,9 @@ instance Show a => Show (Maybe a) where

134134 show Nothing = "Nothing"

135135 show (Just x) = "Just " ++ show x

136136

137+instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

138+ show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

139+

137140---- Functor instances

138141

139142instance Functor PrimIO where

@@ -242,8 +245,8 @@ natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc

242245total natEnumFromTo : Nat -> Nat -> List Nat

243246natEnumFromTo n m = map (plus n) (natRange ((S m) - n))

244247total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat

245−natEnumFromThenTo _ Z _ = []

246−natEnumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))

248+natEnumFromThenTo _ Z _ = []

249+natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (m - n) (S inc) SIsNotZ)))

247250

248251class Enum a where

249252 total pred : a -> a

@@ -282,7 +285,7 @@ instance Enum Integer where

282285 go [] = []

283286 go (x :: xs) = n + cast x :: go xs

284287 enumFromThenTo _ 0 _ = []

285− enumFromThenTo n inc m = go (natRange (S (fromInteger (abs (m - n)) `div` fromInteger (abs inc))))

288+ enumFromThenTo n inc m = go (natRange (S (divNatNZ (fromInteger (abs (m - n))) (S (fromInteger ((abs inc) - 1))) SIsNotZ)))

286289 where go : List Nat -> List Integer

287290 go [] = []

288291 go (x :: xs) = n + (cast x * inc) :: go xs

@@ -302,7 +305,7 @@ instance Enum Int where

302305 go acc (S k) m = go (m :: acc) k (m - 1)

303306 enumFromThen n inc = n :: enumFromThen (inc + n) inc

304307 enumFromThenTo _ 0 _ = []

305− enumFromThenTo n inc m = go (natRange (S (cast {to=Nat} (abs (m - n)) `div` cast {to=Nat} (abs inc))))

308+ enumFromThenTo n inc m = go (natRange (S (divNatNZ (cast {to=Nat} (abs (m - n))) (S (cast {to=Nat} ((abs inc) - 1))) SIsNotZ)))

306309 where go : List Nat -> List Int

307310 go [] = []

308311 go (x :: xs) = n + (cast x * inc) :: go xs

@@ -346,7 +349,7 @@ partial

346349printLn : Show a => a -> IO' ffi ()

347350printLn x = putStrLn (show x)

348351

349−||| Read one line of input from stdin

352+||| Read one line of input from stdin, without the trailing newline

350353partial

351354getLine : IO' ffi String

352355getLine = prim_read

@@ -526,7 +529,7 @@ validFile (FHandle h) = do x <- nullPtr h

526529||| @ test the condition of the loop

527530||| @ body the loop body

528531partial -- obviously

529−while : (test : IO Bool) -> (body : IO ()) -> IO ()

532+while : (test : IO' l Bool) -> (body : IO' l ()) -> IO' l ()

530533while t b = do v <- t

531534 if v then do b

532535 while t b

@@ -545,5 +548,7 @@ readFile fn = do h <- openFile fn Read

545548 readFile' h contents =

546549 do x <- feof h

547550 if not x then do l <- fread h

548− readFile' h (contents ++ l)

551+ case contents of

552+ "" => readFile' h l

553+ _ => readFile' h (contents ++ "\n" ++ l)

549554 else return contents

libs/prelude/Prelude/Algebra.idr−4

@@ -2,11 +2,7 @@ module Prelude.Algebra

22

33import Builtins

44

5−-- XXX: change?

6−infixl 6 <->

75infixl 6 <+>

8−infixl 6 <.>

9−infixl 5 <#>

106

117%access public

128

libs/prelude/Prelude/Classes.idr+24−12

@@ -315,10 +315,12 @@ class Integral a where

315315

316316-- ---------------------------------------------------------------- [ Integers ]

317317divBigInt : Integer -> Integer -> Integer

318−divBigInt = prim__sdivBigInt

318+divBigInt x y = case y == 0 of

319+ False => prim__sdivBigInt x y

319320

320321modBigInt : Integer -> Integer -> Integer

321−modBigInt = prim__sremBigInt

322+modBigInt x y = case y == 0 of

323+ False => prim__sremBigInt x y

322324

323325instance Integral Integer where

324326 div = divBigInt

@@ -327,10 +329,12 @@ instance Integral Integer where

327329-- --------------------------------------------------------------------- [ Int ]

328330

329331divInt : Int -> Int -> Int

330−divInt = prim__sdivInt

332+divInt x y = case y == 0 of

333+ False => prim__sdivInt x y

331334

332335modInt : Int -> Int -> Int

333−modInt = prim__sremInt

336+modInt x y = case y == 0 of

337+ False => prim__sremInt x y

334338

335339instance Integral Int where

336340 div = divInt

@@ -338,10 +342,12 @@ instance Integral Int where

338342

339343-- ------------------------------------------------------------------- [ Bits8 ]

340344divB8 : Bits8 -> Bits8 -> Bits8

341−divB8 = prim__sdivB8

345+divB8 x y = case y == 0 of

346+ False => prim__sdivB8 x y

342347

343348modB8 : Bits8 -> Bits8 -> Bits8

344−modB8 = prim__sremB8

349+modB8 x y = case y == 0 of

350+ False => prim__sremB8 x y

345351

346352instance Integral Bits8 where

347353 div = divB8

@@ -349,10 +355,12 @@ instance Integral Bits8 where

349355

350356-- ------------------------------------------------------------------ [ Bits16 ]

351357divB16 : Bits16 -> Bits16 -> Bits16

352−divB16 = prim__sdivB16

358+divB16 x y = case y == 0 of

359+ False => prim__sdivB16 x y

353360

354361modB16 : Bits16 -> Bits16 -> Bits16

355−modB16 = prim__sremB16

362+modB16 x y = case y == 0 of

363+ False => prim__sremB16 x y

356364

357365instance Integral Bits16 where

358366 div = divB16

@@ -360,10 +368,12 @@ instance Integral Bits16 where

360368

361369-- ------------------------------------------------------------------ [ Bits32 ]

362370divB32 : Bits32 -> Bits32 -> Bits32

363−divB32 = prim__sdivB32

371+divB32 x y = case y == 0 of

372+ False => prim__sdivB32 x y

364373

365374modB32 : Bits32 -> Bits32 -> Bits32

366−modB32 = prim__sremB32

375+modB32 x y = case y == 0 of

376+ False => prim__sremB32 x y

367377

368378instance Integral Bits32 where

369379 div = divB32

@@ -371,10 +381,12 @@ instance Integral Bits32 where

371381

372382-- ------------------------------------------------------------------ [ Bits64 ]

373383divB64 : Bits64 -> Bits64 -> Bits64

374−divB64 = prim__sdivB64

384+divB64 x y = case y == 0 of

385+ False => prim__sdivB64 x y

375386

376387modB64 : Bits64 -> Bits64 -> Bits64

377−modB64 = prim__sremB64

388+modB64 x y = case y == 0 of

389+ False => prim__sremB64 x y

378390

379391instance Integral Bits64 where

380392 div = divB64

libs/prelude/Prelude/Either.idr+5

@@ -66,6 +66,11 @@ fromEither : Either a a -> a

6666fromEither (Left l) = l

6767fromEither (Right r) = r

6868

69+||| Right becomes left and left becomes right

70+mirror : Either a b -> Either b a

71+mirror (Left x) = Right x

72+mirror (Right x) = Left x

73+

6974--------------------------------------------------------------------------------

7075-- Conversions

7176--------------------------------------------------------------------------------

libs/prelude/Prelude/List.idr+17−8

@@ -309,13 +309,12 @@ mapMaybe f (x::xs) =

309309-- Folds

310310--------------------------------------------------------------------------------

311311

312−||| A tail recursive right fold on Lists.

313−total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc

314−foldrImpl f e go [] = go e

315−foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

316−

317312instance Foldable List where

318− foldr f e xs = foldrImpl f e id xs

313+ foldr c n [] = n

314+ foldr c n (x::xs) = c x (foldr c n xs)

315+

316+ foldl f q [] = q

317+ foldl f q (x::xs) = foldl f (f q x) xs

319318

320319--------------------------------------------------------------------------------

321320-- Special folds

@@ -537,10 +536,11 @@ delete = deleteBy (==)

537536(\\) : (Eq a) => List a -> List a -> List a

538537(\\) = foldl (flip delete)

539538

539+||| The unionBy function returns the union of two lists by user-supplied equality predicate.

540540unionBy : (a -> a -> Bool) -> List a -> List a -> List a

541−unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

541+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

542542

543−||| The union function returns the list union of the two lists. For example,

543+||| Compute the union of two lists according to their `Eq` instance.

544544|||

545545||| ```idris example

546546||| union ['d', 'o', 'g'] ['c', 'o', 'w']

@@ -809,6 +809,15 @@ hasAnyByNilFalse p (x::xs) =

809809hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

810810hasAnyNilFalse l = ?hasAnyNilFalseBody

811811

812+foldlAsFoldr : (b -> a -> b) -> b -> List a -> b

813+foldlAsFoldr f z t = foldr (flip (.) . flip f) id t z

814+

815+||| The definition of foldl works the same as the default definition

816+||| in terms of foldr

817+foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs

818+foldlMatchesFoldr f q [] = Refl

819+foldlMatchesFoldr f q (x :: xs) = foldlMatchesFoldr f (f q x) xs

820+

812821

813822--------------------------------------------------------------------------------

814823-- Proofs

libs/prelude/Prelude/Maybe.idr+18−10

@@ -78,17 +78,25 @@ instance (Eq a) => Eq (Maybe a) where

7878 (Just _) == Nothing = False

7979 (Just a) == (Just b) = a == b

8080

81−-- Lift a semigroup into 'Maybe' forming a 'Monoid' according to

82−-- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be

83−-- turned into a monoid simply by adjoining an element i not in S

84−-- and defining i+i = i and i+s = s = s+i for all s in S."

85−

86−instance (Semigroup a) => Semigroup (Maybe a) where

87− Nothing <+> m = m

88− m <+> Nothing = m

81+||| Prioritised choice. Just like the `Alternative` instance, the

82+||| `Semigroup` for `Maybe a` keeps the first succeeding computation.

83+|||

84+||| **NB**: This is a different choice than in the Haskell libraries.

85+||| Use `collectJust` to get the Haskell behaviour.

86+instance Semigroup (Maybe a) where

87+ Nothing <+> m = m

88+ (Just x) <+> _ = Just x

89+

90+||| Transform any semigroup into a monoid by using `Nothing` as the

91+||| designated neutral element and collecting the contents of the

92+||| `Just` constructors using a semigroup structure on `a`. This is

93+||| the behaviour in the Haskell libraries.

94+instance [collectJust] Semigroup a => Semigroup (Maybe a) where

95+ Nothing <+> m = m

96+ m <+> Nothing = m

8997 (Just m1) <+> (Just m2) = Just (m1 <+> m2)

9098

91−instance (Semigroup a) => Monoid (Maybe a) where

99+instance Monoid (Maybe a) where

92100 neutral = Nothing

93101

94102instance (Monoid a, Eq a) => Cast a (Maybe a) where

@@ -98,5 +106,5 @@ instance (Monoid a) => Cast (Maybe a) a where

98106 cast = lowerMaybe

99107

100108instance Foldable Maybe where

101− foldr _ z Nothing = z

109+ foldr _ z Nothing = z

102110 foldr f z (Just x) = f x z

libs/prelude/Prelude/Nat.idr+36−17

@@ -290,10 +290,12 @@ fact (S n) = (S n) * fact n

290290-- Division and modulus

291291--------------------------------------------------------------------------------

292292

293−total

294−modNat : Nat -> Nat -> Nat

295−modNat left Z = left

296−modNat left (S right) = mod' left left right

293+SIsNotZ : {x: Nat} -> (S x = Z) -> Void

294+SIsNotZ Refl impossible

295+

296+modNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat

297+modNatNZ left Z p = void (p Refl)

298+modNatNZ left (S right) _ = mod' left left right

297299 where

298300 total mod' : Nat -> Nat -> Nat -> Nat

299301 mod' Z centre right = centre

@@ -303,10 +305,13 @@ modNat left (S right) = mod' left left right

303305 else

304306 mod' left (centre - (S right)) right

305307

306−total

307−divNat : Nat -> Nat -> Nat

308−divNat left Z = S left -- div by zero

309−divNat left (S right) = div' left left right

308+partial

309+modNat : Nat -> Nat -> Nat

310+modNat left (S right) = modNatNZ left (S right) SIsNotZ

311+

312+divNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat

313+divNatNZ left Z p = void (p Refl)

314+divNatNZ left (S right) _ = div' left left right

310315 where

311316 total div' : Nat -> Nat -> Nat -> Nat

312317 div' Z centre right = Z

@@ -316,23 +321,42 @@ divNat left (S right) = div' left left right

316321 else

317322 S (div' left (centre - (S right)) right)

318323

324+partial

325+divNat : Nat -> Nat -> Nat

326+divNat left (S right) = divNatNZ left (S right) SIsNotZ

327+

328+divCeilNZ : Nat -> (y: Nat) -> Not (y = 0) -> Nat

329+divCeilNZ x y p = case (modNatNZ x y p) of

330+ Z => divNatNZ x y p

331+ S _ => S (divNatNZ x y p)

332+

333+partial

334+divCeil : Nat -> Nat -> Nat

335+divCeil x (S y) = divCeilNZ x (S y) SIsNotZ

336+

319337instance Integral Nat where

320338 div = divNat

321339 mod = modNat

322340

341+log2NZ : (x: Nat) -> Not (x = Z) -> Nat

342+log2NZ Z p = void (p Refl)

343+log2NZ (S Z) _ = Z

344+log2NZ (S (S n)) _ = S (log2NZ (assert_smaller (S (S n)) (S (divNatNZ n 2 SIsNotZ))) SIsNotZ)

345+

346+partial

323347log2 : Nat -> Nat

324−log2 Z = Z

325−log2 (S Z) = Z

326−log2 n = S (log2 (assert_smaller n (n `divNat` 2)))

348+log2 (S n) = log2NZ (S n) SIsNotZ

327349

328350--------------------------------------------------------------------------------

329351-- GCD and LCM

330352--------------------------------------------------------------------------------

353+partial

331354gcd : Nat -> Nat -> Nat

332355gcd a Z = a

333356gcd a b = assert_total (gcd b (a `modNat` b))

334357

335−total lcm : Nat -> Nat -> Nat

358+partial

359+lcm : Nat -> Nat -> Nat

336360lcm _ Z = Z

337361lcm Z _ = Z

338362lcm x y = divNat (x * y) (gcd x y)

@@ -726,11 +750,6 @@ total sucMinR : (l : Nat) -> minimum l (S l) = l

726750sucMinR Z = Refl

727751sucMinR (S l) = cong (sucMinR l)

728752

729−-- div and mod

730−total modZeroZero : (n : Nat) -> mod 0 n = Z

731−modZeroZero Z = Refl

732−modZeroZero (S n) = Refl

733−

734753--------------------------------------------------------------------------------

735754-- Proofs

736755--------------------------------------------------------------------------------

libs/prelude/Prelude/Pairs.idr+3

@@ -5,6 +5,9 @@ import Builtins

55%access public

66%default total

77

8+swap : (a, b) -> (b, a)

9+swap (x, y) = (y, x)

10+

811using (a : Type, P : a -> Type)

912

1013 ||| Dependent pair where the first field is erased.

libs/prelude/prelude.ipkg+1−1

@@ -10,7 +10,7 @@ modules = Builtins, Prelude, IO,

1010 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

1111 Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers,

1212

13− Language.Reflection, Language.Reflection.Errors, Language.Reflection.Tactical,

13+ Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,

1414

1515 Decidable.Equality

1616

main/Main.hs+2

@@ -29,6 +29,7 @@ import Idris.CmdOptions

2929import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )

3030

3131import Util.DynamicLinker

32+import Util.System

3233

3334import Pkg.Package

3435

@@ -43,6 +44,7 @@ main = do opts <- runArgParser

4344

4445runIdris :: [Opt] -> Idris ()

4546runIdris opts = do

47+ runIO setupBundledCC

4648 when (ShowIncs `elem` opts) $ runIO showIncs

4749 when (ShowLibs `elem` opts) $ runIO showLibs

4850 when (ShowLibdir `elem` opts) $ runIO showLibdir

rts/Makefile+2−1

@@ -5,7 +5,7 @@ OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \

55HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \

66 idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h \

77 idris_utf8.h getline.h

8−CFLAGS:=-fPIC $(CFLAGS)

8+CFLAGS := $(CFLAGS)

99CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""

1010CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""

1111

@@ -21,6 +21,7 @@ endif

2121ifeq ($(OS), windows)

2222 OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o

2323else

24+ CFLAGS += -fPIC

2425 OBJS += idris_stdfgn.o idris_net.o

2526endif

2627

rts/idris_gc.c+7

@@ -53,6 +53,13 @@ VAL copy(VM* vm, VAL x) {

5353 break;

5454 case FWD:

5555 return x->info.ptr;

56+ case RAWDATA:

57+ {

58+ size_t size = x->info.size + sizeof(Closure);

59+ cl = allocate(size, 0);

60+ memcpy(cl, x, size);

61+ }

62+ break;

5663 default:

5764 break;

5865 }

rts/idris_rts.c+16−3

@@ -143,7 +143,10 @@ int space(VM* vm, size_t size) {

143143}

144144

145145void* idris_alloc(size_t size) {

146− return allocate(size, 0);

146+ Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);

147+ SETTY(cl, RAWDATA);

148+ cl->info.size = size;

149+ return (void*)cl+sizeof(Closure);

147150}

148151

149152void* idris_realloc(void* old, size_t old_size, size_t size) {

@@ -501,17 +504,20 @@ VAL idris_strlen(VM* vm, VAL l) {

501504}

502505

503506VAL idris_readStr(VM* vm, FILE* h) {

507+ VAL ret;

504508 char *buffer = NULL;

505509 size_t n = 0;

506510 ssize_t len;

507511 len = getline(&buffer, &n, h);

512+ strtok(buffer, "\n");

508513

509514 if (len <= 0) {

510− return MKSTR(vm, "");

515+ ret = MKSTR(vm, "");

511516 } else {

512− return MKSTR(vm, buffer);

517+ ret = MKSTR(vm, buffer);

513518 }

514519 free(buffer);

520+ return ret;

515521}

516522

517523VAL idris_strHead(VM* vm, VAL str) {

@@ -712,6 +718,13 @@ VAL doCopyTo(VM* vm, VAL x) {

712718 case BITS64:

713719 cl = idris_b64CopyForGC(vm, x);

714720 break;

721+ case RAWDATA:

722+ {

723+ size_t size = x->info.size + sizeof(Closure);

724+ cl = allocate(size, 0);

725+ memcpy(cl, x, size);

726+ }

727+ break;

715728 default:

716729 assert(0); // We're in trouble if this happens...

717730 }

rts/idris_rts.h+2−34

@@ -10,8 +10,6 @@

1010#endif

1111#include <stdint.h>

1212

13−#include <emmintrin.h>

14−

1513#include "idris_heap.h"

1614#include "idris_stats.h"

1715

@@ -26,7 +24,7 @@

2624typedef enum {

2725 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

2826 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

29− MANAGEDPTR

27+ MANAGEDPTR, RAWDATA

3028} ClosureType;

3129

3230typedef struct Closure *VAL;

@@ -41,14 +39,6 @@ typedef struct {

4139 size_t offset;

4240} StrOffset;

4341

44−typedef struct {

45− // If we ever have multithreaded access to the same heap,

46− // fill is mutable so needs synchronization!

47− size_t fill;

48− size_t cap;

49− unsigned char store[];

50−} Buffer;

51−

5242// A foreign pointer, managed by the idris GC

5343typedef struct {

5444 size_t size;

@@ -73,9 +63,8 @@ typedef struct Closure {

7363 uint16_t bits16;

7464 uint32_t bits32;

7565 uint64_t bits64;

76− __m128i* bits128p;

77− Buffer* buf;

7866 ManagedPtr* mptr;

67+ size_t size;

7968 } info;

8069} Closure;

8170

@@ -315,27 +304,6 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs);

315304VAL idris_strIndex(VM* vm, VAL str, VAL i);

316305VAL idris_strRev(VM* vm, VAL str);

317306

318−VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

319−VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

320−VAL idris_appendB16LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

321−VAL idris_appendB16BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

322−VAL idris_appendB32Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

323−VAL idris_appendB32LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

324−VAL idris_appendB32BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

325−VAL idris_appendB64Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

326−VAL idris_appendB64LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

327−VAL idris_appendB64BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val);

328−VAL idris_peekB8Native(VM* vm, VAL buf, VAL off);

329−VAL idris_peekB16Native(VM* vm, VAL buf, VAL off);

330−VAL idris_peekB16LE(VM* vm, VAL buf, VAL off);

331−VAL idris_peekB16BE(VM* vm, VAL buf, VAL off);

332−VAL idris_peekB32Native(VM* vm, VAL buf, VAL off);

333−VAL idris_peekB32LE(VM* vm, VAL buf, VAL off);

334−VAL idris_peekB32BE(VM* vm, VAL buf, VAL off);

335−VAL idris_peekB64Native(VM* vm, VAL buf, VAL off);

336−VAL idris_peekB64LE(VM* vm, VAL buf, VAL off);

337−VAL idris_peekB64BE(VM* vm, VAL buf, VAL off);

338−

339307// system infox

340308// used indices:

341309// 0 returns backend

samples/ConsoleIO.idr → samples/effects/ConsoleIO.idrrenamed

The content is the same.

samples/Exception.idr → samples/effects/Exception.idrrenamed

The content is the same.

samples/Makefile → samples/effects/Makefilerenamed

The content is the same.

samples/Random.idr → samples/effects/Random.idrrenamed

The content is the same.

samples/ReadInt.idr → samples/effects/ReadInt.idrrenamed

The content is the same.

samples/Select.idr → samples/effects/Select.idrrenamed

The content is the same.

samples/TreeTag-noeff.idr → samples/effects/TreeTag-noeff.idrrenamed

The content is the same.

samples/TreeTag.idr → samples/effects/TreeTag.idrrenamed

The content is the same.

samples/TreeTagCount.idr → samples/effects/TreeTagCount.idrrenamed

The content is the same.

samples/hworld.idr → samples/effects/hworld.idrrenamed

The content is the same.

samples/vadd.idr → samples/effects/vadd.idrrenamed

The content is the same.

samples/misc/Makefilenew file+8

@@ -0,0 +1,8 @@

1+check:

2+ rm -f *.ibc

3+ for x in *.idr ; do \

4+ echo "Checking $$x"; \

5+ idris --check $$x; \

6+ done

7+

8+.PHONY: check

samples/binary.idr → samples/misc/binary.idrrenamed

The content is the same.

samples/interp-alt.idr → samples/misc/interp-alt.idrrenamed

The content is the same.

samples/interp.idr → samples/misc/interp.idrrenamed

The content is the same.

samples/javaffi.idr → samples/misc/javaffi.idrrenamed

The content is the same.

samples/named_instance.lidr → samples/misc/named_instance.lidrrenamed

The content is the same.

samples/reflection.idr → samples/misc/reflection.idrrenamed

The content is the same.

samples/tutorial/Makefilenew file+11

@@ -0,0 +1,11 @@

1+check: .PHONY

2+ rm -f *.ibc

3+ for x in *.idr ; do \

4+ echo "Checking $$x"; \

5+ idris --check $$x; \

6+ done

7+

8+clean:

9+ rm -f *.ibc

10+

11+.PHONY:

samples/tutorial/binary.idrnew file+61

@@ -0,0 +1,61 @@

1+module Main

2+

3+data Binary : Nat -> Type where

4+ bEnd : Binary Z

5+ bO : Binary n -> Binary (n + n)

6+ bI : Binary n -> Binary (S (n + n))

7+

8+instance Show (Binary n) where

9+ show (bO x) = show x ++ "0"

10+ show (bI x) = show x ++ "1"

11+ show bEnd = ""

12+

13+data Parity : Nat -> Type where

14+ Even : Parity (n + n)

15+ Odd : Parity (S (n + n))

16+

17+parity : (n:Nat) -> Parity n

18+parity Z = Even {n=Z}

19+parity (S Z) = Odd {n=Z}

20+parity (S (S k)) with (parity k)

21+ parity (S (S (j + j))) | Even ?= Even {n=S j}

22+ parity (S (S (S (j + j)))) | Odd ?= Odd {n=S j}

23+

24+natToBin : (n:Nat) -> Binary n

25+natToBin Z = bEnd

26+natToBin (S k) with (parity k)

27+ natToBin (S (j + j)) | Even = bI (natToBin j)

28+ natToBin (S (S (j + j))) | Odd ?= bO (natToBin (S j))

29+

30+intToNat : Int -> Nat

31+intToNat 0 = Z

32+intToNat x = if (x>0) then (S (intToNat (x-1))) else Z

33+

34+main : IO ()

35+main = do putStr "Enter a number: "

36+ x <- getLine

37+ print (natToBin (fromInteger (cast x)))

38+

39+---------- Proofs ----------

40+

41+Main.natToBin_lemma_1 = proof

42+ intros

43+ rewrite plusSuccRightSucc j j

44+ rewrite sym (plusSuccRightSucc j j)

45+ trivial

46+

47+

48+parity_lemma_1 = proof

49+ intros

50+ rewrite sym (plusSuccRightSucc j j)

51+ trivial

52+

53+

54+parity_lemma_2 = proof {

55+ intro;

56+ intro;

57+ rewrite sym (plusSuccRightSucc j j);

58+ trivial;

59+}

60+

61+

samples/tutorial/bmain.idrnew file+8

@@ -0,0 +1,8 @@

1+module Main

2+

3+import btree

4+

5+main : IO ()

6+main = do let t = toTree [1,8,2,7,9,3]

7+ print (btree.toList t)

8+

samples/tutorial/btree.idrnew file+18

@@ -0,0 +1,18 @@

1+module btree

2+

3+data BTree a = Leaf

4+ | Node (BTree a) a (BTree a)

5+

6+insert : Ord a => a -> BTree a -> BTree a

7+insert x Leaf = Node Leaf x Leaf

8+insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)

9+ else (Node l v (insert x r))

10+

11+toList : BTree a -> List a

12+toList Leaf = []

13+toList (Node l v r) = btree.toList l ++ (v :: btree.toList r)

14+

15+toTree : Ord a => List a -> BTree a

16+toTree [] = Leaf

17+toTree (x :: xs) = insert x (toTree xs)

18+

samples/tutorial/btreemod.idrnew file+20

@@ -0,0 +1,20 @@

1+module btree

2+

3+abstract data BTree a = Leaf

4+ | Node (BTree a) a (BTree a)

5+

6+abstract

7+insert : Ord a => a -> BTree a -> BTree a

8+insert x Leaf = Node Leaf x Leaf

9+insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)

10+ else (Node l v (insert x r))

11+

12+abstract

13+toList : BTree a -> List a

14+toList Leaf = []

15+toList (Node l v r) = btree.toList l ++ (v :: btree.toList r)

16+

17+abstract

18+toTree : Ord a => List a -> BTree a

19+toTree [] = Leaf

20+toTree (x :: xs) = insert x (toTree xs)

samples/tutorial/classes.idrnew file+10

@@ -0,0 +1,10 @@

1+m_add : Maybe Int -> Maybe Int -> Maybe Int

2+m_add x y = do x' <- x -- Extract value from x

3+ y' <- y -- Extract value from y

4+ return (x' + y') -- Add them

5+

6+m_add' : Maybe Int -> Maybe Int -> Maybe Int

7+m_add' x y = [ x' + y' | x' <- x, y' <- y ]

8+

9+sortAndShow : (Ord a, Show a) => List a -> String

10+sortAndShow xs = show (sort xs)

samples/tutorial/foo.idrnew file+10

@@ -0,0 +1,10 @@

1+module foo

2+

3+namespace x

4+ test : Int -> Int

5+ test x = x * 2

6+

7+namespace y

8+ test : String -> String

9+ test x = x ++ x

10+

samples/tutorial/hello.idrnew file+5

@@ -0,0 +1,5 @@

1+module Main

2+

3+main : IO ()

4+main = putStrLn "Hello world"

5+

samples/tutorial/idiom.idrnew file+38

@@ -0,0 +1,38 @@

1+module idiom

2+

3+data Expr = Var String

4+ | Val Int

5+ | Add Expr Expr

6+

7+data Eval : Type -> Type where

8+ MkEval : (List (String, Int) -> Maybe a) -> Eval a

9+

10+fetch : String -> Eval Int

11+fetch x = MkEval fetchVal where

12+ fetchVal : List (String, Int) -> Maybe Int

13+ fetchVal [] = Nothing

14+ fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)

15+

16+instance Functor Eval where

17+ map f (MkEval g) = MkEval (\e => map f (g e))

18+

19+instance Applicative Eval where

20+ pure x = MkEval (\e => Just x)

21+

22+ (<*>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where

23+ app : Maybe (a -> b) -> Maybe a -> Maybe b

24+ app (Just fx) (Just gx) = Just (fx gx)

25+ app _ _ = Nothing

26+

27+eval : Expr -> Eval Int

28+eval (Var x) = fetch x

29+eval (Val x) = [| x |]

30+eval (Add x y) = [| eval x + eval y |]

31+

32+runEval : List (String, Int) -> Expr -> Maybe Int

33+runEval env e = case eval e of

34+ MkEval envFn => envFn env

35+

36+m_add' : Maybe Int -> Maybe Int -> Maybe Int

37+m_add' x y = [| x + y |]

38+

samples/tutorial/interp.idrnew file+68

@@ -0,0 +1,68 @@

1+module Main

2+

3+data Ty = TyInt | TyBool| TyFun Ty Ty

4+

5+interpTy : Ty -> Type

6+interpTy TyInt = Int

7+interpTy TyBool = Bool

8+interpTy (TyFun s t) = interpTy s -> interpTy t

9+

10+using (G : Vect n Ty)

11+

12+ data Env : Vect n Ty -> Type where

13+ Nil : Env Nil

14+ (::) : interpTy a -> Env G -> Env (a :: G)

15+

16+ data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where

17+ Stop : HasType FZ (t :: G) t

18+ Pop : HasType k G t -> HasType (FS k) (u :: G) t

19+

20+ lookup : HasType i G t -> Env G -> interpTy t

21+ lookup Stop (x :: xs) = x

22+ lookup (Pop k) (x :: xs) = lookup k xs

23+

24+ data Expr : Vect n Ty -> Ty -> Type where

25+ Var : HasType i G t -> Expr G t

26+ Val : (x : Int) -> Expr G TyInt

27+ Lam : Expr (a :: G) t -> Expr G (TyFun a t)

28+ App : Expr G (TyFun a t) -> Expr G a -> Expr G t

29+ Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->

30+ Expr G c

31+ If : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

32+

33+ interp : Env G -> [static] (e : Expr G t) -> interpTy t

34+ interp env (Var i) = lookup i env

35+ interp env (Val x) = x

36+ interp env (Lam sc) = \x => interp (x :: env) sc

37+ interp env (App f s) = interp env f (interp env s)

38+ interp env (Op op x y) = op (interp env x) (interp env y)

39+ interp env (If x t e) = if interp env x then interp env t

40+ else interp env e

41+

42+ eId : Expr G (TyFun TyInt TyInt)

43+ eId = Lam (Var Stop)

44+

45+ eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

46+ eAdd = Lam (Lam (Op (+) (Var Stop) (Var (Pop Stop))))

47+

48+ eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool))

49+ eEq = Lam (Lam (Op (==) (Var Stop) (Var (Pop Stop))))

50+

51+ eDouble : Expr G (TyFun TyInt TyInt)

52+ eDouble = Lam (App (App eAdd (Var Stop)) (Var Stop))

53+

54+ fact : Expr G (TyFun TyInt TyInt)

55+ fact = Lam (If (Op (==) (Var Stop) (Val 0))

56+ (Val 1) (Op (*) (App fact (Op (-) (Var Stop) (Val 1))) (Var Stop)))

57+

58+testFac : Int

59+testFac = interp [] fact 4

60+

61+-- unitTestFac : so (interp [] fact 4 == 24)

62+-- unitTestFac = oh

63+

64+main : IO ()

65+main = do putStr "Enter a number: "

66+ x <- getLine

67+ print (interp [] fact (cast x))

68+

samples/tutorial/letbind.idrnew file+16

@@ -0,0 +1,16 @@

1+module letbind

2+

3+mirror : List a -> List a

4+mirror xs = let xs' = reverse xs in

5+ xs ++ xs'

6+

7+data Person = MkPerson String Int

8+

9+showPerson : Person -> String

10+showPerson p = let MkPerson name age = p in

11+ name ++ " is " ++ show age ++ " years old"

12+

13+splitAt : Char -> String -> (String, String)

14+splitAt c x = case break (== c) x of

15+ (x, y) => (x, strTail y)

16+

samples/tutorial/prims.idrnew file+14

@@ -0,0 +1,14 @@

1+module prims

2+

3+x : Int

4+x = 42

5+

6+foo : String

7+foo = "Sausage machine"

8+

9+bar : Char

10+bar = 'Z'

11+

12+quux : Bool

13+quux = False

14+

samples/tutorial/theorems.idrnew file+57

@@ -0,0 +1,57 @@

1+

2+fiveIsFive : 5 = 5

3+fiveIsFive = Refl

4+

5+twoPlusTwo : 2 + 2 = 4

6+twoPlusTwo = Refl

7+

8+total disjoint : (n : Nat) -> Z = S n -> Void

9+disjoint n p = replace {P = disjointTy} p ()

10+ where

11+ disjointTy : Nat -> Type

12+ disjointTy Z = ()

13+ disjointTy (S k) = Void

14+

15+total acyclic : (n : Nat) -> n = S n -> Void

16+acyclic Z p = disjoint _ p

17+acyclic (S k) p = acyclic k (succInjective _ _ p)

18+

19+empty1 : Void

20+empty1 = hd [] where

21+ hd : List a -> a

22+ hd (x :: xs) = x

23+

24+empty2 : Void

25+empty2 = empty2

26+

27+plusReduces : (n:Nat) -> plus Z n = n

28+plusReduces n = Refl

29+

30+plusReducesZ : (n:Nat) -> n = plus n Z

31+plusReducesZ Z = Refl

32+plusReducesZ (S k) = cong (plusReducesZ k)

33+

34+plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)

35+plusReducesS Z m = Refl

36+plusReducesS (S k) m = cong (plusReducesS k m)

37+

38+plusReducesZ' : (n:Nat) -> n = plus n Z

39+plusReducesZ' Z = ?plusredZ_Z

40+plusReducesZ' (S k) = let ih = plusReducesZ' k in

41+ ?plusredZ_S

42+

43+

44+---------- Proofs ----------

45+

46+plusredZ_S = proof {

47+ intro;

48+ intro;

49+ rewrite ih;

50+ trivial;

51+}

52+

53+plusredZ_Z = proof {

54+ compute;

55+ trivial;

56+}

57+

samples/tutorial/universe.idrnew file+7

@@ -0,0 +1,7 @@

1+myid : (a : Type) -> a -> a

2+myid _ x = x

3+

4+idid : (a : Type) -> a -> a

5+idid = myid _ myid

6+

7+

samples/tutorial/usefultypes.idrnew file+20

@@ -0,0 +1,20 @@

1+

2+intVec : Vect 5 Int

3+intVec = [1, 2, 3, 4, 5]

4+

5+double : Int -> Int

6+double x = x * 2

7+

8+vec : (n ** Vect n Int)

9+vec = (_ ** [3, 4])

10+

11+list_lookup : Nat -> List a -> Maybe a

12+list_lookup _ Nil = Nothing

13+list_lookup Z (x :: xs) = Just x

14+list_lookup (S k) (x :: xs) = list_lookup k xs

15+

16+lookup_default : Nat -> List a -> a -> a

17+lookup_default i xs def = case list_lookup i xs of

18+ Nothing => def

19+ Just x => x

20+

samples/tutorial/vbroken.idrnew file+10

@@ -0,0 +1,10 @@

1+module Vect

2+

3+data Vect : Nat -> Type -> Type where

4+ Nil : Vect Z a

5+ (::) : a -> Vect k a -> Vect (S k) a

6+

7+(++) : Vect n a -> Vect m a -> Vect (n + m) a

8+(++) Nil ys = ys

9+(++) (x :: xs) ys = x :: xs ++ xs -- BROKEN

10+

samples/tutorial/views.idrnew file+37

@@ -0,0 +1,37 @@

1+module views

2+

3+data Parity : Nat -> Type where

4+ Even : Parity (n + n)

5+ Odd : Parity (S (n + n))

6+

7+parity : (n:Nat) -> Parity n

8+parity Z = Even {n=Z}

9+parity (S Z) = Odd {n=Z}

10+parity (S (S k)) with (parity k)

11+ parity (S (S (j + j))) | Even ?= Even {n=S j}

12+ parity (S (S (S (j + j)))) | Odd ?= Odd {n=S j}

13+

14+natToBin : Nat -> List Bool

15+natToBin Z = Nil

16+natToBin k with (parity k)

17+ natToBin (j + j) | Even = False :: natToBin j

18+ natToBin (S (j + j)) | Odd = True :: natToBin j

19+

20+

21+---------- Proofs ----------

22+

23+views.parity_lemma_2 = proof {

24+ intro;

25+ intro;

26+ rewrite sym (plusSuccRightSucc j j);

27+ trivial;

28+}

29+

30+views.parity_lemma_1 = proof {

31+ intro;

32+ intro;

33+ rewrite sym (plusSuccRightSucc j j);

34+ trivial;

35+}

36+

37+

samples/tutorial/viewsbroken.idrnew file+12

@@ -0,0 +1,12 @@

1+

2+data Parity : Nat -> Type where

3+ Even : Parity (n + n)

4+ Odd : Parity (S (n + n))

5+

6+parity : (n:Nat) -> Parity n

7+parity Z = Even {n=Z}

8+parity (S Z) = Odd {n=Z}

9+parity (S (S k)) with (parity k)

10+ parity (S (S (j + j))) | Even = Even {n=S j}

11+ parity (S (S (S (j + j)))) | Odd = Odd {n=S j}

12+

samples/tutorial/wheres.idrnew file+14

@@ -0,0 +1,14 @@

1+module wheres

2+

3+even : Nat -> Bool

4+even Z = True

5+even (S k) = odd k where

6+ odd Z = False

7+ odd (S k) = even k

8+

9+test : List Nat

10+test = [c (S 1), c Z, d (S Z)]

11+ where c x = 42 + x

12+ d y = c (y + 1 + z y)

13+ where z w = y + w

14+

src/IRTS/CodegenC.hs+5−5

@@ -220,11 +220,11 @@ bcc i (CASE True r code def)

220220 indent i ++ "}\n"

221221

222222 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

223− showCase i Nothing [(t, c)] = showCode i c

224− showCase i (Just def) [] = showCode i def

223+ showCase i Nothing [(t, c)] = indent i ++ showCode i c

224+ showCase i (Just def) [] = indent i ++ showCode i def

225225 showCase i def ((t, c) : cs)

226226 = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

227− ++ indent i ++ "else " ++ showCase i def cs

227+ ++ indent i ++ "else\n" ++ showCase i def cs

228228

229229bcc i (CASE safe r code def)

230230 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

@@ -307,7 +307,7 @@ bcc i (FOREIGNCALL l rty (FStr fn) args)

307307 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

308308 where fcall (t, arg) = irts_c (toFType t) (creg arg)

309309bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

310−bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1); exit(-1);"

310+bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

311311-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

312312

313313-- Deconstruct the Foreign type in the defunctionalised expression and build

@@ -647,7 +647,7 @@ codegenH es = mapM_ writeIFace es

647647

648648writeIFace :: ExportIFace -> IO ()

649649writeIFace (Export ffic hdr exps)

650− | ffic == sUN "FFI_C"

650+ | ffic == sNS (sUN "FFI_C") ["FFI_C"]

651651 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++

652652 "#define " ++ hdr_guard hdr ++ "\n\n" ++

653653 "#include <idris_rts.h>\n\n" ++

src/IRTS/CodegenJavaScript.hs+4−4

@@ -47,7 +47,7 @@ initCompileInfo bc =

4747 lookupBigInt = any (needsBigInt . snd)

4848 where

4949 needsBigInt :: [BC] -> Bool

50− needsBigInt bc = or $ map testBCForBigInt bc

50+ needsBigInt bc = any testBCForBigInt bc

5151 where

5252 testBCForBigInt :: BC -> Bool

5353 testBCForBigInt (ASSIGNCONST _ c) =

@@ -55,12 +55,12 @@ initCompileInfo bc =

5555

5656 testBCForBigInt (CONSTCASE _ c d) =

5757 maybe False needsBigInt d

58− || (or $ map (needsBigInt . snd) c)

59− || (or $ map (testConstForBigInt . fst) c)

58+ || any (needsBigInt . snd) c

59+ || any (testConstForBigInt . fst) c

6060

6161 testBCForBigInt (CASE _ _ c d) =

6262 maybe False needsBigInt d

63− || (or $ map (needsBigInt . snd) c)

63+ || any (needsBigInt . snd) c

6464

6565 testBCForBigInt _ = False

6666

src/IRTS/Compiler.hs+8−4

@@ -51,8 +51,12 @@ compile codegen f mtm

5151 = do checkMVs -- check for undefined metavariables

5252 checkTotality -- refuse to compile if there are totality problems

5353 exports <- findExports

54+ let rootNames = case mtm of

55+ Nothing -> []

56+ Just t -> freeNames t

5457

55− reachableNames <- performUsageAnalysis (getExpNames exports)

58+ reachableNames <- performUsageAnalysis

59+ (rootNames ++ getExpNames exports)

5660 maindef <- case mtm of

5761 Nothing -> return []

5862 Just tm -> do md <- irMain tm

@@ -231,7 +235,7 @@ data VarInfo = VI

231235type Vars = M.Map Name VarInfo

232236

233237irTerm :: Vars -> [Name] -> Term -> Idris LExp

234−irTerm vs env tm@(App f a) = do

238+irTerm vs env tm@(App _ f a) = do

235239 ist <- getIState

236240 case unApply tm of

237241 (P _ (UN m) _, args)

@@ -293,8 +297,8 @@ irTerm vs env tm@(App f a) = do

293297

294298 -- This case is here until we get more general inlining. It's just

295299 -- a really common case, and the laziness hurts...

296− (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),

297− (App (App (App (P _ (UN d') _) _) _) e)])

300+ (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),

301+ (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])

298302 | be == txt "boolElim"

299303 , d == txt "Delay"

300304 , d' == txt "Delay"

src/IRTS/Defunctionalise.hs+6−6

@@ -162,21 +162,21 @@ addApps defs (n, LFun _ _ args e)

162162 | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)

163163 | otherwise = preEval xs t

164164

165− needsEval x (DApp _ _ args) = or (map (needsEval x) args)

166− needsEval x (DC _ _ _ args) = or (map (needsEval x) args)

167− needsEval x (DCase up e alts) = needsEval x e || or (map nec alts)

165+ needsEval x (DApp _ _ args) = any (needsEval x) args

166+ needsEval x (DC _ _ _ args) = any (needsEval x) args

167+ needsEval x (DCase up e alts) = needsEval x e || any nec alts

168168 where nec (DConCase _ _ _ e) = needsEval x e

169169 nec (DConstCase _ e) = needsEval x e

170170 nec (DDefaultCase e) = needsEval x e

171− needsEval x (DChkCase e alts) = needsEval x e || or (map nec alts)

171+ needsEval x (DChkCase e alts) = needsEval x e || any nec alts

172172 where nec (DConCase _ _ _ e) = needsEval x e

173173 nec (DConstCase _ e) = needsEval x e

174174 nec (DDefaultCase e) = needsEval x e

175175 needsEval x (DLet n v e)

176176 | x == n = needsEval x v

177177 | otherwise = needsEval x v || needsEval x e

178− needsEval x (DForeign _ _ args) = or (map (needsEval x) (map snd args))

179− needsEval x (DOp op args) = or (map (needsEval x) args)

178+ needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)

179+ needsEval x (DOp op args) = any (needsEval x) args

180180 needsEval x (DProj (DV (Glob x')) _) = x == x'

181181 needsEval x _ = False

182182

src/IRTS/Lang.hs+1−1

@@ -132,7 +132,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

132132

133133lname (NS n x) i = NS (lname n i) x

134134lname (UN n) i = MN i n

135−lname x i = sMN i (show x)

135+lname x i = sMN i (show x ++ "_lam")

136136

137137liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

138138liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

src/Idris/AbsSyntax.hs+8−5

@@ -816,7 +816,9 @@ targetCPU = do i <- getIState

816816

817817verbose :: Idris Bool

818818verbose = do i <- getIState

819− return (opt_verbose (idris_options i))

819+ -- Quietness overrides verbosity

820+ return (not (opt_quiet (idris_options i)) &&

821+ opt_verbose (idris_options i))

820822

821823setVerbose :: Bool -> Idris ()

822824setVerbose t = do i <- getIState

@@ -1009,7 +1011,7 @@ expandParams dec ps ns infs tm = en tm

10091011 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

10101012 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

10111013 en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)

1012− en (PRunTactics fc tm) = PRunTactics fc (en tm)

1014+ en (PRunElab fc tm) = PRunElab fc (en tm)

10131015 en t = t

10141016

10151017 nselem x [] = False

@@ -1478,7 +1480,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

14781480 imps top env (PHidden tm) = imps False env tm

14791481 imps top env (PUnifyLog tm) = imps False env tm

14801482 imps top env (PNoImplicits tm) = imps False env tm

1481− imps top env (PRunTactics fc tm) = imps False env tm

1483+ imps top env (PRunElab fc tm) = imps False env tm

14821484 imps top env _ = return ()

14831485

14841486 pibind using [] sc = sc

@@ -1605,7 +1607,7 @@ addImpl' inpat env infns imp_meths ist ptm

16051607 ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)

16061608 (fmap (ai True env ds) g)

16071609 ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)

1608− ai qq env ds (PRunTactics fc tm) = PRunTactics fc (ai False env ds tm)

1610+ ai qq env ds (PRunElab fc tm) = PRunElab fc (ai False env ds tm)

16091611 ai qq env ds tm = tm

16101612

16111613 handleErr (Left err) = PElabError err

@@ -2016,6 +2018,7 @@ substMatchShadow n shs tm t = sm shs t where

20162018 sm xs (PHidden x) = PHidden (sm xs x)

20172019 sm xs (PUnifyLog x) = PUnifyLog (sm xs x)

20182020 sm xs (PNoImplicits x) = PNoImplicits (sm xs x)

2021+ sm xs (PRunElab fc script) = PRunElab fc (sm xs script)

20192022 sm xs x = x

20202023

20212024 fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))

@@ -2142,5 +2145,5 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

21422145 mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

21432146 mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

21442147 mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

2145− mkUniq (PRunTactics fc ts) = liftM (PRunTactics fc ) (mkUniq ts)

2148+ mkUniq (PRunElab fc ts) = liftM (PRunElab fc ) (mkUniq ts)

21462149 mkUniq t = return t

src/Idris/AbsSyntaxTree.hs+74−59

@@ -369,7 +369,7 @@ data Command = Quit

369369 | ModImport String

370370 | Edit

371371 | Compile Codegen String

372− | Execute

372+ | Execute PTerm

373373 | ExecVal PTerm

374374 | Metavars

375375 | Prove Name

@@ -408,6 +408,7 @@ data Command = Quit

408408 | Apropos [String] String

409409 | WhoCalls Name

410410 | CallsWho Name

411+ | Browse [String]

411412 | MakeDoc String -- IdrisDoc

412413 | Warranty

413414 | PrintDef Name

@@ -580,14 +581,6 @@ inlinable = elem Inlinable

580581dictionary :: FnOpts -> Bool

581582dictionary = elem Dictionary

582583

583−-- | Data declaration options

584−data DataOpt = Codata -- ^ Set if the the data-type is coinductive

585− | DefaultEliminator -- ^ Set if an eliminator should be generated for data type

586− | DefaultCaseFun -- ^ Set if a case function should be generated for data type

587− | DataErrRev

588− deriving (Show, Eq)

589−

590−type DataOpts = [DataOpt]

591584

592585-- | Type provider - what to provide

593586data ProvideWhat' t = ProvTerm t t -- ^ the first is the goal type, the second is the term

@@ -642,7 +635,7 @@ data PDecl' t

642635 | PDSL Name (DSL' t) -- ^ DSL declaration

643636 | PSyntax FC Syntax -- ^ Syntax definition

644637 | PMutual FC [PDecl' t] -- ^ Mutual block

645− | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.

638+ | PDirective Directive -- ^ Compiler directive.

646639 | PProvider (Docstring (Either Err PTerm)) SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term

647640 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

648641 -- bool is True, lhs and rhs must be convertible

@@ -652,11 +645,32 @@ deriving instance Binary PDecl'

652645deriving instance NFData PDecl'

653646!-}

654647

655−-- For elaborator state

648+-- | The set of source directives

649+data Directive = DLib Codegen String |

650+ DLink Codegen String |

651+ DFlag Codegen String |

652+ DInclude Codegen String |

653+ DHide Name |

654+ DFreeze Name |

655+ DAccess Accessibility |

656+ DDefault Bool |

657+ DLogging Integer |

658+ DDynamicLibs [String] |

659+ DNameHint Name [Name] |

660+ DErrorHandlers Name Name [Name] |

661+ DLanguage LanguageExt |

662+ DUsed FC Name Name

663+

664+-- | A set of instructions for things that need to happen in IState

665+-- after a term elaboration when there's been reflected elaboration.

666+data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

667+ | RClausesInstrs Name [([Name], Term, Term)]

668+

669+-- | For elaborator state

656670data EState = EState {

657− case_decls :: [PDecl],

671+ case_decls :: [(Name, PDecl)],

658672 delayed_elab :: [Elab' EState ()],

659− new_tyDecls :: [(Name, FC, [PArg], Type)]

673+ new_tyDecls :: [RDeclInstructions]

660674 }

661675

662676initEState :: EState

@@ -829,7 +843,8 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

829843 | PNoImplicits PTerm -- ^ never run implicit converions on the term

830844 | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])

831845 | PUnquote PTerm -- ^ ~Term

832− | PRunTactics FC PTerm -- ^ %runTactics tm - New-style proof script

846+ | PQuoteName Name -- ^ `{n}

847+ | PRunElab FC PTerm -- ^ %runElab tm - New-style proof script

833848 deriving (Eq, Data, Typeable)

834849

835850

@@ -1048,6 +1063,7 @@ highestFC (PUnifyLog tm) = highestFC tm

10481063highestFC (PNoImplicits tm) = highestFC tm

10491064highestFC (PQuasiquote _ _) = Nothing

10501065highestFC (PUnquote tm) = highestFC tm

1066+highestFC (PQuoteName _) = Nothing

10511067

10521068-- Type class data

10531069

@@ -1086,20 +1102,7 @@ deriving instance Binary OptInfo

10861102deriving instance NFData OptInfo

10871103!-}

10881104

1089−

1090−data TypeInfo = TI { con_names :: [Name],

1091− codata :: Bool,

1092− data_opts :: DataOpts,

1093− param_pos :: [Int],

1094− mutual_types :: [Name] }

1095− deriving Show

1096−{-!

1097−deriving instance Binary TypeInfo

1098−deriving instance NFData TypeInfo

1099−!-}

1100−

1101−-- Syntactic sugar info

1102−

1105+-- | Syntactic sugar info

11031106data DSL' t = DSL { dsl_bind :: t,

11041107 dsl_return :: t,

11051108 dsl_apply :: t,

@@ -1261,14 +1264,14 @@ infP = P (TCon 6 0) inferTy (TType (UVal 0))

12611264

12621265getInferTerm, getInferType :: Term -> Term

12631266getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

1264−getInferTerm (App (App _ _) tm) = tm

1267+getInferTerm (App _ (App _ _ _) tm) = tm

12651268getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

12661269

12671270getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

12681271 where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

12691272 toTy (PVar t) = PVTy t

12701273 toTy b = b

1271−getInferType (App (App _ ty) _) = ty

1274+getInferType (App _ (App _ _ ty) _) = ty

12721275

12731276

12741277

@@ -1436,16 +1439,16 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

14361439 prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n

14371440 prettySe p bnd (PLam fc n ty sc) =

14381441 bracket p startPrec . group . align . hang 2 $

1439− text "\\" <> bindingOf n False <+> text "=>" <$>

1442+ text "\\" <> prettyBindingOf n False <+> text "=>" <$>

14401443 prettySe startPrec ((n, False):bnd) sc

14411444 prettySe p bnd (PLet fc n ty v sc) =

14421445 bracket p startPrec . group . align $

1443− kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>

1446+ kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe startPrec bnd v) </>

14441447 kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)

14451448 prettySe p bnd (PPi (Exp l s _) n ty sc)

14461449 | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

14471450 bracket p startPrec . group $

1448− enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>

1451+ enclose lparen rparen (group . align $ prettyBindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+>

14491452 st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc

14501453 | otherwise =

14511454 bracket p startPrec . group $

@@ -1458,7 +1461,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

14581461 prettySe p bnd (PPi (Imp l s _ fa) n ty sc)

14591462 | ppopt_impl ppo =

14601463 bracket p startPrec $

1461− lbrace <> bindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>

1464+ lbrace <> prettyBindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+>

14621465 st <> text "->" </> prettySe startPrec ((n, True):bnd) sc

14631466 | otherwise = prettySe startPrec ((n, True):bnd) sc

14641467 where

@@ -1612,9 +1615,18 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

16121615 prettySe p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe p [] t <> text ")"

16131616 prettySe p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe p [] t <+> colon <+> prettySe p [] g <> text ")"

16141617 prettySe p bnd (PUnquote t) = text "~" <> prettySe p bnd t

1618+ prettySe p bnd (PQuoteName n) = text "`{" <> prettyName True (ppopt_impl ppo) bnd n <> text "}"

16151619

16161620 prettySe p bnd _ = text "missing pretty-printer for term"

16171621

1622+ prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

1623+ prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

1624+ where display (UN n) = T.unpack n

1625+ display (MN _ n) = T.unpack n

1626+ -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings

1627+ display (NS n ns) = (concat . intersperse "." . map T.unpack . reverse) ns ++ "." ++ display n

1628+ display n = show n

1629+

16181630 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

16191631 prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

16201632 prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

@@ -1636,6 +1648,8 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

16361648 basename (NS n _) = basename n

16371649 basename n = n

16381650

1651+ slist' _ _ e

1652+ | containsHole e = Nothing

16391653 slist' p bnd (PApp _ (PRef _ nil) _)

16401654 | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

16411655 slist' p bnd (PRef _ nil)

@@ -1765,9 +1779,6 @@ showDeclImp o (PInstance _ _ _ _ cs n _ t _ ds)

17651779showDeclImp _ _ = text "..."

17661780-- showDeclImp (PImport o) = "import " ++ o

17671781

1768−instance Show (Doc OutputAnnotation) where

1769− show = flip (displayS . renderCompact) ""

1770−

17711782getImps :: [PArg] -> [(Name, PTerm)]

17721783getImps [] = []

17731784getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

@@ -1905,31 +1916,35 @@ allNamesIn tm = nub $ ni [] tm

19051916 niTacImp env (TacImp _ _ scr) = ni env scr

19061917 niTacImp _ _ = []

19071918

1919+

19081920-- Return all names defined in binders in the given term

19091921boundNamesIn :: PTerm -> [Name]

1910−boundNamesIn tm = nub $ ni tm

1922+boundNamesIn tm = S.toList (ni S.empty tm)

19111923 where -- TODO THINK Added niTacImp, but is it right?

1912− ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1913− ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1914− ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1915− ni (PLam fc n ty sc) = n : (ni ty ++ ni sc)

1916− ni (PLet fc n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1917− ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))

1918− ni (PEq _ _ _ l r) = ni l ++ ni r

1919− ni (PRewrite _ l r _) = ni l ++ ni r

1920− ni (PTyped l r) = ni l ++ ni r

1921− ni (PPair _ _ l r) = ni l ++ ni r

1922− ni (PDPair _ _ (PRef _ n) t r) = ni t ++ ni r

1923− ni (PDPair _ _ l t r) = ni l ++ ni t ++ ni r

1924− ni (PAlternative a as) = concatMap (ni) as

1925− ni (PHidden tm) = ni tm

1926− ni (PUnifyLog tm) = ni tm

1927− ni (PDisamb _ tm) = ni tm

1928− ni (PNoImplicits tm) = ni tm

1929− ni _ = []

1930−

1931− niTacImp (TacImp _ _ scr) = ni scr

1932− niTacImp _ = []

1924+ ni set (PApp _ f as) = niTms (ni set f) (map getTm as)

1925+ ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)

1926+ ni set (PCase _ c os) = niTms (ni set c) (map snd os)

1927+ ni set (PLam fc n ty sc) = S.insert n $ ni (ni set ty) sc

1928+ ni set (PLet fc n ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc

1929+ ni set (PPi p n ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p

1930+ ni set (PEq _ _ _ l r) = ni (ni set l) r

1931+ ni set (PRewrite _ l r _) = ni (ni set l) r

1932+ ni set (PTyped l r) = ni (ni set l) r

1933+ ni set (PPair _ _ l r) = ni (ni set l) r

1934+ ni set (PDPair _ _ (PRef _ n) t r) = ni (ni set t) r

1935+ ni set (PDPair _ _ l t r) = ni (ni (ni set l) t) r

1936+ ni set (PAlternative a as) = niTms set as

1937+ ni set (PHidden tm) = ni set tm

1938+ ni set (PUnifyLog tm) = ni set tm

1939+ ni set (PDisamb _ tm) = ni set tm

1940+ ni set (PNoImplicits tm) = ni set tm

1941+ ni set _ = set

1942+

1943+ niTms set [] = set

1944+ niTms set (x : xs) = niTms (ni set x) xs

1945+

1946+ niTacImp set (TacImp _ _ scr) = ni set scr

1947+ niTacImp set _ = set

19331948

19341949-- Return names which are valid implicits in the given term (type).

19351950implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]

src/Idris/Apropos.hs+1−1

@@ -77,7 +77,7 @@ instance Apropos (TT Name) where

7777 isApropos str (P (DCon _ _ _) n ty) = isApropos str n || isApropos str ty

7878 isApropos str (P Bound _ ty) = isApropos str ty

7979 isApropos str (Bind n b tm) = isApropos str b || isApropos str tm

80− isApropos str (App t1 t2) = isApropos str t1 || isApropos str t2

80+ isApropos str (App _ t1 t2) = isApropos str t1 || isApropos str t2

8181 isApropos str (Constant const) = isApropos str const

8282 isApropos str _ = False

8383

src/Idris/CaseSplit.hs+2−2

@@ -10,13 +10,13 @@ module Idris.CaseSplit(splitOnLine, replaceSplits,

1010import Idris.AbsSyntax

1111import Idris.AbsSyntaxTree (Idris, IState, PTerm)

1212import Idris.ElabDecls

13−import Idris.ElabTerm

1413import Idris.Delaborate

1514import Idris.Parser

1615import Idris.Error

1716import Idris.Output

1817

1918import Idris.Elab.Value

19+import Idris.Elab.Term

2020

2121import Idris.Core.TT

2222import Idris.Core.Typecheck

@@ -69,7 +69,7 @@ split n t'

6969 let t = mergeUserImpl (addImplPat ist t') (delab ist tm)

7070 let ctxt = tt_ctxt ist

7171 case lookup n pats of

72− Nothing -> fail $ show n ++ " is not a pattern variable"

72+ Nothing -> ifail $ show n ++ " is not a pattern variable"

7373 Just ty ->

7474 do let splits = findPats ist ty

7575 iLOG ("New patterns " ++ showSep ", "

src/Idris/Chaser.hs+13−2

@@ -15,6 +15,7 @@ import Control.Monad.State

1515import Data.List

1616

1717import Debug.Trace

18+import Util.System (readSource, writeSource)

1819

1920data ModuleTree = MTree { mod_path :: IFileType,

2021 mod_needsRecheck :: Bool,

@@ -64,6 +65,16 @@ getModuleFiles ts = nub $ execState (modList ts) [] where

6465 then getSrc x : updateToSrc path xs

6566 else x : updateToSrc path xs

6667

68+-- Strip quotes and the backslash escapes that Haskeline adds

69+extractFileName :: String -> String

70+extractFileName ('"':xs) = takeWhile (/= '"') xs

71+extractFileName ('\'':xs) = takeWhile (/= '\'') xs

72+extractFileName x = build x []

73+ where

74+ build [] acc = reverse acc

75+ build ('\\':' ':xs) acc = build xs (' ':acc)

76+ build (x:xs) acc = build xs (x:acc)

77+

6778getIModTime (IBC i _) = getModificationTime i

6879getIModTime (IDR i) = getModificationTime i

6980getIModTime (LIDR i) = getModificationTime i

@@ -78,7 +89,7 @@ buildTree built fp = btree [] fp

7889 where

7990 btree done f =

8091 do i <- getIState

81− let file = takeWhile (/= ' ') f

92+ let file = extractFileName f

8293 iLOG $ "CHASING " ++ show file

8394 ibcsd <- valIBCSubDir i

8495 ids <- allImportDirs

@@ -133,7 +144,7 @@ buildTree built fp = btree [] fp

133144 children lit f done = -- idrisCatch

134145 do exist <- runIO $ doesFileExist f

135146 if exist then do

136− file_in <- runIO $ readFile f

147+ file_in <- runIO $ readSource f

137148 file <- if lit then tclift $ unlit f file_in else return file_in

138149 (_, _, modules, _) <- parseImports f file

139150 -- The chaser should never report warnings from sub-modules

src/Idris/Core/Binary.hs+48−14

@@ -3,10 +3,13 @@

33{-| Binary instances for the core datatypes -}

44module Idris.Core.Binary where

55

6+import Control.Applicative ((<*>), (<$>))

7+import Control.Monad (liftM2)

8+

69import Data.Binary

710import Data.Vector.Binary

811import qualified Data.Text as T

9−

12+import qualified Data.Text.Encoding as E

1013import Idris.Core.TT

1114

1215instance Binary ErrorReportPart where

@@ -43,6 +46,22 @@ instance Binary Provenance where

4346 return (TooManyArgs x1)

4447 _ -> error "Corrupted binary data for Provenance"

4548

49+instance Binary UConstraint where

50+ put (ULT x1 x2) = putWord8 0 >> put x1 >> put x2

51+ put (ULE x1 x2) = putWord8 1 >> put x1 >> put x2

52+ get = do i <- getWord8

53+ case i of

54+ 0 -> ULT <$> get <*> get

55+ 1 -> ULE <$> get <*> get

56+ _ -> error "Corrupted binary data for UConstraint"

57+

58+instance Binary ConstraintFC where

59+ put (ConstraintFC x1 x2) = putWord8 0 >> put x1 >> put x2

60+ get = do i <- getWord8

61+ case i of

62+ 0 -> liftM2 ConstraintFC get get

63+ _ -> error "Corrupted binary data for ConstraintFC"

64+

4665instance Binary a => Binary (Err' a) where

4766 put (Msg str) = do putWord8 0

4867 put str

@@ -97,7 +116,12 @@ instance Binary a => Binary (Err' a) where

97116 put ns

98117 put (IncompleteTerm t) = do putWord8 17

99118 put t

100− put UniverseError = putWord8 18

119+ put (UniverseError x1 x2 x3 x4 x5) = do putWord8 18

120+ put x1

121+ put x2

122+ put x3

123+ put x4

124+ put x5

101125 put (UniqueError u n) = do putWord8 19

102126 put u

103127 put n

@@ -142,16 +166,18 @@ instance Binary a => Binary (Err' a) where

142166 put t

143167 put (CantMatch t) = do putWord8 35

144168 put t

145− put (ElabDebug x1 x2 x3) = do putWord8 36

146− put x1

147− put x2

148− put x3

169+ put (ElabScriptDebug x1 x2 x3) = do putWord8 36

170+ put x1

171+ put x2

172+ put x3

149173 put (NoEliminator s t) = do putWord8 37

150174 put s

151175 put t

152176 put (InvalidTCArg n t) = do putWord8 38

153177 put n

154178 put t

179+ put (ElabScriptStuck x1) = do putWord8 39

180+ put x1

155181

156182 get = do i <- getWord8

157183 case i of

@@ -181,7 +207,7 @@ instance Binary a => Binary (Err' a) where

181207 15 -> fmap (CantResolve False) get

182208 16 -> fmap CantResolveAlts get

183209 17 -> fmap IncompleteTerm get

184− 18 -> return UniverseError

210+ 18 -> UniverseError <$> get <*> get <*> get <*> get <*> get

185211 19 -> do x <- get ; y <- get

186212 return $ UniqueError x y

187213 20 -> do x <- get ; y <- get

@@ -210,13 +236,15 @@ instance Binary a => Binary (Err' a) where

210236 36 -> do x1 <- get

211237 x2 <- get

212238 x3 <- get

213− return (ElabDebug x1 x2 x3)

239+ return (ElabScriptDebug x1 x2 x3)

214240 37 -> do x1 <- get

215241 x2 <- get

216242 return (NoEliminator x1 x2)

217243 38 -> do x1 <- get

218244 x2 <- get

219245 return (InvalidTCArg x1 x2)

246+ 39 -> do x1 <- get

247+ return (ElabScriptStuck x1)

220248 _ -> error "Corrupted binary data for Err'"

221249----- Generated by 'derive'

222250

@@ -267,9 +295,9 @@ instance Binary Name where

267295 _ -> error "Corrupted binary data for Name"

268296

269297instance Binary T.Text where

270− put x = put (str x)

298+ put x = put (E.encodeUtf8 x)

271299 get = do x <- get

272− return (txt x)

300+ return (E.decodeUtf8 x)

273301

274302instance Binary SpecialName where

275303 put x

@@ -292,6 +320,9 @@ instance Binary SpecialName where

292320 WithN x1 x2 -> do putWord8 7

293321 put x1

294322 put x2

323+ MetaN x1 x2 -> do putWord8 8

324+ put x1

325+ put x2

295326 get

296327 = do i <- getWord8

297328 case i of

@@ -316,6 +347,9 @@ instance Binary SpecialName where

316347 7 -> do x1 <- get

317348 x2 <- get

318349 return (WithN x1 x2)

350+ 8 -> do x1 <- get

351+ x2 <- get

352+ return (MetaN x1 x2)

319353 _ -> error "Corrupted binary data for SpecialName"

320354

321355

@@ -555,9 +589,9 @@ instance {- (Binary n) => -} Binary (TT Name) where

555589 put x1

556590 put x2

557591 put x3

558− App x1 x2 -> do putWord8 3

559− put x1

560− put x2

592+ App _ x1 x2 -> do putWord8 3

593+ put x1

594+ put x2

561595 Constant x1 -> do putWord8 4

562596 put x1

563597 Proj x1 x2 -> do putWord8 5

@@ -584,7 +618,7 @@ instance {- (Binary n) => -} Binary (TT Name) where

584618 return (Bind x1 x2 x3)

585619 3 -> do x1 <- get

586620 x2 <- get

587− return (App x1 x2)

621+ return (App Complete x1 x2)

588622 4 -> do x1 <- get

589623 return (Constant x1)

590624 5 -> do x1 <- get

src/Idris/Core/CaseTree.hs+13−14

@@ -130,16 +130,15 @@ namesUsed sc = nub $ nu' [] sc where

130130

131131 nut ps (P _ n _) | n `elem` ps = []

132132 | otherwise = [n]

133− nut ps (App f a) = nut ps f ++ nut ps a

133+ nut ps (App _ f a) = nut ps f ++ nut ps a

134134 nut ps (Proj t _) = nut ps t

135135 nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc

136136 nut ps (Bind n b sc) = nut (n:ps) sc

137137 nut ps _ = []

138138

139−-- Return all called functions, and which arguments are used in each argument position

140−-- for the call, in order to help reduce compilation time, and trace all unused

141−-- arguments

142−

139+-- | Return all called functions, and which arguments are used

140+-- in each argument position for the call, in order to help reduce

141+-- compilation time, and trace all unused arguments

143142findCalls :: SC -> [Name] -> [(Name, [[Name]])]

144143findCalls sc topargs = nub $ nu' topargs sc where

145144 nu' ps (Case _ n alts) = nub (concatMap (nua (n : ps)) alts)

@@ -155,7 +154,7 @@ findCalls sc topargs = nub $ nu' topargs sc where

155154

156155 nut ps (P Ref n _) | n `elem` ps = []

157156 | otherwise = [(n, [])] -- tmp

158− nut ps fn@(App f a)

157+ nut ps fn@(App _ f a)

159158 | (P Ref n _, args) <- unApply fn

160159 = if n `elem` ps then nut ps f ++ nut ps a

161160 else [(n, map argNames args)] ++ concatMap (nut ps) args

@@ -176,8 +175,8 @@ directUse (P _ n _) = [n]

176175directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

177176 ++ directUse t

178177directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

179−directUse fn@(App f a)

180− | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

178+directUse fn@(App _ f a)

179+ | (P Ref (UN pfk) _, [App _ e w]) <- unApply fn,

181180 pfk == txt "prim_fork"

182181 = directUse e ++ directUse w -- HACK so that fork works

183182 | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,

@@ -210,8 +209,8 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

210209isUsed :: SC -> Name -> Bool

211210isUsed sc n = used sc where

212211

213− used (Case _ n' alts) = n == n' || or (map usedA alts)

214− used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)

212+ used (Case _ n' alts) = n == n' || any usedA alts

213+ used (ProjCase t alts) = n `elem` freeNames t || any usedA alts

215214 used (STerm t) = n `elem` freeNames t

216215 used _ = False

217216

@@ -337,7 +336,7 @@ data Pat = PCon Bool Name Int [Pat]

337336

338337toPats :: Bool -> Bool -> Term -> [Pat]

339338toPats reflect tc f = reverse (toPat reflect tc (getArgs f)) where

340− getArgs (App f a) = a : getArgs f

339+ getArgs (App _ f a) = a : getArgs f

341340 getArgs _ = []

342341

343342toPat :: Bool -> Bool -> [Term] -> [Pat]

@@ -362,7 +361,7 @@ toPat reflect tc = map $ toPat' []

362361 = PSuc $ toPat' [] p

363362

364363 toPat' [] (P Bound n ty) = PV n ty

365− toPat' args (App f a) = toPat' (a : args) f

364+ toPat' args (App _ f a) = toPat' (a : args) f

366365 toPat' [] (Constant x) | isTypeConst x = PTyPat

367366 | otherwise = PConst x

368367

@@ -639,7 +638,7 @@ depatt ns tm = dp [] tm

639638 dpa ms x (SucCase n sc) = SucCase n (dp ms sc)

640639 dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)

641640

642− applyMaps ms f@(App _ _)

641+ applyMaps ms f@(App _ _ _)

643642 | (P nt cn pty, args) <- unApply f

644643 = let args' = map (applyMaps ms) args in

645644 applyMap ms nt cn pty args'

@@ -652,7 +651,7 @@ depatt ns tm = dp [] tm

652651 same n (P _ n' _) = n == n'

653652 same _ _ = False

654653

655− applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a)

654+ applyMaps ms (App s f a) = App s (applyMaps ms f) (applyMaps ms a)

656655 applyMaps ms t = t

657656

658657-- FIXME: Do this for SucCase too

src/Idris/Core/Constraints.hs+8−7

@@ -145,18 +145,19 @@ solve maxUniverseLevel ucs =

145145 domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)

146146 domainOf (UVal val) = return (Domain val val)

147147

148+ asPair :: Domain -> (Int, Int)

149+ asPair (Domain x y) = (x, y)

150+

148151 updateUpperBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()

149152 updateUpperBoundOf suspect (UVar var) upper = do

150153 doms <- gets domainStore

151154 let (oldDom@(Domain lower _), suspects) = doms M.! Var var

152155 let newDom = Domain lower upper

153− when (wipeOut newDom) $ lift $ Error $ At (ufc suspect) $ Msg $ unlines

154− $ "Universe inconsistency."

155− : ("Working on: " ++ show (UVar var))

156− : ("Old domain: " ++ show oldDom)

157− : ("New domain: " ++ show newDom)

158− : "Involved constraints: "

159− : map (("\t"++) . show) (suspect : S.toList suspects)

156+ when (wipeOut newDom) $

157+ lift $ Error $

158+ UniverseError (ufc suspect) (UVar var)

159+ (asPair oldDom) (asPair newDom)

160+ (suspect : S.toList suspects)

160161 modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }

161162 addToQueueRHS (uconstraint suspect) (Var var)

162163 updateUpperBoundOf _ UVal{} _ = return ()

src/Idris/Core/DeepSeq.hs+12−3

@@ -25,6 +25,7 @@ instance NFData SpecialName where

2525 rnf (CaseN x1) = rnf x1 `seq` ()

2626 rnf (ElimN x1) = rnf x1 `seq` ()

2727 rnf (InstanceCtorN x1) = rnf x1 `seq` ()

28+ rnf (MetaN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

2829

2930instance NFData Universe where

3031 rnf NullType = ()

@@ -50,6 +51,13 @@ instance NFData Provenance where

5051 rnf (SourceTerm x1) = rnf x1 `seq` ()

5152 rnf (TooManyArgs x1) = rnf x1 `seq` ()

5253

54+instance NFData UConstraint where

55+ rnf (ULT x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

56+ rnf (ULE x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

57+

58+instance NFData ConstraintFC where

59+ rnf (ConstraintFC x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

60+

5361instance NFData Err where

5462 rnf (Msg x1) = rnf x1 `seq` ()

5563 rnf (InternalMsg x1) = rnf x1 `seq` ()

@@ -85,7 +93,7 @@ instance NFData Err where

8593 rnf (CantResolveAlts x1) = rnf x1 `seq` ()

8694 rnf (IncompleteTerm x1) = rnf x1 `seq` ()

8795 rnf (NoEliminator x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

88− rnf UniverseError = ()

96+ rnf (UniverseError x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

8997 rnf ProgramLineComment = ()

9098 rnf (Inaccessible x1) = rnf x1 `seq` ()

9199 rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

@@ -97,7 +105,8 @@ instance NFData Err where

97105 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

98106 rnf (ProviderError x1) = rnf x1 `seq` ()

99107 rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

100− rnf (ElabDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

108+ rnf (ElabScriptDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

109+ rnf (ElabScriptStuck x1) = rnf x1 `seq` ()

101110

102111instance NFData ImplicitInfo where

103112 rnf (Impl x1) = rnf x1 `seq` ()

@@ -160,7 +169,7 @@ instance (NFData n) => NFData (TT n) where

160169 rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

161170 rnf (V x1) = rnf x1 `seq` ()

162171 rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

163− rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

172+ rnf (App x1 x2 x3) = rnf x2 `seq` rnf x3 `seq` ()

164173 rnf (Constant x1) = rnf x1 `seq` ()

165174 rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

166175 rnf Erased = ()

src/Idris/Core/Elaborate.hs+19−10

@@ -115,13 +115,13 @@ runElab a e ps = runStateT e (ES (ps, a) "" Nothing)

115115execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux)

116116execElab a e ps = execStateT e (ES (ps, a) "" Nothing)

117117

118−initElaborator :: Name -> Context -> Type -> ProofState

118+initElaborator :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

119119initElaborator = newProof

120120

121−elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

122−elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

123− (a, ES ps' str _) <- runElab d elab ps

124− return $! (a, str)

121+elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

122+elaborate ctxt datatypes n ty d elab = do let ps = initElaborator n ctxt datatypes ty

123+ (a, ES ps' str _) <- runElab d elab ps

124+ return $! (a, str)

125125

126126-- | Modify the auxiliary state

127127updateAux :: (aux -> aux) -> Elab' aux ()

@@ -178,6 +178,14 @@ set_context :: Context -> Elab' aux ()

178178set_context ctxt = do ES (p, a) logs prev <- get

179179 put (ES (p { context = ctxt }, a) logs prev)

180180

181+get_datatypes :: Elab' aux (Ctxt TypeInfo)

182+get_datatypes = do ES p _ _ <- get

183+ return $! (datatypes (fst p))

184+

185+set_datatypes :: Ctxt TypeInfo -> Elab' aux ()

186+set_datatypes ds = do ES (p, a) logs prev <- get

187+ put (ES (p { datatypes = ds }, a) logs prev)

188+

181189-- | get the proof term

182190get_term :: Elab' aux Term

183191get_term = do ES p _ _ <- get

@@ -258,7 +266,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

258266 else lift $ tfail (NotInjective tm l r)

259267 where isInj ctxt (P _ n _)

260268 | isConName n ctxt = True

261− isInj ctxt (App f a) = isInj ctxt f

269+ isInj ctxt (App _ f a) = isInj ctxt f

262270 isInj ctxt (Constant _) = True

263271 isInj ctxt (TType _) = True

264272 isInj ctxt (Bind _ (Pi _ _ _) sc) = True

@@ -431,7 +439,7 @@ dotterm = do ES (p, a) s m <- get

431439 where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v)

432440 foB (Let t v) = union (findOuter h env t) (findOuter h env v)

433441 foB b = findOuter h env (binderTy b)

434− findOuter h env (App f a)

442+ findOuter h env (App _ f a)

435443 = union (findOuter h env f) (findOuter h env a)

436444 findOuter h env _ = []

437445

@@ -541,7 +549,7 @@ prepare_apply fn imps =

541549 | n `elem` hs = let n' = uniqueName n hs in

542550 Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc)

543551 | otherwise = Bind n (fmap (rebind hs) t) (rebind (n:hs) sc)

544− rebind hs (App f a) = App (rebind hs f) (rebind hs a)

552+ rebind hs (App s f a) = App s (rebind hs f) (rebind hs a)

545553 rebind hs t = t

546554

547555apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]

@@ -759,6 +767,7 @@ try' t1 t2 proofSearch

759767 = do s <- get

760768 ps <- get_probs

761769 ulog <- getUnifyLog

770+ ivs <- get_instances

762771 case prunStateT 999999 False ps t1 s of

763772 OK ((v, _, _), s') -> do put s'

764773 return $! v

@@ -779,7 +788,7 @@ try' t1 t2 proofSearch

779788 recoverableErr (ProofSearchFail _) = False

780789 recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

781790 recoverableErr (At _ e) = recoverableErr e

782− recoverableErr (ElabDebug _ _ _) = False

791+ recoverableErr (ElabScriptDebug _ _ _) = False

783792 recoverableErr _ = True

784793

785794tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a

@@ -863,7 +872,7 @@ debugElaborator msg = do ps <- fmap proof get

863872 hs <- get_holes

864873 holeInfo <- mapM getHoleInfo hs

865874 loadState

866− lift . Error $ ElabDebug msg (getProofTerm (pterm ps)) holeInfo

875+ lift . Error $ ElabScriptDebug msg (getProofTerm (pterm ps)) holeInfo

867876 where getHoleInfo :: Name -> Elab' aux (Name, Type, [(Name, Binder Type)])

868877 getHoleInfo h = do focus h

869878 g <- goal

src/Idris/Core/Evaluate.hs+25−23

@@ -74,12 +74,12 @@ instance Show (a -> b) where

7474-- | Normalise fully type checked terms (so, assume all names/let bindings resolved)

7575normaliseC :: Context -> Env -> TT Name -> TT Name

7676normaliseC ctxt env t

77− = evalState (do val <- eval False ctxt [] env t []

77+ = evalState (do val <- eval False ctxt [] (map finalEntry env) t []

7878 quote 0 val) initEval

7979

8080normaliseAll :: Context -> Env -> TT Name -> TT Name

8181normaliseAll ctxt env t

82− = evalState (do val <- eval False ctxt [] env t [AtREPL]

82+ = evalState (do val <- eval False ctxt [] (map finalEntry env) t [AtREPL]

8383 quote 0 val) initEval

8484

8585normalise :: Context -> Env -> TT Name -> TT Name

@@ -285,7 +285,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

285285 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

286286 -- block reduction immediately under codata (and not forced)

287287 ev ntimes stk top env

288− (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)

288+ (App _ (App _ (App _ d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)

289289 | dly == txt "Delay" && lco == txt "LazyCodata" && not (simpl || atRepl)

290290 = do let (f, _) = unApply arg

291291 let ntimes' = case f of

@@ -299,11 +299,11 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

299299 when spec $ setBlock False

300300 evApply ntimes' stk top env [l',t',arg'] d'

301301 -- Treat "assert_total" specially, as long as it's defined!

302− ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

302+ ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)

303303 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

304304 at == txt "assert_total" && not simpl

305305 = ev ntimes (n : stk) top env arg

306− ev ntimes stk top env (App f a)

306+ ev ntimes stk top env (App _ f a)

307307 = do f' <- ev ntimes stk False env f

308308 a' <- ev ntimes stk False env a

309309 evApply ntimes stk top env [a'] f'

@@ -434,7 +434,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

434434 Just (altmap, sc) -> evTree ntimes stk top env altmap sc

435435 _ -> return Nothing

436436

437− conHeaded tm@(App _ _)

437+ conHeaded tm@(App _ _ _)

438438 | (P (DCon _ _ _) _ _, args) <- unApply tm = True

439439 conHeaded t = False

440440

@@ -540,7 +540,7 @@ instance Quote Value where

540540 v' <- quote i v

541541 let sc'' = pToV (sMN vd "vlet") (addBinder sc')

542542 return (Bind n (Let t' v') sc'')

543− quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

543+ quote i (VApp f a) = liftM2 (App MaybeHoles) (quote i f) (quote i a)

544544 quote i (VType u) = return $ TType u

545545 quote i (VUType u) = return $ UType u

546546 quote i VErased = return $ Erased

@@ -576,13 +576,13 @@ convEq ctxt holes topx topy = ceq [] topx topy where

576576 | x `elem` holes || y `elem` holes = return True

577577 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

578578 | otherwise = sameDefs ps x y

579− ceq ps x (Bind n (Lam t) (App y (V 0)))

579+ ceq ps x (Bind n (Lam t) (App _ y (V 0)))

580580 = ceq ps x (substV (P Bound n t) y)

581− ceq ps (Bind n (Lam t) (App x (V 0))) y

581+ ceq ps (Bind n (Lam t) (App _ x (V 0))) y

582582 = ceq ps (substV (P Bound n t) x) y

583− ceq ps x (Bind n (Lam t) (App y (P Bound n' _)))

583+ ceq ps x (Bind n (Lam t) (App _ y (P Bound n' _)))

584584 | n == n' = ceq ps x y

585− ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

585+ ceq ps (Bind n (Lam t) (App _ x (P Bound n' _))) y

586586 | n == n' = ceq ps x y

587587

588588 ceq ps (Bind n (PVar t) sc) y = ceq ps sc y

@@ -604,7 +604,7 @@ convEq ctxt holes topx topy = ceq [] topx topy where

604604 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

605605 ceqB ps (Pi i v t) (Pi i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

606606 ceqB ps b b' = ceq ps (binderTy b) (binderTy b')

607− ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay)

607+ ceq ps (App _ fx ax) (App _ fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay)

608608 ceq ps (Constant x) (Constant y) = return (x == y)

609609 ceq ps (TType x) (TType y) = do (v, cs) <- get

610610 put (v, ULE x y : cs)

@@ -887,11 +887,13 @@ addCasedef n ei ci@(CaseInfo inline alwaysInline tcdict)

887887 cdef = CaseDefs (args_tot, sc_tot)

888888 (args_ct, sc_ct)

889889 (args_inl, sc_inl)

890− (args_rt, sc_rt) in

891− addDef n (CaseOp (ci { case_inlinable = inlc })

892− ty argtys ps_in ps_tot cdef,

893− access, Unchecked, EmptyMI) ctxt in

894− uctxt { definitions = ctxt' }

890+ (args_rt, sc_rt)

891+ op = (CaseOp (ci { case_inlinable = inlc })

892+ ty argtys ps_in ps_tot cdef,

893+ access, Unchecked, EmptyMI)

894+ in addDef n op ctxt

895+ other -> error ("Error adding case def: " ++ show other)

896+ in uctxt { definitions = ctxt' }

895897

896898-- simplify a definition for totality checking

897899simplifyCasedef :: Name -> ErasureInfo -> Context -> Context

@@ -1009,12 +1011,12 @@ lookupP = lookupP_all False

10091011

10101012lookupP_all :: Bool -> Name -> Context -> [Term]

10111013lookupP_all all n ctxt

1012− = do def <- lookupCtxt n (definitions ctxt)

1014+ = do (n', def) <- lookupCtxtName n (definitions ctxt)

10131015 p <- case def of

1014− (Function ty tm, a, _, _) -> return (P Ref n ty, a)

1015− (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)

1016− (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a)

1017− (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)

1016+ (Function ty tm, a, _, _) -> return (P Ref n' ty, a)

1017+ (TyDecl nt ty, a, _, _) -> return (P nt n' ty, a)

1018+ (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n' ty, a)

1019+ (Operator ty _ _, a, _, _) -> return (P Ref n' ty, a)

10181020 case snd p of

10191021 Hidden -> if all then return (fst p) else []

10201022 _ -> return (fst p)

@@ -1083,5 +1085,5 @@ uniqueBindersCtxt :: Context -> [Name] -> TT Name -> TT Name

10831085uniqueBindersCtxt ctxt ns (Bind n b sc)

10841086 = let n' = uniqueNameCtxt ctxt n ns in

10851087 Bind n' (fmap (uniqueBindersCtxt ctxt (n':ns)) b) (uniqueBindersCtxt ctxt ns sc)

1086−uniqueBindersCtxt ctxt ns (App f a) = App (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a)

1088+uniqueBindersCtxt ctxt ns (App s f a) = App s (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a)

10871089uniqueBindersCtxt ctxt ns t = t

src/Idris/Core/Execute.hs+2−2

@@ -103,7 +103,7 @@ toTT (EBind n b body) = do n' <- newN n

103103 return n'

104104toTT (EApp e1 e2) = do e1' <- toTT e1

105105 e2' <- toTT e2

106− return $ App e1' e2'

106+ return $ App Complete e1' e2'

107107toTT (EType u) = return $ TType u

108108toTT (EUType u) = return $ UType u

109109toTT EErased = return Erased

@@ -192,7 +192,7 @@ doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

192192doExec env ctxt tm@(Bind n b body) = do b' <- forM b (doExec env ctxt)

193193 return $

194194 EBind n b' (\arg -> doExec ((n, arg):env) ctxt body)

195−doExec env ctxt a@(App _ _) =

195+doExec env ctxt a@(App _ _ _) =

196196 do let (f, args) = unApply a

197197 f' <- doExec env ctxt f

198198 args' <- case f' of

src/Idris/Core/ProofState.hs+44−19

@@ -41,6 +41,7 @@ data ProofState = PS { thname :: Name,

4141 autos :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes

4242 previous :: Maybe ProofState, -- ^ for undo

4343 context :: Context,

44+ datatypes :: Ctxt TypeInfo,

4445 plog :: String,

4546 unifylog :: Bool,

4647 done :: Bool,

@@ -292,14 +293,15 @@ query q = do ps <- get

292293addLog :: Monad m => String -> StateT TState m ()

293294addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

294295

295−newProof :: Name -> Context -> Type -> ProofState

296−newProof n ctxt ty = let h = holeName 0

297− ty' = vToP ty

298− in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

299− (P Bound h ty'))) ty [] (h, []) [] []

300− Nothing [] []

301− [] [] []

302− Nothing ctxt "" False False [] []

296+newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

297+newProof n ctxt datatypes ty =

298+ let h = holeName 0

299+ ty' = vToP ty

300+ in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

301+ (P Bound h ty'))) ty [] (h, []) [] []

302+ Nothing [] []

303+ [] [] []

304+ Nothing ctxt datatypes "" False False [] []

303305

304306type TState = ProofState -- [TacticAction])

305307type RunTactic = RunTactic' TState

@@ -328,7 +330,7 @@ computeLet ctxt n tm = cl [] tm where

328330 | n' == n = let v' = normalise ctxt env v in

329331 Bind n' (Let t v') sc

330332 cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, b):env) sc)

331− cl env (App f a) = App (cl env f) (cl env a)

333+ cl env (App s f a) = App s (cl env f) (cl env a)

332334 cl env t = t

333335

334336attack :: RunTactic

@@ -551,13 +553,36 @@ solve ctxt env (Bind x (Guess ty val) sc)

551553 recents = x : recents ps,

552554 instances = instances ps \\ [x],

553555 dotted = dropUnified dropdots (dotted ps) })

554− let tm' = subst x val sc in

555− return tm'

556+ let (locked, did) = tryLock (holes ps \\ [x]) (updsubst x val sc) in

557+ return locked

556558 where dropUnified ddots [] = []

557559 dropUnified ddots ((x, es) : ds)

558560 | x `elem` ddots || any (\e -> e `elem` ddots) es

559561 = dropUnified ddots ds

560562 | otherwise = (x, es) : dropUnified ddots ds

563+

564+ tryLock :: [Name] -> Term -> (Term, Bool)

565+ tryLock hs tm@(App Complete _ _) = (tm, True)

566+ tryLock hs tm@(App s f a) =

567+ let (f', fl) = tryLock hs f

568+ (a', al) = tryLock hs a in

569+ if fl && al then (App Complete f' a', True)

570+ else (App s f' a', False)

571+ tryLock hs t@(P _ n _) = (t, not $ n `elem` hs)

572+ tryLock hs t@(Bind n (Hole _) sc) = (t, False)

573+ tryLock hs t@(Bind n (Guess _ _) sc) = (t, False)

574+ tryLock hs t@(Bind n (Let ty val) sc)

575+ = let (ty', tyl) = tryLock hs ty

576+ (val', vall) = tryLock hs val

577+ (sc', scl) = tryLock hs sc in

578+ (Bind n (Let ty' val') sc', tyl && vall && scl)

579+ tryLock hs t@(Bind n b sc)

580+ = let (bt', btl) = tryLock hs (binderTy b)

581+ (val', vall) = tryLock hs val

582+ (sc', scl) = tryLock hs sc in

583+ (Bind n (b { binderTy = bt' }) sc', btl && scl)

584+ tryLock hs t = (t, True)

585+

561586solve _ _ h@(Bind x t sc)

562587 = do ps <- get

563588 case findType x sc of

@@ -581,7 +606,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

581606 (tyv, tyt) <- lift $ check ctxt env ty

582607-- ns <- lift $ unify ctxt env tyv t'

583608 case t' of

584− Bind y (Pi _ s _) t -> let t' = subst y (P Bound n s) t in

609+ Bind y (Pi _ s _) t -> let t' = updsubst y (P Bound n s) t in

585610 do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)

586611 ps <- get

587612 let (uh, uns) = unified ps

@@ -600,7 +625,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

600625 _ -> hnf ctxt env t

601626 case t' of

602627 Bind y (Pi _ s _) t -> -- trace ("in type " ++ show t') $

603− let t' = subst y (P Bound n s) t in

628+ let t' = updsubst y (P Bound n s) t in

604629 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

605630 _ -> lift $ tfail $ CantIntroduce t'

606631intro n ctxt env _ = fail "Can't introduce here."

@@ -623,7 +648,7 @@ patvar n ctxt env (Bind x (Hole t) sc) =

623648 (notunified ps),

624649 injective = addInj n x (injective ps)

625650 })

626− return $ Bind n (PVar t) (subst x (P Bound n t) sc)

651+ return $ Bind n (PVar t) (updsubst x (P Bound n t) sc)

627652 where addInj n x ps | x `elem` ps = n : ps

628653 | otherwise = ps

629654patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

@@ -638,7 +663,7 @@ letbind n ty val ctxt env _ = fail "Can't let bind here"

638663

639664expandLet :: Name -> Term -> RunTactic

640665expandLet n v ctxt env tm =

641− return $ subst n v tm

666+ return $ updsubst n v tm

642667

643668rewrite :: Raw -> RunTactic

644669rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

@@ -661,9 +686,9 @@ rewrite _ _ _ _ = fail "Can't rewrite here"

661686-- an x, and put \x : lt in front

662687mkP :: TT Name -> TT Name -> TT Name -> TT Name -> TT Name

663688mkP lt l r ty | l == ty = lt

664−mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f

665− a' = if (r /= a) then mkP lt l r a else a in

666− App f' a'

689+mkP lt l r (App s f a) = let f' = if (r /= f) then mkP lt l r f else f

690+ a' = if (r /= a) then mkP lt l r a else a in

691+ App s f' a'

667692mkP lt l r (Bind n b sc)

668693 = let b' = mkPB b

669694 sc' = if (r /= sc) then mkP lt l r sc else sc in

@@ -750,7 +775,7 @@ patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

750775 x@(Bind y (PVTy s) t) -> x

751776 _ -> hnf ctxt env t

752777 case t' of

753− Bind y (PVTy s) t -> let t' = subst y (P Bound n s) t in

778+ Bind y (PVTy s) t -> let t' = updsubst y (P Bound n s) t in

754779 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

755780 _ -> fail "Nothing to pattern bind"

756781patbind n ctxt env _ = fail "Can't pattern bind here"

src/Idris/Core/ProofTerm.hs+69−21

@@ -7,7 +7,7 @@ evaluation/checking inside the proof system, etc.

77

88module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,

99 updateSolved, updateSolvedTerm, updateSolvedTerm',

10− bound_in, bound_in_term, refocus,

10+ bound_in, bound_in_term, refocus, updsubst,

1111 Hole, RunTactic',

1212 goal, atHole) where

1313

@@ -21,8 +21,8 @@ import Debug.Trace

2121

2222-- | A zipper over terms, in order to efficiently update proof terms.

2323data TermPath = Top

24− | AppL TermPath Term

25− | AppR Term TermPath

24+ | AppL (AppStatus Name) TermPath Term

25+ | AppR (AppStatus Name) Term TermPath

2626 | InBind Name BinderPath Term

2727 | InScope Name (Binder Term) TermPath

2828 deriving Show

@@ -39,8 +39,8 @@ data BinderPath = Binder (Binder TermPath)

3939-- words, "graft" one term path into another.

4040replaceTop :: TermPath -> TermPath -> TermPath

4141replaceTop p Top = p

42−replaceTop p (AppL l t) = AppL (replaceTop p l) t

43−replaceTop p (AppR t r) = AppR t (replaceTop p r)

42+replaceTop p (AppL s l t) = AppL s (replaceTop p l) t

43+replaceTop p (AppR s t r) = AppR s t (replaceTop p r)

4444replaceTop p (InBind n bp sc) = InBind n (replaceTopB p bp) sc

4545 where

4646 replaceTopB p (Binder b) = Binder (fmap (replaceTop p) b)

@@ -53,8 +53,8 @@ replaceTop p (InScope n b sc) = InScope n b (replaceTop p sc)

5353-- | Build a term from a zipper, given something to put in the hole.

5454rebuildTerm :: Term -> TermPath -> Term

5555rebuildTerm tm Top = tm

56−rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a

57−rebuildTerm tm (AppR f p) = App f (rebuildTerm tm p)

56+rebuildTerm tm (AppL s p a) = App s (rebuildTerm tm p) a

57+rebuildTerm tm (AppR s f p) = App s f (rebuildTerm tm p)

5858rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p)

5959rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc

6060

@@ -73,9 +73,10 @@ findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term)

7373findHole n env t = fh' env Top t where

7474 fh' env path tm@(Bind x h sc)

7575 | hole h && n == x = Just (path, env, tm)

76− fh' env path (App f a)

77− | Just (p, env', tm) <- fh' env path a = Just (AppR f p, env', tm)

78− | Just (p, env', tm) <- fh' env path f = Just (AppL p a, env', tm)

76+ fh' env path (App Complete _ _) = Nothing

77+ fh' env path (App s f a)

78+ | Just (p, env', tm) <- fh' env path a = Just (AppR s f p, env', tm)

79+ | Just (p, env', tm) <- fh' env path f = Just (AppL s p a, env', tm)

7980 fh' env path (Bind x b sc)

8081 | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)

8182 | Just (p, env', tm) <- fh' ((x,b):env) path sc = Just (InScope x b p, env', tm)

@@ -112,7 +113,7 @@ refocus' (Just n) pt@(PT path env tm ups)

112113 -- First look for the hole in the proof term as-is

113114 | Just (p', env', tm') <- findHole n env tm

114115 = PT (replaceTop p' path) env' tm' ups

115− -- Next apply the updates, and look for the hole in the resulting term

116+ -- If it's not there, rebuild and look from the top

116117 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))

117118 = PT p' env' tm' []

118119 | otherwise = pt

@@ -156,19 +157,20 @@ updateSolvedTerm' xs x = updateSolved' xs x where

156157 updateSolved' xs (Bind n (Hole ty) t)

157158 | Just v <- lookup n xs

158159 = case xs of

159− [_] -> (subst n v t, True) -- some may be Vs! Can't assume

160+ [_] -> (updsubst n v t, True) -- some may be Vs! Can't assume

160161 -- explicit names

161162 _ -> let (t', _) = updateSolved' xs t in

162− (subst n v t', True)

163+ (updsubst n v t', True)

163164 updateSolved' xs tm@(Bind n b t)

164165 | otherwise = let (t', ut) = updateSolved' xs t

165166 (b', ub) = updateSolvedB' xs b in

166167 if ut || ub then (Bind n b' t', True)

167168 else (tm, False)

168− updateSolved' xs t@(App f a)

169+ updateSolved' xs t@(App Complete f a) = (t, False)

170+ updateSolved' xs t@(App s f a)

169171 = let (f', uf) = updateSolved' xs f

170172 (a', ua) = updateSolved' xs a in

171− if uf || ua then (App f' a', True)

173+ if uf || ua then (App s f' a', True)

172174 else (t, False)

173175 updateSolved' xs t@(P _ n@(MN _ _) _)

174176 | Just v <- lookup n xs = (v, True)

@@ -189,7 +191,7 @@ updateSolvedTerm' xs x = updateSolved' xs x where

189191 if u then (b { binderTy = ty' }, u) else (b, False)

190192

191193 noneOf ns (P _ n _) | n `elem` ns = False

192− noneOf ns (App f a) = noneOf ns a && noneOf ns f

194+ noneOf ns (App s f a) = noneOf ns a && noneOf ns f

193195 noneOf ns (Bind n (Hole ty) t) = n `notElem` ns && noneOf ns ty && noneOf ns t

194196 noneOf ns (Bind n b t) = noneOf ns t && noneOfB ns b

195197 where

@@ -198,6 +200,49 @@ updateSolvedTerm' xs x = updateSolved' xs x where

198200 noneOfB ns b = noneOf ns (binderTy b)

199201 noneOf ns _ = True

200202

203+-- | As 'subst', in TT, but takes advantage of knowing not to substitute

204+-- under Complete applications.

205+updsubst :: Eq n => n {-^ The id to replace -} ->

206+ TT n {-^ The replacement term -} ->

207+ TT n {-^ The term to replace in -} ->

208+ TT n

209+-- subst n v tm = instantiate v (pToV n tm)

210+updsubst n v tm = fst $ subst' 0 tm

211+ where

212+ -- keep track of updates to save allocations - this is a big win on

213+ -- large terms in particular

214+ -- ('Maybe' would be neater here, but >>= is not the right combinator.

215+ -- Feel free to tidy up, as long as it still saves allocating when no

216+ -- substitution happens...)

217+ subst' i (V x) | i == x = (v, True)

218+ subst' i (P _ x _) | n == x = (v, True)

219+ subst' i t@(P nt x ty)

220+ = let (ty', ut) = subst' i ty in

221+ if ut then (P nt x ty', True) else (t, False)

222+ subst' i t@(Bind x b sc) | x /= n

223+ = let (b', ub) = substB' i b

224+ (sc', usc) = subst' (i+1) sc in

225+ if ub || usc then (Bind x b' sc', True) else (t, False)

226+ subst' i t@(App Complete f a) = (t, False)

227+ subst' i t@(App s f a) = let (f', uf) = subst' i f

228+ (a', ua) = subst' i a in

229+ if uf || ua then (App s f' a', True) else (t, False)

230+ subst' i t@(Proj x idx) = let (x', u) = subst' i x in

231+ if u then (Proj x' idx, u) else (t, False)

232+ subst' i t = (t, False)

233+

234+ substB' i b@(Let t v) = let (t', ut) = subst' i t

235+ (v', uv) = subst' i v in

236+ if ut || uv then (Let t' v', True)

237+ else (b, False)

238+ substB' i b@(Guess t v) = let (t', ut) = subst' i t

239+ (v', uv) = subst' i v in

240+ if ut || uv then (Guess t' v', True)

241+ else (b, False)

242+ substB' i b = let (ty', u) = subst' i (binderTy b) in

243+ if u then (b { binderTy = ty' }, u) else (b, False)

244+

245+

201246-- | Apply solutions to an environment.

202247updateEnv :: [(Name, Term)] -> Env -> Env

203248updateEnv [] e = e

@@ -208,8 +253,10 @@ updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns e

208253updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath

209254updateSolvedPath [] t = t

210255updateSolvedPath ns Top = Top

211−updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)

212−updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) (updateSolvedPath ns p)

256+updateSolvedPath ns t@(AppL Complete _ _) = t

257+updateSolvedPath ns t@(AppR Complete _ _) = t

258+updateSolvedPath ns (AppL s p r) = AppL s (updateSolvedPath ns p) (updateSolvedTerm ns r)

259+updateSolvedPath ns (AppR s l p) = AppR s (updateSolvedTerm ns l) (updateSolvedPath ns p)

213260updateSolvedPath ns (InBind n b sc)

214261 = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc)

215262 where

@@ -246,7 +293,8 @@ goal h pt@(PT path env sub ups)

246293 g env (Bind n b sc) | hole b && same h n = return $ GD env b

247294 | otherwise

248295 = g ((n, b):env) sc `mplus` gb env b

249− g env (App f a) = g env a `mplus` g env f

296+ g env (App Complete f a) = fail "Can't find hole"

297+ g env (App _ f a) = g env a `mplus` g env f

250298 g env t = fail "Can't find hole"

251299

252300 gb env (Let t v) = g env v `mplus` g env t

@@ -291,7 +339,7 @@ atHole h f c e pt -- @(PT path env sub)

291339 if u then return (Bind n b sc', True)

292340 else do (b', u) <- atHb f c env b

293341 return (Bind n b' sc', u)

294− atH tac c env (App f a) = ulift2 tac c env App f a

342+ atH tac c env (App s f a) = ulift2 tac c env (App s) f a

295343 atH tac c env t = return (t, False)

296344

297345 atHb f c env (Let t v) = ulift2 f c env Let t v

@@ -308,6 +356,6 @@ bound_in_term (Bind n b sc) = n : bi b ++ bound_in_term sc

308356 bi (Let t v) = bound_in_term t ++ bound_in_term v

309357 bi (Guess t v) = bound_in_term t ++ bound_in_term v

310358 bi b = bound_in_term (binderTy b)

311−bound_in_term (App f a) = bound_in_term f ++ bound_in_term a

359+bound_in_term (App _ f a) = bound_in_term f ++ bound_in_term a

312360bound_in_term _ = []

313361

src/Idris/Core/TT.hs+111−56

@@ -1,5 +1,5 @@

11{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable #-}

2−

2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

33{-| TT is the core language of Idris. The language has:

44

55 * Full dependent types

@@ -117,9 +117,6 @@ data ErrorReportPart = TextPart String

117117 deriving (Show, Eq, Data, Typeable)

118118

119119

120−-- Please remember to keep Err synchronised with

121−-- Language.Reflection.Errors.Err in the stdlib!

122−

123120data Provenance = ExpectedType

124121 | TooManyArgs Term

125122 | InferredVal

@@ -131,6 +128,10 @@ deriving instance NFData Err

131128deriving instance Binary Err

132129!-}

133130

131+

132+-- NB: Please remember to keep Err synchronised with

133+-- Language.Reflection.Errors.Err in the stdlib!

134+

134135-- | Idris errors. Used as exceptions in the compiler, but reported to users

135136-- if they reach the top level.

136137data Err' t

@@ -161,7 +162,8 @@ data Err' t

161162 | CantResolveAlts [Name]

162163 | IncompleteTerm t

163164 | NoEliminator String t

164− | UniverseError

165+ | UniverseError FC UExp (Int, Int) (Int, Int) [ConstraintFC]

166+ -- ^ Location, bad universe, old domain, new domain, suspects

165167 | UniqueError Universe Name

166168 | UniqueKindError Universe Name

167169 | ProgramLineComment

@@ -178,8 +180,9 @@ data Err' t

178180 | LoadingFailed String (Err' t)

179181 | ReflectionError [[ErrorReportPart]] (Err' t)

180182 | ReflectionFailed String (Err' t)

181− | ElabDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]

183+ | ElabScriptDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]

182184 -- ^ User-specified message, proof term, goals with context (first goal is focused)

185+ | ElabScriptStuck t

183186 deriving (Eq, Functor, Data, Typeable)

184187

185188type Err = Err' Term

@@ -238,7 +241,6 @@ instance Sized Err where

238241 size (NoRewriting trm) = size trm

239242 size (CantResolveAlts _) = 1

240243 size (IncompleteTerm trm) = size trm

241− size UniverseError = 1

242244 size ProgramLineComment = 1

243245 size (At fc err) = size fc + size err

244246 size (Elaborating _ n err) = size err

@@ -365,6 +367,7 @@ data SpecialName = WhereN Int Name Name

365367 | CaseN Name

366368 | ElimN Name

367369 | InstanceCtorN Name

370+ | MetaN Name Name

368371 deriving (Eq, Ord, Data, Typeable)

369372{-!

370373deriving instance Binary SpecialName

@@ -389,6 +392,9 @@ instance Pretty Name OutputAnnotation where

389392 pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

390393 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

391394 pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

395+ pretty n@(SymRef i) = annotate (AnnName n Nothing Nothing Nothing) $

396+ text $ "##symbol" ++ show i ++ "##"

397+ pretty NErased = annotate (AnnName NErased Nothing Nothing Nothing) $ text "_"

392398

393399instance Pretty [Name] OutputAnnotation where

394400 pretty = encloseSep empty empty comma . map pretty

@@ -399,6 +405,7 @@ instance Show Name where

399405 show (MN _ u) | u == txt "underscore" = "_"

400406 show (MN i s) = "{" ++ str s ++ show i ++ "}"

401407 show (SN s) = show s

408+ show (SymRef i) = "##symbol" ++ show i ++ "##"

402409 show NErased = "_"

403410

404411instance Show SpecialName where

@@ -410,6 +417,7 @@ instance Show SpecialName where

410417 show (CaseN n) = "case block in " ++ show n

411418 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

412419 show (InstanceCtorN n) = "constructor of " ++ show n

420+ show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>"

413421

414422-- Show a name in a way decorated for code generation, not human reading

415423showCG :: Name -> String

@@ -425,6 +433,9 @@ showCG (SN s) = showCG' s

425433 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

426434 showCG' (CaseN c) = showCG c ++ "_case"

427435 showCG' (ElimN sn) = showCG sn ++ "_elim"

436+ showCG' (InstanceCtorN n) = showCG n ++ "_ictor"

437+ showCG' (MetaN parent meta) = showCG parent ++ "_meta_" ++ showCG meta

438+showCG (SymRef i) = error "can't do codegen for a symbol reference"

428439showCG NErased = "_"

429440

430441

@@ -643,7 +654,7 @@ data Universe = NullType | UniqueType | AllTypes

643654instance Show Universe where

644655 show UniqueType = "UniqueType"

645656 show NullType = "NullType"

646− show AllTypes = "Type*"

657+ show AllTypes = "AnyType"

647658

648659data Raw = Var Name

649660 | RBind Name (Binder Raw) Raw

@@ -765,11 +776,11 @@ instance Show UExp where

765776-- | Universe constraints

766777data UConstraint = ULT UExp UExp -- ^ Strictly less than

767778 | ULE UExp UExp -- ^ Less than or equal to

768− deriving (Eq, Ord)

779+ deriving (Eq, Ord, Data, Typeable)

769780

770781data ConstraintFC = ConstraintFC { uconstraint :: UConstraint,

771782 ufc :: FC }

772− deriving Show

783+ deriving (Show, Data, Typeable)

773784

774785instance Eq ConstraintFC where

775786 x == y = uconstraint x == uconstraint y

@@ -806,6 +817,11 @@ instance Eq NameType where

806817 TCon _ a == TCon _ b = (a == b) -- ignore tag

807818 _ == _ = False

808819

820+data AppStatus n = Complete

821+ | MaybeHoles

822+ | Holes [n]

823+ deriving (Eq, Ord, Functor, Data, Typeable, Show)

824+

809825-- | Terms in the core language. The type parameter is the type of

810826-- identifiers used for bindings and explicit named references;

811827-- usually we use @TT 'Name'@.

@@ -814,7 +830,7 @@ data TT n = P NameType n (TT n) -- ^ named references with type

814830 -- Pure Type Systems Formalized)

815831 | V !Int -- ^ a resolved de Bruijn-indexed variable

816832 | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

817− | App !(TT n) (TT n) -- ^ function, function type, arg

833+ | App (AppStatus n) !(TT n) (TT n) -- ^ function, function type, arg

818834 | Constant Const -- ^ constant

819835 | Proj (TT n) !Int -- ^ argument projection; runtime only

820836 -- (-1) is a special case for 'subtract one from BI'

@@ -850,18 +866,24 @@ instance TermSize (TT Name) where

850866 termsize n (Bind n' b sc)

851867 = let rn = if n == n' then sMN 0 "noname" else n in

852868 termsize rn sc

853− termsize n (App f a) = termsize n f + termsize n a

869+ termsize n (App _ f a) = termsize n f + termsize n a

854870 termsize n (Proj t i) = termsize n t

855871 termsize n _ = 1

856872

873+instance Sized Universe where

874+ size u = 1

875+

857876instance Sized a => Sized (TT a) where

858877 size (P name n trm) = 1 + size name + size n + size trm

859878 size (V v) = 1

860879 size (Bind nm binder bdy) = 1 + size nm + size binder + size bdy

861− size (App l r) = 1 + size l + size r

880+ size (App _ l r) = 1 + size l + size r

862881 size (Constant c) = size c

863882 size Erased = 1

864883 size (TType u) = 1 + size u

884+ size (Proj a _) = 1 + size a

885+ size Impossible = 1

886+ size (UType u) = 1 + size u

865887

866888instance Pretty a o => Pretty (TT a) o where

867889 pretty _ = text "test"

@@ -875,12 +897,32 @@ data Datatype n = Data { d_typename :: n,

875897 d_cons :: [(n, TT n)] }

876898 deriving (Show, Functor, Eq)

877899

900+-- | Data declaration options

901+data DataOpt = Codata -- ^ Set if the the data-type is coinductive

902+ | DefaultEliminator -- ^ Set if an eliminator should be generated for data type

903+ | DefaultCaseFun -- ^ Set if a case function should be generated for data type

904+ | DataErrRev

905+ deriving (Show, Eq)

906+

907+type DataOpts = [DataOpt]

908+

909+data TypeInfo = TI { con_names :: [Name],

910+ codata :: Bool,

911+ data_opts :: DataOpts,

912+ param_pos :: [Int],

913+ mutual_types :: [Name] }

914+ deriving Show

915+{-!

916+deriving instance Binary TypeInfo

917+deriving instance NFData TypeInfo

918+!-}

919+

878920instance Eq n => Eq (TT n) where

879921 (==) (P xt x _) (P yt y _) = x == y

880922 (==) (V x) (V y) = x == y

881923 (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

882− (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

883− (==) (TType _) (TType _) = True -- deal with constraints later

924+ (==) (App _ fx ax) (App _ fy ay) = ax == ay && fx == fy

925+ (==) (TType _) (TType _) = True -- deal with constraints later

884926 (==) (Constant x) (Constant y) = x == y

885927 (==) (Proj x i) (Proj y j) = x == y && i == j

886928 (==) Erased _ = True

@@ -896,15 +938,15 @@ isInjective :: TT n -> Bool

896938isInjective (P (DCon _ _ _) _ _) = True

897939isInjective (P (TCon _ _) _ _) = True

898940isInjective (Constant _) = True

899−isInjective (TType x) = True

941+isInjective (TType x) = True

900942isInjective (Bind _ (Pi _ _ _) sc) = True

901−isInjective (App f a) = isInjective f

943+isInjective (App _ f a) = isInjective f

902944isInjective _ = False

903945

904946-- | Count the number of instances of a de Bruijn index in a term

905947vinstances :: Int -> TT n -> Int

906948vinstances i (V x) | i == x = 1

907−vinstances i (App f a) = vinstances i f + vinstances i a

949+vinstances i (App _ f a) = vinstances i f + vinstances i a

908950vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc

909951 where instancesB (Let t v) = vinstances i v

910952 instancesB _ = 0

@@ -916,7 +958,7 @@ instantiate e = subst 0 where

916958 subst i (P nt x ty) = P nt x (subst i ty)

917959 subst i (V x) | i == x = e

918960 subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc)

919− subst i (App f a) = App (subst i f) (subst i a)

961+ subst i (App s f a) = App s (subst i f) (subst i a)

920962 subst i (Proj x idx) = Proj (subst i x) idx

921963 subst i t = t

922964

@@ -925,11 +967,11 @@ instantiate e = subst 0 where

925967-- that has been substituted.

926968substV :: TT n -> TT n -> TT n

927969substV x tm = dropV 0 (instantiate x tm) where

928− subst i (P nt x ty) = P nt x (subst i ty)

970+ dropV i (P nt x ty) = P nt x (dropV i ty)

929971 dropV i (V x) | x > i = V (x - 1)

930972 | otherwise = V x

931973 dropV i (Bind x b sc) = Bind x (fmap (dropV i) b) (dropV (i+1) sc)

932− dropV i (App f a) = App (dropV i f) (dropV i a)

974+ dropV i (App s f a) = App s (dropV i f) (dropV i a)

933975 dropV i (Proj x idx) = Proj (dropV i x) idx

934976 dropV i t = t

935977

@@ -940,7 +982,7 @@ explicitNames (Bind x b sc) = let b' = fmap explicitNames b in

940982 Bind x b'

941983 (explicitNames (instantiate

942984 (P Bound x (binderTy b')) sc))

943−explicitNames (App f a) = App (explicitNames f) (explicitNames a)

985+explicitNames (App s f a) = App s (explicitNames f) (explicitNames a)

944986explicitNames (Proj x idx) = Proj (explicitNames x) idx

945987explicitNames t = t

946988

@@ -954,7 +996,7 @@ pToV' n i (Bind x b sc)

954996-- resolve names from the *outer* scope which may happen to have the same id.

955997 | n == x = Bind x (fmap (pToV' n i) b) sc

956998 | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc)

957−pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a)

999+pToV' n i (App s f a) = App s (pToV' n i f) (pToV' n i a)

9581000pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

9591001pToV' n i t = t

9601002

@@ -965,7 +1007,7 @@ addBinder t = ab 0 t

9651007 ab top (V i) | i >= top = V (i + 1)

9661008 | otherwise = V i

9671009 ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc)

968− ab top (App f a) = App (ab top f) (ab top a)

1010+ ab top (App s f a) = App s (ab top f) (ab top a)

9691011 ab top (Proj t idx) = Proj (ab top t) idx

9701012 ab top t = t

9711013

@@ -984,14 +1026,14 @@ vToP = vToP' [] where

9841026 P Bound n (binderTy b)

9851027 vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in

9861028 Bind n b' (vToP' ((n, b'):env) sc)

987− vToP' env (App f a) = App (vToP' env f) (vToP' env a)

1029+ vToP' env (App s f a) = App s (vToP' env f) (vToP' env a)

9881030 vToP' env t = t

9891031

9901032-- | Replace every non-free reference to the name of a binding in

9911033-- the given term with a de Bruijn index.

9921034finalise :: Eq n => TT n -> TT n

9931035finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc))

994−finalise (App f a) = App (finalise f) (finalise a)

1036+finalise (App s f a) = App s (finalise f) (finalise a)

9951037finalise t = t

9961038

9971039-- Once we've finished checking everything about a term we no longer need

@@ -999,7 +1041,7 @@ finalise t = t

9991041

10001042pEraseType :: TT n -> TT n

10011043pEraseType (P nt t _) = P nt t Erased

1002−pEraseType (App f a) = App (pEraseType f) (pEraseType a)

1044+pEraseType (App s f a) = App s (pEraseType f) (pEraseType a)

10031045pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc)

10041046pEraseType t = t

10051047

@@ -1026,9 +1068,9 @@ subst n v tm = fst $ subst' 0 tm

10261068 = let (b', ub) = substB' i b

10271069 (sc', usc) = subst' (i+1) sc in

10281070 if ub || usc then (Bind x b' sc', True) else (t, False)

1029− subst' i t@(App f a) = let (f', uf) = subst' i f

1030− (a', ua) = subst' i a in

1031− if uf || ua then (App f' a', True) else (t, False)

1071+ subst' i t@(App s f a) = let (f', uf) = subst' i f

1072+ (a', ua) = subst' i a in

1073+ if uf || ua then (App s f' a', True) else (t, False)

10321074 subst' i t@(Proj x idx) = let (x', u) = subst' i x in

10331075 if u then (Proj x' idx, u) else (t, False)

10341076 subst' i t = (t, False)

@@ -1053,7 +1095,7 @@ psubst n v tm = s' 0 tm where

10531095 s' i (P _ x _) | n == x = v

10541096 s' i (Bind x b sc) | n == x = Bind x (fmap (s' i) b) sc

10551097 | otherwise = Bind x (fmap (s' i) b) (s' (i+1) sc)

1056− s' i (App f a) = App (s' i f) (s' i a)

1098+ s' i (App st f a) = App st (s' i f) (s' i a)

10571099 s' i (Proj t idx) = Proj (s' i t) idx

10581100 s' i t = t

10591101

@@ -1071,7 +1113,7 @@ substTerm :: Eq n => TT n {-^ Old term -} ->

10711113 -> TT n

10721114substTerm old new = st where

10731115 st t | t == old = new

1074− st (App f a) = App (st f) (st a)

1116+ st (App s f a) = App s (st f) (st a)

10751117 st (Bind x b sc) = Bind x (fmap st b) (st sc)

10761118 st t = t

10771119

@@ -1085,7 +1127,7 @@ occurrences n t = execState (no' 0 t) 0

10851127 where noB' i (Let t v) = do no' i t; no' i v

10861128 noB' i (Guess t v) = do no' i t; no' i v

10871129 noB' i b = no' i (binderTy b)

1088− no' i (App f a) = do no' i f; no' i a

1130+ no' i (App _ f a) = do no' i f; no' i a

10891131 no' i (Proj x _) = no' i x

10901132 no' i _ = return ()

10911133

@@ -1099,7 +1141,7 @@ noOccurrence n t = no' 0 t

10991141 where noB' i (Let t v) = no' i t && no' i v

11001142 noB' i (Guess t v) = no' i t && no' i v

11011143 noB' i b = no' i (binderTy b)

1102− no' i (App f a) = no' i f && no' i a

1144+ no' i (App _ f a) = no' i f && no' i a

11031145 no' i (Proj x _) = no' i x

11041146 no' i _ = True

11051147

@@ -1111,7 +1153,7 @@ freeNames t = nub $ freeNames' t

11111153 freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n])

11121154 ++ freeNames' t

11131155 freeNames' (Bind n b sc) = freeNames' (binderTy b) ++ (freeNames' sc \\ [n])

1114− freeNames' (App f a) = freeNames' f ++ freeNames' a

1156+ freeNames' (App _ f a) = freeNames' f ++ freeNames' a

11151157 freeNames' (Proj x i) = freeNames' x

11161158 freeNames' _ = []

11171159

@@ -1123,14 +1165,14 @@ arity _ = 0

11231165-- | Deconstruct an application; returns the function and a list of arguments

11241166unApply :: TT n -> (TT n, [TT n])

11251167unApply t = ua [] t where

1126− ua args (App f a) = ua (a:args) f

1168+ ua args (App _ f a) = ua (a:args) f

11271169 ua args t = (t, args)

11281170

11291171-- | Returns a term representing the application of the first argument

11301172-- (a function) to every element of the second argument.

11311173mkApp :: TT n -> [TT n] -> TT n

11321174mkApp f [] = f

1133−mkApp f (a:as) = mkApp (App f a) as

1175+mkApp f (a:as) = mkApp (App MaybeHoles f a) as

11341176

11351177unList :: Term -> Maybe [Term]

11361178unList tm = case unApply tm of

@@ -1159,23 +1201,25 @@ forgetEnv env tm = case safeForgetEnv env tm of

11591201safeForgetEnv :: [Name] -> TT Name -> Maybe Raw

11601202safeForgetEnv env (P _ n _) = Just $ Var n

11611203safeForgetEnv env (V i) | i < length env = Just $ Var (env !! i)

1162− | otherwise = Nothing

1163−safeForgetEnv env (Bind n b sc)

1204+ | otherwise = Nothing

1205+safeForgetEnv env (Bind n b sc)

11641206 = do let n' = uniqueName n env

11651207 b' <- safeForgetEnvB env b

11661208 sc' <- safeForgetEnv (n':env) sc

11671209 Just $ RBind n' b' sc'

1168− where safeForgetEnvB env (Let t v) = liftM2 Let (safeForgetEnv env t)

1210+ where safeForgetEnvB env (Let t v) = liftM2 Let (safeForgetEnv env t)

11691211 (safeForgetEnv env v)

1170− safeForgetEnvB env (Guess t v) = liftM2 Guess (safeForgetEnv env t)

1212+ safeForgetEnvB env (Guess t v) = liftM2 Guess (safeForgetEnv env t)

11711213 (safeForgetEnv env v)

11721214 safeForgetEnvB env b = do ty' <- safeForgetEnv env (binderTy b)

1173− Just $ fmap (\_ -> ty') b

1174−safeForgetEnv env (App f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a)

1215+ Just $ fmap (\_ -> ty') b

1216+safeForgetEnv env (App _ f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a)

11751217safeForgetEnv env (Constant c) = Just $ RConstant c

11761218safeForgetEnv env (TType i) = Just RType

11771219safeForgetEnv env (UType u) = Just $ RUType u

11781220safeForgetEnv env Erased = Just $ RConstant Forgot

1221+safeForgetEnv env (Proj tm i) = error "Don't know how to forget a projection"

1222+safeForgetEnv env Impossible = error "Don't know how to forget Impossible"

11791223

11801224-- | Introduce a 'Bind' into the given term for each element of the

11811225-- given list of (name, binder) pairs.

@@ -1224,10 +1268,11 @@ uniqueBinders ns = ubSet (fromList ns) where

12241268 = let n' = uniqueNameSet n ns

12251269 ns' = insert n' ns in

12261270 Bind n' (fmap (ubSet ns') b) (ubSet ns' sc)

1227− ubSet ns (App f a) = App (ubSet ns f) (ubSet ns a)

1271+ ubSet ns (App s f a) = App s (ubSet ns f) (ubSet ns a)

12281272 ubSet ns t = t

12291273

12301274

1275+nextName :: Name -> Name

12311276nextName (NS x s) = NS (nextName x) s

12321277nextName (MN i n) = MN (i+1) n

12331278nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

@@ -1247,6 +1292,9 @@ nextName (SN x) = SN (nextName' x)

12471292 nextName' (ElimN n) = ElimN (nextName n)

12481293 nextName' (MethodN n) = MethodN (nextName n)

12491294 nextName' (InstanceCtorN n) = InstanceCtorN (nextName n)

1295+ nextName' (MetaN parent meta) = MetaN parent (nextName meta)

1296+nextName NErased = NErased

1297+nextName (SymRef i) = error "Can't generate a name from a symbol reference"

12501298

12511299type Term = TT Name

12521300type Type = Term

@@ -1286,11 +1334,13 @@ instance Show Const where

12861334 show WorldType = "prim__WorldType"

12871335 show StrType = "String"

12881336 show VoidType = "Void"

1337+ show Forgot = "Forgot"

12891338

12901339showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String

12911340showEnv env t = showEnv' env t False

12921341showEnvDbg env t = showEnv' env t True

12931342

1343+prettyEnv :: Env -> Term -> Doc OutputAnnotation

12941344prettyEnv env t = prettyEnv' env t False

12951345 where

12961346 prettyEnv' env t dbg = prettySe 10 env t dbg

@@ -1317,21 +1367,25 @@ prettyEnv env t = prettyEnv' env t False

13171367 bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug

13181368 prettySe p env (Bind n b sc) debug =

13191369 bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug

1320− prettySe p env (App f a) debug =

1370+ prettySe p env (App _ f a) debug =

13211371 bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug

13221372 prettySe p env (Proj x i) debug =

13231373 prettySe 1 env x debug <+> text ("!" ++ show i)

13241374 prettySe p env (Constant c) debug = pretty c

13251375 prettySe p env Erased debug = text "[_]"

13261376 prettySe p env (TType i) debug = text "Type" <+> (text . show $ i)

1377+ prettySe p env Impossible debug = text "Impossible"

1378+ prettySe p env (UType u) debug = text (show u)

13271379

13281380 -- Render a `Binder` and its name

13291381 prettySb env n (Lam t) = prettyB env "λ" "=>" n t

13301382 prettySb env n (Hole t) = prettyB env "?defer" "." n t

1383+ prettySb env n (GHole _ t) = prettyB env "?gdefer" "." n t

13311384 prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t

13321385 prettySb env n (PVar t) = prettyB env "pat" "." n t

13331386 prettySb env n (PVTy t) = prettyB env "pty" "." n t

13341387 prettySb env n (Let t v) = prettyBv env "let" "in" n t v

1388+ prettySb env n (NLet t v) = prettyBv env "nlet" "in" n t v

13351389 prettySb env n (Guess t v) = prettyBv env "??" "in" n t v

13361390

13371391 -- Use `op` and `sc` to delimit `n` (a binding name) and its type

@@ -1361,7 +1415,7 @@ showEnv' env t dbg = se 10 env t where

13611415 where arrow (TType _) = " -> "

13621416 arrow u = " [" ++ show u ++ "] -> "

13631417 se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc

1364− se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a

1418+ se p env (App _ f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a

13651419 se p env (Proj x i) = se 1 env x ++ "!" ++ show i

13661420 se p env (Constant c) = show c

13671421 se p env Erased = "[__]"

@@ -1377,6 +1431,7 @@ showEnv' env t dbg = se 10 env t where

13771431 sb env n (PVar t) = showb env "pat " ". " n t

13781432 sb env n (PVTy t) = showb env "pty " ". " n t

13791433 sb env n (Let t v) = showbv env "let " " in " n t v

1434+ sb env n (NLet t v) = showbv env "nlet " " in " n t v

13801435 sb env n (Guess t v) = showbv env "?? " " in " n t v

13811436

13821437 showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc

@@ -1386,9 +1441,9 @@ showEnv' env t dbg = se 10 env t where

13861441 bracket outer inner str | inner > outer = "(" ++ str ++ ")"

13871442 | otherwise = str

13881443

1389−-- | Check whether a term has any holes in it - impure if so

1444+-- | Check whether a term has any hole bindings in it - impure if so

13901445pureTerm :: TT Name -> Bool

1391−pureTerm (App f a) = pureTerm f && pureTerm a

1446+pureTerm (App _ f a) = pureTerm f && pureTerm a

13921447pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

13931448 pureBinder (Hole _) = False

13941449 pureBinder (Guess _ _) = False

@@ -1404,7 +1459,7 @@ pureTerm _ = True

14041459weakenTm :: Int -> TT n -> TT n

14051460weakenTm i t = wk i 0 t

14061461 where wk i min (V x) | x >= min = V (i + x)

1407− wk i m (App f a) = App (wk i m f) (wk i m a)

1462+ wk i m (App s f a) = App s (wk i m f) (wk i m a)

14081463 wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc)

14091464 wk i m t = t

14101465 wkb i m t = fmap (wk i m) t

@@ -1429,7 +1484,7 @@ weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b))

14291484orderPats :: Term -> Term

14301485orderPats tm = op [] tm

14311486 where

1432− op [] (App f a) = App f (op [] a) -- for Infer terms

1487+ op [] (App s f a) = App s f (op [] a) -- for Infer terms

14331488

14341489 op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc

14351490 op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc

@@ -1454,7 +1509,7 @@ refsIn (Bind n b t) = nub $ nb b ++ refsIn t

14541509 where nb (Let t v) = nub (refsIn t) ++ nub (refsIn v)

14551510 nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v)

14561511 nb t = refsIn (binderTy t)

1457−refsIn (App f a) = nub (refsIn f ++ refsIn a)

1512+refsIn (App s f a) = nub (refsIn f ++ refsIn a)

14581513refsIn _ = []

14591514

14601515-- Make sure all the pattern bindings are as far out as possible

@@ -1491,9 +1546,9 @@ liftPats tm = let (tm', ps) = runState (getPats tm) [] in

14911546 return (Bind n (Hole t') sc')

14921547

14931548

1494− getPats (App f a) = do f' <- getPats f

1495− a' <- getPats a

1496− return (App f' a')

1549+ getPats (App s f a) = do f' <- getPats f

1550+ a' <- getPats a

1551+ return (App s f' a')

14971552 getPats t = return t

14981553

14991554allTTNames :: Eq n => TT n -> [n]

@@ -1503,7 +1558,7 @@ allTTNames = nub . allNamesIn

15031558 where nb (Let t v) = allNamesIn t ++ allNamesIn v

15041559 nb (Guess t v) = allNamesIn t ++ allNamesIn v

15051560 nb t = allNamesIn (binderTy t)

1506− allNamesIn (App f a) = allNamesIn f ++ allNamesIn a

1561+ allNamesIn (App _ f a) = allNamesIn f ++ allNamesIn a

15071562 allNamesIn _ = []

15081563

15091564

@@ -1526,7 +1581,7 @@ pprintTT bound tm = pp startPrec bound tm

15261581 | otherwise = text ("{{{V" ++ show i ++ "}}}")

15271582 pp p bound (Bind n b sc) = ppb p bound n b $

15281583 pp startPrec (n:bound) sc

1529− pp p bound (App tm1 tm2) =

1584+ pp p bound (App _ tm1 tm2) =

15301585 bracket p appPrec . group . hang 2 $

15311586 pp appPrec bound tm1 <> line <>

15321587 pp (appPrec + 1) bound tm2

src/Idris/Core/Typecheck.hs+10−7

@@ -77,14 +77,17 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

7777 smaller _ (UType u) = UType u

7878 smaller x _ = x

7979

80+ astate | holes = MaybeHoles

81+ | otherwise = Complete

82+

8083 chk :: Type -> -- uniqueness level

8184 Env -> Raw -> StateT UCs TC (Term, Type)

8285 chk u env (Var n)

8386 | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)

8487 -- If we're elaborating, we don't want the private names; if we're

8588 -- checking an already elaborated term, we do

86− | (P nt n' ty : _) <- lookupP_all (not holes) n ctxt

87− = return (P nt n' ty, ty)

89+ | [P nt n' ty] <- lookupP_all (not holes) n ctxt

90+ = return (P nt n' ty, ty)

8891 | otherwise = do lift $ tfail $ NoSuchVariable n

8992 chk u env ap@(RApp f RType) | not holes

9093 -- special case to reduce constraintss

@@ -101,13 +104,13 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

101104 put (v+1, ULT (UVar v) v' : cs)

102105 let apty = simplify initContext env

103106 (Bind x (Let (TType v') (TType (UVar v))) t)

104− return (App fv (TType (UVar v)), apty)

107+ return (App Complete fv (TType (UVar v)), apty)

105108 Bind x (Pi i s k) t ->

106109 do (av, aty) <- chk u env RType

107110 convertsC ctxt env aty s

108111 let apty = simplify initContext env

109112 (Bind x (Let aty av) t)

110− return (App fv av, apty)

113+ return (App astate fv av, apty)

111114 t -> lift $ tfail $ NonFunctionType fv fty

112115 chk u env ap@(RApp f a)

113116 = do (fv, fty) <- chk u env f

@@ -123,7 +126,7 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

123126 do convertsC ctxt env aty s

124127 let apty = simplify initContext env

125128 (Bind x (Let aty av) t)

126− return (App fv av, apty)

129+ return (App astate fv av, apty)

127130 t -> lift $ tfail $ NonFunctionType fv fty

128131 chk u env RType

129132 | holes = return (TType (UVal 0), TType (UVal 0))

@@ -298,7 +301,7 @@ checkUnique borrowed ctxt env tm

298301 chkBinders env (P _ n _) = chkName n

299302 -- 'lending' a unique or nulltype variable doesn't count as a use,

300303 -- but we still can't lend something that's already been used.

301− chkBinders env (App (App (P _ (NS (UN lend) [owner]) _) t) a)

304+ chkBinders env (App _ (App _ (P _ (NS (UN lend) [owner]) _) t) a)

302305 | isVar a && owner == txt "Ownership" &&

303306 (lend == txt "lend" || lend == txt "Read")

304307 = do chkBinders env t -- Check the type normally

@@ -307,7 +310,7 @@ checkUnique borrowed ctxt env tm

307310 put (filter (\(n, (ok, _)) -> ok /= LendOnly) st)

308311 chkBinders env a

309312 put st -- Reset the old state after checking the argument

310− chkBinders env (App f a) = do chkBinders env f; chkBinders env a

313+ chkBinders env (App _ f a) = do chkBinders env f; chkBinders env a

311314 chkBinders env (Bind n b t)

312315 = do chkBinderName env n b

313316 st <- get

src/Idris/Core/Unify.hs+33−35

@@ -96,22 +96,22 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

9696 -- but it scares me. However, matching is never guaranteed to give a unique

9797 -- answer, merely a valid one, so perhaps we're okay.

9898 -- In other words: it may vanish without warning some day :)

99− un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a)

99+ un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)

100100 | (P (TCon _ _) _ _, _) <- unApply x,

101101 holeIn env f || f `elem` holes

102102 = let n' = uniqueName (sMN 0 "mv") (map fst env) in

103103 checkCycle names (f, Bind n' (Lam t) x)

104− un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x

104+ un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x

105105 | (P (TCon _ _) _ _, _) <- unApply x,

106106 holeIn env f || f `elem` holes

107107 = let n' = uniqueName fn (map fst env) in

108108 checkCycle names (f, Bind n' (Lam t) x)

109− un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a)

109+ un names x tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a)

110110 | (P (DCon _ _ _) _ _, _) <- unApply x,

111111 holeIn env f || f `elem` holes

112112 = let n' = uniqueName (sMN 0 "mv") (map fst env) in

113113 checkCycle names (f, Bind n' (Lam t) x)

114− un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x

114+ un names tm@(App _ (P _ f (Bind fn (Pi _ t _) sc)) a) x

115115 | (P (DCon _ _ _) _ _, _) <- unApply x,

116116 holeIn env f || f `elem` holes

117117 = let n' = uniqueName fn (map fst env) in

@@ -135,7 +135,7 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

135135 = do h1 <- uB bnames bx by

136136 h2 <- un (((x, y), binderTy bx) : bnames) sx sy

137137 combine bnames h1 h2

138− un names (App fx ax) (App fy ay)

138+ un names (App _ fx ax) (App _ fy ay)

139139 = do hf <- un names fx fy

140140 ha <- un names ax ay

141141 combine names hf ha

@@ -218,7 +218,7 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

218218 bind i ns tm

219219 | i < 0 = tm

220220 | otherwise = let ((x,y),ty) = ns!!i in

221− App (Bind y (Lam ty) (bind (i-1) ns tm))

221+ App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))

222222 (P Bound x ty)

223223

224224renameBinders env (x, t) = (x, renameBindersTm env t)

@@ -233,12 +233,12 @@ renameBindersTm env tm = uniqueBinders (map fst env) tm

233233 (uniqueBinders (n':env) (rename n n' sc))

234234 | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)

235235 (uniqueBinders (n:env) sc)

236− uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a)

236+ uniqueBinders env (App s f a) = App s (uniqueBinders env f) (uniqueBinders env a)

237237 uniqueBinders env t = t

238238

239239 rename n n' (P nt x ty) | n == x = P nt n' ty

240240 rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)

241− rename n n' (App f a) = App (rename n n' f) (rename n n' a)

241+ rename n n' (App s f a) = App s (rename n n' f) (rename n n' a)

242242 rename n n' t = t

243243

244244 explicitHole (Bind n (Hole ty) sc)

@@ -280,7 +280,7 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

280280

281281hasv :: TT Name -> Bool

282282hasv (V x) = True

283−hasv (App f a) = hasv f || hasv a

283+hasv (App _ f a) = hasv f || hasv a

284284hasv (Bind x b sc) = hasv (binderTy b) || hasv sc

285285hasv _ = False

286286

@@ -315,14 +315,12 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

315315

316316 injective (P (DCon _ _ _) _ _) = True

317317 injective (P (TCon _ _) _ _) = True

318−-- injective (App f (P _ _ _)) = injective f

319−-- injective (App f (Constant _)) = injective f

320− injective (App f a) = injective f -- && injective a

318+ injective (App _ f a) = injective f -- && injective a

321319 injective _ = False

322320

323321-- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK

324322 injectiveVar (P _ n _) = n `elem` inj

325− injectiveVar (App f a) = injectiveVar f -- && injective a

323+ injectiveVar (App _ f a) = injectiveVar f -- && injective a

326324 injectiveVar _ = False

327325

328326 injectiveApp x = injective x || injectiveVar x

@@ -426,18 +424,18 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

426424 un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y

427425 un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy

428426

429− un' fn bnames appx@(App _ _) appy@(App _ _)

427+ un' fn bnames appx@(App _ _ _) appy@(App _ _ _)

430428 = unApp fn bnames appx appy

431429-- = uplus (unApp fn bnames appx appy)

432430-- (unifyTmpFail appx appy) -- take the whole lot

433431

434− un' fn bnames x (Bind n (Lam t) (App y (P Bound n' _)))

432+ un' fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _)))

435433 | n == n' = un' False bnames x y

436− un' fn bnames (Bind n (Lam t) (App x (P Bound n' _))) y

434+ un' fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y

437435 | n == n' = un' False bnames x y

438− un' fn bnames x (Bind n (Lam t) (App y (V 0)))

436+ un' fn bnames x (Bind n (Lam t) (App _ y (V 0)))

439437 = un' False bnames x y

440− un' fn bnames (Bind n (Lam t) (App x (V 0))) y

438+ un' fn bnames (Bind n (Lam t) (App _ x (V 0))) y

441439 = un' False bnames x y

442440-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)

443441-- = un' False ((x,y):bnames) sx sy

@@ -447,14 +445,14 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

447445 -- f D unifies with t -> D. This is dubious, but it helps with type

448446 -- class resolution for type classes over functions.

449447

450− un' fn bnames (App f x) (Bind n (Pi i t k) y)

448+ un' fn bnames (App _ f x) (Bind n (Pi i t k) y)

451449 | noOccurrence n y && injectiveApp f

452450 = do ux <- un' False bnames x y

453451 uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

454452 (Bind n (Pi i t k) (V 1)))

455453 combine bnames ux uf

456454

457− un' fn bnames (Bind n (Pi i t k) y) (App f x)

455+ un' fn bnames (Bind n (Pi i t k) y) (App _ f x)

458456 | noOccurrence n y && injectiveApp f

459457 = do ux <- un' False bnames y x

460458 uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

@@ -481,7 +479,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

481479 else do put (UI s ((x, y, True, env, err, from, Unify) : f))

482480 return [] -- lift $ tfail err

483481

484− unApp fn bnames appx@(App fx ax) appy@(App fy ay)

482+ unApp fn bnames appx@(App _ fx ax) appy@(App _ fy ay)

485483 -- shortcut for the common case where we just want to check the

486484 -- arguments are correct

487485 | (injectiveApp fx && fx == fy)

@@ -545,7 +543,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

545543 rigid (P (TCon _ _) _ _) = True

546544 rigid t@(P Ref _ _) = inenv t || globmetavar t

547545 rigid (Constant _) = True

548− rigid (App f a) = rigid f && rigid a

546+ rigid (App _ f a) = rigid f && rigid a

549547 rigid t = not (metavar t) || globmetavar t

550548

551549 globmetavar t = case unApply t of

@@ -636,7 +634,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

636634 bind i ns tm

637635 | i < 0 = tm

638636 | otherwise = let ((x,y),ty) = ns!!i in

639− App (Bind y (Lam ty) (bind (i-1) ns tm))

637+ App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))

640638 (P Bound x ty)

641639

642640 combineArgs bnames args = ca [] args where

@@ -658,16 +656,16 @@ boundVs :: Int -> Term -> [Int]

658656boundVs i (V j) | j < i = []

659657 | otherwise = [j]

660658boundVs i (Bind n b sc) = boundVs (i + 1) sc

661−boundVs i (App f x) = let fs = boundVs i f

662− xs = boundVs i x in

663− nub (fs ++ xs)

659+boundVs i (App _ f x) = let fs = boundVs i f

660+ xs = boundVs i x in

661+ nub (fs ++ xs)

664662boundVs i _ = []

665663

666664highV :: Int -> Term -> Int

667665highV i (V j) | j > i = j

668666 | otherwise = i

669667highV i (Bind n b sc) = maximum [i, highV i (binderTy b), (highV i sc - 1)]

670−highV i (App f x) = max (highV i f) (highV i x)

668+highV i (App _ f x) = max (highV i f) (highV i x)

671669highV i _ = i

672670

673671envPos x i [] = 0

@@ -683,9 +681,9 @@ envPos x i ((y, _) : ys) | x == y = i

683681--

684682-- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722

685683--

686−recoverable t@(App _ _) _

684+recoverable t@(App _ _ _) _

687685 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

688−recoverable _ t@(App _ _)

686+recoverable _ t@(App _ _ _)

689687 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

690688recoverable (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x == y

691689recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y

@@ -696,13 +694,13 @@ recoverable (Constant _) (P (TCon _ _) y _) = False

696694recoverable (P (TCon _ _) x _) (Constant _) = False

697695recoverable (P (DCon _ _ _) x _) (P (TCon _ _) y _) = False

698696recoverable (P (TCon _ _) x _) (P (DCon _ _ _) y _) = False

699−recoverable p@(Constant _) (App f a) = recoverable p f

700−recoverable (App f a) p@(Constant _) = recoverable f p

701−recoverable p@(P _ n _) (App f a) = recoverable p f

702−recoverable (App f a) p@(P _ _ _) = recoverable f p

703−recoverable (App f a) (App f' a')

697+recoverable p@(Constant _) (App _ f a) = recoverable p f

698+recoverable (App _ f a) p@(Constant _) = recoverable f p

699+recoverable p@(P _ n _) (App _ f a) = recoverable p f

700+recoverable (App _ f a) p@(P _ _ _) = recoverable f p

701+recoverable (App _ f a) (App _ f' a')

704702 | f == f' = recoverable a a'

705−recoverable (App f a) (App f' a')

703+recoverable (App _ f a) (App _ f' a')

706704 = recoverable f f' -- && recoverable a a'

707705recoverable f (Bind _ (Pi _ _ _) sc)

708706 | (P (DCon _ _ _) _ _, _) <- unApply f = False

src/Idris/Coverage.hs+63−18

@@ -1,5 +1,6 @@

11{-# LANGUAGE PatternGuards #-}

2−

2+{-| The coverage and totality checkers for Idris are in this module.

3+-}

34module Idris.Coverage where

45

56import Idris.Core.TT

@@ -120,6 +121,52 @@ genClauses fc n xs given

120121 as' <- mkArg as

121122 return (a':as')

122123

124+-- | Does this error result rule out a case as valid when coverage checking?

125+validCoverageCase :: Context -> Err -> Bool

126+validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

127+ = let topx' = normalise ctxt [] topx

128+ topy' = normalise ctxt [] topy in

129+ not (sameFam topx' topy' || not (validCoverageCase ctxt e))

130+ where sameFam topx topy

131+ = case (unApply topx, unApply topy) of

132+ ((P _ x _, _), (P _ y _, _)) -> x == y

133+ _ -> False

134+validCoverageCase ctxt (CantConvert _ _ _) = False

135+validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

136+validCoverageCase ctxt (Elaborating _ _ e) = validCoverageCase ctxt e

137+validCoverageCase ctxt (ElaboratingArg _ _ _ e) = validCoverageCase ctxt e

138+validCoverageCase ctxt _ = True

139+

140+-- | Check whether an error is recoverable in the sense needed for

141+-- coverage checking.

142+recoverableCoverage :: Context -> Err -> Bool

143+recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)

144+ = let topx' = normalise ctxt [] topx

145+ topy' = normalise ctxt [] topy in

146+ checkRec topx' topy'

147+ where -- different notion of recoverable than in unification, since we

148+ -- have no metavars -- just looking to see if a constructor is failing

149+ -- to unify with a function that may be reduced later

150+ checkRec (App _ f a) p@(P _ _ _) = checkRec f p

151+ checkRec p@(P _ _ _) (App _ f a) = checkRec p f

152+ checkRec fa@(App _ _ _) fa'@(App _ _ _)

153+ | (f, as) <- unApply fa,

154+ (f', as') <- unApply fa'

155+ = if (length as /= length as')

156+ then checkRec f f'

157+ else checkRec f f' && and (zipWith checkRec as as')

158+ checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt

159+ checkRec _ _ = False

160+

161+ ntRec x y | Ref <- x = True

162+ | Ref <- y = True

163+ | (Bound, Bound) <- (x, y) = True

164+ | otherwise = False -- name is different, unrecoverable

165+recoverableCoverage ctxt (At _ e) = recoverableCoverage ctxt e

166+recoverableCoverage ctxt (Elaborating _ _ e) = recoverableCoverage ctxt e

167+recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e

168+recoverableCoverage _ _ = False

169+

123170-- FIXME: Just look for which one is the deepest, then generate all

124171-- possibilities up to that depth.

125172-- This and below issues for this function are tracked as Issue #1741 on the issue tracker.

@@ -317,7 +364,7 @@ calcProd i fc topn pats

317364 prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

318365

319366 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

320− prod n done ok ap@(App _ _)

367+ prod n done ok ap@(App _ _ _)

321368 | (P nt f _, args) <- unApply ap

322369 = do recOK <- checkProdRec (n:done) f

323370 let ctxt = tt_ctxt i

@@ -329,8 +376,8 @@ calcProd i fc topn pats

329376 return (and (ok : argsprod) )

330377 else do argsprod <- mapM (prod n done co) args

331378 return (and argsprod)

332− prod n done ok (App f a) = liftM2 (&&) (prod n done False f)

333− (prod n done False a)

379+ prod n done ok (App _ f a) = liftM2 (&&) (prod n done False f)

380+ (prod n done False a)

334381 prod n done ok (Bind _ (Let t v) sc)

335382 = liftM2 (&&) (prod n done False v) (prod n done False v)

336383 prod n done ok (Bind _ b sc) = prod n done ok sc

@@ -350,10 +397,9 @@ calcProd i fc topn pats

350397 _ -> False

351398 cotype nt n ty = False

352399

353−-- Calculate the totality of a function from its patterns.

400+-- | Calculate the totality of a function from its patterns.

354401-- Either follow the size change graph (if inductive) or check for

355402-- productivity (if coinductive)

356−

357403calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

358404calcTotality fc n pats

359405 = do i <- getIState

@@ -368,7 +414,7 @@ calcTotality fc n pats

368414 = case lookupTotal fn (tt_ctxt i) of

369415 [Partial _] -> return (Partial (Other [fn]))

370416 _ -> Nothing

371− checkLHS i (App f a) = mplus (checkLHS i f) (checkLHS i a)

417+ checkLHS i (App _ f a) = mplus (checkLHS i f) (checkLHS i a)

372418 checkLHS _ _ = Nothing

373419

374420checkTotality :: [Name] -> FC -> Name -> Idris Totality

@@ -450,17 +496,16 @@ checkDeclTotality (fc, n)

450496 return t

451497

452498

453−-- Calculate the size change graph for this definition

454−

499+-- | Calculate the size change graph for this definition

500+--

455501-- SCG for a function f consists of a list of:

456502-- (g, [(a1, sizechange1), (a2, sizechange2), ..., (an, sizechangen)])

457−

503+--

458504-- where g is a function called

459505-- a1 ... an are the arguments of f in positions 1..n of g

460506-- sizechange1 ... sizechange2 is how their size has changed wrt the input

461507-- to f

462508-- Nothing, if the argument is unrelated to the input

463−

464509buildSCG :: (FC, Name) -> Idris ()

465510buildSCG (_, n) = do

466511 ist <- getIState

@@ -477,14 +522,14 @@ buildSCG (_, n) = do

477522 x -> error $ "buildSCG: " ++ show (n, x)

478523

479524delazy = delazy' False -- not lazy codata

480−delazy' all t@(App f a)

525+delazy' all t@(App _ f a)

481526 | (P _ (UN l) _, [_, _, arg]) <- unApply t,

482527 l == txt "Force" = delazy' all arg

483528 | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

484529 l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

485530 | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

486531 l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

487−delazy' all (App f a) = App (delazy' all f) (delazy' all a)

532+delazy' all (App s f a) = App s (delazy' all f) (delazy' all a)

488533delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

489534delazy' all t = t

490535

@@ -498,7 +543,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

498543 (f, pargs) = unApply (dePat lhs') in

499544 findCalls Toplevel (dePat rhs') (patvars lhs') pargs

500545

501− findCalls guarded ap@(App f a) pvs pargs

546+ findCalls guarded ap@(App _ f a) pvs pargs

502547 -- under a call to "assert_total", don't do any checking, just believe

503548 -- that it is total.

504549 | (P _ (UN at) _, [_, _]) <- unApply ap,

@@ -519,7 +564,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

519564 else Unguarded in

520565 mkChange n args pargs ++

521566 concatMap (\x -> findCalls nguarded x pvs pargs) args

522− findCalls guarded (App f a) pvs pargs

567+ findCalls guarded (App _ f a) pvs pargs

523568 = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

524569 findCalls guarded (Bind n (Let t v) e) pvs pargs

525570 = findCalls Unguarded t pvs pargs ++

@@ -561,13 +606,13 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

561606 smaller (Just tyn) a (t, Just tyt)

562607 | a == t = isInductive (fst (unApply (getRetTy tyn)))

563608 (fst (unApply (getRetTy tyt)))

564− smaller ty a (ap@(App f s), _)

609+ smaller ty a (ap@(App _ f s), _)

565610 | (P (DCon _ _ _) n _, args) <- unApply ap

566611 = let tyn = getType n in

567612 any (smaller (ty `mplus` Just tyn) a)

568613 (zip args (map toJust (getArgTys tyn)))

569614 -- check higher order recursive arguments

570− smaller ty (App f s) a = smaller ty f a

615+ smaller ty (App _ f s) a = smaller ty f a

571616 smaller _ _ _ = False

572617

573618 toJust (n, t) = Just t

@@ -660,7 +705,7 @@ checkMP ist i mp = if i > 0

660705 = case lookupTotal f (tt_ctxt ist) of

661706 [Total _] -> Unchecked -- okay so far

662707 [Partial _] -> Partial (Other [f])

663− x -> error $ "CAN'T HAPPEN: " ++ (show x)

708+ x -> error $ "CAN'T HAPPEN: " ++ show x ++ " for " ++ show f

664709 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

665710 = Total []

666711 tryPath desc path (e@(f, args) : es) arg

src/Idris/DSL.hs+2−2

@@ -108,7 +108,7 @@ expandDo dsl (PDoBlock ds)

108108 block b _ = PElabError (Msg "Invalid statement in do block")

109109

110110expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

111−expandDo dsl (PRunTactics fc tm) = PRunTactics fc $ expandDo dsl tm

111+expandDo dsl (PRunElab fc tm) = PRunElab fc $ expandDo dsl tm

112112expandDo dsl t = t

113113

114114-- | Replace DSL-bound variable in a term

@@ -195,7 +195,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

195195 db' (PDPair fc p l t r) = do l' <- db' l

196196 r' <- db' r

197197 return (PDPair fc p l' t r')

198− db' (PRunTactics fc t) = fmap (PRunTactics fc) (db' t)

198+ db' (PRunElab fc t) = fmap (PRunElab fc) (db' t)

199199 db' t = return t

200200

201201 dbArg a = do t' <- db' (getTm a)

src/Idris/DataOpts.hs+12−6

@@ -63,21 +63,27 @@ instance Optimisable (TT Name) where

6363 applyOpts (P _ (NS (UN fn) mod) _)

6464 | fn == txt "mult" && mod == prel

6565 = return (P Ref (sUN "prim__mulBigInt") Erased)

66− applyOpts (App (P _ (NS (UN fn) mod) _) x)

66+ applyOpts (P _ (NS (UN fn) mod) _)

67+ | fn == txt "divNat" && mod == prel

68+ = return (P Ref (sUN "prim__sdivBigInt") Erased)

69+ applyOpts (P _ (NS (UN fn) mod) _)

70+ | fn == txt "modNat" && mod == prel

71+ = return (P Ref (sUN "prim__sremBigInt") Erased)

72+ applyOpts (App _ (P _ (NS (UN fn) mod) _) x)

6773 | fn == txt "fromIntegerNat" && mod == prel

6874 = applyOpts x

6975 applyOpts (P _ (NS (UN fn) mod) _)

7076 | fn == txt "fromIntegerNat" && mod == prel

71− = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

77+ = return (App Complete (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

7278 applyOpts (P _ (NS (UN fn) mod) _)

7379 | fn == txt "toIntegerNat" && mod == prel

74− = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

80+ = return (App Complete (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

7581 applyOpts c@(P (DCon t arity uniq) n _)

7682 = return $ applyDataOptRT n t arity uniq []

77− applyOpts t@(App f a)

83+ applyOpts t@(App s f a)

7884 | (c@(P (DCon t arity uniq) n _), args) <- unApply t

7985 = applyDataOptRT n t arity uniq <$> mapM applyOpts args

80− | otherwise = App <$> applyOpts f <*> applyOpts a

86+ | otherwise = App s <$> applyOpts f <*> applyOpts a

8187 applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

8288 applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

8389 applyOpts t = return t

@@ -103,6 +109,6 @@ applyDataOptRT n tag arity uniq args

103109 = Constant (BI 0)

104110 doOpts (NS (UN s) [nat, prelude]) [k]

105111 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

106− = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

112+ = App Complete (App Complete (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

107113

108114 doOpts n args = mkApp (P (DCon tag arity uniq) n Erased) args

src/Idris/DeepSeq.hs+2−1

@@ -243,7 +243,8 @@ instance NFData PTerm where

243243 rnf (PNoImplicits x1) = rnf x1 `seq` ()

244244 rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

245245 rnf (PUnquote x1) = rnf x1 `seq` ()

246− rnf (PRunTactics x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

246+ rnf (PQuoteName x1) = rnf x1 `seq` ()

247+ rnf (PRunElab x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

247248

248249instance (NFData t) => NFData (PTactic' t) where

249250 rnf (Intro x1) = rnf x1 `seq` ()

src/Idris/Delaborate.hs+22−11

@@ -49,7 +49,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

4949 where

5050 un = fileFC "(val)"

5151

52− de env _ (App f a) = deFn env f [a]

52+ de env _ (App _ f a) = deFn env f [a]

5353 de env _ (V i) | i < length env = PRef un (snd (env!!i))

5454 | otherwise = PRef un (sUN ("v" ++ show i ++ ""))

5555 de env _ (P _ n _) | n == unitTy = PTrue un IsType

@@ -103,7 +103,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

103103 _ -> ns

104104 dens n = n

105105

106− deFn env (App f a) args = deFn env f (a:args)

106+ deFn env (App _ f a) args = deFn env f (a:args)

107107 deFn env (P _ n _) [l,r]

108108 | n == pairTy = PPair un IsType (de env [] l) (de env [] r)

109109 | n == eqCon = PRefl un (de env [] r)

@@ -163,7 +163,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

163163 | otherwise = tm

164164 nonVar [] = error "Tried to delaborate empty case list"

165165 nonVar [x] = x

166− nonVar (x@(App _ _) : _) = x

166+ nonVar (x@(App _ _ _) : _) = x

167167 nonVar (x@(P (DCon _ _ _) _ _) : _) = x

168168 nonVar (x:xs) = nonVar xs

169169-- | How far to indent sub-errors

@@ -256,9 +256,9 @@ pprintErr' i (CantConvert x_in y_in env) =

256256 y)) <>

257257 if (opt_errContext (idris_options i)) then line <> showSc i env else empty

258258 where flagUnique (Bind n (Pi i t k@(UType u)) sc)

259− = App (P Ref (sUN (show u)) Erased)

259+ = App Complete (P Ref (sUN (show u)) Erased)

260260 (Bind n (Pi i (flagUnique t) k) (flagUnique sc))

261− flagUnique (App f a) = App (flagUnique f) (flagUnique a)

261+ flagUnique (App s f a) = App s (flagUnique f) (flagUnique a)

262262 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)

263263 flagUnique t = t

264264pprintErr' i (CantSolveGoal x env) =

@@ -311,7 +311,14 @@ pprintErr' i (NoEliminator s t)

311311 text "Please note that 'induction' is experimental." <$>

312312 text "Only types declared with '%elim' can be used." <$>

313313 text "Consider writing a pattern matching definition instead."

314−pprintErr' i UniverseError = text "Universe inconsistency"

314+pprintErr' i (UniverseError fc uexp old new suspects) =

315+ text "Universe inconsistency." <>

316+ (indented . vsep) [ text "Working on:" <+> text (show uexp)

317+ , text "Old domain:" <+> text (show old)

318+ , text "New domain:" <+> text (show new)

319+ , text "Involved constraints:" <+>

320+ (indented . vsep) (map (text . show) suspects)

321+ ]

315322pprintErr' i (UniqueError NullType n)

316323 = text "Borrowed name" <+> annName' n (showbasic n)

317324 <+> text "must not be used on RHS"

@@ -373,12 +380,13 @@ pprintErr' i (ReflectionFailed msg err) =

373380 text "When attempting to perform error reflection, the following internal error occurred:" <>

374381 indented (pprintErr' i err) <>

375382 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

376−pprintErr' i (ElabDebug msg tm holes) =

383+pprintErr' i (ElabScriptDebug msg tm holes) =

377384 text "Elaboration halted." <>

378− maybe empty (indented . text) msg <> line <>

379− text "Term: " <> indented (pprintTT [] tm) <> line <>

385+ maybe empty (indented . text) msg <>

386+ line <> line <>

380387 text "Holes:" <>

381− indented (vsep (map ppHole holes))

388+ indented (vsep (map ppHole holes)) <> line <> line <>

389+ text "Term: " <> indented (pprintTT [] tm)

382390

383391 where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation

384392 ppHole (hn, goal, env) =

@@ -394,6 +402,9 @@ pprintErr' i (ElabDebug msg tm holes) =

394402 pprintTT ns (binderTy b) <>

395403 line <>

396404 ppAssumptions (n:ns) rest

405+pprintErr' i (ElabScriptStuck tm) =

406+ text "Can't run" <+> pprintTT [] tm <+> text "as an elaborator script." <$>

407+ text "Is it a stuck term?"

397408

398409-- | Make sure the machine invented names are shown helpfully to the user, so

399410-- that any names which differ internally also differ visibly

@@ -423,7 +434,7 @@ renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y

423434

424435 rename :: [(Name, Name)] -> Term -> Term

425436 rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t

426− rename ns (App f a) = App (rename ns f) (rename ns a)

437+ rename ns (App s f a) = App s (rename ns f) (rename ns a)

427438 rename ns (Bind x b sc)

428439 = let b' = fmap (rename ns) b

429440 sc' = rename ns sc in

src/Idris/Directives.hsnew file+65

@@ -0,0 +1,65 @@

1+

2+module Idris.Directives where

3+

4+import Idris.AbsSyntax

5+import Idris.ASTUtils

6+import Idris.Imports

7+

8+import Idris.Core.Evaluate

9+import Idris.Core.TT

10+

11+import Util.DynamicLinker

12+

13+-- | Run the action corresponding to a directive

14+directiveAction :: Directive -> Idris ()

15+directiveAction (DLib cgn lib) = do addLib cgn lib

16+ addIBC (IBCLib cgn lib)

17+

18+directiveAction (DLink cgn obj) = do dirs <- allImportDirs

19+ o <- runIO $ findInPath dirs obj

20+ addIBC (IBCObj cgn obj) -- just name, search on loading ibc

21+ addObjectFile cgn o

22+

23+directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)

24+ addFlag cgn flag

25+

26+directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

27+ addIBC (IBCHeader cgn hdr)

28+

29+directiveAction (DHide n) = do setAccessibility n Hidden

30+ addIBC (IBCAccess n Hidden)

31+

32+directiveAction (DFreeze n) = do setAccessibility n Frozen

33+ addIBC (IBCAccess n Frozen)

34+

35+directiveAction (DAccess acc) = do updateIState (\i -> i { default_access = acc })

36+

37+directiveAction (DDefault tot) = do updateIState (\i -> i { default_total = tot })

38+

39+directiveAction (DLogging lvl) = setLogLevel (fromInteger lvl)

40+

41+directiveAction (DDynamicLibs libs) = do added <- addDyLib libs

42+ case added of

43+ Left lib -> addIBC (IBCDyLib (lib_name lib))

44+ Right msg -> fail $ msg

45+

46+directiveAction (DNameHint ty ns) = do ty' <- disambiguate ty

47+ mapM_ (addNameHint ty') ns

48+ mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns

49+

50+directiveAction (DErrorHandlers fn arg ns) = do fn' <- disambiguate fn

51+ ns' <- mapM disambiguate ns

52+ addFunctionErrorHandlers fn' arg ns'

53+ mapM_ (addIBC .

54+ IBCFunctionErrorHandler fn' arg) ns'

55+

56+directiveAction (DLanguage ext) = addLangExt ext

57+

58+directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

59+

60+disambiguate :: Name -> Idris Name

61+disambiguate n = do i <- getIState

62+ case lookupCtxtName n (idris_implicits i) of

63+ [(n', _)] -> return n'

64+ [] -> throwError (NoSuchVariable n)

65+ more -> throwError (CantResolveAlts (map fst more))

src/Idris/Elab/Class.hs+23−7

@@ -7,7 +7,7 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

1111import Idris.Coverage

1212import Idris.DataOpts

1313import Idris.Providers

@@ -106,7 +106,14 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

106106 where

107107 nodoc (n, (_, o, t)) = (n, (o, t))

108108 pibind [] x = x

109− pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x)

109+ pibind ((n, ty): ns) x = PPi expl n ty (pibind ns (chkUniq ty x))

110+

111+ -- To make sure the type constructor of the class is in the appropriate

112+ -- uniqueness hierarchy

113+ chkUniq u@(PUniverse _) PType = u

114+ chkUniq (PUniverse l) (PUniverse r) = PUniverse (min l r)

115+ chkUniq (PPi _ _ _ sc) t = chkUniq sc t

116+ chkUniq _ t = t

110117

111118 mdec :: Name -> Name

112119 mdec (UN n) = SN (MethodN (UN n))

@@ -175,8 +182,8 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

175182 let lhs = PApp fc (PRef fc cfn) [pconst capp]

176183 let rhs = PResolveTC (fileFC "HACK")

177184 let ty = PPi constraint cnm c con

178− iLOG (showTmImpls ty)

179− iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

185+ logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

186+ logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

180187 i <- getIState

181188 let conn = case con of

182189 PRef _ n -> n

@@ -193,16 +200,16 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

193200 -- Generate a top level function which looks up a method in a given

194201 -- dictionary (this is inlinable, always)

195202 tfun cn c syn all (m, (doc, o, ty))

196− = do let ty' = insertConstraint c ty

203+ = do let ty' = expandMethNS syn (insertConstraint c ty)

197204 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

198205 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

199206 let margs = getMArgs ty

200207 let anames = map (\x -> sMN x "arg") [0..]

201208 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

202209 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

203− iLOG (showTmImpls ty')

210+ logLvl 2 ("Top level type: " ++ showTmImpls ty')

204211 iLOG (show (m, ty', capp, margs))

205− iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

212+ logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

206213 return [PTy doc [] syn fc o m ty',

207214 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

208215

@@ -236,6 +243,15 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

236243 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

237244 toExp ns e sc = sc

238245

246+-- In a top level type for a method, expand all the method names namespaces

247+-- so that we don't have to disambiguate later

248+expandMethNS :: SyntaxInfo

249+ -> PTerm -> PTerm

250+expandMethNS syn = mapPT expand

251+ where

252+ expand (PRef fc n) | n `elem` imp_methods syn = PRef fc $ expandNS syn n

253+ expand t = t

254+

239255findDets :: Name -> [Name] -> Idris [Int]

240256findDets n ns =

241257 do i <- getIState

src/Idris/Elab/Clause.hs+26−69

@@ -7,7 +7,7 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

1111import Idris.Coverage

1212import Idris.DataOpts

1313import Idris.Providers

@@ -433,7 +433,7 @@ elabPE info fc caller r =

433433 showArg _ = ""

434434

435435 qshow (Bind _ _ _) = "fn"

436− qshow (App f a) = qshow f ++ qshow a

436+ qshow (App _ f a) = qshow f ++ qshow a

437437 qshow (P _ n _) = show n

438438 qshow (Constant c) = show c

439439 qshow _ = ""

@@ -444,71 +444,27 @@ elabPE info fc caller r =

444444 qhash hash [] = showHex (abs hash `mod` 0xffffffff) ""

445445 qhash hash (x:xs) = qhash (hash * 33 + fromEnum x) xs

446446

447−-- checks if the clause is a possible left hand side. Returns the term if

448−-- possible, otherwise Nothing.

449−

447+-- | Checks if the clause is a possible left hand side.

450448checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool

451449checkPossible info fc tcgen fname lhs_in

452450 = do ctxt <- getContext

453451 i <- getIState

454452 let lhs = addImplPat i lhs_in

455453 -- if the LHS type checks, it is possible

456− case elaborate ctxt (sMN 0 "patLHS") infP initEState

454+ case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

457455 (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

458456 OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->

459457 do setContext ctxt'

460− processTacticDecls newDecls

458+ processTacticDecls info newDecls

461459 let lhs_tm = orderPats (getInferTerm lhs')

462460 case recheck ctxt [] (forget lhs_tm) lhs_tm of

463461 OK _ -> return True

464462 err -> return False

465463 -- if it's a recoverable error, the case may become possible

466− Error err -> if tcgen then return (recoverable ctxt err)

467− else return (validCase ctxt err ||

468− recoverable ctxt err)

469− where validCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

470− = let topx' = normalise ctxt [] topx

471− topy' = normalise ctxt [] topy in

472− not (sameFam topx' topy' || not (validCase ctxt e))

473− validCase ctxt (CantConvert _ _ _) = False

474− validCase ctxt (At _ e) = validCase ctxt e

475− validCase ctxt (Elaborating _ _ e) = validCase ctxt e

476− validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e

477− validCase ctxt _ = True

478−

479− recoverable ctxt (CantUnify r (topx, _) (topy, _) e _ _)

480− = let topx' = normalise ctxt [] topx

481− topy' = normalise ctxt [] topy in

482− checkRec topx' topy'

483− recoverable ctxt (At _ e) = recoverable ctxt e

484− recoverable ctxt (Elaborating _ _ e) = recoverable ctxt e

485− recoverable ctxt (ElaboratingArg _ _ _ e) = recoverable ctxt e

486− recoverable _ _ = False

487−

488− sameFam topx topy

489− = case (unApply topx, unApply topy) of

490− ((P _ x _, _), (P _ y _, _)) -> x == y

491− _ -> False

492−

493− -- different notion of recoverable than in unification, since we

494− -- have no metavars -- just looking to see if a constructor is failing

495− -- to unify with a function that may be reduced later

496−

497− checkRec (App f a) p@(P _ _ _) = checkRec f p

498− checkRec p@(P _ _ _) (App f a) = checkRec p f

499− checkRec fa@(App _ _) fa'@(App _ _)

500− | (f, as) <- unApply fa,

501− (f', as') <- unApply fa'

502− = if (length as /= length as')

503− then checkRec f f'

504− else checkRec f f' && and (zipWith checkRec as as')

505− checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt

506− checkRec _ _ = False

507−

508− ntRec x y | Ref <- x = True

509− | Ref <- y = True

510− | (Bound, Bound) <- (x, y) = True

511− | otherwise = False -- name is different, unrecoverable

464+ Error err -> if tcgen then return (recoverableCoverage ctxt err)

465+ else return (validCoverageCase ctxt err ||

466+ recoverableCoverage ctxt err)

467+

512468

513469propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm

514470propagateParams i ps t tm@(PApp _ (PRef fc n) args)

@@ -582,14 +538,14 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

582538 "\n" ++ show (fn_ty, fn_is))

583539

584540 ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <-

585− tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState

541+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

586542 (do res <- errAt "left hand side of " fname

587543 (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

588544 probs <- get_probs

589545 inj <- get_inj

590546 return (res, probs, inj))

591547 setContext ctxt'

592− processTacticDecls newDecls

548+ processTacticDecls info newDecls

593549 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

594550

595551 let lhs_tm = orderPats (getInferTerm lhs')

@@ -657,7 +613,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

657613 ctxt <- getContext -- new context with where block added

658614 logLvl 5 "STARTING CHECK"

659615 ((rhs', defer, is, probs, ctxt', newDecls), _) <-

660− tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty initEState

616+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

661617 (do pbinds ist lhs_tm

662618 mapM_ setinj (nub (params ++ inj))

663619 setNextName

@@ -667,14 +623,15 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

667623 errAt "right hand side of " fname

668624 (erun fc $ psolve lhs_tm)

669625 hs <- get_holes

670− aux <- getAux

671− mapM_ (elabCaseHole (case_decls aux)) hs

626+ mapM_ (elabCaseHole is) hs

672627 tt <- get_term

673− let (tm, ds) = runState (collectDeferred (Just fname) tt) []

628+ aux <- getAux

629+ let (tm, ds) = runState (collectDeferred (Just fname)

630+ (map fst $ case_decls aux) ctxt tt) []

674631 probs <- get_probs

675632 return (tm, ds, is, probs, ctxt', newDecls))

676633 setContext ctxt'

677− processTacticDecls newDecls

634+ processTacticDecls info newDecls

678635 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

679636

680637 logLvl 5 "DONE CHECK"

@@ -745,14 +702,14 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

745702 -- Find the variable names which appear under a 'Ownership.Read' so that

746703 -- we know they can't be used on the RHS

747704 borrowedNames :: [Name] -> Term -> [Name]

748− borrowedNames env (App (App (P _ (NS (UN lend) [owner]) _) _) arg)

705+ borrowedNames env (App _ (App _ (P _ (NS (UN lend) [owner]) _) _) arg)

749706 | owner == txt "Ownership" &&

750707 (lend == txt "lend" || lend == txt "Read") = getVs arg

751708 where

752709 getVs (V i) = [env!!i]

753− getVs (App f a) = nub $ getVs f ++ getVs a

710+ getVs (App _ f a) = nub $ getVs f ++ getVs a

754711 getVs _ = []

755− borrowedNames env (App f a) = nub $ borrowedNames env f ++ borrowedNames env a

712+ borrowedNames env (App _ f a) = nub $ borrowedNames env f ++ borrowedNames env a

756713 borrowedNames env (Bind n b sc) = nub $ borrowedB b ++ borrowedNames (n:env) sc

757714 where borrowedB (Let t v) = nub $ borrowedNames env t ++ borrowedNames env v

758715 borrowedB b = borrowedNames env (binderTy b)

@@ -818,11 +775,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

818775 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

819776 logLvl 2 ("LHS: " ++ show lhs)

820777 (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

821− tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState

778+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

822779 (errAt "left hand side of with in " fname

823780 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

824781 setContext ctxt'

825− processTacticDecls newDecls

782+ processTacticDecls info newDecls

826783 let lhs_tm = orderPats (getInferTerm lhs')

827784 let lhs_ty = getInferType lhs'

828785 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

@@ -835,7 +792,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

835792 logLvl 5 ("Checking " ++ showTmImpls wval)

836793 -- Elaborate wval in this context

837794 ((wval', defer, is, ctxt', newDecls), _) <-

838− tclift $ elaborate ctxt (sMN 0 "withRHS")

795+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

839796 (bindTyArgs PVTy bargs infP) initEState

840797 (do pbinds i lhs_tm

841798 setNextName

@@ -846,7 +803,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

846803 tt <- get_term

847804 return (tt, d, is, ctxt', newDecls))

848805 setContext ctxt'

849− processTacticDecls newDecls

806+ processTacticDecls info newDecls

850807 def' <- checkDef fc iderr defer

851808 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

852809 addDeferred def''

@@ -933,7 +890,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

933890 ctxt <- getContext -- New context with block added

934891 i <- getIState

935892 ((rhs', defer, is, ctxt', newDecls), _) <-

936− tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty initEState

893+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

937894 (do pbinds i lhs_tm

938895 setNextName

939896 (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs)

@@ -941,7 +898,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

941898 tt <- get_term

942899 return (tt, d, is, ctxt', newDecls))

943900 setContext ctxt'

944− processTacticDecls newDecls

901+ processTacticDecls info newDecls

945902

946903 def' <- checkDef fc iderr defer

947904 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

src/Idris/Elab/Data.hs+8−4

@@ -7,7 +7,7 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

1111import Idris.Coverage

1212import Idris.DataOpts

1313import Idris.Providers

@@ -174,7 +174,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

174174 update ((n, _) : as) (_ : args) = (n, Nothing) : update as args

175175

176176 getDataApp :: Type -> [[Maybe Name]]

177− getDataApp f@(App _ _)

177+ getDataApp f@(App _ _ _)

178178 | (P _ d _, args) <- unApply f

179179 = if (d == n) then [mParam args args] else []

180180 getDataApp (Bind n (Pi _ t _) sc)

@@ -271,7 +271,8 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

271271 getNamePos _ _ _ = Nothing

272272

273273 -- if the constructor is a UniqueType, the datatype must be too

274− -- (Type* is fine, since that is checked for uniqueness too)

274+ -- (AnyType is fine, since that is checked for uniqueness too)

275+ -- if hte contructor is AnyType, the datatype must be at least AnyType

275276 checkUniqueKind (UType NullType) (UType NullType) = return ()

276277 checkUniqueKind (UType NullType) _

277278 = tclift $ tfail (At fc (UniqueKindError NullType n))

@@ -279,7 +280,10 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

279280 checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()

280281 checkUniqueKind (UType UniqueType) _

281282 = tclift $ tfail (At fc (UniqueKindError UniqueType n))

282− checkUniqueKind (UType AllTypes) _ = return ()

283+ checkUniqueKind (UType AllTypes) (UType AllTypes) = return ()

284+ checkUniqueKind (UType AllTypes) (UType UniqueType) = return ()

285+ checkUniqueKind (UType AllTypes) _

286+ = tclift $ tfail (At fc (UniqueKindError AllTypes n))

283287 checkUniqueKind _ _ = return ()

284288

285289 -- Constructor's kind must be <= expected kind

src/Idris/Elab/Instance.hs+7−7

@@ -7,7 +7,6 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

1110import Idris.Coverage

1211import Idris.DataOpts

1312import Idris.Providers

@@ -21,6 +20,7 @@ import IRTS.Lang

2120import Idris.Elab.Type

2221import Idris.Elab.Data

2322import Idris.Elab.Utils

23+import Idris.Elab.Term

2424

2525import Idris.Core.TT

2626import Idris.Core.Elaborate hiding (Tactic(..))

@@ -177,10 +177,10 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

177177 let ty = addImpl [] i ty'

178178 ctxt <- getContext

179179 (ElabResult tyT _ _ ctxt' newDecls, _) <-

180− tclift $ elaborate ctxt iname (TType (UVal 0)) initEState

180+ tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

181181 (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

182182 setContext ctxt'

183− processTacticDecls newDecls

183+ processTacticDecls info newDecls

184184 ctxt <- getContext

185185 (cty, _) <- recheckC fc id [] tyT

186186 let nty = normalise ctxt [] cty

@@ -280,19 +280,19 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

280280 = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds)

281281

282282 insertDef i meth def clauses ns iname decls

283− | null $ filter (clauseFor meth iname ns) decls

283+ | not $ any (clauseFor meth iname ns) decls

284284 = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in

285285 -- trace (show newd) $

286286 decls ++ [newd]

287287 | otherwise = decls

288288

289289 warnMissing decls ns iname meth

290− | null $ filter (clauseFor meth iname ns) decls

290+ | not $ any (clauseFor meth iname ns) decls

291291 = iWarn fc . text $ "method " ++ show meth ++ " not defined"

292292 | otherwise = return ()

293293

294294 checkInClass ns meth

295− | not (null (filter (eqRoot meth) ns)) = return ()

295+ | any (eqRoot meth) ns = return ()

296296 | otherwise = tclift $ tfail (At fc (Msg $

297297 show meth ++ " not a method of class " ++ show n))

298298

@@ -317,7 +317,7 @@ checkInjectiveArgs fc n ds (Just ty)

317317

318318 isInj i (P Bound n _) = True

319319 isInj i (P _ n _) = isConName n (tt_ctxt i)

320− isInj i (App f a) = isInj i f && isInj i a

320+ isInj i (App _ f a) = isInj i f && isInj i a

321321 isInj i (V _) = True

322322 isInj i (Bind n b sc) = isInj i sc

323323 isInj _ _ = True

src/Idris/Elab/Provider.hs+3−3

@@ -7,7 +7,6 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

1110import Idris.Coverage

1211import Idris.DataOpts

1312import Idris.Providers

@@ -22,6 +21,7 @@ import Idris.Elab.Type

2221import Idris.Elab.Clause

2322import Idris.Elab.Value

2423import Idris.Elab.Utils

24+import Idris.Elab.Term

2525

2626import Idris.Core.TT

2727import Idris.Core.Elaborate hiding (Tactic(..))

@@ -111,8 +111,8 @@ elabProvider doc info syn fc what n

111111 -- (MkFFI C_FFI) (Providers.Provider ty) in hopes of better

112112 -- error messages with less normalisation

113113 providerOf :: Type -> Type

114− providerOf ty = App (P Ref (sUN "IO") Erased) $

115− App (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)

114+ providerOf ty = App Complete (P Ref (sUN "IO") Erased) $

115+ App Complete (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)

116116 ty

117117

118118 isProviderOf :: Context -> TT Name -> TT Name -> Bool

src/Idris/Elab/Record.hs+20−2

@@ -5,7 +5,24 @@ import Idris.AbsSyntax

55import Idris.Docstrings

66import Idris.Error

77import Idris.Delaborate

8−import Idris.ParseExpr

8+import Idris.Imports

9+import Idris.Elab.Term

10+import Idris.Coverage

11+import Idris.DataOpts

12+import Idris.Providers

13+import Idris.Primitives

14+import Idris.Inliner

15+import Idris.PartialEval

16+import Idris.DeepSeq

17+import Idris.Output (iputStrLn, pshow, iWarn)

18+import IRTS.Lang

19+

20+import Idris.ParseExpr (tryFullExpr)

21+

22+import Idris.Elab.Type

23+import Idris.Elab.Data

24+import Idris.Elab.Utils

25+

926import Idris.Core.TT

1027import Idris.Core.Evaluate

1128

@@ -427,4 +444,5 @@ projectInType xs = mapPT st

427444

428445-- | Creates an PArg from a plicity and a name where the term is a PRef.

429446asPRefArg :: Plicity -> Name -> PArg

430−asPRefArg p n = asArg p (nsroot n) $ PRef emptyFC (nsroot n)

447+asPRefArg p n = asArg p (nsroot n) $ PRef emptyFC (nsroot n)

448+

src/Idris/ElabTerm.hs → src/Idris/Elab/Term.hsrenamed+329−916

@@ -1,6 +1,6 @@

1−{-# LANGUAGE PatternGuards, ViewPatterns #-}

1+{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}

22{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3−module Idris.ElabTerm where

3+module Idris.Elab.Term where

44

55import Idris.AbsSyntax

66import Idris.AbsSyntaxTree

@@ -10,11 +10,13 @@ import Idris.Error

1010import Idris.ProofSearch

1111import Idris.Output (pshow)

1212

13+import Idris.Core.CaseTree (SC, SC'(STerm), findCalls, findUsedArgs)

1314import Idris.Core.Elaborate hiding (Tactic(..))

1415import Idris.Core.TT

1516import Idris.Core.Evaluate

1617import Idris.Core.Unify

17−import Idris.Core.Typecheck (check, recheck)

18+import Idris.Core.Typecheck (check, recheck, isType)

19+import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)

1820import Idris.ErrReverse (errReverse)

1921import Idris.ElabQuasiquote (extractUnquotes)

2022import Idris.Elab.Utils

@@ -26,7 +28,7 @@ import Control.Monad

2628import Control.Monad.State.Strict

2729import Data.List

2830import qualified Data.Map as M

29−import Data.Maybe (mapMaybe, fromMaybe)

31+import Data.Maybe (mapMaybe, fromMaybe, catMaybes)

3032import qualified Data.Set as S

3133import qualified Data.Text as T

3234

@@ -35,6 +37,7 @@ import Debug.Trace

3537data ElabMode = ETyDecl | ELHS | ERHS

3638 deriving Eq

3739

40+

3841data ElabResult =

3942 ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration

4043 , resultMetavars :: [(Name, (Int, Maybe Name, Type))]

@@ -43,23 +46,10 @@ data ElabResult =

4346 -- ^ Deferred declarations as the meaning of case blocks

4447 , resultContext :: Context

4548 -- ^ The potentially extended context from new definitions

46− , resultTyDecls :: [(Name, FC, [PArg], Type)]

49+ , resultTyDecls :: [RDeclInstructions]

4750 -- ^ Meta-info about the new type declarations

4851 }

4952

50−processTacticDecls :: [(Name, FC, [PArg], Type)] -> Idris ()

51−processTacticDecls info =

52− forM_ info $ \(n, fc, impls, ty) ->

53− do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty

54− logLvl 3 $ " It has impls " ++ show impls

55− updateIState $ \i -> i { idris_implicits =

56− addDef n impls (idris_implicits i) }

57− addIBC (IBCImp n)

58− ds <- checkDef fc iderr [(n, (-1, Nothing, ty))]

59− addIBC (IBCDef n)

60− let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

61− addDeferred ds'

62−

6353

6454-- Using the elaborator, convert a term in raw syntax to a fully

6555-- elaborated, typechecked term.

@@ -122,11 +112,11 @@ build ist info emode opts fn tm

122112 update_term orderPats)

123113 EState is _ impls <- getAux

124114 tt <- get_term

125− let (tm, ds) = runState (collectDeferred (Just fn) tt) []

126− log <- getLog

127115 ctxt <- get_context

128− if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)

129− else return (ElabResult tm ds is ctxt impls)

116+ let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

117+ log <- getLog

118+ if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

119+ else return (ElabResult tm ds (map snd is) ctxt impls)

130120 where pattern = emode == ELHS

131121 tydecl = emode == ETyDecl

132122

@@ -164,11 +154,11 @@ buildTC ist info emode opts fn tm

164154 lift (Error (CantMatch (getInferTerm tm)))

165155 EState is _ impls <- getAux

166156 tt <- get_term

167− let (tm, ds) = runState (collectDeferred (Just fn) tt) []

168− log <- getLog

169157 ctxt <- get_context

170− if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)

171− else return (ElabResult tm ds is ctxt impls)

158+ let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

159+ log <- getLog

160+ if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

161+ else return (ElabResult tm ds (map snd is) ctxt impls)

172162 where pattern = emode == ELHS

173163

174164-- return whether arguments of the given constructor name can be

@@ -213,7 +203,7 @@ goal_polymorphic =

213203

214204-- | Returns the set of declarations we need to add to complete the

215205-- definition (most likely case blocks to elaborate) as well as

216−-- declarations resulting from user tactic scripts (%runTactics)

206+-- declarations resulting from user tactic scripts (%runElab)

217207elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->

218208 ElabD ()

219209elab ist info emode opts fn tm

@@ -262,9 +252,7 @@ elab ist info emode opts fn tm

262252 -- normally correct to call elabE - the ones that don't are desugarings

263253 -- typically

264254 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()

265− elabE ina fc' t =

266− --do g <- goal

267− --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

255+ elabE ina fc' t =

268256 do solved <- get_recents

269257 as <- get_autos

270258 -- If any of the autos use variables which have recently been solved,

@@ -430,7 +418,7 @@ elab ist info emode opts fn tm

430418 [pimp (sMN 0 "a") t False,

431419 pimp (sMN 0 "P") Placeholder True,

432420 pexp l, pexp r])

433− elab' ina fc (PAlternative True as)

421+ elab' ina fc (PAlternative True as)

434422 = do hnf_compute

435423 ty <- goal

436424 ctxt <- get_context

@@ -953,7 +941,7 @@ elab ist info emode opts fn tm

953941 (caseBlock fc cname'

954942 (map (isScr scr) (reverse args')) opts)

955943 -- elaborate case

956− updateAux (\e -> e { case_decls = newdef : case_decls e } )

944+ updateAux (\e -> e { case_decls = (cname', newdef) : case_decls e } )

957945 -- if we haven't got the type yet, hopefully we'll get it later!

958946 movelast tyn

959947 solve

@@ -967,7 +955,7 @@ elab ist info emode opts fn tm

967955 _ -> n

968956

969957 inApp (P _ n _) = [n]

970− inApp (App f a) = inApp f ++ inApp a

958+ inApp (App _ f a) = inApp f ++ inApp a

971959 inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

972960 inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc

973961 inApp (Bind n b sc) = inApp sc

@@ -1012,9 +1000,10 @@ elab ist info emode opts fn tm

10121000 -- Save the old state - we need a fresh proof state to avoid

10131001 -- capturing lexically available variables in the quoted term.

10141002 ctxt <- get_context

1003+ datatypes <- get_datatypes

10151004 saveState

10161005 updatePS (const .

1017− newProof (sMN 0 "q") ctxt $

1006+ newProof (sMN 0 "q") ctxt datatypes $

10181007 P Ref (reflm "TT") Erased)

10191008

10201009 -- Re-add the unquotes, letting Idris infer the (fictional)

@@ -1085,6 +1074,17 @@ elab ist info emode opts fn tm

10851074

10861075

10871076 elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"

1077+ elab' ina fc (PQuoteName n) =

1078+ do ctxt <- get_context

1079+ env <- get_env

1080+ case lookup n env of

1081+ Just _ -> do fill $ reflectName n ; solve

1082+ Nothing ->

1083+ case lookupNameDef n ctxt of

1084+ [(n', _)] -> do fill $ reflectName n'

1085+ solve

1086+ [] -> lift . tfail . NoSuchVariable $ n

1087+ more -> lift . tfail . CantResolveAlts $ map fst more

10881088 elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"

10891089 elab' ina fc (PHidden t)

10901090 | reflection = elab' ina fc t

@@ -1100,11 +1100,13 @@ elab ist info emode opts fn tm

11001100 delayElab $ do focus h

11011101 dotterm

11021102 elab' ina fc t

1103− elab' ina fc (PRunTactics fc' tm) =

1103+ elab' ina fc (PRunElab fc' tm) =

11041104 do attack

11051105 n <- getNameFrom (sMN 0 "tacticScript")

11061106 n' <- getNameFrom (sMN 0 "tacticExpr")

1107− let scriptTy = RApp (Var (sNS (sUN "Tactical") ["Tactical", "Reflection", "Language"])) (Var unitTy)

1107+ let scriptTy = RApp (Var (sNS (sUN "Elab")

1108+ ["Elab", "Reflection", "Language"]))

1109+ (Var unitTy)

11081110 claim n scriptTy

11091111 movelast n

11101112 letbind n' scriptTy (Var n)

@@ -1112,11 +1114,10 @@ elab ist info emode opts fn tm

11121114 elab' ina (Just fc') tm

11131115 env <- get_env

11141116 runTactical (maybe fc' id fc) env (P Bound n' Erased)

1115− EState _ _ todo <- getAux

11161117 solve

11171118 elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x

11181119

1119− delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

1120+ delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

11201121

11211122 isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))

11221123 isScr (PRef _ n) (n', b) = (n', (n == n', b))

@@ -1378,7 +1379,7 @@ pruneByType _ t _ as = as

13781379

13791380findInstances :: IState -> Term -> [Name]

13801381findInstances ist t

1381− | (P _ n _, _) <- unApply t

1382+ | (P _ n _, _) <- unApply (getRetTy t)

13821383 = case lookupCtxt n (idris_classes ist) of

13831384 [CI _ _ _ _ _ ins _] -> filter accessible ins

13841385 _ -> []

@@ -1429,17 +1430,17 @@ resTC' tcs defaultOn topholes depth topg fn ist

14291430 = do compute

14301431 g <- goal

14311432 let argsok = tcArgsOK g topholes

1432−-- trace (show (g,hs,argsok,topholes)) $

14331433 if not argsok -- && not mvok)

14341434 then lift $ tfail $ CantResolve True topg

14351435 else do

14361436 ptm <- get_term

14371437 ulog <- getUnifyLog

14381438 hs <- get_holes

1439− traceWhen ulog ("Resolving class " ++ show g) $

1439+ env <- get_env

1440+ traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env) $

14401441 try' (trivial' ist)

14411442 (do t <- goal

1442− let (tc, ttypes) = unApply t

1443+ let (tc, ttypes) = unApply (getRetTy t)

14431444 scopeOnly <- needsDefault t tc ttypes

14441445 let stk = elab_stack ist

14451446 let insts_in = findInstances ist t

@@ -1449,10 +1450,10 @@ resTC' tcs defaultOn topholes depth topg fn ist

14491450 let depth' = if scopeOnly then 2 else depth

14501451 blunderbuss t depth' stk (stk ++ insts)) True

14511452 where

1452− tcArgsOK ty hs | (P _ nc _, as) <- unApply ty, nc == numclass && defaultOn

1453+ tcArgsOK ty hs | (P _ nc _, as) <- unApply (getRetTy ty), nc == numclass && defaultOn

14531454 = True

14541455 tcArgsOK ty hs -- if any arguments are metavariables, postpone

1455− = let (f, as) = unApply ty in

1456+ = let (f, as) = unApply (getRetTy ty) in

14561457 case f of

14571458 P _ cn _ -> case lookupCtxtExact cn (idris_classes ist) of

14581459 Just ci -> tcDetArgsOK 0 (class_determiners ci) hs as

@@ -1469,7 +1470,7 @@ resTC' tcs defaultOn topholes depth topg fn ist

14691470 isMeta _ _ = False

14701471

14711472 notHole hs (P _ n _, c)

1472− | (P _ cn _, _) <- unApply c,

1473+ | (P _ cn _, _) <- unApply (getRetTy c),

14731474 n `elem` hs && isConName cn (tt_ctxt ist) = False

14741475 | Constant _ <- c = not (n `elem` hs)

14751476 notHole _ _ = True

@@ -1510,11 +1511,22 @@ resTC' tcs defaultOn topholes depth topg fn ist

15101511 _ -> blunderbuss t d stk ns)

15111512 | otherwise = blunderbuss t d stk ns

15121513

1514+ introImps = do g <- goal

1515+ case g of

1516+ (Bind _ (Pi _ _ _) sc) -> do attack; intro Nothing

1517+ num <- introImps

1518+ return (num + 1)

1519+ _ -> return 0

1520+

1521+ solven 0 = return ()

1522+ solven n = do solve; solven (n - 1)

1523+

15131524 resolve n depth

15141525 | depth == 0 = fail $ "Can't resolve type class"

15151526 | otherwise

1516− = do t <- goal

1517− let (tc, ttypes) = unApply t

1527+ = do lams <- introImps

1528+ t <- goal

1529+ let (tc, ttypes) = trace (show t) $ unApply (getRetTy t)

15181530-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

15191531-- else do

15201532 -- if there's a hole in the goal, don't even try

@@ -1526,14 +1538,15 @@ resTC' tcs defaultOn topholes depth topg fn ist

15261538 tm <- get_term

15271539 args <- map snd <$> try' (apply (Var n) imps)

15281540 (match_apply (Var n) imps) True

1541+ solven lams -- close any implicit lambdas we introduced

15291542 ps' <- get_probs

15301543 when (length ps < length ps' || unrecoverable ps') $

15311544 fail "Can't apply type class"

15321545-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

15331546 mapM_ (\ (_,n) -> do focus n

15341547 t' <- goal

1535− let (tc', ttype) = unApply t'

1536− let got = fst (unApply t)

1548+ let (tc', ttype) = unApply (getRetTy t')

1549+ let got = fst (unApply (getRetTy t))

15371550 let depth' = if tc' `elem` tcs

15381551 then depth - 1 else depth

15391552 resTC' (got : tcs) defaultOn topholes depth' topg fn ist)

@@ -1546,23 +1559,49 @@ resTC' tcs defaultOn topholes depth topg fn ist

15461559 where isImp (PImp p _ _ _ _) = (True, p)

15471560 isImp arg = (False, priority arg)

15481561

1549−collectDeferred :: Maybe Name ->

1562+collectDeferred :: Maybe Name -> [Name] -> Context ->

15501563 Term -> State [(Name, (Int, Maybe Name, Type))] Term

1551−collectDeferred top (Bind n (GHole i t) app) =

1564+collectDeferred top casenames ctxt (Bind n (GHole i t) app) =

15521565 do ds <- get

1553− t' <- collectDeferred top t

1554− when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, t'))])

1555− collectDeferred top app

1556−collectDeferred top (Bind n b t) = do b' <- cdb b

1557− t' <- collectDeferred top t

1558− return (Bind n b' t')

1566+ t' <- collectDeferred top casenames ctxt t

1567+ when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, tidyArg [] t'))])

1568+ collectDeferred top casenames ctxt app

1569+ where

1570+ -- Evaluate the top level functions in arguments, if possible, and if it's

1571+ -- not a name we're immediately going to define in a case block, so that

1572+ -- any immediate specialisation of the function applied to constructors

1573+ -- can be done

1574+ tidyArg env (Bind n b@(Pi im t k) sc)

1575+ = Bind n (Pi im (tidy ctxt env t) k)

1576+ (tidyArg ((n, b) : env) sc)

1577+ tidyArg env t = t

1578+

1579+ tidy ctxt env t | (f, args) <- unApply t,

1580+ P _ specn _ <- getFn f,

1581+ n `notElem` casenames

1582+ = fst $ specialise ctxt env [(specn, 99999)] t

1583+ tidy ctxt env t@(Bind n (Let _ _) sct)

1584+ | (f, args) <- unApply sct,

1585+ P _ specn _ <- getFn f,

1586+ n `notElem` casenames

1587+ = fst $ specialise ctxt env [(specn, 99999)] t

1588+ tidy ctxt env t = t

1589+

1590+ getFn (Bind n (Lam _) t) = getFn t

1591+ getFn t | (f, a) <- unApply t = f

1592+

1593+collectDeferred top ns ctxt (Bind n b t)

1594+ = do b' <- cdb b

1595+ t' <- collectDeferred top ns ctxt t

1596+ return (Bind n b' t')

15591597 where

1560− cdb (Let t v) = liftM2 Let (collectDeferred top t) (collectDeferred top v)

1561− cdb (Guess t v) = liftM2 Guess (collectDeferred top t) (collectDeferred top v)

1562− cdb b = do ty' <- collectDeferred top (binderTy b)

1598+ cdb (Let t v) = liftM2 Let (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1599+ cdb (Guess t v) = liftM2 Guess (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1600+ cdb b = do ty' <- collectDeferred top ns ctxt (binderTy b)

15631601 return (b { binderTy = ty' })

1564−collectDeferred top (App f a) = liftM2 App (collectDeferred top f) (collectDeferred top a)

1565−collectDeferred top t = return t

1602+collectDeferred top ns ctxt (App s f a) = liftM2 (App s) (collectDeferred top ns ctxt f)

1603+ (collectDeferred top ns ctxt a)

1604+collectDeferred top ns ctxt t = return t

15661605

15671606case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()

15681607case_ ind autoSolve ist fn tm = do

@@ -1582,8 +1621,6 @@ case_ ind autoSolve ist fn tm = do

15821621 else casetac (forget val)

15831622 when autoSolve solveAll

15841623

1585−tacN :: String -> Name

1586−tacN str = sNS (sUN str) ["Tactical", "Reflection", "Language"]

15871624

15881625runTactical :: FC -> Env -> Term -> ElabD ()

15891626runTactical fc env tm = do tm' <- eval tm

@@ -1591,10 +1628,50 @@ runTactical fc env tm = do tm' <- eval tm

15911628 return ()

15921629 where

15931630 eval tm = do ctxt <- get_context

1631+ env <- get_env

15941632 return $ normaliseAll ctxt env (finalise tm)

15951633

15961634 returnUnit = fmap fst $ get_type_val (Var unitCon)

15971635

1636+ patvars :: [Name] -> Term -> ([Name], Term)

1637+ patvars ns (Bind n (PVar t) sc) = patvars (n : ns) (instantiate (P Bound n t) sc)

1638+ patvars ns tm = (ns, tm)

1639+

1640+ pullVars :: (Term, Term) -> ([Name], Term, Term)

1641+ pullVars (lhs, rhs) = (fst (patvars [] lhs), snd (patvars [] lhs), snd (patvars [] rhs)) -- TODO alpha-convert rhs

1642+

1643+ defineFunction :: RFunDefn -> ElabD ()

1644+ defineFunction (RDefineFun n clauses) =

1645+ do ctxt <- get_context

1646+ ty <- maybe (fail "no type decl") return $ lookupTyExact n ctxt

1647+ let info = CaseInfo True True False -- TODO document and figure out

1648+ clauses' <- forM clauses (\case

1649+ RMkFunClause lhs rhs ->

1650+ do lhs' <- fmap fst . lift $ check ctxt [] lhs

1651+ rhs' <- fmap fst . lift $ check ctxt [] rhs

1652+ return $ Right (lhs', rhs')

1653+ RMkImpossibleClause lhs ->

1654+ do lhs' <- fmap fst . lift $ check ctxt [] lhs

1655+ return $ Left lhs')

1656+ let clauses'' = map (\case Right c -> pullVars c

1657+ Left lhs -> let (ns, lhs') = patvars [] lhs'

1658+ in (ns, lhs', Impossible))

1659+ clauses'

1660+ set_context $

1661+ addCasedef n (const [])

1662+ info False (STerm Erased)

1663+ True False -- TODO what are these?

1664+ (map snd $ getArgTys ty) [] -- TODO inaccessible types

1665+ clauses'

1666+ clauses''

1667+ clauses''

1668+ clauses''

1669+ clauses''

1670+ ty

1671+ ctxt

1672+ updateAux $ \e -> e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}

1673+ return ()

1674+

15981675 -- | Do a step in the reflected elaborator monad. The input is the

15991676 -- step, the output is the (reflected) term returned.

16001677 runTacTm :: Term -> ElabD Term

@@ -1623,6 +1700,35 @@ runTactical fc env tm = do tm' <- eval tm

16231700 else fmap fst . get_type_val $

16241701 RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))

16251702 (Var (reflm "TT"))

1703+ | n == tacN "prim__LookupTy", [n] <- args

1704+ = do n' <- reifyTTName n

1705+ ctxt <- get_context

1706+ let getNameTypeAndType = \case Function ty _ -> (Ref, ty)

1707+ TyDecl nt ty -> (nt, ty)

1708+ Operator ty _ _ -> (Ref, ty)

1709+ CaseOp _ ty _ _ _ _ -> (Ref, ty)

1710+ -- Idris tuples nest to the right

1711+ reflectTriple (x, y, z) =

1712+ raw_apply (Var pairCon) [ Var (reflm "TTName")

1713+ , raw_apply (Var pairTy) [Var (reflm "NameType"), Var (reflm "TT")]

1714+ , x

1715+ , raw_apply (Var pairCon) [ Var (reflm "NameType"), Var (reflm "TT")

1716+ , y, z]]

1717+ let defs = [ reflectTriple (reflectName n, reflectNameType nt, reflect ty)

1718+ | (n, def) <- lookupNameDef n' ctxt

1719+ , let (nt, ty) = getNameTypeAndType def ]

1720+ fmap fst . get_type_val $

1721+ rawList (raw_apply (Var pairTy) [ Var (reflm "TTName")

1722+ , raw_apply (Var pairTy) [ Var (reflm "NameType")

1723+ , Var (reflm "TT")]])

1724+ defs

1725+ | n == tacN "prim__LookupDatatype", [name] <- args

1726+ = do n' <- reifyTTName name

1727+ datatypes <- get_datatypes

1728+ ctxt <- get_context

1729+ fmap fst . get_type_val $

1730+ rawList (Var (tacN "Datatype"))

1731+ (map reflectDatatype (buildDatatypes ctxt datatypes n'))

16261732 | n == tacN "prim__SourceLocation", [] <- args

16271733 = fmap fst . get_type_val $

16281734 reflectFC fc

@@ -1633,19 +1739,23 @@ runTactical fc env tm = do tm' <- eval tm

16331739 = do errs' <- eval errs

16341740 parts <- reifyReportParts errs'

16351741 lift . tfail $ ReflectionError [parts] (Msg "")

1636− | n == tacN "prim__PureTactical", [_a, tm] <- args

1742+ | n == tacN "prim__PureElab", [_a, tm] <- args

16371743 = return tm

1638− | n == tacN "prim__BindTactical", [_a, _b, first, andThen] <- args

1744+ | n == tacN "prim__BindElab", [_a, _b, first, andThen] <- args

16391745 = do first' <- eval first

1640− res <- runTacTm first'

1641− next <- eval (App andThen res)

1746+ res <- eval =<< runTacTm first'

1747+ next <- eval (App Complete andThen res)

16421748 runTacTm next

16431749 | n == tacN "prim__Try", [_a, first, alt] <- args

16441750 = do first' <- eval first

16451751 alt' <- eval alt

16461752 try' (runTacTm first') (runTacTm alt') True

16471753 | n == tacN "prim__Fill", [raw] <- args

1648− = do raw' <- reifyRaw raw

1754+ = do raw' <- reifyRaw =<< eval raw

1755+ fill raw'

1756+ returnUnit

1757+ | n == tacN "prim__Apply", [raw] <- args

1758+ = do raw' <- reifyRaw =<< eval raw

16491759 apply raw' []

16501760 returnUnit

16511761 | n == tacN "prim__Gensym", [hint] <- args

@@ -1662,7 +1772,7 @@ runTactical fc env tm = do tm' <- eval tm

16621772 returnUnit

16631773 | n == tacN "prim__Forget", [tt] <- args

16641774 = do tt' <- reifyTT tt

1665− fmap fst . get_type_val $ reflect tt'

1775+ fmap fst . get_type_val . reflectRaw $ forget tt'

16661776 | n == tacN "prim__Attack", [] <- args

16671777 = do attack

16681778 returnUnit

@@ -1684,6 +1794,21 @@ runTactical fc env tm = do tm' <- eval tm

16841794 Just name -> fmap Just $ reifyTTName name

16851795 intro n

16861796 returnUnit

1797+ | n == tacN "prim__Forall", [n, ty] <- args

1798+ = do n' <- reifyTTName n

1799+ ty' <- reifyRaw ty

1800+ forall n' Nothing ty'

1801+ returnUnit

1802+ | n == tacN "prim__PatVar", [n] <- args

1803+ = do n' <- reifyTTName n

1804+ patvar n'

1805+ returnUnit

1806+ | n == tacN "prim__PatBind", [n] <- args

1807+ = do n' <- reifyTTName n

1808+ patbind n'

1809+ returnUnit

1810+ | n == tacN "prim__Compute", [] <- args

1811+ = do compute ; returnUnit

16871812 | n == tacN "prim__DeclareType", [decl] <- args

16881813 = do (RDeclare n args res) <- reifyTyDecl decl

16891814 ctxt <- get_context

@@ -1693,9 +1818,10 @@ runTactical fc env tm = do tm' <- eval tm

16931818 rty = foldr mkPi res args

16941819 (checked, ty') <- lift $ check ctxt [] rty

16951820 case normaliseAll ctxt [] (finalise ty') of

1696− TType _ -> lift . tfail . InternalMsg $

1697− show checked ++ " is not a type: it's " ++ show ty'

1698− _ -> return ()

1821+ UType _ -> return ()

1822+ TType _ -> return ()

1823+ ty'' -> lift . tfail . InternalMsg $

1824+ show checked ++ " is not a type: it's " ++ show ty''

16991825 case lookupDefExact n ctxt of

17001826 Just _ -> lift . tfail . InternalMsg $

17011827 show n ++ " is already defined."

@@ -1703,17 +1829,41 @@ runTactical fc env tm = do tm' <- eval tm

17031829 let decl = TyDecl Ref checked

17041830 ctxt' = addCtxtDef n decl ctxt

17051831 set_context ctxt'

1706− updateAux $ \e -> e { new_tyDecls = (n, fc, map rArgToPArg args, checked) :

1832+ updateAux $ \e -> e { new_tyDecls = (RTyDeclInstrs n fc (map rArgToPArg args) checked) :

17071833 new_tyDecls e }

17081834 aux <- getAux

17091835 returnUnit

1836+ | n == tacN "prim__DefineFunction", [decl] <- args

1837+ = do defn <- reifyFunDefn decl

1838+ defineFunction defn

1839+ returnUnit

1840+ | n == tacN "prim__RecursiveElab", [goal, script] <- args

1841+ = do goal' <- reifyRaw goal

1842+ ctxt <- get_context

1843+ script <- eval script

1844+ (goalTT, goalTy) <- lift $ check ctxt [] goal'

1845+ lift $ isType ctxt [] goalTy

1846+ recH <- getNameFrom (sMN 0 "recElabHole")

1847+ aux <- getAux

1848+ datatypes <- get_datatypes

1849+ env <- get_env

1850+ (tm_out, ES (_, aux') _ _) <-

1851+ lift $ runElab aux (runTactical fc env script >> solve >> get_term)

1852+ (newProof recH ctxt datatypes goalTT)

1853+ updateAux $ const aux'

1854+ env' <- get_env

1855+ (tm, ty, _) <- lift $ recheck ctxt env (forget tm_out) tm_out

1856+ let (tm', ty') = (reflect tm, reflect ty)

1857+ fmap fst . get_type_val $

1858+ rawPair (Var $ reflm "TT", Var $ reflm "TT")

1859+ (tm', ty')

17101860 | n == tacN "prim__Debug", [ty, msg] <- args

17111861 = do let msg' = fromTTMaybe msg

17121862 case msg' of

17131863 Nothing -> debugElaborator Nothing

17141864 Just (Constant (Str m)) -> debugElaborator (Just m)

17151865 Just x -> lift . tfail . InternalMsg $ "Can't reify message for debugging: " ++ show x

1716− runTacTm x = lift . tfail . InternalMsg $ "tactical is not implemented for " ++ show x

1866+ runTacTm x = lift . tfail $ ElabScriptStuck x

17171867

17181868-- Running tactics directly

17191869-- if a tactic adds unification problems, return an error

@@ -1968,781 +2118,6 @@ runTac autoSolve ist perhapsFC fn tac

19682118 runReflected t = do t' <- reify ist t

19692119 runTac autoSolve ist perhapsFC fn t'

19702120

1971−-- | Prefix a name with the "Language.Reflection" namespace

1972−reflm :: String -> Name

1973−reflm n = sNS (sUN n) ["Reflection", "Language"]

1974−

1975−

1976−-- | Reify tactics from their reflected representation

1977−reify :: IState -> Term -> ElabD PTactic

1978−reify _ (P _ n _) | n == reflm "Intros" = return Intros

1979−reify _ (P _ n _) | n == reflm "Trivial" = return Trivial

1980−reify _ (P _ n _) | n == reflm "Instance" = return TCInstance

1981−reify _ (P _ n _) | n == reflm "Solve" = return Solve

1982−reify _ (P _ n _) | n == reflm "Compute" = return Compute

1983−reify _ (P _ n _) | n == reflm "Skip" = return Skip

1984−reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC

1985−reify _ (P _ n _) | n == reflm "Unfocus" = return Unfocus

1986−reify ist t@(App _ _)

1987− | (P _ f _, args) <- unApply t = reifyApp ist f args

1988−reify _ t = fail ("Unknown tactic " ++ show t)

1989−

1990−reifyApp :: IState -> Name -> [Term] -> ElabD PTactic

1991−reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)

1992−reifyApp _ t [Constant (I i)]

1993− | t == reflm "Search" = return (ProofSearch True True i Nothing [])

1994−reifyApp _ t [x]

1995− | t == reflm "Refine" = do n <- reifyTTName x

1996− return $ Refine n []

1997−reifyApp ist t [n, ty] | t == reflm "Claim" = do n' <- reifyTTName n

1998− goal <- reifyTT ty

1999− return $ Claim n' (delab ist goal)

2000−reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

2001−reifyApp ist t [Constant (Str n), x]

2002− | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

2003−reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)

2004−reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')

2005−reifyApp ist t [t'] | t == reflm "Case" = liftM (Induction . delab ist) (reifyTT t')

2006−reifyApp ist t [t']

2007− | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

2008−reifyApp ist t [t']

2009− | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

2010−reifyApp ist t [t']

2011− | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

2012−reifyApp _ t [t']

2013− | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

2014−reifyApp ist t [t']

2015− | t == reflm "Exact" = liftM (Exact . delab ist) (reifyTT t')

2016−reifyApp ist t [x]

2017− | t == reflm "Focus" = liftM Focus (reifyTTName x)

2018−reifyApp ist t [t']

2019− | t == reflm "Rewrite" = liftM (Rewrite . delab ist) (reifyTT t')

2020−reifyApp ist t [n, t']

2021− | t == reflm "LetTac" = do n' <- reifyTTName n

2022− t'' <- reifyTT t'

2023− return $ LetTac n' (delab ist t')

2024−reifyApp ist t [n, tt', t']

2025− | t == reflm "LetTacTy" = do n' <- reifyTTName n

2026− tt'' <- reifyTT tt'

2027− t'' <- reifyTT t'

2028− return $ LetTacTy n' (delab ist tt'') (delab ist t'')

2029−reifyApp ist t [errs]

2030− | t == reflm "Fail" = fmap TFail (reifyReportParts errs)

2031−reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen

2032−

2033−reifyReportParts :: Term -> ElabD [ErrorReportPart]

2034−reifyReportParts errs =

2035− case unList errs of

2036− Nothing -> fail "Failed to reify errors"

2037− Just errs' ->

2038− let parts = mapM reifyReportPart errs' in

2039− case parts of

2040− Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err

2041− Right errs'' ->

2042− return errs''

2043−

2044−-- | Reify terms from their reflected representation

2045−reifyTT :: Term -> ElabD Term

2046−reifyTT t@(App _ _)

2047− | (P _ f _, args) <- unApply t = reifyTTApp f args

2048−reifyTT t@(P _ n _)

2049− | n == reflm "Erased" = return $ Erased

2050−reifyTT t@(P _ n _)

2051− | n == reflm "Impossible" = return $ Impossible

2052−reifyTT t = fail ("Unknown reflection term: " ++ show t)

2053−

2054−reifyTTApp :: Name -> [Term] -> ElabD Term

2055−reifyTTApp t [nt, n, x]

2056− | t == reflm "P" = do nt' <- reifyTTNameType nt

2057− n' <- reifyTTName n

2058− x' <- reifyTT x

2059− return $ P nt' n' x'

2060−reifyTTApp t [Constant (I i)]

2061− | t == reflm "V" = return $ V i

2062−reifyTTApp t [n, b, x]

2063− | t == reflm "Bind" = do n' <- reifyTTName n

2064− b' <- reifyTTBinder reifyTT (reflm "TT") b

2065− x' <- reifyTT x

2066− return $ Bind n' b' x'

2067−reifyTTApp t [f, x]

2068− | t == reflm "App" = do f' <- reifyTT f

2069− x' <- reifyTT x

2070− return $ App f' x'

2071−reifyTTApp t [c]

2072− | t == reflm "TConst" = liftM Constant (reifyTTConst c)

2073−reifyTTApp t [t', Constant (I i)]

2074− | t == reflm "Proj" = do t'' <- reifyTT t'

2075− return $ Proj t'' i

2076−reifyTTApp t [tt]

2077− | t == reflm "TType" = liftM TType (reifyTTUExp tt)

2078−reifyTTApp t args = fail ("Unknown reflection term: " ++ show (t, args))

2079−

2080−-- | Reify raw terms from their reflected representation

2081−reifyRaw :: Term -> ElabD Raw

2082−reifyRaw t@(App _ _)

2083− | (P _ f _, args) <- unApply t = reifyRawApp f args

2084−reifyRaw t@(P _ n _)

2085− | n == reflm "RType" = return $ RType

2086−reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t)

2087−

2088−reifyRawApp :: Name -> [Term] -> ElabD Raw

2089−reifyRawApp t [n]

2090− | t == reflm "Var" = liftM Var (reifyTTName n)

2091−reifyRawApp t [n, b, x]

2092− | t == reflm "RBind" = do n' <- reifyTTName n

2093− b' <- reifyTTBinder reifyRaw (reflm "Raw") b

2094− x' <- reifyRaw x

2095− return $ RBind n' b' x'

2096−reifyRawApp t [f, x]

2097− | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)

2098−reifyRawApp t [t']

2099− | t == reflm "RForce" = liftM RForce (reifyRaw t')

2100−reifyRawApp t [c]

2101− | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)

2102−reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))

2103−

2104−reifyTTName :: Term -> ElabD Name

2105−reifyTTName t

2106− | (P _ f _, args) <- unApply t = reifyTTNameApp f args

2107−reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

2108−

2109−reifyTTNameApp :: Name -> [Term] -> ElabD Name

2110−reifyTTNameApp t [Constant (Str n)]

2111− | t == reflm "UN" = return $ sUN n

2112−reifyTTNameApp t [n, ns]

2113− | t == reflm "NS" = do n' <- reifyTTName n

2114− ns' <- reifyTTNamespace ns

2115− return $ sNS n' ns'

2116−reifyTTNameApp t [Constant (I i), Constant (Str n)]

2117− | t == reflm "MN" = return $ sMN i n

2118−reifyTTNameApp t []

2119− | t == reflm "NErased" = return NErased

2120−reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

2121−

2122−reifyTTNamespace :: Term -> ElabD [String]

2123−reifyTTNamespace t@(App _ _)

2124− = case unApply t of

2125− (P _ f _, [Constant StrType])

2126− | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

2127− (P _ f _, [Constant StrType, Constant (Str n), ns])

2128− | f == sNS (sUN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

2129− _ -> fail ("Unknown reflection namespace arg: " ++ show t)

2130−reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

2131−

2132−reifyTTNameType :: Term -> ElabD NameType

2133−reifyTTNameType t@(P _ n _) | n == reflm "Bound" = return $ Bound

2134−reifyTTNameType t@(P _ n _) | n == reflm "Ref" = return $ Ref

2135−reifyTTNameType t@(App _ _)

2136− = case unApply t of

2137− (P _ f _, [Constant (I tag), Constant (I num)])

2138− | f == reflm "DCon" -> return $ DCon tag num False -- FIXME: Uniqueness!

2139− | f == reflm "TCon" -> return $ TCon tag num

2140− _ -> fail ("Unknown reflection name type: " ++ show t)

2141−reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)

2142−

2143−reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)

2144−reifyTTBinder reificator binderType t@(App _ _)

2145− = case unApply t of

2146− (P _ f _, bt:args) | forget bt == Var binderType

2147− -> reifyTTBinderApp reificator f args

2148− _ -> fail ("Mismatching binder reflection: " ++ show t)

2149−reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)

2150−

2151−reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)

2152−reifyTTBinderApp reif f [t]

2153− | f == reflm "Lam" = liftM Lam (reif t)

2154−reifyTTBinderApp reif f [t, k]

2155− | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)

2156−reifyTTBinderApp reif f [x, y]

2157− | f == reflm "Let" = liftM2 Let (reif x) (reif y)

2158−reifyTTBinderApp reif f [x, y]

2159− | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)

2160−reifyTTBinderApp reif f [t]

2161− | f == reflm "Hole" = liftM Hole (reif t)

2162−reifyTTBinderApp reif f [t]

2163− | f == reflm "GHole" = liftM (GHole 0) (reif t)

2164−reifyTTBinderApp reif f [x, y]

2165− | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)

2166−reifyTTBinderApp reif f [t]

2167− | f == reflm "PVar" = liftM PVar (reif t)

2168−reifyTTBinderApp reif f [t]

2169− | f == reflm "PVTy" = liftM PVTy (reif t)

2170−reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))

2171−

2172−reifyTTConst :: Term -> ElabD Const

2173−reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType

2174−reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType

2175−reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot

2176−reifyTTConst t@(App _ _)

2177− | (P _ f _, [arg]) <- unApply t = reifyTTConstApp f arg

2178−reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)

2179−

2180−reifyTTConstApp :: Name -> Term -> ElabD Const

2181−reifyTTConstApp f aty

2182− | f == reflm "AType" = fmap AType (reifyArithTy aty)

2183−reifyTTConstApp f (Constant c@(I _))

2184− | f == reflm "I" = return $ c

2185−reifyTTConstApp f (Constant c@(BI _))

2186− | f == reflm "BI" = return $ c

2187−reifyTTConstApp f (Constant c@(Fl _))

2188− | f == reflm "Fl" = return $ c

2189−reifyTTConstApp f (Constant c@(I _))

2190− | f == reflm "Ch" = return $ c

2191−reifyTTConstApp f (Constant c@(Str _))

2192− | f == reflm "Str" = return $ c

2193−reifyTTConstApp f (Constant c@(B8 _))

2194− | f == reflm "B8" = return $ c

2195−reifyTTConstApp f (Constant c@(B16 _))

2196− | f == reflm "B16" = return $ c

2197−reifyTTConstApp f (Constant c@(B32 _))

2198− | f == reflm "B32" = return $ c

2199−reifyTTConstApp f (Constant c@(B64 _))

2200− | f == reflm "B64" = return $ c

2201−reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))

2202−

2203−reifyArithTy :: Term -> ElabD ArithTy

2204−reifyArithTy (App (P _ n _) intTy) | n == reflm "ATInt" = fmap ATInt (reifyIntTy intTy)

2205−reifyArithTy (P _ n _) | n == reflm "ATFloat" = return ATFloat

2206−reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

2207−

2208−reifyNativeTy :: Term -> ElabD NativeTy

2209−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

2210−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

2211−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

2212−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

2213−reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

2214−

2215−reifyIntTy :: Term -> ElabD IntTy

2216−reifyIntTy (App (P _ n _) nt) | n == reflm "ITFixed" = fmap ITFixed (reifyNativeTy nt)

2217−reifyIntTy (P _ n _) | n == reflm "ITNative" = return ITNative

2218−reifyIntTy (P _ n _) | n == reflm "ITBig" = return ITBig

2219−reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar

2220−reifyIntTy tm = fail $ "The term " ++ show tm ++ " is not a reflected IntTy"

2221−

2222−reifyTTUExp :: Term -> ElabD UExp

2223−reifyTTUExp t@(App _ _)

2224− = case unApply t of

2225− (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i

2226− (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i

2227− _ -> fail ("Unknown reflection type universe expression: " ++ show t)

2228−reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)

2229−

2230−-- | Create a reflected call to a named function/constructor

2231−reflCall :: String -> [Raw] -> Raw

2232−reflCall funName args

2233− = raw_apply (Var (reflm funName)) args

2234−

2235−-- | Lift a term into its Language.Reflection.TT representation

2236−reflect :: Term -> Raw

2237−reflect = reflectTTQuote []

2238−

2239−-- | Lift a term into its Language.Reflection.Raw representation

2240−reflectRaw :: Raw -> Raw

2241−reflectRaw = reflectRawQuote []

2242−

2243−claimTT :: Name -> ElabD Name

2244−claimTT n = do n' <- getNameFrom n

2245− claim n' (Var (sNS (sUN "TT") ["Reflection", "Language"]))

2246− return n'

2247−

2248−-- | Convert a reflected term to a more suitable form for pattern-matching.

2249−-- In particular, the less-interesting bits are elaborated to _ patterns. This

2250−-- happens to NameTypes, universe levels, names that are bound but not used,

2251−-- and the type annotation field of the P constructor.

2252−reflectTTQuotePattern :: [Name] -> Term -> ElabD ()

2253−reflectTTQuotePattern unq (P _ n _)

2254− | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them

2255− do fill (Var n) ; solve

2256− | otherwise =

2257− do tyannot <- claimTT (sMN 0 "pTyAnnot")

2258− movelast tyannot -- use a _ pattern here

2259− nt <- getNameFrom (sMN 0 "nt")

2260− claim nt (Var (reflm "NameType"))

2261− movelast nt -- use a _ pattern here

2262− n' <- getNameFrom (sMN 0 "n")

2263− claim n' (Var (reflm "TTName"))

2264− fill $ reflCall "P" [Var nt, Var n', Var tyannot]

2265− solve

2266− focus n'; reflectNameQuotePattern n

2267−reflectTTQuotePattern unq (V n)

2268− = do fill $ reflCall "V" [RConstant (I n)]

2269− solve

2270−reflectTTQuotePattern unq (Bind n b x)

2271− = do x' <- claimTT (sMN 0 "sc")

2272− movelast x'

2273− b' <- getNameFrom (sMN 0 "binder")

2274− claim b' (RApp (Var (sNS (sUN "Binder") ["Reflection", "Language"]))

2275− (Var (sNS (sUN "TT") ["Reflection", "Language"])))

2276− if n `elem` freeNames x

2277− then do fill $ reflCall "Bind"

2278− [reflectName n,

2279− Var b',

2280− Var x']

2281− solve

2282− else do any <- getNameFrom (sMN 0 "anyName")

2283− claim any (Var (reflm "TTName"))

2284− movelast any

2285− fill $ reflCall "Bind"

2286− [Var any,

2287− Var b',

2288− Var x']

2289− solve

2290− focus x'; reflectTTQuotePattern unq x

2291− focus b'; reflectBinderQuotePattern reflectTTQuotePattern unq b

2292−reflectTTQuotePattern unq (App f x)

2293− = do f' <- claimTT (sMN 0 "f"); movelast f'

2294− x' <- claimTT (sMN 0 "x"); movelast x'

2295− fill $ reflCall "App" [Var f', Var x']

2296− solve

2297− focus f'; reflectTTQuotePattern unq f

2298− focus x'; reflectTTQuotePattern unq x

2299−reflectTTQuotePattern unq (Constant c)

2300− = do fill $ reflCall "TConst" [reflectConstant c]

2301− solve

2302−reflectTTQuotePattern unq (Proj t i)

2303− = do t' <- claimTT (sMN 0 "t"); movelast t'

2304− fill $ reflCall "Proj" [Var t', RConstant (I i)]

2305− solve

2306− focus t'; reflectTTQuotePattern unq t

2307−reflectTTQuotePattern unq (Erased)

2308− = do erased <- claimTT (sMN 0 "erased")

2309− movelast erased

2310− fill $ (Var erased)

2311− solve

2312−reflectTTQuotePattern unq (Impossible)

2313− = do fill $ Var (reflm "Impossible")

2314− solve

2315−reflectTTQuotePattern unq (TType exp)

2316− = do ue <- getNameFrom (sMN 0 "uexp")

2317− claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

2318− movelast ue

2319− fill $ reflCall "TType" [Var ue]

2320− solve

2321−reflectTTQuotePattern unq (UType u)

2322− = do uH <- getNameFrom (sMN 0 "someUniv")

2323− claim uH (Var (reflm "Universe"))

2324− movelast uH

2325− fill $ reflCall "UType" [Var uH]

2326− solve

2327− focus uH

2328− fill (Var (reflm (case u of

2329− NullType -> "NullType"

2330− UniqueType -> "UniqueType"

2331− AllTypes -> "AllTypes")))

2332− solve

2333−

2334−reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()

2335−reflectRawQuotePattern unq (Var n)

2336− -- the unquoted names already have types, just use them

2337− | n `elem` unq = do fill (Var n); solve

2338− | otherwise = do fill (reflCall "Var" [reflectName n]); solve

2339−reflectRawQuotePattern unq (RBind n b sc) =

2340− do scH <- getNameFrom (sMN 0 "sc")

2341− claim scH (Var (reflm "Raw"))

2342− movelast scH

2343− bH <- getNameFrom (sMN 0 "binder")

2344− claim bH (RApp (Var (reflm "Binder"))

2345− (Var (reflm "Raw")))

2346− if n `elem` freeNamesR sc

2347− then do fill $ reflCall "RBind" [reflectName n,

2348− Var bH,

2349− Var scH]

2350− solve

2351− else do any <- getNameFrom (sMN 0 "anyName")

2352− claim any (Var (reflm "TTName"))

2353− movelast any

2354− fill $ reflCall "RBind" [Var any, Var bH, Var scH]

2355− solve

2356− focus scH; reflectRawQuotePattern unq sc

2357− focus bH; reflectBinderQuotePattern reflectRawQuotePattern unq b

2358− where freeNamesR (Var n) = [n]

2359− freeNamesR (RBind n (Let t v) body) = concat [freeNamesR v,

2360− freeNamesR body \\ [n],

2361− freeNamesR t]

2362− freeNamesR (RBind n b body) = freeNamesR (binderTy b) ++

2363− (freeNamesR body \\ [n])

2364− freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x

2365− freeNamesR RType = []

2366− freeNamesR (RUType _) = []

2367− freeNamesR (RForce r) = freeNamesR r

2368− freeNamesR (RConstant _) = []

2369−reflectRawQuotePattern unq (RApp f x) =

2370− do fH <- getNameFrom (sMN 0 "f")

2371− claim fH (Var (reflm "Raw"))

2372− movelast fH

2373− xH <- getNameFrom (sMN 0 "x")

2374− claim xH (Var (reflm "Raw"))

2375− movelast xH

2376− fill $ reflCall "RApp" [Var fH, Var xH]

2377− solve

2378− focus fH; reflectRawQuotePattern unq f

2379− focus xH; reflectRawQuotePattern unq x

2380−reflectRawQuotePattern unq RType =

2381− do fill (Var (reflm "RType"))

2382− solve

2383−reflectRawQuotePattern unq (RUType univ) =

2384− do uH <- getNameFrom (sMN 0 "universe")

2385− claim uH (Var (reflm "Universe"))

2386− movelast uH

2387− fill $ reflCall "RUType" [Var uH]

2388− solve

2389− focus uH; fill (reflectUniverse univ); solve

2390−reflectRawQuotePattern unq (RForce r) =

2391− do rH <- getNameFrom (sMN 0 "raw")

2392− claim rH (Var (reflm "Raw"))

2393− movelast rH

2394− fill $ reflCall "RForce" [Var rH]

2395− solve

2396− focus rH; reflectRawQuotePattern unq r

2397−reflectRawQuotePattern unq (RConstant c) =

2398− do cH <- getNameFrom (sMN 0 "const")

2399− claim cH (Var (reflm "Constant"))

2400− movelast cH

2401− fill (reflCall "RConstant" [Var cH]); solve

2402− focus cH

2403− fill (reflectConstant c); solve

2404−

2405−reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()

2406−reflectBinderQuotePattern q unq (Lam t)

2407− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2408− fill $ reflCall "Lam" [Var (reflm "TT"), Var t']

2409− solve

2410− focus t'; q unq t

2411−reflectBinderQuotePattern q unq (Pi _ t k)

2412− = do t' <- claimTT (sMN 0 "ty") ; movelast t'

2413− k' <- claimTT (sMN 0 "k"); movelast k';

2414− fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']

2415− solve

2416− focus t'; q unq t

2417−reflectBinderQuotePattern q unq (Let x y)

2418− = do x' <- claimTT (sMN 0 "ty"); movelast x';

2419− y' <- claimTT (sMN 0 "v"); movelast y';

2420− fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']

2421− solve

2422− focus x'; q unq x

2423− focus y'; q unq y

2424−reflectBinderQuotePattern q unq (NLet x y)

2425− = do x' <- claimTT (sMN 0 "ty"); movelast x'

2426− y' <- claimTT (sMN 0 "v"); movelast y'

2427− fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']

2428− solve

2429− focus x'; q unq x

2430− focus y'; q unq y

2431−reflectBinderQuotePattern q unq (Hole t)

2432− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2433− fill $ reflCall "Hole" [Var (reflm "TT"), Var t']

2434− solve

2435− focus t'; q unq t

2436−reflectBinderQuotePattern q unq (GHole _ t)

2437− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2438− fill $ reflCall "GHole" [Var (reflm "TT"), Var t']

2439− solve

2440− focus t'; q unq t

2441−reflectBinderQuotePattern q unq (Guess x y)

2442− = do x' <- claimTT (sMN 0 "ty"); movelast x'

2443− y' <- claimTT (sMN 0 "v"); movelast y'

2444− fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']

2445− solve

2446− focus x'; q unq x

2447− focus y'; q unq y

2448−reflectBinderQuotePattern q unq (PVar t)

2449− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2450− fill $ reflCall "PVar" [Var (reflm "TT"), Var t']

2451− solve

2452− focus t'; q unq t

2453−reflectBinderQuotePattern q unq (PVTy t)

2454− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2455− fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']

2456− solve

2457− focus t'; q unq t

2458−

2459−reflectUniverse :: Universe -> Raw

2460−reflectUniverse u =

2461− (Var (reflm (case u of

2462− NullType -> "NullType"

2463− UniqueType -> "UniqueType"

2464− AllTypes -> "AllTypes")))

2465−

2466−-- | Create a reflected TT term, but leave refs to the provided name intact

2467−reflectTTQuote :: [Name] -> Term -> Raw

2468−reflectTTQuote unq (P nt n t)

2469− | n `elem` unq = Var n

2470− | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]

2471−reflectTTQuote unq (V n)

2472− = reflCall "V" [RConstant (I n)]

2473−reflectTTQuote unq (Bind n b x)

2474− = reflCall "Bind" [reflectName n, reflectBinderQuote reflectTTQuote (reflm "TT") unq b, reflectTTQuote unq x]

2475−reflectTTQuote unq (App f x)

2476− = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]

2477−reflectTTQuote unq (Constant c)

2478− = reflCall "TConst" [reflectConstant c]

2479−reflectTTQuote unq (Proj t i)

2480− = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]

2481−reflectTTQuote unq (Erased) = Var (reflm "Erased")

2482−reflectTTQuote unq (Impossible) = Var (reflm "Impossible")

2483−reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

2484−reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]

2485−

2486−reflectRawQuote :: [Name] -> Raw -> Raw

2487−reflectRawQuote unq (Var n)

2488− | n `elem` unq = Var n

2489− | otherwise = reflCall "Var" [reflectName n]

2490−reflectRawQuote unq (RBind n b r) =

2491− reflCall "RBind" [reflectName n, reflectBinderQuote reflectRawQuote (reflm "Raw") unq b, reflectRawQuote unq r]

2492−reflectRawQuote unq (RApp f x) =

2493− reflCall "RApp" [reflectRawQuote unq f, reflectRawQuote unq x]

2494−reflectRawQuote unq RType = Var (reflm "RType")

2495−reflectRawQuote unq (RUType u) =

2496− reflCall "RUType" [reflectUniverse u]

2497−reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]

2498−reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]

2499−

2500−reflectNameType :: NameType -> Raw

2501−reflectNameType (Bound) = Var (reflm "Bound")

2502−reflectNameType (Ref) = Var (reflm "Ref")

2503−reflectNameType (DCon x y _)

2504− = reflCall "DCon" [RConstant (I x), RConstant (I y)] -- FIXME: Uniqueness!

2505−reflectNameType (TCon x y)

2506− = reflCall "TCon" [RConstant (I x), RConstant (I y)]

2507−

2508−reflectName :: Name -> Raw

2509−reflectName (UN s)

2510− = reflCall "UN" [RConstant (Str (str s))]

2511−reflectName (NS n ns)

2512− = reflCall "NS" [ reflectName n

2513− , foldr (\ n s ->

2514− raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

2515− [ RConstant StrType, RConstant (Str n), s ])

2516− ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

2517− [ RConstant StrType ])

2518− (map str ns)

2519− ]

2520−reflectName (MN i n)

2521− = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

2522−reflectName (NErased) = Var (reflm "NErased")

2523−reflectName n = Var (reflm "NErased") -- special name, not yet implemented

2524−

2525−-- | Elaborate a name to a pattern. This means that NS and UN will be intact.

2526−-- MNs corresponding to will care about the string but not the number. All

2527−-- others become _.

2528−reflectNameQuotePattern :: Name -> ElabD ()

2529−reflectNameQuotePattern n@(UN s)

2530− = do fill $ reflectName n

2531− solve

2532−reflectNameQuotePattern n@(NS _ _)

2533− = do fill $ reflectName n

2534− solve

2535−reflectNameQuotePattern (MN _ n)

2536− = do i <- getNameFrom (sMN 0 "mnCounter")

2537− claim i (RConstant (AType (ATInt ITNative)))

2538− movelast i

2539− fill $ reflCall "MN" [Var i, RConstant (Str $ T.unpack n)]

2540− solve

2541−reflectNameQuotePattern _ -- for all other names, match any

2542− = do nameHole <- getNameFrom (sMN 0 "name")

2543− claim nameHole (Var (reflm "TTName"))

2544− movelast nameHole

2545− fill (Var nameHole)

2546− solve

2547−

2548−reflectBinder :: Binder Term -> Raw

2549−reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []

2550−

2551−reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw

2552−reflectBinderQuote q ty unq (Lam t)

2553− = reflCall "Lam" [Var ty, q unq t]

2554−reflectBinderQuote q ty unq (Pi _ t k)

2555− = reflCall "Pi" [Var ty, q unq t, q unq k]

2556−reflectBinderQuote q ty unq (Let x y)

2557− = reflCall "Let" [Var ty, q unq x, q unq y]

2558−reflectBinderQuote q ty unq (NLet x y)

2559− = reflCall "NLet" [Var ty, q unq x, q unq y]

2560−reflectBinderQuote q ty unq (Hole t)

2561− = reflCall "Hole" [Var ty, q unq t]

2562−reflectBinderQuote q ty unq (GHole _ t)

2563− = reflCall "GHole" [Var ty, q unq t]

2564−reflectBinderQuote q ty unq (Guess x y)

2565− = reflCall "Guess" [Var ty, q unq x, q unq y]

2566−reflectBinderQuote q ty unq (PVar t)

2567− = reflCall "PVar" [Var ty, q unq t]

2568−reflectBinderQuote q ty unq (PVTy t)

2569− = reflCall "PVTy" [Var ty, q unq t]

2570−

2571−mkList :: Raw -> [Raw] -> Raw

2572−mkList ty [] = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty

2573−mkList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"])) ty)

2574− x)

2575− (mkList ty xs)

2576−

2577−reflectConstant :: Const -> Raw

2578−reflectConstant c@(I _) = reflCall "I" [RConstant c]

2579−reflectConstant c@(BI _) = reflCall "BI" [RConstant c]

2580−reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]

2581−reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]

2582−reflectConstant c@(Str _) = reflCall "Str" [RConstant c]

2583−reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]

2584−reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]

2585−reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]

2586−reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]

2587−reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]

2588−reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]

2589−reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATFloat")]

2590−reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]

2591−reflectConstant StrType = Var (reflm "StrType")

2592−reflectConstant (AType (ATInt (ITFixed IT8))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]

2593−reflectConstant (AType (ATInt (ITFixed IT16))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT16")]]]

2594−reflectConstant (AType (ATInt (ITFixed IT32))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT32")]]]

2595−reflectConstant (AType (ATInt (ITFixed IT64))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT64")]]]

2596−reflectConstant VoidType = Var (reflm "VoidType")

2597−reflectConstant Forgot = Var (reflm "Forgot")

2598−reflectConstant WorldType = Var (reflm "WorldType")

2599−reflectConstant TheWorld = Var (reflm "TheWorld")

2600−

2601−reflectUExp :: UExp -> Raw

2602−reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]

2603−reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]

2604−

2605−-- | Reflect the environment of a proof into a List (TTName, Binder TT)

2606−reflectEnv :: Env -> Raw

2607−reflectEnv = foldr consToEnvList emptyEnvList

2608− where

2609− consToEnvList :: (Name, Binder Term) -> Raw -> Raw

2610− consToEnvList (n, b) l

2611− = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

2612− [ envTupleType

2613− , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

2614− , (RApp (Var $ reflm "Binder")

2615− (Var $ reflm "TT"))

2616− , reflectName n

2617− , reflectBinder b

2618− ]

2619− , l

2620− ]

2621−

2622− emptyEnvList :: Raw

2623− emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

2624− [envTupleType]

2625−

2626−-- | Reflect an error into the internal datatype of Idris -- TODO

2627−rawBool :: Bool -> Raw

2628−rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"])

2629−rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"])

2630−

2631−rawNil :: Raw -> Raw

2632−rawNil ty = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [ty]

2633−

2634−rawCons :: Raw -> Raw -> Raw -> Raw

2635−rawCons ty hd tl = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ty, hd, tl]

2636−

2637−rawList :: Raw -> [Raw] -> Raw

2638−rawList ty = foldr (rawCons ty) (rawNil ty)

2639−

2640−rawPairTy :: Raw -> Raw -> Raw

2641−rawPairTy t1 t2 = raw_apply (Var pairTy) [t1, t2]

2642−

2643−rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw

2644−rawPair (a, b) (x, y) = raw_apply (Var pairCon) [a, b, x, y]

2645−

2646−reflectCtxt :: [(Name, Type)] -> Raw

2647−reflectCtxt ctxt = rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "TT"))

2648− (map (\ (n, t) -> (rawPair (Var $ reflm "TTName", Var $ reflm "TT")

2649− (reflectName n, reflect t)))

2650− ctxt)

2651−

2652−reflectErr :: Err -> Raw

2653−reflectErr (Msg msg) = raw_apply (Var $ reflErrName "Msg") [RConstant (Str msg)]

2654−reflectErr (InternalMsg msg) = raw_apply (Var $ reflErrName "InternalMsg") [RConstant (Str msg)]

2655−reflectErr (CantUnify b (t1,_) (t2,_) e ctxt i) =

2656− raw_apply (Var $ reflErrName "CantUnify")

2657− [ rawBool b

2658− , reflect t1

2659− , reflect t2

2660− , reflectErr e

2661− , reflectCtxt ctxt

2662− , RConstant (I i)]

2663−reflectErr (InfiniteUnify n tm ctxt) =

2664− raw_apply (Var $ reflErrName "InfiniteUnify")

2665− [ reflectName n

2666− , reflect tm

2667− , reflectCtxt ctxt

2668− ]

2669−reflectErr (CantConvert t t' ctxt) =

2670− raw_apply (Var $ reflErrName "CantConvert")

2671− [ reflect t

2672− , reflect t'

2673− , reflectCtxt ctxt

2674− ]

2675−reflectErr (CantSolveGoal t ctxt) =

2676− raw_apply (Var $ reflErrName "CantSolveGoal")

2677− [ reflect t

2678− , reflectCtxt ctxt

2679− ]

2680−reflectErr (UnifyScope n n' t ctxt) =

2681− raw_apply (Var $ reflErrName "UnifyScope")

2682− [ reflectName n

2683− , reflectName n'

2684− , reflect t

2685− , reflectCtxt ctxt

2686− ]

2687−reflectErr (CantInferType str) =

2688− raw_apply (Var $ reflErrName "CantInferType") [RConstant (Str str)]

2689−reflectErr (NonFunctionType t t') =

2690− raw_apply (Var $ reflErrName "NonFunctionType") [reflect t, reflect t']

2691−reflectErr (NotEquality t t') =

2692− raw_apply (Var $ reflErrName "NotEquality") [reflect t, reflect t']

2693−reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n]

2694−reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t]

2695−reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n]

2696−reflectErr (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t]

2697−reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t]

2698−reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n]

2699−reflectErr (NotInjective t1 t2 t3) =

2700− raw_apply (Var $ reflErrName "NotInjective")

2701− [ reflect t1

2702− , reflect t2

2703− , reflect t3

2704− ]

2705−reflectErr (CantResolve _ t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

2706−reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]

2707−reflectErr (CantResolveAlts ss) =

2708− raw_apply (Var $ reflErrName "CantResolveAlts")

2709− [rawList (Var $ reflm "TTName") (map reflectName ss)]

2710−reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

2711−reflectErr (NoEliminator str t)

2712− = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),

2713− reflect t]

2714−reflectErr UniverseError = Var $ reflErrName "UniverseError"

2715−reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

2716−reflectErr (Inaccessible n) = raw_apply (Var $ reflErrName "Inaccessible") [reflectName n]

2717−reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollabsiblePostulate") [reflectName n]

2718−reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

2719−reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

2720−reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

2721−reflectErr (ProviderError str) =

2722− raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

2723−reflectErr (LoadingFailed str err) =

2724− raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

2725−reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

2726−

2727−-- | Reflect a file context

2728−reflectFC :: FC -> Raw

2729−reflectFC fc = raw_apply (Var (reflm "FileLoc"))

2730− [ RConstant (Str (fc_fname fc))

2731− , raw_apply (Var pairCon) $

2732− [intTy, intTy] ++

2733− map (RConstant . I)

2734− [ fst (fc_start fc)

2735− , snd (fc_start fc)

2736− ]

2737− , raw_apply (Var pairCon) $

2738− [intTy, intTy] ++

2739− map (RConstant . I)

2740− [ fst (fc_end fc)

2741− , snd (fc_end fc)

2742− ]

2743− ]

2744− where intTy = RConstant (AType (ATInt ITNative))

2745−

27462121elaboratingArgErr :: [(Name, Name)] -> Err -> Err

27472122elaboratingArgErr [] err = err

27482123elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

@@ -2813,70 +2188,108 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

28132188 [] -> e

28142189 parts -> ReflectionError errorparts e

28152190

2816−fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

2817−fromTTMaybe (App (App (P (DCon _ _ _) (NS (UN just) _) _) ty) tm)

2818− | just == txt "Just" = Just tm

2819−fromTTMaybe x = Nothing

2820−

2821−reflErrName :: String -> Name

2822−reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"]

2823−

2824−-- | Attempt to reify a report part from TT to the internal

2825−-- representation. Not in Idris or ElabD monads because it should be usable

2826−-- from either.

2827−reifyReportPart :: Term -> Either Err ErrorReportPart

2828−reifyReportPart (App (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "TextPart" =

2829− Right (TextPart msg)

2830−reifyReportPart (App (P (DCon _ _ _) n _) ttn)

2831− | n == reflm "NamePart" =

2832− case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext Erased) of

2833− Error e -> Left . InternalMsg $

2834− "could not reify name term " ++

2835− show ttn ++

2836− " when reflecting an error:" ++ show e

2837− OK (n', _)-> Right $ NamePart n'

2838−reifyReportPart (App (P (DCon _ _ _) n _) tm)

2839− | n == reflm "TermPart" =

2840− case runElab initEState (reifyTT tm) (initElaborator NErased initContext Erased) of

2841− Error e -> Left . InternalMsg $

2842− "could not reify reflected term " ++

2843− show tm ++

2844− " when reflecting an error:" ++ show e

2845− OK (tm', _) -> Right $ TermPart tm'

2846−reifyReportPart (App (P (DCon _ _ _) n _) tm)

2847− | n == reflm "SubReport" =

2848− case unList tm of

2849− Just xs -> do subParts <- mapM reifyReportPart xs

2850− Right (SubReport subParts)

2851− Nothing -> Left . InternalMsg $ "could not reify subreport " ++ show tm

2852−reifyReportPart x = Left . InternalMsg $ "could not reify " ++ show x

2853−

2854−reifyTyDecl :: Term -> ElabD RTyDecl

2855−reifyTyDecl (App (App (App (P (DCon _ _ _) n _) tyN) args) ret)

2856− | n == tacN "Declare" =

2857− do tyN' <- reifyTTName tyN

2858− args' <- case unList args of

2859− Nothing -> fail $ "Couldn't reify " ++ show args ++ " as an arglist."

2860− Just xs -> mapM reifyRArg xs

2861− ret' <- reifyRaw ret

2862− return $ RDeclare tyN' args' ret'

2863− where reifyRArg :: Term -> ElabD RArg

2864− reifyRArg (App (App (P (DCon _ _ _) n _) argN) argTy)

2865− | n == tacN "Explicit" = liftM2 RExplicit

2866− (reifyTTName argN)

2867− (reifyRaw argTy)

2868− | n == tacN "Implicit" = liftM2 RImplicit

2869− (reifyTTName argN)

2870− (reifyRaw argTy) | n == tacN "Constraint" = liftM2 RConstraint

2871− (reifyTTName argN)

2872− (reifyRaw argTy)

2873− reifyRArg aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RArg."

2874−reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."

2875−

2876−envTupleType :: Raw

2877−envTupleType

2878− = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

2879− , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

2880− ]

2881−

28822191solveAll = try (do solve; solveAll) (return ())

2192+

2193+-- | Do the left-over work after creating declarations in reflected

2194+-- elaborator scripts

2195+processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()

2196+processTacticDecls info steps =

2197+ -- The order of steps is important: type declarations might

2198+ -- establish metavars that later function bodies resolve.

2199+ forM_ (reverse steps) $ \case

2200+ RTyDeclInstrs n fc impls ty ->

2201+ do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty

2202+ logLvl 3 $ " It has impls " ++ show impls

2203+ updateIState $ \i -> i { idris_implicits =

2204+ addDef n impls (idris_implicits i) }

2205+ addIBC (IBCImp n)

2206+ ds <- checkDef fc (\_ e -> e) [(n, (-1, Nothing, ty))]

2207+ addIBC (IBCDef n)

2208+ ctxt <- getContext

2209+ case lookupDef n ctxt of

2210+ (TyDecl _ _ : _) ->

2211+ -- If the function isn't defined at the end of the elab script,

2212+ -- then it must be added as a metavariable. This needs guarding

2213+ -- to prevent overwriting case defs with a metavar, if the case

2214+ -- defs come after the type decl in the same script!

2215+ let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

2216+ in addDeferred ds'

2217+ _ -> return ()

2218+ RClausesInstrs n cs ->

2219+ do logLvl 3 $ "Pattern-matching definition from tactics: " ++ show n

2220+ solveDeferred n

2221+ let lhss = map (\(_, lhs, _) -> lhs) cs

2222+ let fc = fileFC "elab_reflected"

2223+ pmissing <-

2224+ do ist <- getIState

2225+ possible <- genClauses fc n lhss

2226+ (map (\lhs ->

2227+ delab' ist lhs True True) lhss)

2228+ missing <- filterM (checkPossible n) possible

2229+ return (filter (noMatch ist lhss) missing)

2230+ let tot = if null pmissing

2231+ then Unchecked -- still need to check recursive calls

2232+ else Partial NotCovering -- missing cases implies not total

2233+ setTotality n tot

2234+ updateIState $ \i -> i { idris_patdefs =

2235+ addDef n (cs, pmissing) $ idris_patdefs i }

2236+ addIBC (IBCDef n)

2237+

2238+ ctxt <- getContext

2239+ case lookupDefExact n ctxt of

2240+ Just (CaseOp _ _ _ _ _ cd) ->

2241+ -- Here, we populate the call graph with a list of things

2242+ -- we refer to, so that if they aren't total, the whole

2243+ -- thing won't be.

2244+ let (scargs, sc) = cases_compiletime cd

2245+ (scargs', sc') = cases_runtime cd

2246+ calls = findCalls sc' scargs

2247+ used = findUsedArgs sc' scargs'

2248+ cg = CGInfo scargs' calls [] used []

2249+ in do logLvl 2 $ "Called names in reflected elab: " ++ show cg

2250+ addToCG n cg

2251+ addToCalledG n (nub (map fst calls))

2252+ addIBC $ IBCCG n

2253+ Just _ -> return () -- TODO throw internal error

2254+ Nothing -> return ()

2255+

2256+ -- checkDeclTotality requires that the call graph be present

2257+ -- before calling it.

2258+ -- TODO: reduce code duplication with Idris.Elab.Clause

2259+ buildSCG (fc, n)

2260+

2261+ -- Actually run the totality checker. In the main clause

2262+ -- elaborator, this is deferred until after. Here, we run it

2263+ -- now to get totality information as early as possible.

2264+ tot' <- checkDeclTotality (fc, n)

2265+ setTotality n tot'

2266+ when (tot' /= Unchecked) $ addIBC (IBCTotal n tot')

2267+ where

2268+ -- TODO: see if the code duplication with Idris.Elab.Clause can be

2269+ -- reduced or eliminated.

2270+ checkPossible :: Name -> PTerm -> Idris Bool

2271+ checkPossible fname lhs_in =

2272+ do ctxt <- getContext

2273+ ist <- getIState

2274+ let lhs = addImplPat ist lhs_in

2275+ let fc = fileFC "elab_reflected_totality"

2276+ let tcgen = False -- TODO: later we may support dictionary generation

2277+ case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2278+ (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of

2279+ OK (ElabResult lhs' _ _ _ _, _) ->

2280+ do -- not recursively calling here, because we don't

2281+ -- want to run infinitely many times

2282+ let lhs_tm = orderPats (getInferTerm lhs')

2283+ case recheck ctxt [] (forget lhs_tm) lhs_tm of

2284+ OK _ -> return True

2285+ err -> return False

2286+ -- if it's a recoverable error, the case may become possible

2287+ Error err -> if tcgen then return (recoverableCoverage ctxt err)

2288+ else return (validCoverageCase ctxt err ||

2289+ recoverableCoverage ctxt err)

2290+

2291+

2292+ -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause

2293+ noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

2294+ Right _ -> False

2295+ Left _ -> True) cs

src/Idris/Elab/Transform.hs+6−6

@@ -7,7 +7,6 @@ import Idris.DSL

77import Idris.Error

88import Idris.Delaborate

99import Idris.Imports

10−import Idris.ElabTerm

1110import Idris.Coverage

1211import Idris.DataOpts

1312import Idris.Providers

@@ -19,6 +18,7 @@ import Idris.Output (iputStrLn, pshow, iWarn)

1918import IRTS.Lang

2019

2120import Idris.Elab.Utils

21+import Idris.Elab.Term

2222

2323import Idris.Core.TT

2424import Idris.Core.Elaborate hiding (Tactic(..))

@@ -54,11 +54,11 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

5454 i <- getIState

5555 let lhs = addImplPat i lhs_in

5656 (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

57− tclift $ elaborate ctxt (sMN 0 "transLHS") infP initEState

57+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

5858 (erun fc (buildTC i info ELHS [] (sUN "transform")

5959 (infTerm lhs)))

6060 setContext ctxt'

61− processTacticDecls newDecls

61+ processTacticDecls info newDecls

6262 let lhs_tm = orderPats (getInferTerm lhs')

6363 let lhs_ty = getInferType lhs'

6464 let newargs = pvars i lhs_tm

@@ -69,16 +69,16 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

6969

7070 let rhs = addImplBound i (map fst newargs) rhs_in

7171 ((rhs', defer, ctxt', newDecls), _) <-

72− tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty initEState

72+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

7373 (do pbinds i lhs_tm

7474 setNextName

7575 (ElabResult _ _ _ ctxt' newDecls) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

7676 erun fc $ psolve lhs_tm

7777 tt <- get_term

78− let (rhs', defer) = runState (collectDeferred Nothing tt) []

78+ let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

7979 return (rhs', defer, ctxt', newDecls))

8080 setContext ctxt'

81− processTacticDecls newDecls

81+ processTacticDecls info newDecls

8282

8383 (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'

8484 let crhs_tm = renamepats pnames crhs_tm_in

src/Idris/Elab/Type.hs+5−5

@@ -8,7 +8,7 @@ import Idris.DSL

88import Idris.Error

99import Idris.Delaborate

1010import Idris.Imports

11−import Idris.ElabTerm

11+import Idris.Elab.Term

1212import Idris.Coverage

1313import Idris.DataOpts

1414import Idris.Providers

@@ -67,10 +67,10 @@ buildType info syn fc opts n ty' = do

6767 logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

6868

6969 (ElabResult tyT' defer is ctxt' newDecls, log) <-

70− tclift $ elaborate ctxt n (TType (UVal 0)) initEState

70+ tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

7171 (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))

7272 setContext ctxt'

73− processTacticDecls newDecls

73+ processTacticDecls info newDecls

7474

7575 let tyT = patToImp tyT'

7676

@@ -215,8 +215,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

215215 errrep = txt "ErrorReportPart"

216216

217217 tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _)

218− (App (P _ (NS (UN m) ns2) _)

219− (App (P _ (NS (UN l) ns3) _)

218+ (App _ (P _ (NS (UN m) ns2) _)

219+ (App _ (P _ (NS (UN l) ns3) _)

220220 (P _ (NS (UN r) ns4) _))))

221221 | e == err && m == maybe && l == lst && r == errrep

222222 , ns1 == map txt ["Errors","Reflection","Language"]

src/Idris/Elab/Utils.hs+15−13

@@ -171,7 +171,7 @@ getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi _ t _) sc)

171171 _ -> []

172172getFixedInType i env (_ : is) (Bind n (Pi _ t _) sc)

173173 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

174−getFixedInType i env is tm@(App f a)

174+getFixedInType i env is tm@(App _ f a)

175175 | (P _ tn _, args) <- unApply tm

176176 = case lookupCtxt tn (idris_datatypes i) of

177177 [t] -> nub $ paramNames args env (param_pos t) ++

@@ -186,27 +186,29 @@ getFixedInType i _ _ _ = []

186186getFlexInType i env ps (Bind n (Pi _ t _) sc)

187187 = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++

188188 getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)

189−getFlexInType i env ps tm@(App f a)

190− | (P _ tn _, args) <- unApply tm

189+

190+getFlexInType i env ps tm@(App _ f a)

191+ | (P nt tn _, args) <- unApply tm, nt /= Bound

191192 = case lookupCtxt tn (idris_datatypes i) of

192193 [t] -> nub $ paramNames args env [x | x <- [0..length args],

193194 not (x `elem` param_pos t)]

194195 ++ getFlexInType i env ps f ++

195196 getFlexInType i env ps a

196− [] -> let ppos = case lookupCtxt tn (idris_fninfo i) of

197− [fi] -> fn_params fi

198− [] -> [] in

199− nub $ paramNames args env [x | x <- [0..length args],

200− not (x `elem` ppos)]

201− ++ getFlexInType i env ps f ++

202− getFlexInType i env ps a

197+ [] -> let ppos = case lookupCtxtName tn (idris_fninfo i) of

198+ [fi] -> fn_params (snd fi)

199+ [] -> []

200+ xs -> error ("Too much function info: " ++ show xs)

201+ in nub $ paramNames args env [x | x <- [0..length args],

202+ not (x `elem` ppos)]

203+ ++ getFlexInType i env ps f ++

204+ getFlexInType i env ps a

203205 | otherwise = nub $ getFlexInType i env ps f ++

204206 getFlexInType i env ps a

205207getFlexInType i _ _ _ = []

206208

207−-- Treat a name as a parameter if it appears in parameter positions in

209+-- | Treat a name as a parameter if it appears in parameter positions in

208210-- types, and never in a non-parameter position in a (non-param) argument type.

209−

211+getParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name]

210212getParamsInType i env ps t = let fix = getFixedInType i env ps t

211213 flex = getFlexInType i env fix t in

212214 [x | x <- fix, not (x `elem` flex)]

@@ -232,7 +234,7 @@ getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []

232234 _ -> False in

233235 do getUniqB env us b

234236 getUniq ((n,b):env) ((n, uniq):us) sc

235− getUniq env us (App f a) = do getUniq env us f; getUniq env us a

237+ getUniq env us (App _ f a) = do getUniq env us f; getUniq env us a

236238 getUniq env us (V i)

237239 | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()

238240 getUniq env us (P _ n _)

src/Idris/Elab/Value.hs+19−4

@@ -1,6 +1,6 @@

11{-# LANGUAGE PatternGuards #-}

22{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3−module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where

3+module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms, elabExec) where

44

55import Idris.AbsSyntax

66import Idris.ASTUtils

@@ -8,7 +8,6 @@ import Idris.DSL

88import Idris.Error

99import Idris.Delaborate

1010import Idris.Imports

11−import Idris.ElabTerm

1211import Idris.Coverage

1312import Idris.DataOpts

1413import Idris.Providers

@@ -20,6 +19,7 @@ import Idris.Output (iputStrLn, pshow, iWarn)

2019import IRTS.Lang

2120

2221import Idris.Elab.Utils

22+import Idris.Elab.Term

2323

2424import Idris.Core.TT

2525import Idris.Core.Elaborate hiding (Tactic(..))

@@ -64,12 +64,12 @@ elabValBind info aspat norm tm_in

6464 -- * elaboration as a function a -> b

6565

6666 (ElabResult tm' defer is ctxt' newDecls, _) <-

67− tclift (elaborate ctxt (sMN 0 "val") infP initEState

67+ tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState

6868 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

6969

7070 -- Extend the context with new definitions created

7171 setContext ctxt'

72− processTacticDecls newDecls

72+ processTacticDecls info newDecls

7373

7474 let vtm = orderPats (getInferTerm tm')

7575

@@ -114,3 +114,18 @@ elabDocTerms info str = do typechecked <- Traversable.mapM decorate str

114114 then Example tm

115115 else Checked tm

116116 | otherwise = Unchecked

117+

118+-- Try running the term directly (as IO ()), then printing it as an Integer

119+-- (as a default numeric tye), then printing it as any Showable thing

120+elabExec :: FC -> PTerm -> PTerm

121+elabExec fc tm = runtm (PAlternative False

122+ [printtm (PApp fc (PRef fc (sUN "the"))

123+ [pexp (PConstant (AType (ATInt ITBig))), pexp tm]),

124+ tm,

125+ printtm tm

126+ ])

127+ where

128+ runtm t = PApp fc (PRef fc (sUN "run__IO")) [pexp t]

129+ printtm t = PApp fc (PRef fc (sUN "printLn"))

130+ [pimp (sUN "ffi") (PRef fc (sUN "FFI_C")) False, pexp t]

131+

src/Idris/ElabDecls.hs+3−2

@@ -8,8 +8,9 @@ import Idris.ASTUtils

88import Idris.DSL

99import Idris.Error

1010import Idris.Delaborate

11+import Idris.Directives

1112import Idris.Imports

12−import Idris.ElabTerm

13+import Idris.Elab.Term

1314import Idris.Coverage

1415import Idris.DataOpts

1516import Idris.Providers

@@ -252,7 +253,7 @@ elabDecl' _ info (PDSL n dsl)

252253 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

253254 addIBC (IBCDSL n)

254255elabDecl' what info (PDirective i)

255− | what /= EDefns = i

256+ | what /= EDefns = directiveAction i

256257elabDecl' what info (PProvider doc syn fc provWhat n)

257258 | what /= EDefns

258259 = do iLOG $ "Elaborating type provider " ++ show n

src/Idris/ElabQuasiquote.hs+2−2

@@ -170,8 +170,8 @@ extractUnquotes n (PUnquote tm)

170170 return (PRef (fileFC "(unquote)") n, [(n, tm)])

171171 | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $

172172 extractUnquotes (n-1) tm

173−extractUnquotes n (PRunTactics fc tm)

174− = fmap (\(tm', ex) -> (PRunTactics fc tm', ex)) $ extractUnquotes n tm

173+extractUnquotes n (PRunElab fc tm)

174+ = fmap (\(tm', ex) -> (PRunElab fc tm', ex)) $ extractUnquotes n tm

175175extractUnquotes n x = return (x, []) -- no subterms!

176176

177177

src/Idris/Erasure.hs+13−27

@@ -66,13 +66,11 @@ type Vars = Map Name VarInfo

6666-- Perform usage analysis, write the relevant information in the internal

6767-- structures, returning the list of reachable names.

6868performUsageAnalysis :: [Name] -> Idris [Name]

69−performUsageAnalysis roots = do

69+performUsageAnalysis startNames = do

7070 ctx <- tt_ctxt <$> getIState

71− startNames <- getStartNames <$> getIState

72−

7371 case startNames of

74− Left reason -> return [] -- no main -> not compiling -> reachability irrelevant

75− Right main -> do

72+ [] -> return [] -- no main -> not compiling -> reachability irrelevant

73+ main -> do

7674 ci <- idris_classes <$> getIState

7775 cg <- idris_callgraph <$> getIState

7876 opt <- idris_optimisation <$> getIState

@@ -107,17 +105,6 @@ performUsageAnalysis roots = do

107105

108106 return $ S.toList reachableNames

109107 where

110− getStartNames :: IState -> Either Err [Name]

111− getStartNames ist

112− = case lookupCtxtName n (idris_implicits ist) of

113− [(n', _)] -> Right (n' : roots)

114− [] -> if null roots

115− then Left (NoSuchVariable n)

116− else Right roots

117− more -> Left (CantResolveAlts (map fst more))

118− where

119− n = sNS (sUN "main") ["Main"]

120−

121108 indent = (" " ++)

122109

123110 fmtItem :: (Cond, DepSet) -> String

@@ -292,7 +279,7 @@ buildDepMap ci used externs ctx startNames

292279

293280 etaExpand :: [Name] -> Term -> Term

294281 etaExpand [] t = t

295− etaExpand (n : ns) t = etaExpand ns (App t (P Ref n Erased))

282+ etaExpand (n : ns) t = etaExpand ns (App Complete t (P Ref n Erased))

296283

297284 getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps

298285 getDepsSC fn es vs ImpossibleCase = M.empty

@@ -383,7 +370,7 @@ buildDepMap ci used externs ctx startNames

383370 var t cd = getDepsTerm vs bs cd t

384371

385372 -- applications may add items to Cond

386− getDepsTerm vs bs cd app@(App _ _)

373+ getDepsTerm vs bs cd app@(App _ _ _)

387374 | (fun, args) <- unApply app = case fun of

388375 -- instance constructors -> create metamethod deps

389376 P (DCon _ _ _) ctorName@(SN (InstanceCtorN className)) _

@@ -395,12 +382,11 @@ buildDepMap ci used externs ctx startNames

395382 P (DCon _ _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used

396383

397384 -- mkForeign* calls must be special-cased because they are variadic

398− -- All arguments must be marked as used, except for the first one,

399− -- which is the (Foreign a) spec that defines the type

400− -- and is not needed at runtime.

385+ -- All arguments must be marked as used, except for the first four,

386+ -- which define the call type and are not needed at runtime.

401387 P _ (UN n) _

402− | n `elem` map T.pack ["mkForeignPrim"]

403− -> unconditionalDeps args -- (drop 1 args)

388+ | n == T.pack "mkForeignPrim"

389+ -> unconditionalDeps $ drop 4 args

404390

405391 -- a bound variable might draw in additional dependencies,

406392 -- think: f x = x 0 <-- here, `x' _is_ used

@@ -431,8 +417,8 @@ buildDepMap ci used externs ctx startNames

431417 Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

432418

433419 -- and we interpret applied lets as lambdas

434− Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

435− Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

420+ Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')

421+ Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')

436422

437423 Proj t i

438424 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t

@@ -506,9 +492,9 @@ buildDepMap ci used externs ctx startNames

506492 -- convert applications of lambdas to lets

507493 -- Note that this transformation preserves de bruijn numbering

508494 lamToLet :: [Term] -> Term -> Term

509− lamToLet xs (App f x) = lamToLet (x:xs) f

495+ lamToLet xs (App _ f x) = lamToLet (x:xs) f

510496 lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)

511− lamToLet (x:xs) t = App (lamToLet xs t) x

497+ lamToLet (x:xs) t = App Complete (lamToLet xs t) x

512498 lamToLet [] t = t

513499

514500 -- split "\x_i -> T(x_i)" into [x_i] and T

src/Idris/ErrReverse.hs+7−7

@@ -35,9 +35,9 @@ errReverse ist t = rewrite 5 t -- (elideLambdas t)

3535

3636 matchTerm ns l r t

3737 | Just nmap <- match ns l t = substNames nmap r

38− matchTerm ns l r (App f a) = let f' = matchTerm ns l r f

39− a' = matchTerm ns l r a in

40− App f' a'

38+ matchTerm ns l r (App s f a) = let f' = matchTerm ns l r f

39+ a' = matchTerm ns l r a in

40+ App s f' a'

4141 matchTerm ns l r (Bind n b sc) = let b' = fmap (matchTerm ns l r) b

4242 sc' = matchTerm ns l r sc in

4343 Bind n b' sc'

@@ -54,16 +54,16 @@ errReverse ist t = rewrite 5 t -- (elideLambdas t)

5454 Just ((x, t) : xs')

5555

5656 match' ns (P Ref n _) t | n `elem` ns = Just [(n, t)]

57− match' ns (App f a) (App f' a') = do fs <- match' ns f f'

58− as <- match' ns a a'

59− Just (fs ++ as)

57+ match' ns (App _ f a) (App _ f' a') = do fs <- match' ns f f'

58+ as <- match' ns a a'

59+ Just (fs ++ as)

6060 -- no matching Binds, for now...

6161 match' ns x y = if x == y then Just [] else Nothing

6262

6363 -- if the term under a lambda is huge, there's no much point in showing

6464 -- it as it won't be very enlightening.

6565

66− elideLambdas (App f a) = App (elideLambdas f) (elideLambdas a)

66+ elideLambdas (App s f a) = App s (elideLambdas f) (elideLambdas a)

6767 elideLambdas (Bind n (Lam t) sc)

6868 | size sc > 200 = P Ref (sUN "...") Erased

6969 elideLambdas (Bind n b sc)

src/Idris/Error.hs+8−4

@@ -32,8 +32,9 @@ iucheck = do tit <- typeInType

3232 logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs

3333 when (not tit) $

3434 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

35− (\e -> do setErrSpan (getErrSpan e)

36− iputStrLn (pshow ist e))

35+ (\e -> do let fc = getErrSpan e

36+ setErrSpan fc

37+ iWarn fc $ pprintErr ist e)

3738

3839showErr :: Err -> Idris String

3940showErr e = getIState >>= return . flip pshow e

@@ -67,6 +68,7 @@ ierror = throwError

6768tclift :: TC a -> Idris a

6869tclift (OK v) = return v

6970tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err

71+tclift (Error err@(UniverseError fc _ _ _ _)) = do setErrSpan fc; throwError err

7072tclift (Error err) = throwError err

7173

7274tctry :: TC a -> TC a -> Idris a

@@ -77,6 +79,7 @@ tctry tc1 tc2

7779

7880getErrSpan :: Err -> FC

7981getErrSpan (At fc _) = fc

82+getErrSpan (UniverseError fc _ _ _ _) = fc

8083getErrSpan _ = emptyFC

8184

8285--------------------------------------------------------------------

@@ -133,7 +136,7 @@ warnDisamb ist (PCoerced tm) = warnDisamb ist tm

133136warnDisamb ist (PDisamb ds tm) = warnDisamb ist tm >>

134137 mapM_ warnEmpty ds

135138 where warnEmpty d =

136− when (null (filter (isIn d . fst) (ctxtAlist (tt_ctxt ist)))) $

139+ when (not (any (isIn d . fst) (ctxtAlist (tt_ctxt ist)))) $

137140 ierror . Msg $

138141 "Nothing found in namespace \"" ++

139142 intercalate "." (map T.unpack d) ++

@@ -146,6 +149,7 @@ warnDisamb ist (PNoImplicits tm) = warnDisamb ist tm

146149warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>

147150 Foldable.mapM_ (warnDisamb ist) goal

148151warnDisamb ist (PUnquote tm) = warnDisamb ist tm

152+warnDisamb ist (PQuoteName _) = return ()

149153warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm

150154warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm

151−warnDisamb ist (PRunTactics _ tm) = warnDisamb ist tm

155+warnDisamb ist (PRunElab _ tm) = warnDisamb ist tm

src/Idris/IBC.hs+173−243

@@ -1,7 +1,8 @@

11{-# LANGUAGE TypeSynonymInstances #-}

22{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

33

4−module Idris.IBC where

4+module Idris.IBC (loadIBC, loadPkgIndex,

5+ writeIBC, writePkgIndex) where

56

67import Idris.Core.Evaluate

78import Idris.Core.TT

@@ -21,8 +22,10 @@ import Paths_idris

2122import qualified Cheapskate.Types as CT

2223

2324import Data.Binary

25+import Data.Functor

2426import Data.Vector.Binary

25−import Data.List

27+import Data.List as L

28+import Data.Maybe (catMaybes)

2629import Data.ByteString.Lazy as B hiding (length, elem, map)

2730import qualified Data.Text as T

2831import qualified Data.Set as S

@@ -34,12 +37,13 @@ import qualified Control.Monad.State.Strict as ST

3437import System.FilePath

3538import System.Directory

3639import Codec.Compression.Zlib (compress)

40+import Codec.Archive.Zip

3741import Util.Zlib (decompressEither)

3842

39−ibcVersion :: Word8

40−ibcVersion = 104

43+ibcVersion :: Word16

44+ibcVersion = 107

4145

42−data IBCFile = IBCFile { ver :: Word8,

46+data IBCFile = IBCFile { ver :: Word16,

4347 sourcefile :: FilePath,

4448 symbols :: ![Name],

4549 ibc_imports :: ![(Bool, FilePath)],

@@ -102,9 +106,12 @@ loadIBC reexport fp

102106 Just p -> not p && reexport

103107 when redo $

104108 do iLOG $ "Loading ibc " ++ fp ++ " " ++ show reexport

105− ibcf <- runIO $ (bdecode fp :: IO IBCFile)

106− process reexport ibcf fp

107− addImported reexport fp

109+ archiveFile <- runIO $ B.readFile fp

110+ case toArchiveOrFail archiveFile of

111+ Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

112+ ++ "Please clean and rebuild it."

113+ Right archive -> do process reexport archive fp

114+ addImported reexport fp

108115

109116-- | Load an entire package from its index file

110117loadPkgIndex :: String -> Idris ()

@@ -113,15 +120,63 @@ loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

113120 fp <- findPkgIndex pkg

114121 loadIBC True fp

115122

116−bencode :: Binary a => FilePath -> a -> IO ()

117−bencode f d = B.writeFile f (compress (encode d))

118123

119−bdecode :: Binary b => FilePath -> IO b

120−bdecode f = do d' <- B.readFile f

121− either

122− (\(_, e) -> error $ "Invalid / corrupted zip format on " ++ show f ++ ": " ++ e)

123− (return . decode)

124− (decompressEither d')

124+makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

125+makeEntry name val = if L.null val

126+ then Nothing

127+ else Just $ toEntry name 0 (encode val)

128+

129+

130+entries :: IBCFile -> [Entry]

131+entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

132+ makeEntry "sourcefile" (sourcefile i),

133+ makeEntry "symbols" (symbols i),

134+ makeEntry "ibc_imports" (ibc_imports i),

135+ makeEntry "ibc_importdirs" (ibc_importdirs i),

136+ makeEntry "ibc_implicits" (ibc_implicits i),

137+ makeEntry "ibc_fixes" (ibc_fixes i),

138+ makeEntry "ibc_statics" (ibc_statics i),

139+ makeEntry "ibc_classes" (ibc_classes i),

140+ makeEntry "ibc_instances" (ibc_instances i),

141+ makeEntry "ibc_dsls" (ibc_dsls i),

142+ makeEntry "ibc_datatypes" (ibc_datatypes i),

143+ makeEntry "ibc_optimise" (ibc_optimise i),

144+ makeEntry "ibc_syntax" (ibc_syntax i),

145+ makeEntry "ibc_keywords" (ibc_keywords i),

146+ makeEntry "ibc_objs" (ibc_objs i),

147+ makeEntry "ibc_libs" (ibc_libs i),

148+ makeEntry "ibc_cgflags" (ibc_cgflags i),

149+ makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

150+ makeEntry "ibc_hdrs" (ibc_hdrs i),

151+ makeEntry "ibc_access" (ibc_access i),

152+ makeEntry "ibc_total" (ibc_total i),

153+ makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

154+ makeEntry "ibc_flags" (ibc_flags i),

155+ makeEntry "ibc_fninfo" (ibc_fninfo i),

156+ makeEntry "ibc_cg" (ibc_cg i),

157+ makeEntry "ibc_defs" (ibc_defs i),

158+ makeEntry "ibc_docstrings" (ibc_docstrings i),

159+ makeEntry "ibc_moduledocs" (ibc_moduledocs i),

160+ makeEntry "ibc_transforms" (ibc_transforms i),

161+ makeEntry "ibc_errRev" (ibc_errRev i),

162+ makeEntry "ibc_coercions" (ibc_coercions i),

163+ makeEntry "ibc_lineapps" (ibc_lineapps i),

164+ makeEntry "ibc_namehints" (ibc_namehints i),

165+ makeEntry "ibc_metainformation" (ibc_metainformation i),

166+ makeEntry "ibc_errorhandlers" (ibc_errorhandlers i),

167+ makeEntry "ibc_function_errorhandlers" (ibc_function_errorhandlers i),

168+ makeEntry "ibc_metavars" (ibc_metavars i),

169+ makeEntry "ibc_patdefs" (ibc_patdefs i),

170+ makeEntry "ibc_postulates" (ibc_postulates i),

171+ makeEntry "ibc_externs" (ibc_externs i),

172+ toEntry "ibc_parsedSpan" 0 . encode <$> ibc_parsedSpan i,

173+ makeEntry "ibc_usage" (ibc_usage i),

174+ makeEntry "ibc_exports" (ibc_exports i),

175+ makeEntry "ibc_autohints" (ibc_autohints i)]

176+

177+writeArchive :: FilePath -> IBCFile -> Idris ()

178+writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

179+ runIO $ B.writeFile fp (fromArchive a)

125180

126181writeIBC :: FilePath -> FilePath -> Idris ()

127182writeIBC src f

@@ -133,7 +188,7 @@ writeIBC src f

133188 resetNameIdx

134189 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

135190 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

136− runIO $ bencode f ibcf

191+ writeArchive f ibcf

137192 iLOG "Written")

138193 (\c -> do iLOG $ "Failed " ++ pshow i c)

139194 return ()

@@ -149,7 +204,7 @@ writePkgIndex f

149204 resetNameIdx

150205 let ibcf = initIBC { ibc_imports = imps }

151206 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

152− runIO $ bencode f ibcf

207+ writeArchive f ibcf

153208 iLOG "Written")

154209 (\c -> do iLOG $ "Failed " ++ pshow i c)

155210 return ()

@@ -157,7 +212,7 @@ writePkgIndex f

157212mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

158213mkIBC [] f = return f

159214mkIBC (i:is) f = do ist <- getIState

160− logLvl 5 $ show i ++ " " ++ show (Data.List.length is)

215+ logLvl 5 $ show i ++ " " ++ show (L.length is)

161216 f' <- ibc ist i f

162217 mkIBC is f'

163218

@@ -240,65 +295,68 @@ ibc i (IBCUsage n) f = return f { ibc_usage = n : ibc_usage f }

240295ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }

241296ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f }

242297

298+getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b

299+getEntry alt f a = case findEntryByPath f a of

300+ Nothing -> return alt

301+ Just e -> return $ (force . decode . fromEntry) e

302+

243303process :: Bool -- ^ Reexporting

244− -> IBCFile -> FilePath -> Idris ()

245−process reexp i fn

246− | ver i /= ibcVersion

247− = do iLOG "ibc out of date"

248− let e = if ver i < ibcVersion then " an earlier " else " a later "

249− ifail $ "Incompatible ibc version.\nThis library was built with"

250− ++ e ++ "version of Idris.\n" ++

251− "Please clean and rebuild."

252−

253− --- please rebuild"

254− | otherwise =

255− do srcok <- runIO $ doesFileExist (sourcefile i)

256− when srcok $ timestampOlder (sourcefile i) fn

257− v <- verbose

258− quiet <- getQuiet

259−-- when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i

260− pImportDirs $ force (ibc_importdirs i)

261− pImports $ force (ibc_imports i)

262− pImps $ force (ibc_implicits i)

263− pFixes $ force (ibc_fixes i)

264− pStatics $ force (ibc_statics i)

265− pClasses $ force (ibc_classes i)

266− pInstances $ force (ibc_instances i)

267− pDSLs $ force (ibc_dsls i)

268− pDatatypes $ force (ibc_datatypes i)

269− pOptimise $ force (ibc_optimise i)

270− pSyntax $ force (ibc_syntax i)

271− pKeywords $ force (ibc_keywords i)

272− pObjs $ force (ibc_objs i)

273− pLibs $ force (ibc_libs i)

274− pCGFlags $ force (ibc_cgflags i)

275− pDyLibs $ force (ibc_dynamic_libs i)

276− pHdrs $ force (ibc_hdrs i)

277− pDefs reexp (symbols i) $ force (ibc_defs i)

278− pPatdefs $ force (ibc_patdefs i)

279− pAccess reexp $ force (ibc_access i)

280− pFlags $ force (ibc_flags i)

281− pFnInfo $ force (ibc_fninfo i)

282− pTotal $ force (ibc_total i)

283− pTotCheckErr $ force (ibc_totcheckfail i)

284− pCG $ force (ibc_cg i)

285− pDocs $ force (ibc_docstrings i)

286− pMDocs $ force (ibc_moduledocs i)

287− pCoercions $ force (ibc_coercions i)

288− pTrans $ force (ibc_transforms i)

289− pErrRev $ force (ibc_errRev i)

290− pLineApps $ force (ibc_lineapps i)

291− pNameHints $ force (ibc_namehints i)

292− pMetaInformation $ force (ibc_metainformation i)

293− pErrorHandlers $ force (ibc_errorhandlers i)

294− pFunctionErrorHandlers $ force (ibc_function_errorhandlers i)

295− pMetavars $ force (ibc_metavars i)

296− pPostulates $ force (ibc_postulates i)

297− pExterns $ force (ibc_externs i)

298− pParsedSpan $ force (ibc_parsedSpan i)

299− pUsage $ force (ibc_usage i)

300− pExports $ force (ibc_exports i)

301− pAutoHints $ force (ibc_autohints i)

304+ -> Archive -> FilePath -> Idris ()

305+process reexp i fn = do

306+ ver <- getEntry 0 "ver" i

307+ when (ver /= ibcVersion) $ do

308+ iLOG "ibc out of date"

309+ let e = if ver < ibcVersion

310+ then " an earlier " else " a later "

311+ ifail $ "Incompatible ibc version.\nThis library was built with"

312+ ++ e ++ "version of Idris.\n" ++ "Please clean and rebuild."

313+ source <- getEntry "" "sourcefile" i

314+ srcok <- runIO $ doesFileExist source

315+ when srcok $ timestampOlder source fn

316+ pImportDirs =<< getEntry [] "ibc_importdirs" i

317+ pImports =<< getEntry [] "ibc_imports" i

318+ pImps =<< getEntry [] "ibc_implicits" i

319+ pFixes =<< getEntry [] "ibc_fixes" i

320+ pStatics =<< getEntry [] "ibc_statics" i

321+ pClasses =<< getEntry [] "ibc_classes" i

322+ pInstances =<< getEntry [] "ibc_instances" i

323+ pDSLs =<< getEntry [] "ibc_dsls" i

324+ pDatatypes =<< getEntry [] "ibc_datatypes" i

325+ pOptimise =<< getEntry [] "ibc_optimise" i

326+ pSyntax =<< getEntry [] "ibc_syntax" i

327+ pKeywords =<< getEntry [] "ibc_keywords" i

328+ pObjs =<< getEntry [] "ibc_objs" i

329+ pLibs =<< getEntry [] "ibc_libs" i

330+ pCGFlags =<< getEntry [] "ibc_cgflags" i

331+ pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

332+ pHdrs =<< getEntry [] "ibc_hdrs" i

333+ symbols <- getEntry [] "symbols" i

334+ defs <- getEntry [] "ibc_defs" i

335+ pDefs reexp symbols defs

336+ pPatdefs =<< getEntry [] "ibc_patdefs" i

337+ pAccess reexp =<< getEntry [] "ibc_access" i

338+ pFlags =<< getEntry [] "ibc_flags" i

339+ pFnInfo =<< getEntry [] "ibc_fninfo" i

340+ pTotal =<< getEntry [] "ibc_total" i

341+ pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

342+ pCG =<< getEntry [] "ibc_cg" i

343+ pDocs =<< getEntry [] "ibc_docstrings" i

344+ pMDocs =<< getEntry [] "ibc_moduledocs" i

345+ pCoercions =<< getEntry [] "ibc_coercions" i

346+ pTrans =<< getEntry [] "ibc_transforms" i

347+ pErrRev =<< getEntry [] "ibc_errRev" i

348+ pLineApps =<< getEntry [] "ibc_lineapps" i

349+ pNameHints =<< getEntry [] "ibc_namehints" i

350+ pMetaInformation =<< getEntry [] "ibc_metainformation" i

351+ pErrorHandlers =<< getEntry [] "ibc_errorhandlers" i

352+ pFunctionErrorHandlers =<< getEntry [] "ibc_function_errorhandlers" i

353+ pMetavars =<< getEntry [] "ibc_metavars" i

354+ pPostulates =<< getEntry [] "ibc_postulates" i

355+ pExterns =<< getEntry [] "ibc_externs" i

356+ pParsedSpan =<< getEntry Nothing "ibc_parsedSpan" i

357+ pUsage =<< getEntry [] "ibc_usage" i

358+ pExports =<< getEntry [] "ibc_exports" i

359+ pAutoHints =<< getEntry [] "ibc_autohints" i

302360

303361timestampOlder :: FilePath -> FilePath -> Idris ()

304362timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -308,26 +366,20 @@ timestampOlder src ibc = do srct <- runIO $ getModificationTime src

308366 else return ()

309367

310368pPostulates :: [Name] -> Idris ()

311−pPostulates ns = do

312− i <- getIState

313− putIState i{ idris_postulates = idris_postulates i `S.union` S.fromList ns }

369+pPostulates ns = updateIState

370+ (\i -> i { idris_postulates = idris_postulates i `S.union` S.fromList ns })

314371

315372pExterns :: [(Name, Int)] -> Idris ()

316−pExterns ns = do

317− i <- getIState

318− putIState i{ idris_externs = idris_externs i `S.union` S.fromList ns }

373+pExterns ns = updateIState (\i -> i{ idris_externs = idris_externs i `S.union` S.fromList ns })

319374

320375pParsedSpan :: Maybe FC -> Idris ()

321−pParsedSpan fc = do ist <- getIState

322− putIState ist { idris_parsedSpan = fc }

376+pParsedSpan fc = updateIState (\i -> i { idris_parsedSpan = fc })

323377

324378pUsage :: [(Name, Int)] -> Idris ()

325−pUsage ns = do ist <- getIState

326− putIState ist { idris_erasureUsed = ns ++ idris_erasureUsed ist }

379+pUsage ns = updateIState (\i -> i { idris_erasureUsed = ns ++ idris_erasureUsed i })

327380

328381pExports :: [Name] -> Idris ()

329−pExports ns = do ist <- getIState

330− putIState ist { idris_exports = ns ++ idris_exports ist }

382+pExports ns = updateIState (\i -> i { idris_exports = ns ++ idris_exports i })

331383

332384pAutoHints :: [(Name, Name)] -> Idris ()

333385pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns

@@ -391,33 +443,22 @@ pInstances :: [(Bool, Name, Name)] -> Idris ()

391443pInstances cs = mapM_ (\ (i, n, ins) -> addInstance i n ins) cs

392444

393445pDSLs :: [(Name, DSL)] -> Idris ()

394−pDSLs cs = mapM_ (\ (n, c) ->

395− do i <- getIState

396− putIState (i { idris_dsls

397− = addDef n c (idris_dsls i) }))

398− cs

446+pDSLs cs = mapM_ (\ (n, c) -> updateIState (\i ->

447+ i { idris_dsls = addDef n c (idris_dsls i) })) cs

399448

400449pDatatypes :: [(Name, TypeInfo)] -> Idris ()

401−pDatatypes cs = mapM_ (\ (n, c) ->

402− do i <- getIState

403− putIState (i { idris_datatypes

404− = addDef n c (idris_datatypes i) }))

405− cs

450+pDatatypes cs = mapM_ (\ (n, c) -> updateIState (\i ->

451+ i { idris_datatypes = addDef n c (idris_datatypes i) })) cs

406452

407453pOptimise :: [(Name, OptInfo)] -> Idris ()

408−pOptimise cs = mapM_ (\ (n, c) ->

409− do i <- getIState

410− putIState (i { idris_optimisation

411− = addDef n c (idris_optimisation i) }))

412− cs

454+pOptimise cs = mapM_ (\ (n, c) -> updateIState (\i ->

455+ i { idris_optimisation = addDef n c (idris_optimisation i) })) cs

413456

414457pSyntax :: [Syntax] -> Idris ()

415−pSyntax s = do i <- getIState

416− putIState (i { syntax_rules = updateSyntaxRules s (syntax_rules i) })

458+pSyntax s = updateIState (\i -> i { syntax_rules = updateSyntaxRules s (syntax_rules i) })

417459

418460pKeywords :: [String] -> Idris ()

419−pKeywords k = do i <- getIState

420− putIState (i { syntax_keywords = k ++ syntax_keywords i })

461+pKeywords k = updateIState (\i -> i { syntax_keywords = k ++ syntax_keywords i })

421462

422463pObjs :: [(Codegen, FilePath)] -> Idris ()

423464pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs

@@ -441,11 +482,8 @@ pHdrs :: [(Codegen, String)] -> Idris ()

441482pHdrs hs = mapM_ (uncurry addHdr) hs

442483

443484pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()

444−pPatdefs ds

445− = mapM_ (\ (n, d) ->

446− do i <- getIState

447− putIState (i { idris_patdefs = addDef n (force d) (idris_patdefs i) }))

448− ds

485+pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->

486+ i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds

449487

450488pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()

451489pDefs reexp syms ds

@@ -455,9 +493,8 @@ pDefs reexp syms ds

455493 TyDecl _ _ -> return ()

456494 _ -> do iLOG $ "SOLVING " ++ show n

457495 solveDeferred n

458− i <- getIState

496+ updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

459497-- logLvl 1 $ "Added " ++ show (n, d')

460− putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

461498 if (not reexp) then do iLOG $ "Not exporting " ++ show n

462499 setAccessibility n Hidden

463500 else iLOG $ "Exporting " ++ show n) ds

@@ -501,7 +538,7 @@ pDefs reexp syms ds

501538

502539 update (P t n ty) = do n' <- getSymbol n

503540 return $ P t n' ty

504− update (App f a) = liftM2 App (update f) (update a)

541+ update (App s f a) = liftM2 (App s) (update f) (update a)

505542 update (Bind n b sc) = do b' <- updateB b

506543 sc' <- update sc

507544 return $ Bind n b' sc'

@@ -517,9 +554,8 @@ pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris

517554pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

518555

519556pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()

520−pMDocs ds = mapM_ addMDocStr ds

521− where addMDocStr (n, d) = do ist <- getIState

522− putIState ist { idris_moduledocs = addDef n d (idris_moduledocs ist) }

557+pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

558+ i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

523559

524560pAccess :: Bool -- ^ Reexporting?

525561 -> [(Name, Accessibility)] -> Idris ()

@@ -527,9 +563,7 @@ pAccess reexp ds

527563 = mapM_ (\ (n, a_in) ->

528564 do let a = if reexp then a_in else Hidden

529565 logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

530− i <- getIState

531− putIState (i { tt_ctxt = setAccess n a (tt_ctxt i) }))

532− ds

566+ updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

533567

534568pFlags :: [(Name, [FnOpt])] -> Idris ()

535569pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -538,14 +572,10 @@ pFnInfo :: [(Name, FnInfo)] -> Idris ()

538572pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds

539573

540574pTotal :: [(Name, Totality)] -> Idris ()

541−pTotal ds = mapM_ (\ (n, a) ->

542− do i <- getIState

543− putIState (i { tt_ctxt = setTotal n a (tt_ctxt i) }))

544− ds

575+pTotal ds = mapM_ (\ (n, a) -> updateIState (\i -> i { tt_ctxt = setTotal n a (tt_ctxt i) })) ds

545576

546577pTotCheckErr :: [(FC, String)] -> Idris ()

547−pTotCheckErr es = do ist <- getIState

548− putIState ist { idris_totcheckfail = idris_totcheckfail ist ++ es }

578+pTotCheckErr es = updateIState (\i -> i { idris_totcheckfail = idris_totcheckfail i ++ es })

549579

550580pCG :: [(Name, CGInfo)] -> Idris ()

551581pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds

@@ -566,24 +596,19 @@ pNameHints :: [(Name, Name)] -> Idris ()

566596pNameHints ns = mapM_ (\ (n, ty) -> addNameHint n ty) ns

567597

568598pMetaInformation :: [(Name, MetaInformation)] -> Idris ()

569−pMetaInformation ds = mapM_ (\ (n, m) ->

570− do i <- getIState

571− putIState (i { tt_ctxt = setMetaInformation n m (tt_ctxt i) }))

572− ds

599+pMetaInformation ds = mapM_ (\ (n, m) -> updateIState (\i ->

600+ i { tt_ctxt = setMetaInformation n m (tt_ctxt i) })) ds

573601

574602pErrorHandlers :: [Name] -> Idris ()

575−pErrorHandlers ns = do i <- getIState

576− putIState $ i { idris_errorhandlers = idris_errorhandlers i ++ ns }

603+pErrorHandlers ns = updateIState (\i ->

604+ i { idris_errorhandlers = idris_errorhandlers i ++ ns })

577605

578606pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()

579−pFunctionErrorHandlers [] = return ()

580−pFunctionErrorHandlers ((fn, arg, handler):ns) = do addFunctionErrorHandlers fn arg [handler]

581− pFunctionErrorHandlers ns

607+pFunctionErrorHandlers ns = mapM_ (\ (fn,arg,handler) ->

608+ addFunctionErrorHandlers fn arg [handler]) ns

582609

583610pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()

584−pMetavars ns = do i <- getIState

585− putIState $ i { idris_metavars = Data.List.reverse ns

586− ++ idris_metavars i }

611+pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })

587612

588613----- For Cheapskate and docstrings

589614

@@ -947,105 +972,6 @@ instance Binary MetaInformation where

947972 return (DataMI x1)

948973 _ -> error "Corrupted binary data for MetaInformation"

949974

950−instance Binary IBCFile where

951− 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 x39 x40 x41 x42 x43 x44 x45)

952− = {-# SCC "putIBCFile" #-}

953− do put x1

954− put x2

955− put x3

956− put x4

957− put x5

958− put x6

959− put x7

960− put x8

961− put x9

962− put x10

963− put x11

964− put x12

965− put x13

966− put x14

967− put x15

968− put x16

969− put x17

970− put x18

971− put x19

972− put x20

973− put x21

974− put x22

975− put x23

976− put x24

977− put x25

978− put x26

979− put x27

980− put x28

981− put x29

982− put x30

983− put x31

984− put x32

985− put x33

986− put x34

987− put x35

988− put x36

989− put x37

990− put x38

991− put x39

992− put x40

993− put x41

994− put x42

995− put x43

996− put x44

997− put x45

998−

999− get

1000− = do x1 <- get

1001− if x1 == ibcVersion then

1002− do x2 <- get

1003− x3 <- get

1004− x4 <- get

1005− x5 <- get

1006− x6 <- get

1007− x7 <- get

1008− x8 <- get

1009− x9 <- get

1010− x10 <- get

1011− x11 <- get

1012− x12 <- get

1013− x13 <- get

1014− x14 <- get

1015− x15 <- get

1016− x16 <- get

1017− x17 <- get

1018− x18 <- get

1019− x19 <- get

1020− x20 <- get

1021− x21 <- get

1022− x22 <- get

1023− x23 <- get

1024− x24 <- get

1025− x25 <- get

1026− x26 <- get

1027− x27 <- get

1028− x28 <- get

1029− x29 <- get

1030− x30 <- get

1031− x31 <- get

1032− x32 <- get

1033− x33 <- get

1034− x34 <- get

1035− x35 <- get

1036− x36 <- get

1037− x37 <- get

1038− x38 <- get

1039− x39 <- get

1040− x40 <- get

1041− x41 <- get

1042− x42 <- get

1043− x43 <- get

1044− x44 <- get

1045− x45 <- get

1046− 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 x39 x40 x41 x42 x43 x44 x45)

1047− else return (initIBC { ver = x1 })

1048−

1049975instance Binary DataOpt where

1050976 put x = case x of

1051977 Codata -> putWord8 0

@@ -1678,9 +1604,9 @@ instance Binary PTerm where

16781604 put x2

16791605 PUniverse x1 -> do putWord8 38

16801606 put x1

1681− PRunTactics x1 x2 -> do putWord8 39

1682− put x1

1683− put x2

1607+ PRunElab x1 x2 -> do putWord8 39

1608+ put x1

1609+ put x2

16841610 PAs x1 x2 x3 -> do putWord8 40

16851611 put x1

16861612 put x2

@@ -1692,6 +1618,8 @@ instance Binary PTerm where

16921618 put x2

16931619 PUnquote x1 -> do putWord8 43

16941620 put x1

1621+ PQuoteName x1 -> do putWord8 44

1622+ put x1

16951623

16961624

16971625 get

@@ -1813,7 +1741,7 @@ instance Binary PTerm where

18131741 return (PUniverse x1)

18141742 39 -> do x1 <- get

18151743 x2 <- get

1816− return (PRunTactics x1 x2)

1744+ return (PRunElab x1 x2)

18171745 40 -> do x1 <- get

18181746 x2 <- get

18191747 x3 <- get

@@ -1825,6 +1753,8 @@ instance Binary PTerm where

18251753 return (PQuasiquote x1 x2)

18261754 43 -> do x1 <- get

18271755 return (PUnquote x1)

1756+ 44 -> do x1 <- get

1757+ return (PQuoteName x1)

18281758 _ -> error "Corrupted binary data for PTerm"

18291759

18301760instance (Binary t) => Binary (PTactic' t) where

src/Idris/IdeMode.hs+2

@@ -222,6 +222,7 @@ data IdeModeCommand = REPLCompletions String

222222 | Metavariables Int -- ^^ the Int is the column count for pretty-printing

223223 | WhoCalls String

224224 | CallsWho String

225+ | BrowseNS String

225226 | TermNormalise [(Name, Bool)] Term

226227 | TermShowImplicits [(Name, Bool)] Term

227228 | TermNoImplicits [(Name, Bool)] Term

@@ -269,6 +270,7 @@ sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

269270sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols]) = Just (Metavariables (fromIntegral cols))

270271sexpToCommand (SexpList [SymbolAtom "who-calls", StringAtom name]) = Just (WhoCalls name)

271272sexpToCommand (SexpList [SymbolAtom "calls-who", StringAtom name]) = Just (CallsWho name)

273+sexpToCommand (SexpList [SymbolAtom "browse-namespace", StringAtom ns]) = Just (BrowseNS ns)

272274sexpToCommand (SexpList [SymbolAtom "normalise-term", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

273275 Just (TermNormalise bnd tm)

274276sexpToCommand (SexpList [SymbolAtom "show-term-implicits", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

src/Idris/IdrisDoc.hs+10−5

@@ -1,5 +1,6 @@

11{-# LANGUAGE PatternGuards #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

34

45-- | Generation of HTML documentation for Idris code

56module Idris.IdrisDoc (generateDocs) where

@@ -217,9 +218,11 @@ referredNss (n, Just d, _) =

217218 names = concatMap (extractPTermNames) ts

218219 in S.map getNs $ S.fromList names

219220

220− where getFunDocs (FunDoc f) = [f]

221− getFunDocs (DataDoc f fs) = f:fs

221+ where getFunDocs (FunDoc f) = [f]

222+ getFunDocs (DataDoc f fs) = f:fs

222223 getFunDocs (ClassDoc _ _ fs _ _ _ _) = fs

224+ getFunDocs (NamedInstanceDoc _ fd) = [fd]

225+ getFunDocs (ModDoc _ _) = []

223226 types (FD _ _ args t _) = t:(map second args)

224227 second (_, x, _, _) = x

225228

@@ -318,7 +321,7 @@ extractPTermNames (PCoerced p) = extract p

318321extractPTermNames (PDisamb _ p) = extract p

319322extractPTermNames (PUnifyLog p) = extract p

320323extractPTermNames (PNoImplicits p) = extract p

321−extractPTermNames (PRunTactics _ p) = extract p

324+extractPTermNames (PRunElab _ p) = extract p

322325extractPTermNames _ = []

323326

324327-- | Shorter name for extractPTermNames

@@ -417,7 +420,7 @@ createIndex nss out =

417420 BS2.hPut h $ renderHtml $ wrapper Nothing $ do

418421 H.h1 $ "Namespaces"

419422 H.ul ! class_ "names" $ do

420− let path ns = "docs" </> genRelNsPath ns "html"

423+ let path ns = "docs" ++ "/" ++ genRelNsPath ns "html"

421424 item ns = do let n = toHtml $ nsName2Str ns

422425 link = toValue $ path ns

423426 H.li $ H.a ! href link ! class_ "code" $ n

@@ -609,6 +612,8 @@ createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do

609612 H.dt $ toHtml $ show name

610613 H.dd $ Docstrings.renderHtml docstring

611614

615+createOtherDoc ist (NamedInstanceDoc _ fd) = createFunDoc ist fd

616+

612617createOtherDoc ist (ModDoc _ docstring) = do

613618 Docstrings.renderHtml docstring

614619

@@ -658,7 +663,7 @@ existingNamespaces :: FilePath -- ^ The base directory containing the

658663 -- namespace pages

659664 -> IO (S.Set NsName)

660665existingNamespaces out = do

661− let docs = out </> "docs"

666+ let docs = out ++ "/" ++ "docs"

662667 str2Ns s | s == rootNsStr = []

663668 str2Ns s = reverse $ T.splitOn (T.singleton '.') (txt s)

664669 toNs fp = do isFile <- doesFileExist $ docs </> fp

src/Idris/Inliner.hs+1−1

@@ -21,7 +21,7 @@ inlineDef ist ds = map (\ (ns, lhs, rhs) -> (ns, lhs, inlineTerm ist rhs)) ds

2121inlineTerm :: IState -> Term -> Term

2222inlineTerm ist tm = inl tm where

2323 inl orig@(P _ n _) = inlApp n [] orig

24− inl orig@(App f a)

24+ inl orig@(App _ f a)

2525 | (P _ fn _, args) <- unApply orig = inlApp fn args orig

2626 inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc)

2727 inl (Bind n b sc) = Bind n b (inl sc)

src/Idris/Interactive.hs+17−18

@@ -12,13 +12,12 @@ import Idris.Core.Evaluate

1212import Idris.CaseSplit

1313import Idris.AbsSyntax

1414import Idris.ElabDecls

15−import Idris.ElabTerm

1615import Idris.Error

1716import Idris.Delaborate

1817import Idris.Output

1918import Idris.IdeMode hiding (IdeModeCommand(..))

20−

2119import Idris.Elab.Value

20+import Idris.Elab.Term

2221

2322import Util.Pretty

2423import Util.System

@@ -34,7 +33,7 @@ import Debug.Trace

3433

3534caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris ()

3635caseSplitAt fn updatefile l n

37− = do src <- runIO $ readFile fn

36+ = do src <- runIO $ readSource fn

3837 res <- splitOnLine l n fn

3938 iLOG (showSep "\n" (map show res))

4039 let (before, (ap : later)) = splitAt (l-1) (lines src)

@@ -42,14 +41,14 @@ caseSplitAt fn updatefile l n

4241 let new = concat res'

4342 if updatefile

4443 then do let fb = fn ++ "~" -- make a backup!

45− runIO $ writeFile fb (unlines before ++ new ++ unlines later)

44+ runIO $ writeSource fb (unlines before ++ new ++ unlines later)

4645 runIO $ copyFile fb fn

4746 else -- do iputStrLn (show res)

4847 iPrintResult new

4948

5049addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

5150addClauseFrom fn updatefile l n

52− = do src <- runIO $ readFile fn

51+ = do src <- runIO $ readSource fn

5352 let (before, tyline : later) = splitAt (l-1) (lines src)

5453 let indent = getIndent 0 (show n) tyline

5554 cl <- getClause l n fn

@@ -57,7 +56,7 @@ addClauseFrom fn updatefile l n

5756 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

5857 if updatefile

5958 then do let fb = fn ++ "~"

60− runIO $ writeFile fb (unlines (before ++ nonblank) ++

59+ runIO $ writeSource fb (unlines (before ++ nonblank) ++

6160 replicate indent ' ' ++

6261 cl ++ "\n" ++

6362 unlines rest)

@@ -71,7 +70,7 @@ addClauseFrom fn updatefile l n

7170

7271addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

7372addProofClauseFrom fn updatefile l n

74− = do src <- runIO $ readFile fn

73+ = do src <- runIO $ readSource fn

7574 let (before, tyline : later) = splitAt (l-1) (lines src)

7675 let indent = getIndent 0 (show n) tyline

7776 cl <- getProofClause l n fn

@@ -79,7 +78,7 @@ addProofClauseFrom fn updatefile l n

7978 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

8079 if updatefile

8180 then do let fb = fn ++ "~"

82− runIO $ writeFile fb (unlines (before ++ nonblank) ++

81+ runIO $ writeSource fb (unlines (before ++ nonblank) ++

8382 replicate indent ' ' ++

8483 cl ++ "\n" ++

8584 unlines rest)

@@ -92,7 +91,7 @@ addProofClauseFrom fn updatefile l n

9291

9392addMissing :: FilePath -> Bool -> Int -> Name -> Idris ()

9493addMissing fn updatefile l n

95− = do src <- runIO $ readFile fn

94+ = do src <- runIO $ readSource fn

9695 let (before, tyline : later) = splitAt (l-1) (lines src)

9796 let indent = getIndent 0 (show n) tyline

9897 i <- getIState

@@ -106,7 +105,7 @@ addMissing fn updatefile l n

106105 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

107106 if updatefile

108107 then do let fb = fn ++ "~"

109− runIO $ writeFile fb (unlines (before ++ nonblank)

108+ runIO $ writeSource fb (unlines (before ++ nonblank)

110109 ++ extras ++ unlines rest)

111110 runIO $ copyFile fb fn

112111 else iPrintResult extras

@@ -141,7 +140,7 @@ addMissing fn updatefile l n

141140

142141makeWith :: FilePath -> Bool -> Int -> Name -> Idris ()

143142makeWith fn updatefile l n

144− = do src <- runIO $ readFile fn

143+ = do src <- runIO $ readSource fn

145144 let (before, tyline : later) = splitAt (l-1) (lines src)

146145 let ind = getIndent tyline

147146 let with = mkWith tyline n

@@ -151,7 +150,7 @@ makeWith fn updatefile l n

151150 not (ind == getIndent x)) later

152151 if updatefile then

153152 do let fb = fn ++ "~"

154− runIO $ writeFile fb (unlines (before ++ nonblank)

153+ runIO $ writeSource fb (unlines (before ++ nonblank)

155154 ++ with ++ "\n" ++

156155 unlines rest)

157156 runIO $ copyFile fb fn

@@ -164,7 +163,7 @@ doProofSearch :: FilePath -> Bool -> Bool ->

164163doProofSearch fn updatefile rec l n hints Nothing

165164 = doProofSearch fn updatefile rec l n hints (Just 10)

166165doProofSearch fn updatefile rec l n hints (Just depth)

167− = do src <- runIO $ readFile fn

166+ = do src <- runIO $ readSource fn

168167 let (before, tyline : later) = splitAt (l-1) (lines src)

169168 ctxt <- getContext

170169 mn <- case lookupNames n ctxt of

@@ -192,7 +191,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

192191 (\e -> return ("?" ++ show n))

193192 if updatefile then

194193 do let fb = fn ++ "~"

195− runIO $ writeFile fb (unlines before ++

194+ runIO $ writeSource fb (unlines before ++

196195 updateMeta False tyline (show n) newmv ++ "\n"

197196 ++ unlines later)

198197 runIO $ copyFile fb fn

@@ -241,7 +240,7 @@ addBracket True new | any isSpace new = '(' : new ++ ")"

241240

242241makeLemma :: FilePath -> Bool -> Int -> Name -> Idris ()

243242makeLemma fn updatefile l n

244− = do src <- runIO $ readFile fn

243+ = do src <- runIO $ readSource fn

245244 let (before, tyline : later) = splitAt (l-1) (lines src)

246245

247246 -- if the name is in braces, rather than preceded by a ?, treat it

@@ -267,7 +266,7 @@ makeLemma fn updatefile l n

267266

268267 if updatefile then

269268 do let fb = fn ++ "~"

270− runIO $ writeFile fb (addLem before tyline lem lem_app later)

269+ runIO $ writeSource fb (addLem before tyline lem lem_app later)

271270 runIO $ copyFile fb fn

272271 else case idris_outputmode i of

273272 RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app

@@ -285,7 +284,7 @@ makeLemma fn updatefile l n

285284 " = ?" ++ show n ++ "_rhs"

286285 if updatefile then

287286 do let fb = fn ++ "~"

288− runIO $ writeFile fb (addProv before tyline lem_app later)

287+ runIO $ writeSource fb (addProv before tyline lem_app later)

289288 runIO $ copyFile fb fn

290289 else case idris_outputmode i of

291290 RawOutput _ -> iPrintResult $ lem_app

@@ -323,7 +322,7 @@ makeLemma fn updatefile l n

323322 guessImps ctxt _ = []

324323

325324 guarded ctxt n (P _ n' _) | n == n' = True

326− guarded ctxt n ap@(App _ _)

325+ guarded ctxt n ap@(App _ _ _)

327326 | (P _ f _, args) <- unApply ap,

328327 isConName f ctxt = any (guarded ctxt n) args

329328-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

src/Idris/ParseExpr.hs+84−53

@@ -1,5 +1,4 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−{-# OPTIONS_GHC -O0 #-}

32module Idris.ParseExpr where

43

54import Prelude hiding (pi)

@@ -221,7 +220,7 @@ InternalExpr ::=

221220internalExpr :: SyntaxInfo -> IdrisParser PTerm

222221internalExpr syn =

223222 unifyLog syn

224− <|> runTactics syn

223+ <|> runElab syn

225224 <|> disamb syn

226225 <|> noImplicits syn

227226 <|> recordType syn

@@ -312,6 +311,7 @@ SimpleExpr ::=

312311 | Type

313312 | 'Void'

314313 | Quasiquote

314+ | NameQuote

315315 | Unquote

316316 | '_'

317317 ;

@@ -330,6 +330,7 @@ simpleExpr syn =

330330 <|> proofExpr syn

331331 <|> tacticsExpr syn

332332 <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)

333+ <|> do reserved "AnyType"; return $ PUniverse AllTypes

333334 <|> do reserved "Type"; return PType

334335 <|> do reserved "UniqueType"; return $ PUniverse UniqueType

335336 <|> do reserved "NullType"; return $ PUniverse NullType

@@ -356,6 +357,7 @@ simpleExpr syn =

356357 return (PAppBind fc s [])

357358 <|> bracketed (disallowImp syn)

358359 <|> quasiquote syn

360+ <|> namequote syn

359361 <|> unquote syn

360362 <|> do lchar '_'; return Placeholder

361363 <?> "expression"

@@ -498,16 +500,16 @@ unifyLog syn = do try (lchar '%' *> reserved "unifyLog")

498500

499501{- | Parses a new-style tactics expression

500502RunTactics ::=

501− '%' 'runTactics' SimpleExpr

503+ '%' 'runElab' SimpleExpr

502504 ;

503505-}

504−runTactics :: SyntaxInfo -> IdrisParser PTerm

505−runTactics syn = do try (lchar '%' *> reserved "runTactics")

506− fc <- getFC

507− tm <- simpleExpr syn

508− i <- get

509− return $ PRunTactics fc tm

510− <?> "new-style tactics expression"

506+runElab :: SyntaxInfo -> IdrisParser PTerm

507+runElab syn = do try (lchar '%' *> reserved "runElab")

508+ fc <- getFC

509+ tm <- simpleExpr syn

510+ i <- get

511+ return $ PRunElab fc tm

512+ <?> "new-style tactics expression"

511513

512514{- | Parses a disambiguation expression

513515Disamb ::=

@@ -640,6 +642,18 @@ unquote syn = do guard (syn_in_quasiquote syn > 0)

640642 return $ PUnquote e

641643 <?> "unquotation"

642644

645+{-| Parses a quotation of a name (for using the elaborator to resolve boring details)

646+

647+> NameQuote ::= '`{' Name '}'

648+

649+-}

650+namequote :: SyntaxInfo -> IdrisParser PTerm

651+namequote syn = do symbol "`{"

652+ n <- fnName

653+ symbol "}"

654+ return $ PQuoteName n

655+ <?> "quoted name"

656+

643657

644658{-| Parses a record field setter expression

645659@

@@ -869,49 +883,67 @@ bindsymbol opts st syn

869883 = do symbol "->"

870884 return (Exp opts st False)

871885

886+explicitPi opts st syn

887+ = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')

888+ binder <- bindsymbol opts st syn

889+ sc <- expr syn

890+ return (bindList (PPi binder) xt sc)

891+

892+autoImplicit opts st syn

893+ = do reserved "auto"

894+ when (st == Static) $ fail "auto implicits can not be static"

895+ xt <- typeDeclList syn

896+ lchar '}'

897+ symbol "->"

898+ sc <- expr syn

899+ return (bindList (PPi

900+ (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing []]))) xt sc)

901+

902+defaultImplicit opts st syn = do

903+ reserved "default"

904+ when (st == Static) $ fail "default implicits can not be static"

905+ ist <- get

906+ script' <- simpleExpr syn

907+ let script = debindApp syn . desugar syn ist $ script'

908+ xt <- typeDeclList syn

909+ lchar '}'

910+ symbol "->"

911+ sc <- expr syn

912+ return (bindList (PPi (TacImp [] Dynamic script)) xt sc)

913+

914+normalImplicit opts st syn = do

915+ xt <- typeDeclList syn <* lchar '}'

916+ symbol "->"

917+ cs <- constraintList syn

918+ sc <- expr syn

919+ let (im,cl)

920+ = if implicitAllowed syn

921+ then (Imp opts st False Nothing,

922+ constraint)

923+ else (Imp opts st False (Just (Impl False)),

924+ Imp opts st False (Just (Impl True)))

925+ return (bindList (PPi im) xt

926+ (bindList (PPi cl) cs sc))

927+

928+implicitPi opts st syn =

929+ autoImplicit opts st syn

930+ <|> defaultImplicit opts st syn

931+ <|> normalImplicit opts st syn

932+

933+unboundPi opts st syn = do

934+ x <- opExpr syn

935+ (do binder <- bindsymbol opts st syn

936+ sc <- expr syn

937+ return (PPi binder (sUN "__pi_arg") x sc))

938+ <|> return x

939+

872940pi :: SyntaxInfo -> IdrisParser PTerm

873941pi syn =

874942 do opts <- piOpts syn

875943 st <- static

876− (do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')

877− binder <- bindsymbol opts st syn

878− sc <- expr syn

879− return (bindList (PPi binder) xt sc)) <|> (do

880− (do try (lchar '{' *> reserved "auto")

881− when (st == Static) $ fail "auto type constraints can not be static"

882− xt <- typeDeclList syn

883− lchar '}'

884− symbol "->"

885− sc <- expr syn

886− return (bindList (PPi

887− (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing []]))) xt sc)) <|> (do

888− try (lchar '{' *> reserved "default")

889− when (st == Static) $ fail "default tactic constraints can not be static"

890− ist <- get

891− script' <- simpleExpr syn

892− let script = debindApp syn . desugar syn ist $ script'

893− xt <- typeDeclList syn

894− lchar '}'

895− symbol "->"

896− sc <- expr syn

897− return (bindList (PPi (TacImp [] Dynamic script)) xt sc))

898− <|> (do xt <- try (lchar '{' *> typeDeclList syn <* lchar '}')

899− symbol "->"

900− cs <- constraintList syn

901− sc <- expr syn

902− let (im,cl)

903− = if implicitAllowed syn

904− then (Imp opts st False Nothing,

905− constraint)

906− else (Imp opts st False (Just (Impl False)),

907− Imp opts st False (Just (Impl True)))

908− return (bindList (PPi im) xt

909− (bindList (PPi cl) cs sc))))

910− <|> (do x <- opExpr syn

911− (do binder <- bindsymbol opts st syn

912− sc <- expr syn

913− return (PPi binder (sUN "__pi_arg") x sc))

914− <|> return x)

944+ explicitPi opts st syn

945+ <|> try (do lchar '{'; implicitPi opts st syn)

946+ <|> unboundPi opts st syn

915947 <?> "dependent type signature"

916948

917949{- | Parses Possible Options for Pi Expressions

@@ -944,14 +976,14 @@ constraintList1 syn = try (do lchar '('

944976 lchar ')'

945977 reservedOp "=>"

946978 return tys)

947− <|> try (do t <- expr (disallowImp syn)

979+ <|> try (do t <- opExpr (disallowImp syn)

948980 reservedOp "=>"

949981 return [(defname, t)])

950982 <?> "type constraint list"

951983 where nexpr = try (do n <- name; lchar ':'

952− e <- expr' (disallowImp syn)

984+ e <- expr syn

953985 return (n, e))

954− <|> do e <- expr' (disallowImp syn)

986+ <|> do e <- expr syn

955987 return (defname, e)

956988 defname = sMN 0 "constrarg"

957989

@@ -1148,7 +1180,6 @@ Constant ::=

11481180 | 'String'

11491181 | 'Ptr'

11501182 | 'ManagedPtr'

1151− | 'prim__UnsafeBuffer'

11521183 | 'Bits8'

11531184 | 'Bits16'

11541185 | 'Bits32'

src/Idris/Parser.hs+20−45

@@ -25,8 +25,8 @@ import Idris.Imports

2525import Idris.Delaborate

2626import Idris.Error

2727import Idris.Elab.Value

28+import Idris.Elab.Term

2829import Idris.ElabDecls

29−import Idris.ElabTerm

3030import Idris.Coverage

3131import Idris.IBC

3232import Idris.Unlit

@@ -43,6 +43,7 @@ import Idris.Docstrings hiding (Unchecked)

4343import Paths_idris

4444

4545import Util.DynamicLinker

46+import Util.System (readSource, writeSource)

4647import qualified Util.Pretty as P

4748

4849import Idris.Core.TT

@@ -1076,71 +1077,44 @@ Directive' ::= 'lib' CodeGen String_t

10761077-}

10771078directive :: SyntaxInfo -> IdrisParser [PDecl]

10781079directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;

1079− return [PDirective (do addLib cgn lib

1080− addIBC (IBCLib cgn lib))]

1080+ return [PDirective (DLib cgn lib)]

10811081 <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;

1082− return [PDirective (do dirs <- allImportDirs

1083− o <- liftIO $ findInPath dirs obj

1084− addIBC (IBCObj cgn obj) -- just name, search on loading ibc

1085− addObjectFile cgn o)]

1086− <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_;

1087− flag <- stringLiteral

1088− return [PDirective (do addIBC (IBCCGFlag cgn flag)

1089− addFlag cgn flag)]

1082+ return [PDirective (DLink cgn obj)]

1083+ <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_; flag <- stringLiteral

1084+ return [PDirective (DFlag cgn flag)]

10901085 <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;

1091− return [PDirective (do addHdr cgn hdr

1092− addIBC (IBCHeader cgn hdr))]

1086+ return [PDirective (DInclude cgn hdr)]

10931087 <|> do try (lchar '%' *> reserved "hide"); n <- fnName

1094− return [PDirective (do setAccessibility n Hidden

1095− addIBC (IBCAccess n Hidden))]

1088+ return [PDirective (DHide n)]

10961089 <|> do try (lchar '%' *> reserved "freeze"); n <- iName []

1097− return [PDirective (do setAccessibility n Frozen

1098− addIBC (IBCAccess n Frozen))]

1090+ return [PDirective (DFreeze n)]

10991091 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1100− return [PDirective (do i <- get

1101− put(i { default_access = acc }))]

1092+ return [PDirective (DAccess acc)]

11021093 <|> do try (lchar '%' *> reserved "default"); tot <- totality

11031094 i <- get

11041095 put (i { default_total = tot } )

1105− return [PDirective (do i <- get

1106− put(i { default_total = tot }))]

1096+ return [PDirective (DDefault tot)]

11071097 <|> do try (lchar '%' *> reserved "logging"); i <- natural;

1108− return [PDirective (setLogLevel (fromInteger i))]

1098+ return [PDirective (DLogging i)]

11091099 <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');

1110− return [PDirective (do added <- addDyLib libs

1111− case added of

1112− Left lib -> addIBC (IBCDyLib (lib_name lib))

1113− Right msg ->

1114− fail $ msg)]

1100+ return [PDirective (DDynamicLibs libs)]

11151101 <|> do try (lchar '%' *> reserved "name")

11161102 ty <- fnName

11171103 ns <- sepBy1 name (lchar ',')

1118− return [PDirective (do ty' <- disambiguate ty

1119− mapM_ (addNameHint ty') ns

1120− mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

1104+ return [PDirective (DNameHint ty ns)]

11211105 <|> do try (lchar '%' *> reserved "error_handlers")

11221106 fn <- fnName

11231107 arg <- fnName

11241108 ns <- sepBy1 name (lchar ',')

1125− return [PDirective (do fn' <- disambiguate fn

1126− ns' <- mapM disambiguate ns

1127− addFunctionErrorHandlers fn' arg ns'

1128− mapM_ (addIBC . IBCFunctionErrorHandler fn' arg) ns')]

1109+ return [PDirective (DErrorHandlers fn arg ns) ]

11291110 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1130− return [PDirective (addLangExt ext)]

1111+ return [PDirective (DLanguage ext)]

11311112 <|> do fc <- getFC

11321113 try (lchar '%' *> reserved "used")

11331114 fn <- fnName

11341115 arg <- iName []

1135− return [PDirective (addUsedName fc fn arg)]

1136−

1116+ return [PDirective (DUsed fc fn arg)]

11371117 <?> "directive"

1138− where disambiguate :: Name -> Idris Name

1139− disambiguate n = do i <- getIState

1140− case lookupCtxtName n (idris_implicits i) of

1141− [(n', _)] -> return n'

1142− [] -> throwError (NoSuchVariable n)

1143− more -> throwError (CantResolveAlts (map fst more))

11441118

11451119pLangExt :: IdrisParser LanguageExt

11461120pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1345,7 +1319,7 @@ loadSource lidr f toline

13451319 = do iLOG ("Reading " ++ f)

13461320 i <- getIState

13471321 let def_total = default_total i

1348− file_in <- runIO $ readFile f

1322+ file_in <- runIO $ readSource f

13491323 file <- if lidr then tclift $ unlit f file_in else return file_in

13501324 (mdocs, mname, imports_in, pos) <- parseImports f file

13511325 ai <- getAutoImports

@@ -1364,7 +1338,7 @@ loadSource lidr f toline

13641338 -- process and check module aliases

13651339 let modAliases = M.fromList

13661340 [(prep alias, prep realName) | (reexport, realName, Just alias, fc) <- imports]

1367− prep = map T.pack . reverse . Spl.splitOn "/"

1341+ prep = map T.pack . reverse . Spl.splitOn [pathSeparator]

13681342 aliasNames = [(alias, fc) | (_, _, Just alias, fc) <- imports]

13691343 histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames

13701344 case map head . filter ((/= 1) . length) $ histogram of

@@ -1470,6 +1444,7 @@ loadSource lidr f toline

14701444 case x of

14711445 PClauses{} -> r

14721446 PClass{} -> r

1447+ PData{} -> r

14731448 PInstance{} -> r

14741449 _ -> x

14751450

src/Idris/PartialEval.hs+2−2

@@ -146,7 +146,7 @@ mkPE_TyDecl ist args ty = mkty args ty

146146 = do nm <- get

147147 put (nm + 1)

148148 return (P Bound (sMN nm "spec") Erased)

149− gen (App f a) = App <$> gen f <*> gen a

149+ gen (App s f a) = App s <$> gen f <*> gen a

150150 gen tm = return tm

151151

152152-- | Checks if a given argument is a type class constraint argument

@@ -291,7 +291,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

291291

292292 -- if we have a *defined* function that has static arguments,

293293 -- it will become a specialised application

294− ga env tm@(App f a) | (P _ n _, args) <- unApply tm,

294+ ga env tm@(App _ f a) | (P _ n _, args) <- unApply tm,

295295 n `notElem` map fst (idris_metavars ist) =

296296 ga env f ++ ga env a ++

297297 case (lookupCtxtExact n (idris_statics ist),

src/Idris/ProofSearch.hs+37−24

@@ -15,6 +15,7 @@ import Idris.Error

1515import Control.Applicative ((<$>))

1616import Control.Monad

1717import Control.Monad.State.Strict

18+import qualified Data.Set as S

1819import Data.List

1920import Debug.Trace

2021

@@ -91,7 +92,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

9192 if ambigok || argsok then

9293 case lookupCtxt nroot (idris_tyinfodata ist) of

9394 [TISolution ts] -> findInferredTy ts

94− _ -> psRec rec maxDepth []

95+ _ -> psRec rec maxDepth [] S.empty

9596 else autoArg (sUN "auto") -- not enough info in the type yet

9697 where

9798 findInferredTy (t : _) = elab (delab ist (toUN t))

@@ -127,20 +128,28 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

127128 toUN t@(P nt (MN i n) ty)

128129 | ('_':xs) <- str n = t

129130 | otherwise = P nt (UN n) ty

130− toUN (App f a) = App (toUN f) (toUN a)

131+ toUN (App s f a) = App s (toUN f) (toUN a)

131132 toUN t = t

132133

133134 -- psRec counts depth and the local variable applications we're under

134135 -- (so we don't try a pointless application of something to itself,

135136 -- which obviously won't work anyway but might lead us on a wild

136137 -- goose chase...)

137− psRec _ 0 locs | fromProver = cantSolveGoal

138− psRec rec 0 locs = do attack; defer [] nroot; solve --fail "Maximum depth reached"

139− psRec False d locs = tryCons d locs hints

140− psRec True d locs

138+ -- Also keep track of the types we've proved so far in this branch

139+ -- (if we get back to one we've been to before, we're just in a cycle and

140+ -- that's no use)

141+ psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()

142+ psRec _ 0 locs tys | fromProver = cantSolveGoal

143+ psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"

144+ psRec False d locs tys = tryCons d locs tys hints

145+ psRec True d locs tys

141146 = do compute

147+ ty <- goal

148+ when (S.member ty tys) $ fail "Been here before"

149+ let tys' = S.insert ty tys

142150 try' (trivial elab ist)

143− (try' (try' (resolveByCon (d - 1) locs) (resolveByLocals (d - 1) locs)

151+ (try' (try' (resolveByCon (d - 1) locs tys')

152+ (resolveByLocals (d - 1) locs tys')

144153 True)

145154 -- if all else fails, make a new metavariable

146155 (if fromProver

@@ -151,7 +160,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

151160 getFn d (Just f) | d < maxDepth-1 = [f]

152161 | otherwise = []

153162

154− resolveByCon d locs

163+ resolveByCon d locs tys

155164 = do t <- goal

156165 let (f, _) = unApply t

157166 case f of

@@ -160,7 +169,8 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

160169 Nothing -> []

161170 Just hs -> hs

162171 case lookupCtxtExact n (idris_datatypes ist) of

163− Just t -> tryCons d locs (hints ++

172+ Just t -> tryCons d locs tys

173+ (hints ++

164174 con_names t ++

165175 autohints ++

166176 getFn d fn)

@@ -169,28 +179,31 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

169179

170180 -- if there are local variables which have a function type, try

171181 -- applying them too

172− resolveByLocals d locs

182+ resolveByLocals d locs tys

173183 = do env <- get_env

174− tryLocals d locs env

184+ tryLocals d locs tys env

175185

176− tryLocals d locs [] = fail "Locals failed"

177− tryLocals d locs ((x, t) : xs)

178− | x `elem` locs = tryLocals d locs xs

179− | otherwise = try' (tryLocal d (x : locs) x t) (tryLocals d locs xs) True

186+ tryLocals d locs tys [] = fail "Locals failed"

187+ tryLocals d locs tys ((x, t) : xs)

188+ | x `elem` locs = tryLocals d locs tys xs

189+ | otherwise = try' (tryLocal d (x : locs) tys x t)

190+ (tryLocals d locs tys xs) True

180191

181− tryCons d locs [] = fail "Constructors failed"

182− tryCons d locs (c : cs) = try' (tryCon d locs c) (tryCons d locs cs) True

192+ tryCons d locs tys [] = fail "Constructors failed"

193+ tryCons d locs tys (c : cs)

194+ = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

183195

184− tryLocal d locs n t

196+ tryLocal d locs tys n t

185197 = do let a = getPArity (delab ist (binderTy t))

186− tryLocalArg d locs n a

198+ tryLocalArg d locs tys n a

187199

188− tryLocalArg d locs n 0 = elab (PRef (fileFC "prf") n)

189− tryLocalArg d locs n i = simple_app False (tryLocalArg d locs n (i - 1))

190− (psRec True d locs) "proof search local apply"

200+ tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") n)

201+ tryLocalArg d locs tys n i

202+ = simple_app False (tryLocalArg d locs tys n (i - 1))

203+ (psRec True d locs tys) "proof search local apply"

191204

192205 -- Like type class resolution, but searching with constructors

193− tryCon d locs n =

206+ tryCon d locs tys n =

194207 do ty <- goal

195208 let imps = case lookupCtxtExact n (idris_implicits ist) of

196209 Nothing -> []

@@ -204,7 +217,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

204217 when (length ps < length ps') $ fail "Can't apply constructor"

205218 mapM_ (\ (_, h) -> do focus h

206219 aty <- goal

207− psRec True d locs)

220+ psRec True d locs tys)

208221 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

209222 solve

210223

src/Idris/Prover.hs+2−2

@@ -9,13 +9,13 @@ import Idris.Core.Typecheck

99

1010import Idris.Elab.Utils

1111import Idris.Elab.Value

12+import Idris.Elab.Term

1213

1314import Idris.AbsSyntax

1415import Idris.AbsSyntaxTree

1516import Idris.Delaborate

1617import Idris.Docs (getDocs, pprintDocs, pprintConstDocs)

1718import Idris.ElabDecls

18−import Idris.ElabTerm

1919import Idris.Parser hiding (params)

2020import Idris.Error

2121import Idris.DataOpts

@@ -66,7 +66,7 @@ assumptionNames e

6666

6767prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

6868prove opt ctxt lit n ty

69− = do let ps = initElaborator n ctxt ty

69+ = do ps <- fmap (\ist -> initElaborator n ctxt (idris_datatypes ist) ty) getIState

7070 idemodePutSExp "start-proof-mode" n

7171 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing

7272 iLOG $ "Adding " ++ show tm

src/Idris/REPL.hs+45−15

@@ -8,7 +8,6 @@ import Idris.ASTUtils

88import Idris.Apropos (apropos, aproposModules)

99import Idris.REPLParser

1010import Idris.ElabDecls

11−import Idris.ElabTerm

1211import Idris.Erasure

1312import Idris.Error

1413import Idris.ErrReverse

@@ -35,10 +34,13 @@ import Idris.WhoCalls

3534import Idris.TypeSearch (searchByType)

3635import Idris.IBC (loadPkgIndex, writePkgIndex)

3736

37+import Idris.REPL.Browse (namesInNS, namespacesInNS)

38+

3839import Idris.Elab.Type

3940import Idris.Elab.Clause

4041import Idris.Elab.Data

4142import Idris.Elab.Value

43+import Idris.Elab.Term

4244

4345import Version_idris (gitHash)

4446import Util.System

@@ -463,6 +465,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) =

463465 renderPretty 0.9 1000 .

464466 fmap (fancifyAnnots ist) .

465467 prettyName True True []

468+

466469runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

467470 case splitName n of

468471 Left err -> iPrintError err

@@ -476,6 +479,20 @@ runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

476479 fmap (fancifyAnnots ist) .

477480 prettyName True True []

478481

482+runIdeModeCommand h id orig fn modes (IdeMode.BrowseNS ns) =

483+ case splitOn "." ns of

484+ [] -> iPrintError "No namespace provided"

485+ ns -> do underNSs <- fmap (map $ concat . intersperse ".") $ namespacesInNS ns

486+ names <- namesInNS ns

487+ if null underNSs && null names

488+ then iPrintError "Invalid or empty namespace"

489+ else do ist <- getIState

490+ let msg = (IdeMode.SymbolAtom "ok", (underNSs, map (pn ist) names))

491+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

492+ where pn ist = displaySpans .

493+ renderPretty 0.9 1000 .

494+ fmap (fancifyAnnots ist) .

495+ prettyName True True []

479496runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

480497 do ctxt <- getContext

481498 ist <- getIState

@@ -582,8 +599,8 @@ idemodeProcess fn (HNF t) = process fn (HNF t)

582599--idemodeProcess fn TTShell = process fn TTShell -- need some prove mode!

583600idemodeProcess fn (TestInline t) = process fn (TestInline t)

584601

585−idemodeProcess fn Execute = do process fn Execute

586− iPrintResult ""

602+idemodeProcess fn (Execute t) = do process fn (Execute t)

603+ iPrintResult ""

587604idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)

588605 iPrintResult ""

589606idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)

@@ -1059,7 +1076,7 @@ process fn' (AddProof prf)

10591076 else ifail $ "Neither \""++fn''++"\" nor \""++fnExt++"\" exist"

10601077 let fb = fn ++ "~"

10611078 runIO $ copyFile fn fb -- make a backup in case something goes wrong!

1062− prog <- runIO $ readFile fb

1079+ prog <- runIO $ readSource fb

10631080 i <- getIState

10641081 let proofs = proof_list i

10651082 n' <- case prf of

@@ -1071,7 +1088,7 @@ process fn' (AddProof prf)

10711088 case lookup n proofs of

10721089 Nothing -> iputStrLn "No proof to add"

10731090 Just p -> do let prog' = insertScript (showProof (lit fn) n p) ls

1074− runIO $ writeFile fn (unlines prog')

1091+ runIO $ writeSource fn (unlines prog')

10751092 removeProof n

10761093 iputStrLn $ "Added proof " ++ show n

10771094 where ls = (lines prog)

@@ -1115,13 +1132,10 @@ process fn (TestInline t)

11151132 let tm' = inlineTerm ist tm

11161133 c <- colourise

11171134 iPrintResult (showTm ist (delab ist tm'))

1118−process fn Execute

1135+process fn (Execute tm)

11191136 = idrisCatch

11201137 (do ist <- getIState

1121− (m, _) <- elabVal recinfo ERHS

1122− (PApp fc

1123− (PRef fc (sUN "run__IO"))

1124− [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

1138+ (m, _) <- elabVal recinfo ERHS (elabExec fc tm)

11251139 (tmpn, tmph) <- runIO tempfile

11261140 runIO $ hClose tmph

11271141 t <- codegen

@@ -1232,10 +1246,11 @@ process fn (Apropos pkgs a) =

12321246 delabTy ist n,

12331247 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

12341248 | n <- sort names, isUN n ]

1235− iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>

1236− ppD ist d <> line) mods) <$>

1237− vsep (map (prettyDocumentedIst ist) aproposInfo)

1238− putIState orig

1249+ if (not (null mods)) || (not (null aproposInfo))

1250+ then iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>

1251+ ppD ist d <> line) mods) <$>

1252+ vsep (map (prettyDocumentedIst ist) aproposInfo)

1253+ else iRenderError $ text "No results found"

12391254 where isUN (UN _) = True

12401255 isUN (NS n _) = isUN n

12411256 isUN _ = False

@@ -1259,6 +1274,21 @@ process fn (CallsWho n) =

12591274 prettyName True True [] n <+> text "calls:" <$>

12601275 indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))

12611276 calls

1277+

1278+process fn (Browse ns) =

1279+ do underNSs <- namespacesInNS ns

1280+ names <- namesInNS ns

1281+ if null underNSs && null names

1282+ then iPrintError "Invalid or empty namespace"

1283+ else do ist <- getIState

1284+ iRenderResult $

1285+ text "Namespaces:" <$>

1286+ indent 2 (vsep (map (text . showSep ".") underNSs)) <$>

1287+ text "Names:" <$>

1288+ indent 2 (vsep (map (\n -> prettyName True False [] n <+> colon <+>

1289+ (group . align $ pprintDelabTy ist n))

1290+ names))

1291+

12621292-- IdrisDoc

12631293process fn (MakeDoc s) =

12641294 do istate <- getIState

@@ -1557,7 +1587,7 @@ idrisMain opts =

15571587

15581588 when (DefaultTotal `elem` opts) $ do i <- getIState

15591589 putIState (i { default_total = True })

1560− setColourise $ not quiet && last (True : opt getColour opts)

1590+ setColourise $ not quiet && last ((not isWindows) : opt getColour opts)

15611591

15621592

15631593

src/Idris/REPL/Browse.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-}

2+

3+module Idris.REPL.Browse (namespacesInNS, namesInNS) where

4+

5+import Data.List (isSuffixOf, nub)

6+import Data.Maybe (mapMaybe)

7+import qualified Data.Text as T (unpack)

8+

9+import Idris.Core.Evaluate (ctxtAlist)

10+import Idris.Core.TT (Name(..))

11+

12+import Idris.AbsSyntaxTree (Idris)

13+import Idris.AbsSyntax (getContext)

14+

15+-- | Find the sub-namespaces of a given namespace. The components

16+-- should be in display order rather than the order that they are in

17+-- inside of NS constructors.

18+namespacesInNS :: [String] -> Idris [[String]]

19+namespacesInNS ns = do let revNS = reverse ns

20+ allNames <- fmap ctxtAlist getContext

21+ return . nub $

22+ [ reverse space | space <- mapMaybe (getNS . fst) allNames

23+ , revNS `isSuffixOf` space

24+ , revNS /= space ]

25+ where getNS (NS _ namespace) = Just (map T.unpack namespace)

26+ getNS _ = Nothing

27+

28+-- | Find the user-accessible names that occur directly within a given

29+-- namespace. The components should be in display order rather than

30+-- the order that they are in inside of NS constructors.

31+namesInNS :: [String] -> Idris [Name]

32+namesInNS ns = do let revNS = reverse ns

33+ allNames <- fmap ctxtAlist getContext

34+ return [ n | (n, space) <- mapMaybe (getNS . fst) allNames

35+ , revNS == space ]

36+ where getNS n@(NS (UN n') namespace) = Just (n, (map T.unpack namespace))

37+ getNS _ = Nothing

src/Idris/REPLParser.hs+23−7

@@ -52,6 +52,7 @@ parserCommandsForHelp =

5252 , " Search for values by type", cmd_search)

5353 , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"

5454 , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"

55+ , namespaceArgCmd ["browse"] Browse "List the contents of some namespace"

5556 , nameArgCmd ["total"] TotCheck "Check the totality of a name"

5657 , noArgCmd ["r", "reload"] Reload "Reload current file"

5758 , (["l", "load"], FileArg, "Load a new file"

@@ -71,7 +72,7 @@ parserCommandsForHelp =

7172 , noArgCmd ["proofs"] Proofs "Show available proofs"

7273 , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"

7374 , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)

74− , noArgCmd ["exec", "execute"] Execute "Compile to an executable and run"

75+ , (["exec", "execute"], OptionalArg ExprArg, "Compile to an executable and run", cmd_execute)

7576 , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)

7677 , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)

7778 , noArgCmd ["?", "h", "help"] Help "Display this help text"

@@ -136,17 +137,19 @@ parserCommands =

136137 )

137138 ]

138139

139−noArgCmd names command doc =

140+noArgCmd names command doc =

140141 (names, NoArg, doc, noArgs command)

141−nameArgCmd names command doc =

142+nameArgCmd names command doc =

142143 (names, NameArg, doc, fnNameArg command)

143−exprArgCmd names command doc =

144+namespaceArgCmd names command doc =

145+ (names, NamespaceArg, doc, namespaceArg command)

146+exprArgCmd names command doc =

144147 (names, ExprArg, doc, exprArg command)

145−metavarArgCmd names command doc =

148+metavarArgCmd names command doc =

146149 (names, MetaVarArg, doc, fnNameArg command)

147−optArgCmd names command doc =

150+optArgCmd names command doc =

148151 (names, OptionArg, doc, optArg command)

149−proofArgCmd names command doc =

152+proofArgCmd names command doc =

150153 (names, NoArg, doc, proofArg command)

151154

152155pCmd :: P.IdrisParser (Either String Command)

@@ -220,6 +223,11 @@ moduleArg = genArg "module" (fmap toPath P.identifier)

220223 where

221224 toPath n = foldl1' (</>) $ splitOn "." n

222225

226+namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)

227+namespaceArg = genArg "namespace" (fmap toNS P.identifier)

228+ where

229+ toNS = splitOn "."

230+

223231optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)

224232optArg cmd name = do

225233 let emptyArgs = do

@@ -276,6 +284,14 @@ cmd_consolewidth name = do

276284 <|> do discard (P.symbol "infinite"); return InfinitelyWide

277285 <|> do n <- fmap fromInteger P.natural; return (ColsWide n)

278286

287+cmd_execute :: String -> P.IdrisParser (Either String Command)

288+cmd_execute name = do

289+ tm <- option maintm (P.fullExpr defaultSyntax)

290+ return (Right (Execute tm))

291+ where

292+ maintm = PRef (fileFC "(repl)") (sNS (sUN "main") ["Main"])

293+

294+

279295cmd_dynamic :: String -> P.IdrisParser (Either String Command)

280296cmd_dynamic name = do

281297 let emptyArgs = noArgs ListDynamic name

src/Idris/Reflection.hs+990−6

@@ -1,18 +1,1002 @@

1−{-|

2−Handy tools for doing reflection.

1+{-| Code related to Idris's reflection system. This module contains

2+quoters and unquoters along with some supporting datatypes.

33-}

4+{-# LANGUAGE PatternGuards #-}

5+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-}

46module Idris.Reflection where

57

8+import Control.Applicative ((<$>), (<*>), pure)

9+import Control.Monad (liftM, liftM2)

10+import Data.Maybe (catMaybes)

11+import Data.List ((\\))

12+import qualified Data.Text as T

13+

14+import Idris.Core.Elaborate (claim, fill, focus, getNameFrom, initElaborator,

15+ movelast, runElab, solve)

16+import Idris.Core.Evaluate (Context, Def(TyDecl), initContext, lookupDefExact, lookupTyExact)

617import Idris.Core.TT

7−import Idris.AbsSyntaxTree (PArg'(..), PArg, PTerm(Placeholder))

818

9−data RArg = RExplicit { argName :: Name, argTy :: Raw }

10− | RImplicit { argName :: Name, argTy :: Raw }

19+import Idris.AbsSyntaxTree (ElabD, IState, PArg'(..), PArg, PTactic, PTactic'(..),

20+ PTerm(..), initEState, pairCon, pairTy)

21+import Idris.Delaborate (delab)

22+

23+data RArg = RExplicit { argName :: Name, argTy :: Raw }

24+ | RImplicit { argName :: Name, argTy :: Raw }

1125 | RConstraint { argName :: Name, argTy :: Raw }

26+ deriving Show

27+

28+data RTyDecl = RDeclare Name [RArg] Raw deriving Show

1229

13−data RTyDecl = RDeclare Name [RArg] Raw

30+data RTyConArg = RParameter { tcArgName :: Name, tcArgTy :: Raw }

31+ | RIndex { tcArgName :: Name, tcArgTy :: Raw }

32+ deriving Show

33+

34+data RDatatype = RDatatype Name [RTyConArg] Raw [(Name, Raw)] deriving Show

1435

1536rArgToPArg :: RArg -> PArg

1637rArgToPArg (RExplicit n _) = PExp 0 [] n Placeholder

1738rArgToPArg (RImplicit n _) = PImp 0 False [] n Placeholder

1839rArgToPArg (RConstraint n _) = PConstraint 0 [] n Placeholder

40+

41+data RFunClause = RMkFunClause Raw Raw

42+ | RMkImpossibleClause Raw

43+ deriving Show

44+

45+data RFunDefn = RDefineFun Name [RFunClause] deriving Show

46+

47+-- | Prefix a name with the "Language.Reflection" namespace

48+reflm :: String -> Name

49+reflm n = sNS (sUN n) ["Reflection", "Language"]

50+

51+-- | Prefix a name with the "Language.Reflection.Elab" namespace

52+tacN :: String -> Name

53+tacN str = sNS (sUN str) ["Elab", "Reflection", "Language"]

54+

55+-- | Reify tactics from their reflected representation

56+reify :: IState -> Term -> ElabD PTactic

57+reify _ (P _ n _) | n == reflm "Intros" = return Intros

58+reify _ (P _ n _) | n == reflm "Trivial" = return Trivial

59+reify _ (P _ n _) | n == reflm "Instance" = return TCInstance

60+reify _ (P _ n _) | n == reflm "Solve" = return Solve

61+reify _ (P _ n _) | n == reflm "Compute" = return Compute

62+reify _ (P _ n _) | n == reflm "Skip" = return Skip

63+reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC

64+reify _ (P _ n _) | n == reflm "Unfocus" = return Unfocus

65+reify ist t@(App _ _ _)

66+ | (P _ f _, args) <- unApply t = reifyApp ist f args

67+reify _ t = fail ("Unknown tactic " ++ show t)

68+

69+reifyApp :: IState -> Name -> [Term] -> ElabD PTactic

70+reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)

71+reifyApp _ t [Constant (I i)]

72+ | t == reflm "Search" = return (ProofSearch True True i Nothing [])

73+reifyApp _ t [x]

74+ | t == reflm "Refine" = do n <- reifyTTName x

75+ return $ Refine n []

76+reifyApp ist t [n, ty] | t == reflm "Claim" = do n' <- reifyTTName n

77+ goal <- reifyTT ty

78+ return $ Claim n' (delab ist goal)

79+reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

80+reifyApp ist t [Constant (Str n), x]

81+ | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

82+reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)

83+reifyApp ist t [t'] | t == reflm "Induction" = liftM (Induction . delab ist) (reifyTT t')

84+reifyApp ist t [t'] | t == reflm "Case" = liftM (Induction . delab ist) (reifyTT t')

85+reifyApp ist t [t']

86+ | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

87+reifyApp ist t [t']

88+ | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

89+reifyApp ist t [t']

90+ | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

91+reifyApp _ t [t']

92+ | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

93+reifyApp ist t [t']

94+ | t == reflm "Exact" = liftM (Exact . delab ist) (reifyTT t')

95+reifyApp ist t [x]

96+ | t == reflm "Focus" = liftM Focus (reifyTTName x)

97+reifyApp ist t [t']

98+ | t == reflm "Rewrite" = liftM (Rewrite . delab ist) (reifyTT t')

99+reifyApp ist t [n, t']

100+ | t == reflm "LetTac" = do n' <- reifyTTName n

101+ t'' <- reifyTT t'

102+ return $ LetTac n' (delab ist t')

103+reifyApp ist t [n, tt', t']

104+ | t == reflm "LetTacTy" = do n' <- reifyTTName n

105+ tt'' <- reifyTT tt'

106+ t'' <- reifyTT t'

107+ return $ LetTacTy n' (delab ist tt'') (delab ist t'')

108+reifyApp ist t [errs]

109+ | t == reflm "Fail" = fmap TFail (reifyReportParts errs)

110+reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen

111+

112+reifyReportParts :: Term -> ElabD [ErrorReportPart]

113+reifyReportParts errs =

114+ case unList errs of

115+ Nothing -> fail "Failed to reify errors"

116+ Just errs' ->

117+ let parts = mapM reifyReportPart errs' in

118+ case parts of

119+ Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err

120+ Right errs'' ->

121+ return errs''

122+

123+-- | Reify terms from their reflected representation

124+reifyTT :: Term -> ElabD Term

125+reifyTT t@(App _ _ _)

126+ | (P _ f _, args) <- unApply t = reifyTTApp f args

127+reifyTT t@(P _ n _)

128+ | n == reflm "Erased" = return $ Erased

129+reifyTT t@(P _ n _)

130+ | n == reflm "Impossible" = return $ Impossible

131+reifyTT t = fail ("Unknown reflection term: " ++ show t)

132+

133+reifyTTApp :: Name -> [Term] -> ElabD Term

134+reifyTTApp t [nt, n, x]

135+ | t == reflm "P" = do nt' <- reifyTTNameType nt

136+ n' <- reifyTTName n

137+ x' <- reifyTT x

138+ return $ P nt' n' x'

139+reifyTTApp t [Constant (I i)]

140+ | t == reflm "V" = return $ V i

141+reifyTTApp t [n, b, x]

142+ | t == reflm "Bind" = do n' <- reifyTTName n

143+ b' <- reifyTTBinder reifyTT (reflm "TT") b

144+ x' <- reifyTT x

145+ return $ Bind n' b' x'

146+reifyTTApp t [f, x]

147+ | t == reflm "App" = do f' <- reifyTT f

148+ x' <- reifyTT x

149+ return $ App Complete f' x'

150+reifyTTApp t [c]

151+ | t == reflm "TConst" = liftM Constant (reifyTTConst c)

152+reifyTTApp t [t', Constant (I i)]

153+ | t == reflm "Proj" = do t'' <- reifyTT t'

154+ return $ Proj t'' i

155+reifyTTApp t [tt]

156+ | t == reflm "TType" = liftM TType (reifyTTUExp tt)

157+reifyTTApp t args = fail ("Unknown reflection term: " ++ show (t, args))

158+

159+-- | Reify raw terms from their reflected representation

160+reifyRaw :: Term -> ElabD Raw

161+reifyRaw t@(App _ _ _)

162+ | (P _ f _, args) <- unApply t = reifyRawApp f args

163+reifyRaw t@(P _ n _)

164+ | n == reflm "RType" = return $ RType

165+reifyRaw t = fail ("Unknown reflection raw term in reifyRaw: " ++ show t)

166+

167+reifyRawApp :: Name -> [Term] -> ElabD Raw

168+reifyRawApp t [n]

169+ | t == reflm "Var" = liftM Var (reifyTTName n)

170+reifyRawApp t [n, b, x]

171+ | t == reflm "RBind" = do n' <- reifyTTName n

172+ b' <- reifyTTBinder reifyRaw (reflm "Raw") b

173+ x' <- reifyRaw x

174+ return $ RBind n' b' x'

175+reifyRawApp t [f, x]

176+ | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)

177+reifyRawApp t [t']

178+ | t == reflm "RForce" = liftM RForce (reifyRaw t')

179+reifyRawApp t [c]

180+ | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)

181+reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))

182+

183+reifyTTName :: Term -> ElabD Name

184+reifyTTName t

185+ | (P _ f _, args) <- unApply t = reifyTTNameApp f args

186+reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

187+

188+reifyTTNameApp :: Name -> [Term] -> ElabD Name

189+reifyTTNameApp t [Constant (Str n)]

190+ | t == reflm "UN" = return $ sUN n

191+reifyTTNameApp t [n, ns]

192+ | t == reflm "NS" = do n' <- reifyTTName n

193+ ns' <- reifyTTNamespace ns

194+ return $ sNS n' ns'

195+reifyTTNameApp t [Constant (I i), Constant (Str n)]

196+ | t == reflm "MN" = return $ sMN i n

197+reifyTTNameApp t [sn]

198+ | t == reflm "SN"

199+ , (P _ f _, args) <- unApply sn = SN <$> reifySN f args

200+ where reifySN :: Name -> [Term] -> ElabD SpecialName

201+ reifySN t [Constant (I i), n1, n2]

202+ | t == reflm "WhereN" = WhereN i <$> reifyTTName n1 <*> reifyTTName n2

203+ reifySN t [Constant (I i), n]

204+ | t == reflm "WithN" = WithN i <$> reifyTTName n

205+ reifySN t [n, ss]

206+ | t == reflm "InstanceN" =

207+ case unList ss of

208+ Nothing -> fail "Can't reify InstanceN strings"

209+ Just ss' -> InstanceN <$> reifyTTName n <*>

210+ pure [T.pack s | Constant (Str s) <- ss']

211+ reifySN t [n, Constant (Str s)]

212+ | t == reflm "ParentN" =

213+ ParentN <$> reifyTTName n <*> pure (T.pack s)

214+ reifySN t [n]

215+ | t == reflm "MethodN" =

216+ MethodN <$> reifyTTName n

217+ reifySN t [n]

218+ | t == reflm "CaseN" =

219+ CaseN <$> reifyTTName n

220+ reifySN t [n]

221+ | t == reflm "ElimN" =

222+ ElimN <$> reifyTTName n

223+ reifySN t [n]

224+ | t == reflm "InstanceCtorN" =

225+ InstanceCtorN <$> reifyTTName n

226+ reifySN t [n1, n2]

227+ | t == reflm "MetaN" =

228+ MetaN <$> reifyTTName n1 <*> reifyTTName n2

229+ reifySN t args = fail $ "Can't reify special name " ++ show t ++ show args

230+reifyTTNameApp t []

231+ | t == reflm "NErased" = return NErased

232+reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

233+

234+reifyTTNamespace :: Term -> ElabD [String]

235+reifyTTNamespace t@(App _ _ _)

236+ = case unApply t of

237+ (P _ f _, [Constant StrType])

238+ | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

239+ (P _ f _, [Constant StrType, Constant (Str n), ns])

240+ | f == sNS (sUN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

241+ _ -> fail ("Unknown reflection namespace arg: " ++ show t)

242+reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

243+

244+reifyTTNameType :: Term -> ElabD NameType

245+reifyTTNameType t@(P _ n _) | n == reflm "Bound" = return $ Bound

246+reifyTTNameType t@(P _ n _) | n == reflm "Ref" = return $ Ref

247+reifyTTNameType t@(App _ _ _)

248+ = case unApply t of

249+ (P _ f _, [Constant (I tag), Constant (I num)])

250+ | f == reflm "DCon" -> return $ DCon tag num False -- FIXME: Uniqueness!

251+ | f == reflm "TCon" -> return $ TCon tag num

252+ _ -> fail ("Unknown reflection name type: " ++ show t)

253+reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)

254+

255+reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)

256+reifyTTBinder reificator binderType t@(App _ _ _)

257+ = case unApply t of

258+ (P _ f _, bt:args) | forget bt == Var binderType

259+ -> reifyTTBinderApp reificator f args

260+ _ -> fail ("Mismatching binder reflection: " ++ show t)

261+reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)

262+

263+reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)

264+reifyTTBinderApp reif f [t]

265+ | f == reflm "Lam" = liftM Lam (reif t)

266+reifyTTBinderApp reif f [t, k]

267+ | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)

268+reifyTTBinderApp reif f [x, y]

269+ | f == reflm "Let" = liftM2 Let (reif x) (reif y)

270+reifyTTBinderApp reif f [x, y]

271+ | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)

272+reifyTTBinderApp reif f [t]

273+ | f == reflm "Hole" = liftM Hole (reif t)

274+reifyTTBinderApp reif f [t]

275+ | f == reflm "GHole" = liftM (GHole 0) (reif t)

276+reifyTTBinderApp reif f [x, y]

277+ | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)

278+reifyTTBinderApp reif f [t]

279+ | f == reflm "PVar" = liftM PVar (reif t)

280+reifyTTBinderApp reif f [t]

281+ | f == reflm "PVTy" = liftM PVTy (reif t)

282+reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))

283+

284+reifyTTConst :: Term -> ElabD Const

285+reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType

286+reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType

287+reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot

288+reifyTTConst t@(App _ _ _)

289+ | (P _ f _, [arg]) <- unApply t = reifyTTConstApp f arg

290+reifyTTConst t = fail ("Unknown reflection constant: " ++ show t)

291+

292+reifyTTConstApp :: Name -> Term -> ElabD Const

293+reifyTTConstApp f aty

294+ | f == reflm "AType" = fmap AType (reifyArithTy aty)

295+reifyTTConstApp f (Constant c@(I _))

296+ | f == reflm "I" = return $ c

297+reifyTTConstApp f (Constant c@(BI _))

298+ | f == reflm "BI" = return $ c

299+reifyTTConstApp f (Constant c@(Fl _))

300+ | f == reflm "Fl" = return $ c

301+reifyTTConstApp f (Constant c@(I _))

302+ | f == reflm "Ch" = return $ c

303+reifyTTConstApp f (Constant c@(Str _))

304+ | f == reflm "Str" = return $ c

305+reifyTTConstApp f (Constant c@(B8 _))

306+ | f == reflm "B8" = return $ c

307+reifyTTConstApp f (Constant c@(B16 _))

308+ | f == reflm "B16" = return $ c

309+reifyTTConstApp f (Constant c@(B32 _))

310+ | f == reflm "B32" = return $ c

311+reifyTTConstApp f (Constant c@(B64 _))

312+ | f == reflm "B64" = return $ c

313+reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))

314+

315+reifyArithTy :: Term -> ElabD ArithTy

316+reifyArithTy (App _ (P _ n _) intTy) | n == reflm "ATInt" = fmap ATInt (reifyIntTy intTy)

317+reifyArithTy (P _ n _) | n == reflm "ATFloat" = return ATFloat

318+reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

319+

320+reifyNativeTy :: Term -> ElabD NativeTy

321+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

322+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

323+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

324+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

325+reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

326+

327+reifyIntTy :: Term -> ElabD IntTy

328+reifyIntTy (App _ (P _ n _) nt) | n == reflm "ITFixed" = fmap ITFixed (reifyNativeTy nt)

329+reifyIntTy (P _ n _) | n == reflm "ITNative" = return ITNative

330+reifyIntTy (P _ n _) | n == reflm "ITBig" = return ITBig

331+reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar

332+reifyIntTy tm = fail $ "The term " ++ show tm ++ " is not a reflected IntTy"

333+

334+reifyTTUExp :: Term -> ElabD UExp

335+reifyTTUExp t@(App _ _ _)

336+ = case unApply t of

337+ (P _ f _, [Constant (I i)]) | f == reflm "UVar" -> return $ UVar i

338+ (P _ f _, [Constant (I i)]) | f == reflm "UVal" -> return $ UVal i

339+ _ -> fail ("Unknown reflection type universe expression: " ++ show t)

340+reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)

341+

342+-- | Create a reflected call to a named function/constructor

343+reflCall :: String -> [Raw] -> Raw

344+reflCall funName args

345+ = raw_apply (Var (reflm funName)) args

346+

347+-- | Lift a term into its Language.Reflection.TT representation

348+reflect :: Term -> Raw

349+reflect = reflectTTQuote []

350+

351+-- | Lift a term into its Language.Reflection.Raw representation

352+reflectRaw :: Raw -> Raw

353+reflectRaw = reflectRawQuote []

354+

355+claimTT :: Name -> ElabD Name

356+claimTT n = do n' <- getNameFrom n

357+ claim n' (Var (sNS (sUN "TT") ["Reflection", "Language"]))

358+ return n'

359+

360+-- | Convert a reflected term to a more suitable form for pattern-matching.

361+-- In particular, the less-interesting bits are elaborated to _ patterns. This

362+-- happens to NameTypes, universe levels, names that are bound but not used,

363+-- and the type annotation field of the P constructor.

364+reflectTTQuotePattern :: [Name] -> Term -> ElabD ()

365+reflectTTQuotePattern unq (P _ n _)

366+ | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them

367+ do fill (Var n) ; solve

368+ | otherwise =

369+ do tyannot <- claimTT (sMN 0 "pTyAnnot")

370+ movelast tyannot -- use a _ pattern here

371+ nt <- getNameFrom (sMN 0 "nt")

372+ claim nt (Var (reflm "NameType"))

373+ movelast nt -- use a _ pattern here

374+ n' <- getNameFrom (sMN 0 "n")

375+ claim n' (Var (reflm "TTName"))

376+ fill $ reflCall "P" [Var nt, Var n', Var tyannot]

377+ solve

378+ focus n'; reflectNameQuotePattern n

379+reflectTTQuotePattern unq (V n)

380+ = do fill $ reflCall "V" [RConstant (I n)]

381+ solve

382+reflectTTQuotePattern unq (Bind n b x)

383+ = do x' <- claimTT (sMN 0 "sc")

384+ movelast x'

385+ b' <- getNameFrom (sMN 0 "binder")

386+ claim b' (RApp (Var (sNS (sUN "Binder") ["Reflection", "Language"]))

387+ (Var (sNS (sUN "TT") ["Reflection", "Language"])))

388+ if n `elem` freeNames x

389+ then do fill $ reflCall "Bind"

390+ [reflectName n,

391+ Var b',

392+ Var x']

393+ solve

394+ else do any <- getNameFrom (sMN 0 "anyName")

395+ claim any (Var (reflm "TTName"))

396+ movelast any

397+ fill $ reflCall "Bind"

398+ [Var any,

399+ Var b',

400+ Var x']

401+ solve

402+ focus x'; reflectTTQuotePattern unq x

403+ focus b'; reflectBinderQuotePattern reflectTTQuotePattern unq b

404+reflectTTQuotePattern unq (App _ f x)

405+ = do f' <- claimTT (sMN 0 "f"); movelast f'

406+ x' <- claimTT (sMN 0 "x"); movelast x'

407+ fill $ reflCall "App" [Var f', Var x']

408+ solve

409+ focus f'; reflectTTQuotePattern unq f

410+ focus x'; reflectTTQuotePattern unq x

411+reflectTTQuotePattern unq (Constant c)

412+ = do fill $ reflCall "TConst" [reflectConstant c]

413+ solve

414+reflectTTQuotePattern unq (Proj t i)

415+ = do t' <- claimTT (sMN 0 "t"); movelast t'

416+ fill $ reflCall "Proj" [Var t', RConstant (I i)]

417+ solve

418+ focus t'; reflectTTQuotePattern unq t

419+reflectTTQuotePattern unq (Erased)

420+ = do erased <- claimTT (sMN 0 "erased")

421+ movelast erased

422+ fill $ (Var erased)

423+ solve

424+reflectTTQuotePattern unq (Impossible)

425+ = do fill $ Var (reflm "Impossible")

426+ solve

427+reflectTTQuotePattern unq (TType exp)

428+ = do ue <- getNameFrom (sMN 0 "uexp")

429+ claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

430+ movelast ue

431+ fill $ reflCall "TType" [Var ue]

432+ solve

433+reflectTTQuotePattern unq (UType u)

434+ = do uH <- getNameFrom (sMN 0 "someUniv")

435+ claim uH (Var (reflm "Universe"))

436+ movelast uH

437+ fill $ reflCall "UType" [Var uH]

438+ solve

439+ focus uH

440+ fill (Var (reflm (case u of

441+ NullType -> "NullType"

442+ UniqueType -> "UniqueType"

443+ AllTypes -> "AllTypes")))

444+ solve

445+

446+reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()

447+reflectRawQuotePattern unq (Var n)

448+ -- the unquoted names already have types, just use them

449+ | n `elem` unq = do fill (Var n); solve

450+ | otherwise = do fill (reflCall "Var" [reflectName n]); solve

451+reflectRawQuotePattern unq (RBind n b sc) =

452+ do scH <- getNameFrom (sMN 0 "sc")

453+ claim scH (Var (reflm "Raw"))

454+ movelast scH

455+ bH <- getNameFrom (sMN 0 "binder")

456+ claim bH (RApp (Var (reflm "Binder"))

457+ (Var (reflm "Raw")))

458+ if n `elem` freeNamesR sc

459+ then do fill $ reflCall "RBind" [reflectName n,

460+ Var bH,

461+ Var scH]

462+ solve

463+ else do any <- getNameFrom (sMN 0 "anyName")

464+ claim any (Var (reflm "TTName"))

465+ movelast any

466+ fill $ reflCall "RBind" [Var any, Var bH, Var scH]

467+ solve

468+ focus scH; reflectRawQuotePattern unq sc

469+ focus bH; reflectBinderQuotePattern reflectRawQuotePattern unq b

470+ where freeNamesR (Var n) = [n]

471+ freeNamesR (RBind n (Let t v) body) = concat [freeNamesR v,

472+ freeNamesR body \\ [n],

473+ freeNamesR t]

474+ freeNamesR (RBind n b body) = freeNamesR (binderTy b) ++

475+ (freeNamesR body \\ [n])

476+ freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x

477+ freeNamesR RType = []

478+ freeNamesR (RUType _) = []

479+ freeNamesR (RForce r) = freeNamesR r

480+ freeNamesR (RConstant _) = []

481+reflectRawQuotePattern unq (RApp f x) =

482+ do fH <- getNameFrom (sMN 0 "f")

483+ claim fH (Var (reflm "Raw"))

484+ movelast fH

485+ xH <- getNameFrom (sMN 0 "x")

486+ claim xH (Var (reflm "Raw"))

487+ movelast xH

488+ fill $ reflCall "RApp" [Var fH, Var xH]

489+ solve

490+ focus fH; reflectRawQuotePattern unq f

491+ focus xH; reflectRawQuotePattern unq x

492+reflectRawQuotePattern unq RType =

493+ do fill (Var (reflm "RType"))

494+ solve

495+reflectRawQuotePattern unq (RUType univ) =

496+ do uH <- getNameFrom (sMN 0 "universe")

497+ claim uH (Var (reflm "Universe"))

498+ movelast uH

499+ fill $ reflCall "RUType" [Var uH]

500+ solve

501+ focus uH; fill (reflectUniverse univ); solve

502+reflectRawQuotePattern unq (RForce r) =

503+ do rH <- getNameFrom (sMN 0 "raw")

504+ claim rH (Var (reflm "Raw"))

505+ movelast rH

506+ fill $ reflCall "RForce" [Var rH]

507+ solve

508+ focus rH; reflectRawQuotePattern unq r

509+reflectRawQuotePattern unq (RConstant c) =

510+ do cH <- getNameFrom (sMN 0 "const")

511+ claim cH (Var (reflm "Constant"))

512+ movelast cH

513+ fill (reflCall "RConstant" [Var cH]); solve

514+ focus cH

515+ fill (reflectConstant c); solve

516+

517+reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()

518+reflectBinderQuotePattern q unq (Lam t)

519+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

520+ fill $ reflCall "Lam" [Var (reflm "TT"), Var t']

521+ solve

522+ focus t'; q unq t

523+reflectBinderQuotePattern q unq (Pi _ t k)

524+ = do t' <- claimTT (sMN 0 "ty") ; movelast t'

525+ k' <- claimTT (sMN 0 "k"); movelast k';

526+ fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']

527+ solve

528+ focus t'; q unq t

529+reflectBinderQuotePattern q unq (Let x y)

530+ = do x' <- claimTT (sMN 0 "ty"); movelast x';

531+ y' <- claimTT (sMN 0 "v"); movelast y';

532+ fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']

533+ solve

534+ focus x'; q unq x

535+ focus y'; q unq y

536+reflectBinderQuotePattern q unq (NLet x y)

537+ = do x' <- claimTT (sMN 0 "ty"); movelast x'

538+ y' <- claimTT (sMN 0 "v"); movelast y'

539+ fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']

540+ solve

541+ focus x'; q unq x

542+ focus y'; q unq y

543+reflectBinderQuotePattern q unq (Hole t)

544+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

545+ fill $ reflCall "Hole" [Var (reflm "TT"), Var t']

546+ solve

547+ focus t'; q unq t

548+reflectBinderQuotePattern q unq (GHole _ t)

549+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

550+ fill $ reflCall "GHole" [Var (reflm "TT"), Var t']

551+ solve

552+ focus t'; q unq t

553+reflectBinderQuotePattern q unq (Guess x y)

554+ = do x' <- claimTT (sMN 0 "ty"); movelast x'

555+ y' <- claimTT (sMN 0 "v"); movelast y'

556+ fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']

557+ solve

558+ focus x'; q unq x

559+ focus y'; q unq y

560+reflectBinderQuotePattern q unq (PVar t)

561+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

562+ fill $ reflCall "PVar" [Var (reflm "TT"), Var t']

563+ solve

564+ focus t'; q unq t

565+reflectBinderQuotePattern q unq (PVTy t)

566+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

567+ fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']

568+ solve

569+ focus t'; q unq t

570+

571+reflectUniverse :: Universe -> Raw

572+reflectUniverse u =

573+ (Var (reflm (case u of

574+ NullType -> "NullType"

575+ UniqueType -> "UniqueType"

576+ AllTypes -> "AllTypes")))

577+

578+-- | Create a reflected TT term, but leave refs to the provided name intact

579+reflectTTQuote :: [Name] -> Term -> Raw

580+reflectTTQuote unq (P nt n t)

581+ | n `elem` unq = Var n

582+ | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]

583+reflectTTQuote unq (V n)

584+ = reflCall "V" [RConstant (I n)]

585+reflectTTQuote unq (Bind n b x)

586+ = reflCall "Bind" [reflectName n, reflectBinderQuote reflectTTQuote (reflm "TT") unq b, reflectTTQuote unq x]

587+reflectTTQuote unq (App _ f x)

588+ = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]

589+reflectTTQuote unq (Constant c)

590+ = reflCall "TConst" [reflectConstant c]

591+reflectTTQuote unq (Proj t i)

592+ = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]

593+reflectTTQuote unq (Erased) = Var (reflm "Erased")

594+reflectTTQuote unq (Impossible) = Var (reflm "Impossible")

595+reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

596+reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]

597+

598+reflectRawQuote :: [Name] -> Raw -> Raw

599+reflectRawQuote unq (Var n)

600+ | n `elem` unq = Var n

601+ | otherwise = reflCall "Var" [reflectName n]

602+reflectRawQuote unq (RBind n b r) =

603+ reflCall "RBind" [reflectName n, reflectBinderQuote reflectRawQuote (reflm "Raw") unq b, reflectRawQuote unq r]

604+reflectRawQuote unq (RApp f x) =

605+ reflCall "RApp" [reflectRawQuote unq f, reflectRawQuote unq x]

606+reflectRawQuote unq RType = Var (reflm "RType")

607+reflectRawQuote unq (RUType u) =

608+ reflCall "RUType" [reflectUniverse u]

609+reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]

610+reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]

611+

612+reflectNameType :: NameType -> Raw

613+reflectNameType (Bound) = Var (reflm "Bound")

614+reflectNameType (Ref) = Var (reflm "Ref")

615+reflectNameType (DCon x y _)

616+ = reflCall "DCon" [RConstant (I x), RConstant (I y)] -- FIXME: Uniqueness!

617+reflectNameType (TCon x y)

618+ = reflCall "TCon" [RConstant (I x), RConstant (I y)]

619+

620+reflectName :: Name -> Raw

621+reflectName (UN s)

622+ = reflCall "UN" [RConstant (Str (str s))]

623+reflectName (NS n ns)

624+ = reflCall "NS" [ reflectName n

625+ , foldr (\ n s ->

626+ raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

627+ [ RConstant StrType, RConstant (Str n), s ])

628+ ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

629+ [ RConstant StrType ])

630+ (map str ns)

631+ ]

632+reflectName (MN i n)

633+ = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

634+reflectName (NErased) = Var (reflm "NErased")

635+reflectName n = Var (reflm "NErased") -- special name, not yet implemented

636+

637+reflectSpecialName :: SpecialName -> Raw

638+reflectSpecialName (WhereN i n1 n2) =

639+ reflCall "WhereN" [RConstant (I i), reflectName n1, reflectName n2]

640+reflectSpecialName (WithN i n) = reflCall "WithN" [ RConstant (I i)

641+ , reflectName n

642+ ]

643+reflectSpecialName (InstanceN inst ss) =

644+ reflCall "InstanceN" [ reflectName inst

645+ , mkList (RConstant StrType) $

646+ map (RConstant . Str . T.unpack) ss

647+ ]

648+reflectSpecialName (ParentN n s) =

649+ reflCall "ParentN" [reflectName n, RConstant (Str (T.unpack s))]

650+reflectSpecialName (MethodN n) =

651+ reflCall "MethodN" [reflectName n]

652+reflectSpecialName (CaseN n) =

653+ reflCall "CaseN" [reflectName n]

654+reflectSpecialName (ElimN n) =

655+ reflCall "ElimN" [reflectName n]

656+reflectSpecialName (InstanceCtorN n) =

657+ reflCall "InstanceCtorN" [reflectName n]

658+reflectSpecialName (MetaN parent meta) =

659+ reflCall "MetaN" [reflectName parent, reflectName meta]

660+

661+-- | Elaborate a name to a pattern. This means that NS and UN will be intact.

662+-- MNs corresponding to will care about the string but not the number. All

663+-- others become _.

664+reflectNameQuotePattern :: Name -> ElabD ()

665+reflectNameQuotePattern n@(UN s)

666+ = do fill $ reflectName n

667+ solve

668+reflectNameQuotePattern n@(NS _ _)

669+ = do fill $ reflectName n

670+ solve

671+reflectNameQuotePattern (MN _ n)

672+ = do i <- getNameFrom (sMN 0 "mnCounter")

673+ claim i (RConstant (AType (ATInt ITNative)))

674+ movelast i

675+ fill $ reflCall "MN" [Var i, RConstant (Str $ T.unpack n)]

676+ solve

677+reflectNameQuotePattern _ -- for all other names, match any

678+ = do nameHole <- getNameFrom (sMN 0 "name")

679+ claim nameHole (Var (reflm "TTName"))

680+ movelast nameHole

681+ fill (Var nameHole)

682+ solve

683+

684+reflectBinder :: Binder Term -> Raw

685+reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []

686+

687+reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw

688+reflectBinderQuote q ty unq (Lam t)

689+ = reflCall "Lam" [Var ty, q unq t]

690+reflectBinderQuote q ty unq (Pi _ t k)

691+ = reflCall "Pi" [Var ty, q unq t, q unq k]

692+reflectBinderQuote q ty unq (Let x y)

693+ = reflCall "Let" [Var ty, q unq x, q unq y]

694+reflectBinderQuote q ty unq (NLet x y)

695+ = reflCall "NLet" [Var ty, q unq x, q unq y]

696+reflectBinderQuote q ty unq (Hole t)

697+ = reflCall "Hole" [Var ty, q unq t]

698+reflectBinderQuote q ty unq (GHole _ t)

699+ = reflCall "GHole" [Var ty, q unq t]

700+reflectBinderQuote q ty unq (Guess x y)

701+ = reflCall "Guess" [Var ty, q unq x, q unq y]

702+reflectBinderQuote q ty unq (PVar t)

703+ = reflCall "PVar" [Var ty, q unq t]

704+reflectBinderQuote q ty unq (PVTy t)

705+ = reflCall "PVTy" [Var ty, q unq t]

706+

707+mkList :: Raw -> [Raw] -> Raw

708+mkList ty [] = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty

709+mkList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"])) ty)

710+ x)

711+ (mkList ty xs)

712+

713+reflectConstant :: Const -> Raw

714+reflectConstant c@(I _) = reflCall "I" [RConstant c]

715+reflectConstant c@(BI _) = reflCall "BI" [RConstant c]

716+reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]

717+reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]

718+reflectConstant c@(Str _) = reflCall "Str" [RConstant c]

719+reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]

720+reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]

721+reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]

722+reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]

723+reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]

724+reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]

725+reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATFloat")]

726+reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]

727+reflectConstant StrType = Var (reflm "StrType")

728+reflectConstant (AType (ATInt (ITFixed IT8))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]

729+reflectConstant (AType (ATInt (ITFixed IT16))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT16")]]]

730+reflectConstant (AType (ATInt (ITFixed IT32))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT32")]]]

731+reflectConstant (AType (ATInt (ITFixed IT64))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT64")]]]

732+reflectConstant VoidType = Var (reflm "VoidType")

733+reflectConstant Forgot = Var (reflm "Forgot")

734+reflectConstant WorldType = Var (reflm "WorldType")

735+reflectConstant TheWorld = Var (reflm "TheWorld")

736+

737+reflectUExp :: UExp -> Raw

738+reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]

739+reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]

740+

741+-- | Reflect the environment of a proof into a List (TTName, Binder TT)

742+reflectEnv :: Env -> Raw

743+reflectEnv = foldr consToEnvList emptyEnvList

744+ where

745+ consToEnvList :: (Name, Binder Term) -> Raw -> Raw

746+ consToEnvList (n, b) l

747+ = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

748+ [ envTupleType

749+ , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

750+ , (RApp (Var $ reflm "Binder")

751+ (Var $ reflm "TT"))

752+ , reflectName n

753+ , reflectBinder b

754+ ]

755+ , l

756+ ]

757+

758+ emptyEnvList :: Raw

759+ emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

760+ [envTupleType]

761+

762+-- | Reflect an error into the internal datatype of Idris -- TODO

763+rawBool :: Bool -> Raw

764+rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"])

765+rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"])

766+

767+rawNil :: Raw -> Raw

768+rawNil ty = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [ty]

769+

770+rawCons :: Raw -> Raw -> Raw -> Raw

771+rawCons ty hd tl = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ty, hd, tl]

772+

773+rawList :: Raw -> [Raw] -> Raw

774+rawList ty = foldr (rawCons ty) (rawNil ty)

775+

776+rawPairTy :: Raw -> Raw -> Raw

777+rawPairTy t1 t2 = raw_apply (Var pairTy) [t1, t2]

778+

779+rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw

780+rawPair (a, b) (x, y) = raw_apply (Var pairCon) [a, b, x, y]

781+

782+reflectCtxt :: [(Name, Type)] -> Raw

783+reflectCtxt ctxt = rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "TT"))

784+ (map (\ (n, t) -> (rawPair (Var $ reflm "TTName", Var $ reflm "TT")

785+ (reflectName n, reflect t)))

786+ ctxt)

787+

788+reflectErr :: Err -> Raw

789+reflectErr (Msg msg) = raw_apply (Var $ reflErrName "Msg") [RConstant (Str msg)]

790+reflectErr (InternalMsg msg) = raw_apply (Var $ reflErrName "InternalMsg") [RConstant (Str msg)]

791+reflectErr (CantUnify b (t1,_) (t2,_) e ctxt i) =

792+ raw_apply (Var $ reflErrName "CantUnify")

793+ [ rawBool b

794+ , reflect t1

795+ , reflect t2

796+ , reflectErr e

797+ , reflectCtxt ctxt

798+ , RConstant (I i)]

799+reflectErr (InfiniteUnify n tm ctxt) =

800+ raw_apply (Var $ reflErrName "InfiniteUnify")

801+ [ reflectName n

802+ , reflect tm

803+ , reflectCtxt ctxt

804+ ]

805+reflectErr (CantConvert t t' ctxt) =

806+ raw_apply (Var $ reflErrName "CantConvert")

807+ [ reflect t

808+ , reflect t'

809+ , reflectCtxt ctxt

810+ ]

811+reflectErr (CantSolveGoal t ctxt) =

812+ raw_apply (Var $ reflErrName "CantSolveGoal")

813+ [ reflect t

814+ , reflectCtxt ctxt

815+ ]

816+reflectErr (UnifyScope n n' t ctxt) =

817+ raw_apply (Var $ reflErrName "UnifyScope")

818+ [ reflectName n

819+ , reflectName n'

820+ , reflect t

821+ , reflectCtxt ctxt

822+ ]

823+reflectErr (CantInferType str) =

824+ raw_apply (Var $ reflErrName "CantInferType") [RConstant (Str str)]

825+reflectErr (NonFunctionType t t') =

826+ raw_apply (Var $ reflErrName "NonFunctionType") [reflect t, reflect t']

827+reflectErr (NotEquality t t') =

828+ raw_apply (Var $ reflErrName "NotEquality") [reflect t, reflect t']

829+reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n]

830+reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t]

831+reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n]

832+reflectErr (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t]

833+reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t]

834+reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n]

835+reflectErr (NotInjective t1 t2 t3) =

836+ raw_apply (Var $ reflErrName "NotInjective")

837+ [ reflect t1

838+ , reflect t2

839+ , reflect t3

840+ ]

841+reflectErr (CantResolve _ t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

842+reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]

843+reflectErr (CantResolveAlts ss) =

844+ raw_apply (Var $ reflErrName "CantResolveAlts")

845+ [rawList (Var $ reflm "TTName") (map reflectName ss)]

846+reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

847+reflectErr (NoEliminator str t)

848+ = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),

849+ reflect t]

850+reflectErr (UniverseError fc ue old new tys) =

851+ -- NB: loses information, but OK because this is not likely to be rewritten

852+ Var $ reflErrName "UniverseError"

853+reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

854+reflectErr (Inaccessible n) = raw_apply (Var $ reflErrName "Inaccessible") [reflectName n]

855+reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollabsiblePostulate") [reflectName n]

856+reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

857+reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

858+reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

859+reflectErr (ProviderError str) =

860+ raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

861+reflectErr (LoadingFailed str err) =

862+ raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

863+reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

864+

865+-- | Reflect a file context

866+reflectFC :: FC -> Raw

867+reflectFC fc = raw_apply (Var (reflm "FileLoc"))

868+ [ RConstant (Str (fc_fname fc))

869+ , raw_apply (Var pairCon) $

870+ [intTy, intTy] ++

871+ map (RConstant . I)

872+ [ fst (fc_start fc)

873+ , snd (fc_start fc)

874+ ]

875+ , raw_apply (Var pairCon) $

876+ [intTy, intTy] ++

877+ map (RConstant . I)

878+ [ fst (fc_end fc)

879+ , snd (fc_end fc)

880+ ]

881+ ]

882+ where intTy = RConstant (AType (ATInt ITNative))

883+

884+fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

885+fromTTMaybe (App _ (App _ (P (DCon _ _ _) (NS (UN just) _) _) ty) tm)

886+ | just == txt "Just" = Just tm

887+fromTTMaybe x = Nothing

888+

889+reflErrName :: String -> Name

890+reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"]

891+

892+-- | Attempt to reify a report part from TT to the internal

893+-- representation. Not in Idris or ElabD monads because it should be usable

894+-- from either.

895+reifyReportPart :: Term -> Either Err ErrorReportPart

896+reifyReportPart (App _ (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "TextPart" =

897+ Right (TextPart msg)

898+reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

899+ | n == reflm "NamePart" =

900+ case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext emptyContext Erased) of

901+ Error e -> Left . InternalMsg $

902+ "could not reify name term " ++

903+ show ttn ++

904+ " when reflecting an error:" ++ show e

905+ OK (n', _)-> Right $ NamePart n'

906+reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

907+ | n == reflm "TermPart" =

908+ case runElab initEState (reifyTT tm) (initElaborator NErased initContext emptyContext Erased) of

909+ Error e -> Left . InternalMsg $

910+ "could not reify reflected term " ++

911+ show tm ++

912+ " when reflecting an error:" ++ show e

913+ OK (tm', _) -> Right $ TermPart tm'

914+reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

915+ | n == reflm "SubReport" =

916+ case unList tm of

917+ Just xs -> do subParts <- mapM reifyReportPart xs

918+ Right (SubReport subParts)

919+ Nothing -> Left . InternalMsg $ "could not reify subreport " ++ show tm

920+reifyReportPart x = Left . InternalMsg $ "could not reify " ++ show x

921+

922+reifyTyDecl :: Term -> ElabD RTyDecl

923+reifyTyDecl (App _ (App _ (App _ (P (DCon _ _ _) n _) tyN) args) ret)

924+ | n == tacN "Declare" =

925+ do tyN' <- reifyTTName tyN

926+ args' <- case unList args of

927+ Nothing -> fail $ "Couldn't reify " ++ show args ++ " as an arglist."

928+ Just xs -> mapM reifyRArg xs

929+ ret' <- reifyRaw ret

930+ return $ RDeclare tyN' args' ret'

931+ where reifyRArg :: Term -> ElabD RArg

932+ reifyRArg (App _ (App _ (P (DCon _ _ _) n _) argN) argTy)

933+ | n == tacN "Explicit" = liftM2 RExplicit

934+ (reifyTTName argN)

935+ (reifyRaw argTy)

936+ | n == tacN "Implicit" = liftM2 RImplicit

937+ (reifyTTName argN)

938+ (reifyRaw argTy) | n == tacN "Constraint" = liftM2 RConstraint

939+ (reifyTTName argN)

940+ (reifyRaw argTy)

941+ reifyRArg aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RArg."

942+reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."

943+

944+reifyFunDefn :: Term -> ElabD RFunDefn

945+reifyFunDefn (App _ (App _ (P _ n _) fnN) clauses)

946+ | n == tacN "DefineFun" =

947+ do fnN' <- reifyTTName fnN

948+ clauses' <- case unList clauses of

949+ Nothing -> fail $ "Couldn't reify " ++ show clauses ++ " as a clause list"

950+ Just cs -> mapM reifyC cs

951+ return $ RDefineFun fnN' clauses'

952+ where reifyC :: Term -> ElabD RFunClause

953+ reifyC (App _ (App _ (P (DCon _ _ _) n _) lhs) rhs)

954+ | n == tacN "MkFunClause" = liftM2 RMkFunClause

955+ (reifyRaw lhs)

956+ (reifyRaw rhs)

957+ reifyC (App _ (P (DCon _ _ _) n _) lhs)

958+ | n == tacN "MkImpossibleClause" = fmap RMkImpossibleClause $ reifyRaw lhs

959+ reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

960+reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

961+

962+envTupleType :: Raw

963+envTupleType

964+ = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

965+ , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

966+ ]

967+

968+-- | Build the reflected datatype definition(s) that correspond(s) to

969+-- a provided unqualified name

970+buildDatatypes :: Context -> Ctxt TypeInfo -> Name -> [RDatatype]

971+buildDatatypes ctxt datatypes n =

972+ catMaybes [ mkDataType dn ti

973+ | (dn, ti) <- lookupCtxtName n datatypes

974+ ]

975+ where mkDataType name (TI {param_pos = params, con_names = constrs}) =

976+ do (TyDecl (TCon _ _) ty) <- lookupDefExact name ctxt

977+ let (tcargs, tcres) = getArgs params (forget ty) 0

978+ conTys <- mapM (fmap forget . flip lookupTyExact ctxt) constrs

979+ return $ RDatatype name tcargs tcres $ zip constrs conTys

980+

981+ getArgs params (RBind an (Pi _ ty _) body) i =

982+ let (args, res) = getArgs params body (i+1)

983+ in if i `elem` params

984+ then (RParameter an ty : args, res )

985+ else (RIndex an ty : args, res)

986+ getArgs _ tm _ = ([], tm)

987+

988+reflectDatatype :: RDatatype -> Raw

989+reflectDatatype (RDatatype tyn tyConArgs tyConRes constrs) =

990+ raw_apply (Var $ tacN "MkDatatype") [ reflectName tyn

991+ , rawList (Var $ tacN "TyConArg") (map reflectConArg tyConArgs)

992+ , reflectRaw tyConRes

993+ , rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "Raw"))

994+ [ rawPair ((Var $ reflm "TTName"), (Var $ reflm "Raw"))

995+ (reflectName cn, reflectRaw cty)

996+ | (cn, cty) <- constrs

997+ ]

998+ ]

999+ where reflectConArg (RParameter n t) =

1000+ raw_apply (Var $ tacN "Parameter") [reflectName n, reflectRaw t]

1001+ reflectConArg (RIndex n t) =

1002+ raw_apply (Var $ tacN "Index") [reflectName n, reflectRaw t]

src/Idris/Transforms.hs+8−8

@@ -39,21 +39,21 @@ applyTransRulesWith rules tm

3939 = finalise $ applyAll rules emptyContext (vToP tm)

4040

4141applyAll :: [(Term, Term)] -> Ctxt [(Term, Term)] -> Term -> Term

42−applyAll extra ts ap@(App f a)

42+applyAll extra ts ap@(App s f a)

4343 | (P _ fn ty, args) <- unApply ap

4444 = let rules = case lookupCtxtExact fn ts of

4545 Just r -> extra ++ r

4646 Nothing -> extra

47− ap' = App (applyAll extra ts f) (applyAll extra ts a) in

47+ ap' = App s (applyAll extra ts f) (applyAll extra ts a) in

4848 case rules of

4949 [] -> ap'

5050 rs -> case applyFnRules rs ap of

51− Just tm'@(App f' a') ->

52− App (applyAll extra ts f')

53− (applyAll extra ts a')

51+ Just tm'@(App s f' a') ->

52+ App s (applyAll extra ts f')

53+ (applyAll extra ts a')

5454 Just tm' -> tm'

55− _ -> App (applyAll extra ts f)

56− (applyAll extra ts a)

55+ _ -> App s (applyAll extra ts f)

56+ (applyAll extra ts a)

5757applyAll extra ts (Bind n b sc) = Bind n (fmap (applyAll extra ts) b)

5858 (applyAll extra ts sc)

5959applyAll extra ts t = t

@@ -94,7 +94,7 @@ matchTerm lhs tm = matchVars [] lhs tm

9494 doMatch :: [Name] -> Term -> Term -> Maybe [(Name, Term)]

9595 doMatch ns (P _ n _) tm

9696 | n `elem` ns = return [(n, tm)]

97− doMatch ns (App f a) (App f' a')

97+ doMatch ns (App _ f a) (App _ f' a')

9898 = do fm <- doMatch ns f f'

9999 am <- doMatch ns a a'

100100 return (fm ++ am)

src/Idris/TypeSearch.hs+14−11

@@ -30,7 +30,7 @@ import Idris.Core.Unify (match_unify)

3030import Idris.Delaborate (delabTy)

3131import Idris.Docstrings (noDocs, overview)

3232import Idris.Elab.Type (elabType)

33−import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderResult, prettyDocumentedIst)

33+import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderError, iRenderResult, prettyDocumentedIst)

3434import Idris.IBC

3535

3636import Prelude hiding (pred)

@@ -54,10 +54,12 @@ searchByType pkgs pterm = do

5454 [ let docInfo = (n, delabTy i n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings i))) in

5555 displayScore theScore <> char ' ' <> prettyDocumentedIst i docInfo

5656 | (n, theScore) <- names']

57− case idris_outputmode i of

58− RawOutput _ -> do mapM_ iRenderOutput docs

59− iPrintResult ""

60− IdeMode _ _ -> iRenderResult (vsep docs)

57+ if (not (null docs))

58+ then case idris_outputmode i of

59+ RawOutput _ -> do mapM_ iRenderOutput docs

60+ iPrintResult ""

61+ IdeMode _ _ -> iRenderResult (vsep docs)

62+ else iRenderError $ text "No results found"

6163 putIState i -- don't actually make any changes

6264 where

6365 numLimit = 50

@@ -102,9 +104,9 @@ typeFromDef (def, _, _, _) = get def where

102104-- Replace all occurences of `Lazy' s t` with `t` in a type

103105unLazy :: Type -> Type

104106unLazy typ = case typ of

105− App (App (P _ lazy _) _) ty | lazy == sUN "Lazy'" -> unLazy ty

107+ App _ (App _ (P _ lazy _) _) ty | lazy == sUN "Lazy'" -> unLazy ty

106108 Bind name binder ty -> Bind name (fmap unLazy binder) (unLazy ty)

107− App t1 t2 -> App (unLazy t1) (unLazy t2)

109+ App s t1 t2 -> App s (unLazy t1) (unLazy t2)

108110 Proj ty i -> Proj (unLazy ty) i

109111 _ -> typ

110112

@@ -144,7 +146,7 @@ usedVars = f True where

144146 Let t v -> f b t `M.union` f b v

145147 Guess t v -> f b t `M.union` f b v

146148 bind -> f b (binderTy bind)

147− f b (App t1 t2) = f b t1 `M.union` f (b && isInjective t1) t2

149+ f b (App _ t1 t2) = f b t1 `M.union` f (b && isInjective t1) t2

148150 f b (Proj t _) = f b t

149151 f _ (V _) = error "unexpected! run vToP first"

150152 f _ _ = M.empty

@@ -305,13 +307,14 @@ subsets (x : xs) = let ss = subsets xs in map (x :) ss ++ ss

305307-- recalls the number of flips that have been made

306308flipEqualities :: Type -> [(Int, Type)]

307309flipEqualities t = case t of

308− eq1@(App (App (App (App eq@(P _ eqty _) tyL) tyR) valL) valR) | eqty == eqTy ->

309− [(0, eq1), (1, App (App (App (App eq tyR) tyL) valR) valL)]

310+ eq1@(App _ (App _ (App _ (App _ eq@(P _ eqty _) tyL) tyR) valL) valR) | eqty == eqTy ->

311+ [(0, eq1), (1, app (app (app (app eq tyR) tyL) valR) valL)]

310312 Bind n binder sc -> (\bind' (j, sc') -> (fst (binderTy bind') + j, Bind n (fmap snd bind') sc'))

311313 <$> traverse flipEqualities binder <*> flipEqualities sc

312− App f x -> (\(i, f') (j, x') -> (i + j, App f' x'))

314+ App _ f x -> (\(i, f') (j, x') -> (i + j, app f' x'))

313315 <$> flipEqualities f <*> flipEqualities x

314316 t' -> [(0, t')]

317+ where app = App Complete

315318

316319--DONT run vToP first!

317320-- | Try to match two types together in a unification-like procedure.

src/Idris/WhoCalls.hs+2−2

@@ -13,7 +13,7 @@ occurs :: Name -> Term -> Bool

1313occurs n (P Bound _ _) = False

1414occurs n (P _ n' _) = n == n'

1515occurs n (Bind _ b sc) = occursBinder n b || occurs n sc

16−occurs n (App t1 t2) = occurs n t1 || occurs n t2

16+occurs n (App _ t1 t2) = occurs n t1 || occurs n t2

1717occurs n (Proj t _) = occurs n t

1818occurs n _ = False

1919

@@ -21,7 +21,7 @@ names :: Term -> [Name]

2121names (P Bound _ _) = []

2222names (P _ n _) = [n]

2323names (Bind _ b sc) = namesBinder b ++ names sc

24−names (App t1 t2) = names t1 ++ names t2

24+names (App _ t1 t2) = names t1 ++ names t2

2525names (Proj t _) = names t

2626names _ = []

2727

src/Util/System.hs+41−2

@@ -1,4 +1,6 @@

1−module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows) where

1+{-# LANGUAGE CPP #-}

2+module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,

3+ writeSource, readSource, setupBundledCC) where

24

35-- System helper functions.

46import Control.Monad (when)

@@ -6,13 +8,19 @@ import System.Directory (getTemporaryDirectory

68 , removeFile

79 , removeDirectoryRecursive

810 , createDirectoryIfMissing

11+ , doesDirectoryExist

912 )

10−import System.FilePath ((</>), normalise)

13+import System.FilePath ((</>), normalise, isAbsolute, dropFileName)

1114import System.IO

1215import System.Info

1316import System.IO.Error

1417import Control.Exception as CE

1518

19+#ifdef FREESTANDING

20+import Tools_idris

21+import System.Environment (getEnv, setEnv, getExecutablePath)

22+#endif

23+

1624catchIO :: IO a -> (IOError -> IO a) -> IO a

1725catchIO = CE.catch

1826

@@ -26,6 +34,16 @@ tempfile :: IO (FilePath, Handle)

2634tempfile = do dir <- getTemporaryDirectory

2735 openTempFile (normalise dir) "idris"

2836

37+-- | Read a source file, same as readFile but make sure the encoding is utf-8.

38+readSource :: FilePath -> IO String

39+readSource f = do h <- openFile f ReadMode

40+ hSetEncoding h utf8

41+ hGetContents h

42+

43+-- | Write a source file, same as writeFile except the encoding is set to utf-8

44+writeSource :: FilePath -> String -> IO ()

45+writeSource f s = withFile f WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h s)

46+

2947withTempdir :: String -> (FilePath -> IO a) -> IO a

3048withTempdir subdir callback

3149 = do dir <- getTemporaryDirectory

@@ -43,3 +61,24 @@ rmFile f = do putStrLn $ "Removing " ++ f

4361 catchIO (removeFile f)

4462 (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

4563 ++ f ++ ", Error msg:" ++ show ioerr)

64+

65+setupBundledCC :: IO()

66+#ifdef FREESTANDING

67+setupBundledCC = when hasBundledToolchain

68+ $ do

69+ exePath <- getExecutablePath

70+ path <- getEnv "PATH"

71+ tcDir <- return getToolchainDir

72+ absolute <- return $ isAbsolute tcDir

73+ target <- return $

74+ if absolute

75+ then tcDir

76+ else dropFileName exePath ++ tcDir

77+ let pathSep = if isWindows then ";" else ":"

78+ present <- doesDirectoryExist target

79+ when present

80+ $ do newPath <- return $ target ++ pathSep ++ path

81+ setEnv "PATH" newPath

82+#else

83+setupBundledCC = return ()

84+#endif

test/Makefile+1−1

@@ -8,7 +8,7 @@ test: $(TESTS)

88 @perl ./runtest.pl $(patsubst %.test,%,$@)

99

1010test_js:

11− @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 buffer001 basic007 basic011 primitives004 ffi006 --codegen node

11+ @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 effects003 effects004 basic007 basic011 primitives004 ffi006 --codegen node

1212

1313update:

1414 /usr/bin/env perl ./runtest.pl all -u

test/README+1

@@ -1,6 +1,7 @@

11Tests are categorised as follows:

22

33basic: Basic language features, some complete programs

4+bignum: Bignums and GMP

45dsl: Embedded DSLs and features to support DSL development

56effects: Effects package

67error: Error messages and error reflection

test/basic010/Main.idr+1−1

@@ -38,6 +38,6 @@ fmt (axiom n) = "axiom " ++ show n

3838

3939main : IO ()

4040main = do

41− n <- map (const 10000) (putStrLn "*oink*")

41+ n <- map (const (the Nat 10000)) (putStrLn "*oink*")

4242 putStrLn . show $ getWitness (f 4 n)

4343 putStrLn . fmt $ getProof (g 4 n)

test/basic010/run+31−25

@@ -1,28 +1,5 @@

11#!/usr/bin/env bash

22

3−# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting

4−# Here copied from reg039.

5−#

6−# Executes command with a timeout

7−# Params:

8−# $1 timeout in seconds

9−# $2 command

10−# Returns 1 if timed out 0 otherwise

11−timeout() {

12−

13− time=$1

14−

15− # start the command in a subshell to avoid problem with pipes

16− # (spawn accepts one command)

17− command="/bin/sh -c \"$2\""

18−

19− expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"

20−

21− if [ $? = 1 ] ; then

22− echo "Timeout after ${time} seconds"

23− fi

24−

25−}

263

274declare -a extraargs

285for arg in "$@"

@@ -30,6 +7,35 @@ do

307 extraargs=("${extraargs[@]}" "'$arg'")

318done

329

33−timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"

34−timeout 5 "./basic010"

10+if (which timeout&>/dev/null); then

11+ timeout 10 idris $@ Main.idr --nocolour --check --warnreach -o basic010

12+ timeout 5 ./basic010

13+else

14+ # From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting

15+ # Here copied from reg039.

16+ #

17+ # Executes command with a timeout

18+ # Params:

19+ # $1 timeout in seconds

20+ # $2 command

21+ # Returns 1 if timed out 0 otherwise

22+ timeout() {

23+

24+ time=$1

25+

26+ # start the command in a subshell to avoid problem with pipes

27+ # (spawn accepts one command)

28+ command="/bin/sh -c \"$2\""

29+

30+ expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"

31+

32+ if [ $? = 1 ] ; then

33+ echo "Timeout after ${time} seconds"

34+ fi

35+

36+ }

37+

38+ timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"

39+ timeout 5 "./basic010"

40+fi

3541rm -f *.ibc basic010

test/bignum001/bignum001.idrnew file+17

@@ -0,0 +1,17 @@

1+module Main

2+

3+fac : Integer -> Integer

4+fac 0 = 1

5+fac n = n*fac(n-1)

6+

7+binomial : Integer -> Integer -> Integer

8+binomial n k = divBigInt (fac n) ((fac k)*(fac (n-k)))

9+

10+sumBinomials : Integer -> Integer

11+sumBinomials n = foldr (+) 0 (map (\k=>binomial n k) [0..n])

12+

13+main : IO ()

14+main = do

15+ if sumBinomials 1000 - pow 2 1000 == 0

16+ then putStrLn "OK"

17+ else putStrLn "ERROR"

test/bignum001/expectednew file+1

@@ -0,0 +1 @@

1+OK

test/bignum001/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ bignum001.idr -o bignum001

3+./bignum001

4+rm -f bignum001 *.ibc

test/bignum002/bignum002.idrnew file+5

@@ -0,0 +1,5 @@

1+module Main

2+

3+main : IO ()

4+main = do

5+ putStrLn $ show $ divNat 1809022195644390369852458 91238741987

test/bignum002/expectednew file+1

@@ -0,0 +1 @@

1+19827346982734

test/bignum002/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ bignum002.idr -o bignum002

3+./bignum002

4+rm -f bignum002 *.ibc

test/buffer001-disabled/buffer001.idrdeleted−45

@@ -1,45 +0,0 @@

1−module Main

2−

3−import Data.Buffer

4−

5−em : Buffer 0

6−em = allocate 4

7−

8−one : Bits32

9−one = 1

10−

11−two : Bits8

12−two = 2

13−

14−firstHalf : Buffer 4

15−firstHalf = appendBits32LE em 1 one

16−

17−full : Buffer 8

18−full = appendBits8 firstHalf 4 two

19−

20−firstByte : Bits8

21−firstByte = peekBits8 full 0

22−

23−firstHalfView : Buffer 4

24−firstHalfView = peekBuffer full 0

25−

26−firstHalfCopy : Buffer 4

27−firstHalfCopy = copy firstHalfView

28−

29−oneFromFirstHalf : Bits32

30−oneFromFirstHalf = peekBits32LE firstHalf 0

31−

32−oneFromFirstHalfCopy : Bits32

33−oneFromFirstHalfCopy = peekBits32LE firstHalfCopy 0

34−

35−viewsAndCopiesPreserveEquality : Bool

36−viewsAndCopiesPreserveEquality = ( oneFromFirstHalf == one ) && ( oneFromFirstHalfCopy == one )

37−

38−secondHalfWord : Bits32

39−secondHalfWord = peekBits32LE full 4

40−

41−main : IO ()

42−main = do

43− putStrLn $ show firstByte

44− putStrLn $ show viewsAndCopiesPreserveEquality

45− putStrLn $ show secondHalfWord

test/buffer001-disabled/expecteddeleted−3

@@ -1,3 +0,0 @@

1−01

2−True

3−02020202

test/buffer001-disabled/rundeleted−4

@@ -1,4 +0,0 @@

1−#!/usr/bin/env bash

2−idris $@ buffer001.idr -o buffer001

3−./buffer001

4−rm -f buffer001 *.ibc

test/delab001/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./delab001.idr

21foo : Nat -> String

32foo n = case n of

43 0 => "z"

test/docs001/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./docs001.idr

21Type class C

32 class

43

test/docs002/expected+3−5

@@ -1,11 +1,9 @@

1−Type checking ./docs002.idr

2−*docs002> T1 : Type

1+T1 : Type

32 Some documentation

43

5−*docs002> T2 : Type

4+T2 : Type

65 Some other documentation

76

8−*docs002> T3 : Int

7+T3 : Int

98 Some provided postulate

109

11−*docs002> Bye bye

test/docs002/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 --nobanner --nocolor docs002.idr < input

2+idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input

33rm *.ibc

test/docs003/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./docs003.idr

21Type class Functor

32 Functors

43

test/dsl002/expected−1

@@ -1,2 +1 @@

11foo

2−

test/effects001/expected+1−1

@@ -1,4 +1,4 @@

1−["HELLO!!!\n", "WORLD!!!\n", ""]

1+["HELLO!!!", "WORLD!!!", ""]

223

3315

44Answer: 99

test/effects001/test021.idr+1−2

@@ -9,8 +9,7 @@ import Control.IOExcept

99data Count : Type where

1010

1111FileIO : Type -> Type -> Type

12−FileIO st t

13− = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff t

12+FileIO st t = Eff t [FILE_IO st, STDIO, Count ::: STATE Int]

1413

1514readFile : FileIO (OpenFile Read) (List String)

1615readFile = readAcc [] where

test/effects001/test021a.idr+1−1

@@ -18,7 +18,7 @@ Env = List (String, Integer)

1818-- Evaluator t

1919-- = Eff m [EXCEPTION String, RND, STATE Env] t

2020

21−eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff Integer

21+eval : Expr -> Eff Integer [EXCEPTION String, STDIO, RND, STATE Env]

2222eval (Var x) = do vs <- get

2323 case lookup x vs of

2424 Nothing => raise ("No such variable " ++ x)

test/effects002/test025.idr+2−2

@@ -6,8 +6,8 @@ import Control.IOExcept

66import Data.Vect

77

88MemoryIO : Type -> Type -> Type -> Type

9−MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td

10− , Src ::: RAW_MEMORY ts ] } Eff r

9+MemoryIO td ts r = Eff r [Dst ::: RAW_MEMORY td,

10+ Src ::: RAW_MEMORY ts]

1111

1212inpVect : Vect 5 Bits8

1313inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]

test/effects003/hangman.idr+28−26

@@ -74,55 +74,59 @@ data HangmanRules : Effect where

7474-- the number of missing letters, if not, reduce the number of guesses left

7575

7676 Guess : (x : Char) ->

77− { Hangman (Running (S g) (S w)) ==>

78− {inword} (case inword of

77+ sig HangmanRules Bool

78+ (Hangman (Running (S g) (S w)))

79+ (\inword =>

80+ case inword of

7981 True => Hangman (Running (S g) w)

80− False => Hangman (Running g (S w))) }

81− HangmanRules Bool

82+ False => Hangman (Running g (S w)))

8283

8384-- The 'Won' operation requires that there are no missing letters

8485

85− Won : { Hangman (Running g 0) ==> Hangman NotRunning } HangmanRules ()

86+ Won : sig HangmanRules ()

87+ (Hangman (Running g 0))

88+ (Hangman NotRunning)

8689

8790-- The 'Lost' operation requires that there are no guesses left

8891

89− Lost : { Hangman (Running 0 g) ==> Hangman NotRunning } HangmanRules ()

92+ Lost : sig HangmanRules ()

93+ (Hangman (Running 0 g))

94+ (Hangman NotRunning)

9095

9196-- Set up a new game, initialised with 6 guesses and the missing letters in

9297-- the given word. Note that if there are no letters in the word, we won't

9398-- be able to run 'Guess'!

9499

95100 NewWord : (w : String) ->

96− { h ==> Hangman (Running 6 (length (letters w))) } HangmanRules ()

101+ sig HangmanRules () h (Hangman (Running 6 (length (letters w))))

97102

98103-- Finally, allow us to get the current game state

99104

100− Get : { h } HangmanRules h

105+ Get : sig HangmanRules h h

101106

102107HANGMAN : HState -> EFFECT

103108HANGMAN h = MkEff (Hangman h) HangmanRules

104109

105110-- Promote explicit effecst to Eff programs

106111

107−guess : Char ->

108− { [HANGMAN (Running (S g) (S w))] ==>

109− {inword} [HANGMAN (case inword of

110− True => Running (S g) w

111− False => Running g (S w))] } Eff Bool

112+guess : Char -> Eff Bool

113+ [HANGMAN (Running (S g) (S w))]

114+ (\inword => [HANGMAN (case inword of

115+ True => Running (S g) w

116+ False => Running g (S w))])

112117guess c = call (Main.Guess c)

113118

114−won : { [HANGMAN (Running g 0)] ==> [HANGMAN NotRunning]} Eff ()

119+won : Eff () [HANGMAN (Running g 0)] [HANGMAN NotRunning]

115120won = call Won

116121

117−lost : { [HANGMAN (Running 0 g)] ==> [HANGMAN NotRunning]} Eff ()

122+lost : Eff () [HANGMAN (Running 0 g)] [HANGMAN NotRunning]

118123lost = call Lost

119124

120−new_word : (w : String) ->

121− { [HANGMAN h] ==>

122− [HANGMAN (Running 6 (length (letters w)))]} Eff ()

125+new_word : (w : String) -> Eff () [HANGMAN h]

126+ [HANGMAN (Running 6 (length (letters w)))]

123127new_word w = call (NewWord w)

124128

125−get : { [HANGMAN h] } Eff (Hangman h)

129+get : Eff (Hangman h) [HANGMAN h]

126130get = call Get

127131

128132-----------------------------------------------------------------------

@@ -163,8 +167,8 @@ were valid letters in it!

163167soRefl : So x -> (x = True)

164168soRefl Oh = Refl

165169

166−game : { [HANGMAN (Running (S g) w), STDIO] ==>

167− [HANGMAN NotRunning, STDIO] } Eff ()

170+game : Eff () [HANGMAN (Running (S g) w), STDIO]

171+ [HANGMAN NotRunning, STDIO]

168172game {w=Z} = won

169173game {w=S _}

170174 = do putStrLn (show !get)

@@ -175,10 +179,8 @@ game {w=S _}

175179 (Right p) => do putStrLn "Invalid input!"

176180 game

177181 where

178− processGuess : -- {g,w:_} ->

179− Char -> { [HANGMAN (Running (S g) (S w)), STDIO] ==>

180− [HANGMAN NotRunning, STDIO] }

181− Eff ()

182+ processGuess : Char -> Eff () [HANGMAN (Running (S g) (S w)), STDIO]

183+ [HANGMAN NotRunning, STDIO]

182184 processGuess {g} c {w}

183185 = case !(guess c) of

184186 True => do putStrLn "Good guess!"

@@ -203,7 +205,7 @@ wlen = proof search

203205

204206{- It typechecks! Ship it! -}

205207

206−runGame : { [HANGMAN NotRunning, RND, STDIO] } Eff ()

208+runGame : Eff () [HANGMAN NotRunning, RND, STDIO]

207209runGame = do srand 1234567890

208210 let w = index !(rndFin _) words

209211 new_word w

test/effects004/effects004.idrnew file+19

@@ -0,0 +1,19 @@

1+import Effects

2+import Effect.StdIO

3+import Effect.State

4+

5+counter : Eff () [STATE Int, STDIO]

6+counter = do putStrLn $ "Counter at " ++ show !get

7+ x <- getStr

8+ if trim x /= "" then pure ()

9+ else do put (!get + 1)

10+ counter

11+

12+startCounter : Eff () [STDIO]

13+startCounter = do putStrLn "Off we go!"

14+ new (STATE Int) 0 counter

15+ putStrLn "Finished!"

16+

17+main : IO ()

18+main = run startCounter

19+

test/effects004/expectednew file+11

@@ -0,0 +1,11 @@

1+Off we go!

2+Counter at 0

3+Counter at 1

4+Counter at 2

5+Counter at 3

6+Counter at 4

7+Counter at 5

8+Counter at 6

9+Counter at 7

10+Counter at 8

11+Finished!

test/effects004/inputnew file+10

@@ -0,0 +1,10 @@

1+

2+

3+

4+

5+

6+

7+

8+

9+done

10+

test/effects004/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ effects004.idr -o effects004 -p effects

3+./effects004 < input

4+rm -f effects004 *.ibc

test/error001/expected+7−8

@@ -1,9 +1,8 @@

11test002.idr:1:6:Universe inconsistency.

2−Working on: z

3−Old domain: Domain 6 6

4−New domain: Domain 6 5

5−Involved constraints:

6− ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

7− ConstraintFC {uconstraint = y < z, ufc = test002.idr:1:6}

8− ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

9−

2+ Working on: z

3+ Old domain: (6,6)

4+ New domain: (6,5)

5+ Involved constraints:

6+ ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

7+ ConstraintFC {uconstraint = y < z, ufc = test002.idr:1:6}

8+ ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

test/error001/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris $@ test002.idr --check --noprelude

2+idris $@ test002.idr --check --noprelude --consolewidth 70

33rm -f *.ibc

test/ffi001/expected−1

@@ -1,2 +1 @@

1−Type checking ./test022.idr

210.9995736030415051

test/ffi003/expected−1

@@ -1,2 +1 @@

1−Type checking ./test024.idr

21testtest

test/ffi006/run+1−1

@@ -1,5 +1,5 @@

11#!/usr/bin/env bash

22idris $@ ffi006.idr --interface -o ffi006.o

3−cc ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006

3+${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006

44./ffi006

55rm -f ffi006 *.ibc *.o *.h

test/folding002/expecteddeleted−2

@@ -1,2 +0,0 @@

1−500000500000

2−500000500000

test/folding002/folding002.idrdeleted−25

@@ -1,25 +0,0 @@

1−import Data.Vect

2−

3−-- perform a very large foldr to test tail recursion

4−addAll : (Foldable t, Num a) => t a -> a

5−addAll = foldr (+) 0

6−

7−n : Integer

8−n = 1000000

9−

10−numbersList : List Integer

11−numbersList = numbersList' n []

12− where

13− numbersList' : Integer -> List Integer -> List Integer

14− numbersList' 0 xs = xs

15− numbersList' k xs = numbersList' (k - 1) (fromInteger k :: xs)

16−

17−numbersVect : Vect (length numbersList) Integer

18−numbersVect = fromList numbersList

19−

20−main : IO ()

21−main = do

22− putStrLn . show . addAll $ numbersVect

23− putStrLn . show . addAll $ numbersList

24−

25−

test/folding002/rundeleted−4

@@ -1,4 +0,0 @@

1−#!/usr/bin/env bash

2−idris $@ folding002.idr -o folding002

3−./folding002

4−rm -f folding002 *.ibc

test/idrisdoc001/expected−2

@@ -1,5 +1,3 @@

1−Type checking ./TestEmpty.idr

2−Type checking ./TestPrivate.idr

31Warning: Ignoring empty or non-existing namespace 'TestEmpty'

42Warning: Ignoring empty or non-existing namespace 'TestPrivate'

53No namespaces to generate documentation for

test/idrisdoc001/run+1−1

@@ -1,4 +1,4 @@

11#!/usr/bin/env bash

22# Tests that no documentation is built for empty and/or private-only namespaces

33idris --mkdoc test_empty.ipkg

4−rm -rf *.ibc *_doc

4+rm -rf *.ibc *_doc

test/idrisdoc001/test_empty.ipkg+2

@@ -1,4 +1,6 @@

11package test_empty

22

3+opts = "--quiet"

4+

35modules = TestEmpty, TestPrivate

46

test/idrisdoc002/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestFunctions.idr

21Functions are documented

test/idrisdoc002/test_functions.ipkg+2

@@ -1,4 +1,6 @@

11package test_functions

22

3+opts = "--quiet"

4+

35modules = TestFunctions

46

test/idrisdoc003/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestDatatypes.idr

21Data types are documented

test/idrisdoc003/test_datatypes.ipkg+2

@@ -1,4 +1,6 @@

11package test_datatypes

22

3+opts = "--quiet"

4+

35modules = TestDatatypes

46

test/idrisdoc004/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestTypeclasses.idr

21Typeclasses are documented

test/idrisdoc004/test_typeclasses.ipkg+2

@@ -1,4 +1,6 @@

11package test_typeclasses

22

3+opts = "--quiet"

4+

35modules = TestTypeclasses

46

test/idrisdoc005/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./TestTracing.idr

21TestTracing: Check

32Prelude.Bool: Check

test/idrisdoc005/test_tracing.ipkg+2

@@ -1,4 +1,6 @@

11package test_tracing

22

3+opts = "--quiet"

4+

35modules = TestTracing

46

test/idrisdoc006/expected−2

@@ -1,6 +1,4 @@

1−Type checking ./A/fully/Qualified/NAME.idr

21IdrisDoc file written

3−Type checking ./B.idr

42A.fully.Qualified.NAME.html

53B.html

64A.fully.Qualified.NAME is in the index

test/idrisdoc006/package_a.ipkg+2

@@ -1,4 +1,6 @@

11package test_merge

22

3+opts = "--quiet"

4+

35modules = A.fully.Qualified.NAME

46

test/idrisdoc006/package_b.ipkg+2

@@ -1,4 +1,6 @@

11package test_merge

22

3+opts = "--quiet"

4+

35modules = B

46

test/idrisdoc007/package.ipkg+2

@@ -1,4 +1,6 @@

11package do_not_delete

22

3+opts = "--quiet"

4+

35modules = A

46

test/idrisdoc008/expected−2

@@ -1,4 +1,2 @@

1−Type checking ./Abstract.idr

2−Type checking ./Visible.idr

31Abstract members are documented

42Public members are documented

test/idrisdoc008/visibility.ipkg+2

@@ -1,4 +1,6 @@

11package visibility

22

3+opts = "--quiet"

4+

35modules = Abstract, Visible

46

test/idrisdoc009/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./Test.idr

21Data type Test : Type

32 Docs for datatype Test.

43

test/interactive001/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./test032.idr

21isElem x [] = ?isElem_rhs_1

32isElem x (y :: xs) = ?isElem_rhs_3

43

test/interactive002/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive002.idr

21Nat

32Nat

43Nat

test/interactive003/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive003.idr

21ys

32x :: app xs ys

43[]

test/interactive004/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./interactive004.idr

21plus ?foo_rhs2 ?foo_rhs3

32append k m ?append_rhs2 ?append_rhs3

test/interactive005/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive005.idr

213 : Nat

32Hello, World

43main : IO ()

test/interactive006/expected−1

@@ -1,2 +1 @@

1−Type checking ./interactive006.idr

21plus ?foo_rhs2 ?foo_rhs3

test/interactive007/expected.msysnew file+1

@@ -0,0 +1 @@

1+Idris> *Data\ZZ> *Data\ZZ> *Data\ZZ> *Data\ZZ> Bye bye

test/io001/expected+1

@@ -13,4 +13,5 @@ World!

13133

14144

1515Last line

16+

1617---

test/io001/test004.idr+1−1

@@ -13,7 +13,7 @@ dumpFile fn = do { h <- openFile fn Read

1313 x <- feof h

1414 return (not x) })

1515 (do { l <- fread h

16− putStr l })

16+ putStrLn l })

1717 closeFile h }

1818

1919main : IO ()

test/meta001/Finite.idrnew file+184

@@ -0,0 +1,184 @@

1+module Finite

2+

3+import Data.Fin

4+import Language.Reflection.Elab

5+import Language.Reflection.Utils

6+

7+-- Test various features of reflected elaboration, including looking

8+-- up datatypes, defining functions, and totality checking

9+

10+%default total

11+

12+||| A bijection between some type and bounded numbers

13+data Finite : Type -> Nat -> Type where

14+ IsFinite : (toFin : a -> Fin n) ->

15+ (fromFin : Fin n -> a) ->

16+ (ok1 : (x : a) -> fromFin (toFin x) = x) ->

17+ (ok2 : (y : Fin n) -> toFin (fromFin y) = y) ->

18+ Finite a n

19+

20+acceptableConstructor : Raw -> Bool

21+acceptableConstructor (Var _) = True

22+acceptableConstructor _ = False

23+

24+mkFin : Nat -> Nat -> Elab Raw

25+mkFin Z j = fail [TermPart `(Fin Z), TextPart "is uninhabitable!"]

26+mkFin (S k) Z = return `(FZ {k=~(quote k)})

27+mkFin (S k) (S j) = do i <- mkFin k j

28+ return `(FS {k=~(quote k)} ~i)

29+

30+mkToClause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause

31+mkToClause fn size i (n, Var ty) =

32+ MkFunClause (RApp (Var fn) (Var n)) <$> mkFin size i

33+mkToClause fn size i (n, ty) =

34+ fail [TextPart "unsupported constructor", NamePart n]

35+

36+

37+mkFromClause : TTName -> (size, i : Nat) ->

38+ (constr : (TTName, Raw)) ->

39+ Elab FunClause

40+mkFromClause fn size i (n, Var ty) =

41+ return $ MkFunClause (RApp (Var fn) !(mkFin size i)) (Var n)

42+mkFromClause fn size i (n, ty) =

43+ fail [TextPart "unsupported constructor", NamePart n]

44+

45+

46+mkOk1Clause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause

47+mkOk1Clause fn size i (n, Var ty) =

48+ return $ MkFunClause (RApp (Var fn) (Var n))

49+ [| (Var (UN "Refl")) (Var ty) (Var n) |]

50+mkOk1Clause fn size i (n, ty) =

51+ fail [TextPart "unsupported constructor", NamePart n]

52+

53+

54+mkOk2Clause : TTName -> (size, i : Nat) -> (constr : (TTName, Raw)) -> Elab FunClause

55+mkOk2Clause fn size i (n, Var ty) =

56+ return $ MkFunClause (RApp (Var fn) !(mkFin size i))

57+ [| (Var "Refl") `(Fin ~(quote size))

58+ !(mkFin size i) |]

59+mkOk2Clause fn size i (n, ty) =

60+ fail [TextPart "unsupported constructor", NamePart n]

61+

62+

63+mkToClauses : TTName -> Nat -> List (TTName, Raw) -> Elab (List FunClause)

64+mkToClauses fn size xs = mkToClauses' Z xs

65+ where mkToClauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)

66+ mkToClauses' k [] = return []

67+ mkToClauses' k (x :: xs) = do rest <- mkToClauses' (S k) xs

68+ clause <- mkToClause fn size k x

69+ return $ clause :: rest

70+

71+||| Generate a clause for the end of a pattern-match on Fins that

72+||| declares its own impossibility.

73+|||

74+||| This is to satisfy the totality checker, because `impossible`

75+||| clauses are still

76+mkAbsurdFinClause : (fn : TTName) -> (goal : Raw -> Raw) -> (size : Nat) ->

77+ Elab FunClause

78+mkAbsurdFinClause fn goal size =

79+ do pv <- gensym "badfin"

80+ lhsArg <- lhsBody pv size

81+ let lhs = RBind pv (PVar `(Fin Z : Type))

82+ (RApp (Var fn) lhsArg)

83+ let rhs = RBind pv (PVar `(Fin Z : Type))

84+ `(FinZElim {a=~(goal lhsArg)} ~(Var pv))

85+ return $ MkFunClause lhs rhs

86+ where lhsBody : TTName -> Nat -> Elab Raw

87+ lhsBody f Z = return $ Var f

88+ lhsBody f (S k) = do smaller <- lhsBody f k

89+ return `(FS {k=~(quote k)} ~smaller)

90+

91+

92+mkFromClauses : TTName -> TTName -> Nat ->

93+ List (TTName, Raw) -> Elab (List FunClause)

94+mkFromClauses fn ty size xs = mkFromClauses' Z xs

95+ where mkFromClauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)

96+ mkFromClauses' k [] =

97+ return [!(mkAbsurdFinClause fn (const (Var ty)) size)]

98+ mkFromClauses' k (x :: xs) = do rest <- mkFromClauses' (S k) xs

99+ clause <- mkFromClause fn size k x

100+ return $ clause :: rest

101+

102+mkOk1Clauses : TTName -> Nat -> List (TTName, Raw) -> Elab (List FunClause)

103+mkOk1Clauses fn size xs = mkOk1Clauses' Z xs

104+ where mkOk1Clauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)

105+ mkOk1Clauses' k [] = return []

106+ mkOk1Clauses' k (x :: xs) = do rest <- mkOk1Clauses' (S k) xs

107+ clause <- mkOk1Clause fn size k x

108+ return $ clause :: rest

109+

110+mkOk2Clauses : TTName -> Nat -> List (TTName, Raw) -> (Raw -> Raw) -> Elab (List FunClause)

111+mkOk2Clauses fn size xs resTy = mkOk2Clauses' Z xs

112+ where mkOk2Clauses' : Nat -> List (TTName, Raw) -> Elab (List FunClause)

113+ mkOk2Clauses' k [] = return [!(mkAbsurdFinClause fn resTy size)]

114+ mkOk2Clauses' k (x :: xs) = do rest <- mkOk2Clauses' (S k) xs

115+ clause <- mkOk2Clause fn size k x

116+ return $ clause :: rest

117+

118+

119+genToFin : (to, from, ok1, ok2, ty : TTName) -> Elab ()

120+genToFin to from ok1 ok2 ty =

121+ do (MkDatatype famn tcargs tcres constrs) <- lookupDatatypeExact ty

122+ let size = length constrs

123+ argn <- gensym "arg"

124+ declareType $ Declare to [Explicit argn (Var ty)]

125+ `(Fin ~(quote size))

126+ toClauses <- mkToClauses to size constrs

127+ defineFunction $ DefineFun to toClauses

128+

129+ argn' <- gensym "arg"

130+ declareType $ Declare from [Explicit argn' `(Fin ~(quote size))]

131+ (Var ty)

132+ fromClauses <- mkFromClauses from ty size constrs

133+ defineFunction $ DefineFun from fromClauses

134+

135+ argn'' <- gensym "arg"

136+ declareType $ Declare ok1 [Explicit argn'' (Var ty)]

137+ `((=) {A=~(Var ty)} {B=~(Var ty)}

138+ ~(RApp (Var from) (RApp (Var to) (Var argn'')))

139+ ~(Var argn''))

140+ ok1Clauses <- mkOk1Clauses ok1 size constrs

141+ defineFunction $ DefineFun ok1 ok1Clauses

142+

143+ argn''' <- gensym "arg"

144+ let fty : Raw = `(Fin ~(quote size))

145+ let ok2ResTy = the (Raw -> Raw)

146+ (\n => `((=) {A=~fty} {B=~fty}

147+ ~(RApp (Var to) (RApp (Var from) n))

148+ ~n))

149+ declareType $ Declare ok2 [Explicit argn''' fty]

150+ (ok2ResTy (Var argn'''))

151+ ok2Clauses <- mkOk2Clauses ok2 size constrs ok2ResTy

152+ defineFunction $ DefineFun ok2 ok2Clauses

153+

154+ return ()

155+

156+

157+deriveFinite : Elab ()

158+deriveFinite =

159+ do (App (App (P _ `{Finite} _) (P _ tyn _)) _) <- snd <$> getGoal

160+ | ty => fail [TextPart "inapplicable goal type", TermPart ty]

161+ (MkDatatype _ _ _ constrs) <- lookupDatatypeExact tyn

162+ let size = length constrs

163+ let to = SN (MetaN tyn (UN "toFinite"))

164+ let from = SN (MetaN tyn (UN "fromFinite"))

165+ let ok1 = SN (MetaN tyn (UN "finiteOk1"))

166+ let ok2 = SN (MetaN tyn (UN "finiteOk2"))

167+ genToFin to from ok1 ok2 tyn

168+ fill `(IsFinite {a=~(Var tyn)} {n=~(quote size)}

169+ ~(Var to) ~(Var from)

170+ ~(Var ok1) ~(Var ok2))

171+ solve

172+

173+data TwoStateModel = Alive | Dead

174+data ThreeStateModel = Working | Disabled | Deceased

175+

176+

177+twoStateFinite : Finite TwoStateModel 2

178+twoStateFinite = %runElab deriveFinite

179+

180+threeStateFinite : Finite ThreeStateModel 3

181+threeStateFinite = %runElab deriveFinite

182+

183+boolFinite : Finite Bool 2

184+boolFinite = %runElab deriveFinite

test/meta001/expectednew file

No changes to the content.

test/meta001/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ --check --nocolour --consolewidth 70 Finite.idr

3+rm -f *.ibc

test/meta002/Tacs.idrnew file+252

@@ -0,0 +1,252 @@

1+||| A work-in-progress demonstration of Idris elaborator metaprogramming.

2+||| Goals:

3+||| * Let tactics query the environment, for things like type signatures

4+||| * Tactics expressions should be normal Idris expressions, and support

5+||| things like idiom brackets, Alternative, etc

6+||| * Make user-defined tactics just as easy to use as built-in ones

7+module Tacs

8+

9+import Data.Fin

10+import Data.Vect

11+

12+import Language.Reflection

13+import Language.Reflection.Errors

14+import Language.Reflection.Elab

15+import Language.Reflection.Utils

16+

17+%default total

18+

19+-- Tactics can now query the elaborator and bind variables

20+

21+--stuff : Nat -> Nat -> Nat

22+--stuff x y = %runElab (debugMessage "oh noes")

23+

24+intros : Elab ()

25+intros = do g <- getGoal

26+ case snd g of

27+ `(~_ -> ~_) => intro Nothing

28+ _ => return ()

29+

30+foo : Nat -> Nat

31+foo = %runElab (do intro (Just (UN "fnord"))

32+ fill `(plus ~(Var (UN "fnord")) ~(Var (UN "fnord")))

33+ solve)

34+

35+

36+

37+

38+-- Note that <|> is equivalent to "try" in the old tactics.

39+-- In these tactics, we use ordinary do notation and ordinary documentation strings!

40+||| Try to solve a goal with simple guesses of easy type

41+triv : Elab ()

42+triv = do fill `(Z) <|> fill `(() : ())

43+ solve

44+

45+

46+-- Solve both kinds of goal. The %runElab construction elaborates

47+-- to the result of running the tactic script that it contains.

48+

49+test1 : ()

50+test1 = %runElab triv

51+

52+test2 : Nat

53+test2 = %runElab triv

54+

55+

56+namespace STLC

57+

58+ data Ty = UNIT | ARR Ty Ty

59+

60+ %name Ty t,t',t''

61+

62+ instance Quotable Ty TT where

63+ quotedTy = `(Ty : Type)

64+ quote UNIT = `(UNIT : Ty)

65+ quote (ARR t t') = `(ARR ~(quote t) ~(quote t'))

66+

67+ elabTy : Ty -> Elab ()

68+ elabTy UNIT = do fill `(() : Type)

69+ solve

70+ elabTy (ARR t t') = do arg <- gensym "__stlc_arg"

71+ n1 <- mkTypeHole "t1"

72+ n2 <- mkTypeHole "t2"

73+ fill (RBind arg (Pi (Var n1) RType) (Var n2))

74+ focus n1; elabTy t

75+ focus n2; elabTy t'

76+ solve

77+ where mkTypeHole : String -> Elab TTName

78+ mkTypeHole hint = do holeName <- gensym hint

79+ claim holeName RType

80+ unfocus holeName

81+ return holeName

82+

83+ foo : %runElab (elabTy $ ARR (ARR UNIT UNIT) (ARR UNIT UNIT))

84+ foo = id

85+

86+ namespace Untyped

87+ ||| Completely untyped terms

88+ data UTm = Lam String UTm | App UTm UTm | Var String | UnitCon

89+ %name UTm tm,tm',tm''

90+

91+ namespace Scoped

92+ ||| Scope-checked terms - we'll use tactics to infer their types!

93+ data STm : Nat -> Type where

94+ Lam : String -> STm (S n) -> STm n

95+ App : STm n -> STm n -> STm n

96+ Var : Fin n -> STm n

97+ UnitCon : STm n

98+ %name STm tm,tm',tm''

99+

100+ ||| Find the de Bruijn index for a variable in a naming context

101+ findVar : Eq a => a -> Vect n a -> Maybe (Fin n)

102+ findVar x [] = Nothing

103+ findVar x (y :: xs) = if x == y then pure FZ else [| FS (findVar x xs) |]

104+

105+ ||| Resolve the names in a term to de Bruijn indices

106+ scopeCheck : Vect n String -> UTm -> Either String (STm n)

107+ scopeCheck vars (Lam x tm) = [| (Lam x) (scopeCheck (x::vars) tm) |]

108+ scopeCheck vars (App tm tm') = [| App (scopeCheck vars tm)

109+ (scopeCheck vars tm') |]

110+ scopeCheck vars (Var x) = case findVar x vars of

111+ Nothing => Left $ "Unknown var " ++ x

112+ Just i => pure $ Var i

113+ scopeCheck vars UnitCon = pure UnitCon

114+

115+ forgetScope : Vect n String -> STm n -> UTm

116+ forgetScope vars (Lam x tm) = Lam x (forgetScope (x::vars) tm)

117+ forgetScope vars (App tm tm') = App (forgetScope vars tm)

118+ (forgetScope vars tm')

119+ forgetScope vars (Var i) = Var $ index i vars

120+ forgetScope vars UnitCon = UnitCon

121+

122+ namespace Typed

123+

124+ Env : Type

125+ Env = List Ty

126+ %name Typed.Env env

127+

128+ ||| Well-typed de Bruijn indices

129+ data Ix : Env -> Ty -> Type where

130+ Z : Ix (t::env) t

131+ S : Ix env t -> Ix (t'::env) t

132+ %name Ix i,j,k

133+

134+ data Tm : List Ty -> Ty -> Type where

135+ Lam : {env : List Ty} -> {t, t' : Ty} ->

136+ Tm (t::env) t' -> Tm env (ARR t t')

137+ App : Tm env (ARR t t') -> Tm env t -> Tm env t'

138+ Var : Ix env t -> Tm env t

139+ UnitCon : Tm env UNIT

140+

141+ namespace Inference

142+ inNS : String -> TTName

143+ inNS n = NS (UN n) ["STLC", "Tacs"]

144+

145+ inTypedNS : String -> TTName

146+ inTypedNS n = NS (UN n) ["Typed", "STLC", "Tacs"]

147+

148+ elaborateSTLC : STm 0 -> Elab ()

149+ elaborateSTLC tm =

150+ do -- We're going to fill out a goal that wants a Sigma Ty (Tm [])

151+ -- First establish a hole for the type (inferred by side effect,

152+ -- similar to Idris implicit args)

153+ tH <- gensym "t"

154+ claim tH (Var (inNS "Ty"))

155+ unfocus tH

156+ -- Next we make a hole that wants a term in that type

157+ tmH <- gensym "tm"

158+ let p : Raw = `(Tm [])

159+ claim tmH (RApp p (Var tH))

160+ unfocus tmH

161+

162+ -- Now we put this hole variable into our sigma constructor

163+ -- prior to elaboration, so it doesn't disappear too soon

164+ fill `(MkSigma ~(Var tH) ~(Var tmH) : Sigma Ty (Tm []))

165+ solve

166+ focus tmH

167+ mkTerm [] tm

168+

169+ where mkEnvH : Elab TTName

170+ mkEnvH = do envH <- gensym "env"

171+ claim envH `(List Ty)

172+ unfocus envH

173+ return envH

174+

175+ mkTyH : Elab TTName

176+ mkTyH = do tyH <- gensym "ty"

177+ claim tyH `(Ty)

178+ unfocus tyH

179+ return tyH

180+

181+ mkIx : Fin n -> Elab ()

182+ mkIx FZ = do envH <- mkEnvH

183+ tH <- mkTyH

184+ apply `(Z {t=~(Var tH)} {env=~(Var envH)})

185+ solve

186+ mkIx (FS i) = do envH <- mkEnvH

187+ tH <- mkTyH

188+ vH <- mkTyH

189+ argH <- gensym "arg"

190+ claim argH `(Ix ~(Var envH) ~(Var tH))

191+ unfocus argH

192+ apply `(S {env=~(Var envH)} {t=~(Var tH)} {t'=~(Var vH)} ~(Var argH))

193+ solve

194+ focus argH

195+ mkIx i

196+

197+ mkTerm : Vect n TTName -> STm n -> Elab ()

198+ mkTerm xs (Lam x tm) = do tH <- mkTyH

199+ envH <- mkEnvH

200+ tH' <- mkTyH

201+ bodyH <- gensym "body"

202+ claim bodyH `(Tm ((::) ~(Var tH) ~(Var envH)) ~(Var tH'))

203+ apply `(Lam {env=~(Var envH)}

204+ {t=~(Var tH)} {t'=~(Var tH')}

205+ ~(Var bodyH))

206+

207+ solve

208+ focus bodyH

209+ mkTerm (tH::xs) tm

210+ mkTerm xs (App tm tm') = do envH <- mkEnvH

211+ tH <- mkTyH

212+ tH' <- mkTyH

213+ fH <- gensym "f"

214+ claim fH `(Tm ~(Var envH) (ARR ~(Var tH) ~(Var tH')))

215+ unfocus fH

216+ argH <- gensym "arg"

217+ claim argH `(Tm ~(Var envH) ~(Var tH))

218+ unfocus argH

219+ apply `(App {env=~(Var envH)}

220+ {t=~(Var tH)} {t'=~(Var tH')}

221+ ~(Var fH) ~(Var argH))

222+ solve

223+ focus fH

224+ mkTerm xs tm

225+ focus argH

226+ mkTerm xs tm'

227+ mkTerm xs (Var i) = do tH <- mkTyH

228+ envH <- mkEnvH

229+ ixH <- gensym "ix"

230+ claim ixH `(Ix ~(Var envH) ~(Var tH))

231+ unfocus ixH

232+ apply `(Var {env=~(Var envH)} {t=~(Var tH)} ~(Var ixH))

233+ solve

234+ focus ixH

235+ mkIx i

236+ mkTerm xs UnitCon = do envH <- mkEnvH

237+ apply `(UnitCon {env=~(Var envH)})

238+ solve

239+ testElab : Sigma Ty (Tm [])

240+ testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon))

241+

242+ testElab2 : Sigma Ty (Tm [])

243+ testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))

244+

245+ -- Doesn't work! :-)

246+ testElab3 : Sigma Ty (Tm [])

247+ testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))

248+ (Lam "x" (App (Var 0) (Var 0)))))

249+ -- Error is:

250+ -- Tacs.idr line 247 col 14:

251+ -- When elaborating right hand side of testElab3:

252+ -- Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value

test/meta002/expectednew file+3

@@ -0,0 +1,3 @@

1+Tacs.idr:247:15:

2+When elaborating right hand side of testElab3:

3+Unifying ty and ARR ty t would lead to infinite value

test/meta002/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ --nocolour --check --consolewidth 70 Tacs.idr

3+rm -f *.ibc

test/proof007/expected+1−1

@@ -1,4 +1,4 @@

11DefaultArgUnknownName.idr:9:6:

22When elaborating right hand side of test:

3−When elaborating argument [95marg[0m to function [92mDefaultArgUnknownName.funWithBadDefArg[0m:

3+When elaborating argument arg to function DefaultArgUnknownName.funWithBadDefArg:

44 No such variable sadgjhsag

test/proof007/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 --check $@ DefaultArgUnknownName.idr

2+idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

33rm -f *.ibc

test/proof009/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./proof009.idr

21

32

43---------- Goal: ----------

test/quasiquote006/expectednew file+13

@@ -0,0 +1,13 @@

1+quasiquote006.idr:9:3:

2+When elaborating right hand side of b:

3+Can't disambiguate name: ForeignEnv.Nil,

4+ Prelude.List.Nil

5+quasiquote006.idr:12:3:

6+When elaborating right hand side of c:

7+No such variable alsdkjflkj

8+quasiquote006.idr:15:3:

9+When elaborating right hand side of d:

10+Can't disambiguate name: ForeignEnv.::,

11+ Prelude.List.::,

12+ Prelude.Stream.::

13+quasiquote006.idr:17:3:Main.d already defined

test/quasiquote006/quasiquote006.idrnew file+21

@@ -0,0 +1,21 @@

1+

2+a : TTName

3+a = `{Nat}

4+

5+aOK : a = NS (UN "Nat") ["Nat", "Prelude"]

6+aOK = Refl

7+

8+b : TTName

9+b = `{Nil}

10+

11+c : TTName

12+c = `{alsdkjflkj}

13+

14+d : TTName

15+d = `{(::)}

16+

17+d : TTName

18+d = `{List.(::)}

19+

20+dOK : d = NS (UN "::") ["List", "Prelude"]

21+dOK = Refl

test/quasiquote006/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

3+rm -f *.ibc

test/reg003/expected+4

@@ -1,2 +1,6 @@

11reg003a.idr:4:11:When elaborating type of Main.ECons:

22No such variable OddList

3+reg003a.idr:7:11:When elaborating type of Main.OCons:

4+No such variable EvenList

5+reg003a.idr:9:6:When elaborating type of Main.test:

6+No such variable EvenList

test/reg023/expected+2−2

@@ -1,5 +1,5 @@

11reg023.idr:7:5:When elaborating right hand side of bad:

22Can't unify

3− [94mNat[0m (Type of [91m0[0m)

3+ Nat (Type of 0)

44with

5− [92mf[0m [94mNat[0m (Expected type)

5+ f Nat (Expected type)

test/reg023/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg023.idr --check

2+idris --nocolour --consolewidth 80 $@ reg023.idr --check

33rm -f *.ibc

test/reg029/reg029.idr+1−1

@@ -3,7 +3,7 @@ module Main

33import System

44

55-- necessary to find the getenv symbol

6−%dynamic "libm"

6+%dynamic "libm","msvcrt"

77

88main : IO ()

99main = do

test/reg034/expected+2−2

@@ -1,4 +1,4 @@

11reg034.idr:6:5:When elaborating left hand side of bar:

2−Can't match on bar xs xs [91mRefl[0m

2+Can't match on bar xs xs Refl

33reg034.idr:9:5:When elaborating left hand side of foo:

4−Can't match on foo f x x [91mRefl[0m

4+Can't match on foo f x x Refl

test/reg034/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg034.idr

2+idris --nocolour --consolewidth 80 --check reg034.idr

33rm -f reg034 *.ibc

test/reg035/expected+1−4

@@ -1,4 +1 @@

1−reg035b.idr:8:6:Can't convert

2− [94mAdditive[0m -> [94mNat[0m

3−with

4− [94mFin[0m [91m0[0m

1+reg035b.idr:8:6:No such variable __pi_arg

test/reg035/run+3−3

@@ -1,5 +1,5 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg035.idr

3−idris --consolewidth 80 --check reg035a.lidr

4−idris --consolewidth 80 --check reg035b.idr

2+idris --nocolour --consolewidth 80 --check reg035.idr

3+idris --nocolour --consolewidth 80 --check reg035a.lidr

4+idris --nocolour --consolewidth 80 --check reg035b.idr

55rm -f *.ibc

test/reg039/expected−1

@@ -1,2 +1 @@

1−Type checking ./reg039.idr

21[3, 2, 1]

test/reg039/run+27−24

@@ -1,32 +1,35 @@

11#!/usr/bin/env bash

22

3−# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting

4−# Executes command with a timeout

5−# Params:

6−# $1 timeout in seconds

7−# $2 command

8−# Returns 1 if timed out 0 otherwise

9−timeout() {

10−

11− time=$1

12−

13− # start the command in a subshell to avoid problem with pipes

14− # (spawn accepts one command)

15− command="/bin/sh -c \"$2\""

16−

17− expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"

18−

19− if [ $? = 1 ] ; then

20− echo "Timeout after ${time} seconds"

21− fi

22−

23−}

243

254declare -a extraargs

265for arg in "$@"

276do

287 extraargs=("${extraargs[@]}" "'$arg'")

298done

30−

31−timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"

32−rm -f reg039 *.ibc

9+if (which timeout&>/dev/null); then

10+ timeout 60 idris $@ --nocolour reg039.idr --exec go

11+else

12+ # From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting

13+ # Executes command with a timeout

14+ # Params:

15+ # $1 timeout in seconds

16+ # $2 command

17+ # Returns 1 if timed out 0 otherwise

18+ timeout() {

19+

20+ time=$1

21+

22+ # start the command in a subshell to avoid problem with pipes

23+ # (spawn accepts one command)

24+ command="/bin/sh -c \"$2\""

25+

26+ expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"

27+

28+ if [ $? = 1 ] ; then

29+ echo "Timeout after ${time} seconds"

30+ fi

31+

32+ }

33+ timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"

34+ fi

35+ rm -f reg039 *.ibc

test/reg041/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./ott.idr

21?prf : (x : Bool) -> (x1 : Bool) -> El (EQ two x two x1) -> El (EQ two x two x1)

32Z

test/reg044/expected+4−4

@@ -1,11 +1,11 @@

11reg044.idr:4:4:When elaborating right hand side of Main.pf:

22Can't unify

3− [95mb[0m [94m=[0m [95mb[0m (Type of [91mRefl[0m)

3+ b = b (Type of Refl)

44with

5− [95ma[0m [94m=[0m [95mb[0m (Expected type)

5+ a = b (Expected type)

66

77Specifically:

88 Can't unify

9− [95mb[0m

9+ b

1010 with

11− [95ma[0m

11+ a

test/reg044/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 reg044.idr --check

2+idris --nocolour --consolewidth 80 reg044.idr --check

33rm -f *.ibc

test/reg049/expected+2

@@ -1,2 +1,4 @@

11reg049.idr:2:9:When elaborating constructor Main.Bogus:

22Void is not Main.Foo

3+reg049.idr:5:6:When elaborating right hand side of uhOh:

4+No such variable Bogus

test/reg054/expected+4−4

@@ -1,10 +1,10 @@

11reg054.idr:18:5:When elaborating left hand side of inf:

2−When elaborating an application of constructor [91mMain.MkInfer[0m:

2+When elaborating an application of constructor Main.MkInfer:

33 Attempting concrete match on polymorphic argument: 0

44reg054.idr:34:7:When elaborating left hand side of weird:

5−When elaborating argument [95mx[0m to Main.weird:

5+When elaborating argument x to Main.weird:

66 No explicit types on left hand side: Char

77reg054.idr:37:9:Can't convert

8− [94mMaybe[0m a1

8+ Maybe a1

99with

10− [95ma[0m

10+ a

test/reg054/run+1−1

@@ -1,2 +1,2 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg054.idr --check

2+idris --nocolour --consolewidth 80 $@ reg054.idr --check

test/reg055/expected+3−3

@@ -1,9 +1,9 @@

11reg055.idr:5:3:When elaborating left hand side of g:

2−Can't match on g ([92mf[0m [91m0[0m)

2+Can't match on g (f 0)

33reg055.idr:8:3:When elaborating left hand side of h:

44Can't match on h x x

55reg055a.idr:8:5:When elaborating left hand side of foo:

6−When elaborating an application of constructor [91mFoo.CAny[0m:

6+When elaborating an application of constructor Foo.CAny:

77 Attempting concrete match on polymorphic argument: Nothing

88reg055a.idr:13:7:When elaborating left hand side of Foo.apply:

9−Can't match on apply (\[95mx[0m => \[95my[0m => [95mx[0m) a

9+Can't match on apply (\x => \y => x) a

test/reg055/run+2−2

@@ -1,5 +1,5 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg055.idr --check

3−idris --consolewidth 80 $@ reg055a.idr --check

2+idris --nocolour --consolewidth 80 $@ reg055.idr --check

3+idris --nocolour --consolewidth 80 $@ reg055a.idr --check

44rm -f *.ibc

55

test/reg062/expectednew file

No changes to the content.

test/reg062/reg062.idrnew file+13

@@ -0,0 +1,13 @@

1+module MinCrash

2+

3+-- Test that #2130 stays fixed. It's important that the first argument

4+-- to revInduction be called `pred` here, because the bug was

5+-- triggered by looking up a bound variable in the global context and

6+-- getting an ambiguous result in a context where fully-qualified

7+-- names were expected.

8+

9+revInduction : (P : List a -> Type) -> P [] -> ((xs : List a) -> (x : a) -> P xs -> P (xs ++ [x]))

10+ -> (ys : List a) -> P ys

11+revInduction pred base ind ys with (reverse ys)

12+ revInduction pred base ind _ | revys =

13+ ?revInduction_rhs

test/reg062/reg062.lidrnew file+41

@@ -0,0 +1,41 @@

1+

2+This is a test to make sure that #2130 doesn't re-break.

3+

4+> import Data.Vect

5+> import Data.Fin

6+

7+> %default total

8+

9+> idSuccPreservesLTE : (m : Nat) -> (n : Nat) -> m `LTE` n -> m `LTE` (S n)

10+> idSuccPreservesLTE Z n prf = LTEZero

11+> idSuccPreservesLTE (S m) Z prf = absurd prf

12+> idSuccPreservesLTE (S m) (S n) prf = LTESucc (idSuccPreservesLTE m n (fromLteSucc prf))

13+

14+> ltZS : (m : Nat) -> LT Z (S m)

15+> ltZS Z = LTESucc LTEZero

16+> ltZS (S m) = idSuccPreservesLTE (S Z) (S m) (ltZS m)

17+

18+> record Preorder : {T : Type} -> (T -> T -> Type) -> Type where

19+> MkPreorder : {T : Type} ->

20+> (R : T -> T -> Type) ->

21+> (reflexive : (x : T) -> R x x) ->

22+> (transitive : (x : T) -> (y : T) -> (z : T) -> R x y -> R y z -> R x z) ->

23+> Preorder R

24+

25+> record TotalPreorder : {T : Type} -> (T -> T -> Type) -> Type where

26+> MkTotalPreorder : {T : Type} ->

27+> (R : T -> T -> Type) ->

28+> (reflexive : (x : T) -> R x x) ->

29+> (transitive : (x : T) -> (y : T) -> (z : T) -> R x y -> R y z -> R x z) ->

30+> (either : (x : T) -> (y : T) -> Either (R x y) (R y x)) ->

31+> TotalPreorder R

32+

33+> argmaxMax : {A : Type} -> {R : A -> A -> Type} -> TotalPreorder {T = A} R ->

34+> Vect n A -> LT Z n -> (Fin n, A)

35+> argmaxMax {n = Z} tp Nil p = absurd p

36+> argmaxMax {n = S Z} tp (a :: Nil) _ = (FZ, a)

37+> argmaxMax {A} {R} {n = S (S m)} (MkTotalPreorder R r t e) (a' :: (a'' :: as)) _

38+> with (argmaxMax (MkTotalPreorder {T = A} R r t e) (a'' :: as) (ltZS m))

39+> | (k, max) with (e a' max)

40+> | (Left _) = (FS k, max)

41+> | (Right _) = (FZ, a')

test/reg062/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ reg062.idr --check --nocolour

3+idris $@ reg062.lidr --check --nocolour

4+rm -f *.ibc

test/runtest.pl+11−2

@@ -10,10 +10,11 @@ my @idrOpts = ();

1010

1111sub sandbox_path {

1212 my ($test_dir,) = @_;

13− my $sandbox = abs_path("$test_dir/../../.cabal-sandbox/bin");

13+ my $sandbox = "$test_dir/../../.cabal-sandbox/bin";

1414

1515 if ( -d $sandbox ) {

16− return "PATH=$sandbox:$PATH";

16+ my $sandbox_abs = abs_path($sandbox);

17+ return "PATH=\"$sandbox_abs:$PATH\"";

1718 } else {

1819 return "";

1920 }

@@ -30,6 +31,14 @@ sub runtest {

3031 my $got = `$sandbox ./run @idrOpts`;

3132 my $exp = `cat expected`;

3233

34+ # Allow for variant expected output for tests by overriding expected

35+ # when there is an expected.<os> file in the test.

36+ # This should be the exception but there are sometimes valid reasons

37+ # for os-dependent output.

38+ # The endings are msys for windows, darwin for osx and linux for linux

39+ if ( -e "expected.$^O") {

40+ $exp = `cat expected.$^O`;

41+ }

3342 open my $out, '>', 'output';

3443 print $out $got;

3544 close $out;

test/tactics001/Tactics.idr+10−10

@@ -1,6 +1,6 @@

11module Tactics

22

3−import Language.Reflection.Tactical

3+import Language.Reflection.Elab

44

55import Data.Vect

66

@@ -18,24 +18,24 @@ refl t x = RApp (RApp (Var (UN "Refl")) t) x

1818plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n

1919plusZeroRightNeutralNew Z = Refl

2020plusZeroRightNeutralNew (S k) =

21− %runTactics (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))

22− fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))

23− solve)

21+ %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))

22+ fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))

23+ solve)

2424

2525plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k)

2626plusSuccRightSuccNew Z k = Refl

2727plusSuccRightSuccNew (S j) k =

28− %runTactics (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))

29− fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))

30− solve)

28+ %runElab (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))

29+ fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))

30+ solve)

3131

3232-- Test that side effects in new tactics work

3333

3434mkDecl : ()

35−mkDecl = %runTactics (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])

35+mkDecl = %runElab (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])

3636 [Implicit (UN "z") `(Nat)]

3737 `(Vect ~(Var (UN "z")) ())

38− fill `(() : ())

39− solve)

38+ fill `(() : ())

39+ solve)

4040

4141repUnit = pure ()

test/totality007/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./Totality.idr

21Totality.idr:4:1:

32Totality.foo is not total as there are missing cases

43Totality.idr:4:1:Could not build: Totality.foo is not total as there are missing cases

test/totality007/totality.ipkg+1−1

@@ -2,6 +2,6 @@ package totality

22

33-- totality007

44-- Test that the package builder doesn't allow totality errors in a build

5−opts = "--consolewidth 80"

5+opts = "--quiet --consolewidth 80"

66sourcedir = src

77modules = Totality

test/tutorial006/expected+9−9

@@ -1,24 +1,24 @@

11tutorial006a.idr:5:23:When elaborating right hand side of vapp:

2−When elaborating argument [95mxs[0m to constructor [91mData.VectType.Vect.::[0m:

2+When elaborating argument xs to constructor Data.VectType.Vect.:::

33 Can't unify

4− [94mVect[0m ([95mn[0m [92m+[0m [95mn[0m) [95ma[0m (Type of vapp [95mxs[0m [95mxs[0m)

4+ Vect (n + n) a (Type of vapp xs xs)

55 with

6− [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m (Expected type)

6+ Vect (plus n m) a (Expected type)

77

88 Specifically:

99 Can't unify

10− [92mplus[0m [95mn[0m [95mn[0m

10+ plus n n

1111 with

12− [92mplus[0m [95mn[0m [95mm[0m

12+ plus n m

1313tutorial006b.idr:10:10:

1414When elaborating right hand side of with block in Main.parity:

1515Can't unify

16− [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)) (Type of [91meven[0m)

16+ Parity (plus (S j) (S j)) (Type of even)

1717with

18− [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))) (Expected type)

18+ Parity (S (S (plus j j))) (Expected type)

1919

2020Specifically:

2121 Can't unify

22− [92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)

22+ plus (S j) (S j)

2323 with

24− [91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))

24+ S (S (plus j j))

test/tutorial006/run+2−2

@@ -1,4 +1,4 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ tutorial006a.idr --check

3−idris --consolewidth 80 $@ tutorial006b.idr --check

2+idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check

3+idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check

44rm -f *.ibc

test/unique001/expected+6−6

@@ -3,17 +3,17 @@

3338,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END

4438,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END

55unique001a.idr:33:11:Can't convert

6− [94mInt[0m -> [94mString[0m

6+ Int -> String

77with

8− UniqueType ([94mInt[0m -> [94mString[0m)

8+ UniqueType (Int -> String)

99unique001a.idr:44:12:Can't convert

10− [94mInt[0m -> [94mString[0m

10+ Int -> String

1111with

12− UniqueType ([94mInt[0m -> [94mString[0m)

12+ UniqueType (Int -> String)

1313unique001a.idr:55:12:Can't convert

14− UniqueType ([94mInt[0m -> [94mString[0m)

14+ UniqueType (Int -> String)

1515with

16− [94mInt[0m -> [94mString[0m

16+ Int -> String

1717unique001b.idr:16:7:Borrowed name xs must not be used on RHS

1818unique001c.idr:46:6:Unique name f is used more than once

1919unique001d.idr:3:7:Borrowed name x must not be used on RHS

test/unique001/run+6−6

@@ -1,9 +1,9 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique001.idr -o unique001

2+idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001

33./unique001

4−idris --consolewidth 80 $@ unique001a.idr --check

5−idris --consolewidth 80 $@ unique001b.idr --check

6−idris --consolewidth 80 $@ unique001c.idr --check

7−idris --consolewidth 80 $@ unique001d.idr --check

8−idris --consolewidth 80 $@ unique001e.idr --check

4+idris --nocolour --consolewidth 80 $@ unique001a.idr --check

5+idris --nocolour --consolewidth 80 $@ unique001b.idr --check

6+idris --nocolour --consolewidth 80 $@ unique001c.idr --check

7+idris --nocolour --consolewidth 80 $@ unique001d.idr --check

8+idris --nocolour --consolewidth 80 $@ unique001e.idr --check

99rm -f unique001 *.ibc

test/unique001/unique001c.idr+3−3

@@ -25,7 +25,7 @@ share : UTree -> Tree

2525share ULeaf = Leaf

2626share (UNode x y z) = Node (share x) y (share z)

2727

28−class UFunctor (f : Type -> Type*) where

28+class UFunctor (f : Type -> AnyType) where

2929 fmap : (a -> b) -> f a -> f b

3030

3131instance UFunctor List where

@@ -36,10 +36,10 @@ instance UFunctor UList where

3636 fmap f UNil = UNil

3737 fmap f (UCons x xs) = UCons (f x) (fmap f xs)

3838

39−uconst : {a : Type*} -> a -> b -> a

39+uconst : {a : AnyType} -> a -> b -> a

4040uconst x y = x

4141

42−data MPair : Type* -> Type* -> Type* where

42+data MPair : AnyType -> AnyType -> AnyType where

4343 MkMPair : {a, b : Type*} -> a -> b -> MPair a b

4444

4545ndup : {a : UniqueType} -> a -> UPair a a

test/unique002/expected+2−2

@@ -1,5 +1,5 @@

11unique002.idr:15:5:Unique name xs is used more than once

22unique002a.idr:15:5:Can't convert

3− [94mInt[0m -> [94mString[0m

3+ Int -> String

44with

5− UniqueType ([94mInt[0m -> [94mString[0m)

5+ UniqueType (Int -> String)

test/unique002/run+2−2

@@ -1,4 +1,4 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique002.idr --check

3−idris --consolewidth 80 $@ unique002a.idr --check

2+idris --nocolour --consolewidth 80 $@ unique002.idr --check

3+idris --nocolour --consolewidth 80 $@ unique002a.idr --check

44rm -f *.ibc

test/unique003/expected+2−2

@@ -1,4 +1,4 @@

11unique003.idr:18:5:Can't convert

2− [94mInt[0m -> [94mString[0m

2+ Int -> String

33with

4− UniqueType ([94mInt[0m -> [94mString[0m)

4+ UniqueType (Int -> String)

test/unique003/run+1−1

@@ -1,3 +1,3 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique003.idr --check

2+idris --nocolour --consolewidth 80 $@ unique003.idr --check

33rm -f *.ibc

win-release.shnew file+2

@@ -0,0 +1,2 @@

1+

2+IDRIS_LIB_DIR="./libs" IDRIS_TOOLCHAIN_DIR="./mingw/bin" CABALFLAGS="-fffi -ffreestanding -frelease" make