c1cd201 · Idris-dev · git.iko.soy

.gitignore+1

compare with master

unifiedsplit

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

2cabal-dev/

3.cabal-sandbox

4cabal.sandbox.config

5+cabal.config

5.hsenv

6.hsenv

6*.ibc

7*.ibc

7*.o

8*.o

CHANGELOG+15

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

1New in 0.9.18:

2--------------

3+* GHC 7.10 compatibility

4+* Add support for bundled toolchains.

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

5* 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.

4* Some reorganisation of primitives:

8* Some reorganisation of primitives:

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

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

6 tested sufficiently, and lack a maintainer)

10 tested sufficiently, and lack a maintainer)

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

21 requiring a separate lemma.

25 requiring a separate lemma.

22* Case alternatives are allowed to be impossible:

26* Case alternatives are allowed to be impossible:

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

27 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.

24

39

25New in 0.9.17:

40New in 0.9.17:

26--------------

41--------------

CONTRIBUTORS+2

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

17Cezar Ionescu

18Irene Knapp

19Paul Koerbitz

20+Niklas Larsson

20Shea Levy

21Shea Levy

21Mathnerd314

22Mathnerd314

22Hannes Mehnert

23Hannes Mehnert

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

32Seo Sanghyeon

33Seo Sanghyeon

33Benjamin Saunders

34Benjamin Saunders

34Alexander Shabalin

35Alexander Shabalin

36+JP Smith

35startling

37startling

36Chetan T

38Chetan T

37Matúš Tejiščák

39Matúš Tejiščák

Setup.hs+24−7

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

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

63 Just True -> True

64 Just False -> False

65− Nothing -> True

65+ Nothing -> False

66

67isRelease :: S.ConfigFlags -> Bool

68isRelease flags =

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

137 ++ " dir <- getDataDir\n"

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

139

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)

140

151

141idrisConfigure _ flags _ local = do

152idrisConfigure _ flags _ local = do

142− configureRTS

153+ configureRTS

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

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

144− when (isFreestanding $ configFlags local) (do

155+ if (isFreestanding $ configFlags local)

156+ then (do

157+ toolDir <- lookupEnv "IDRIS_TOOLCHAIN_DIR"

158+ generateToolchainModule verbosity (autogenModulesDir local) toolDir

145− targetDir <- lookupEnv "IDRIS_INSTALL_DIR"

159+ targetDir <- lookupEnv "IDRIS_LIB_DIR"

146 case targetDir of

160 case targetDir of

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

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

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

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

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

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

164+ else

165+ generateToolchainModule verbosity (autogenModulesDir local) Nothing

150− where

166+ where

151 verbosity = S.fromFlag $ S.configVerbosity flags

167 verbosity = S.fromFlag $ S.configVerbosity flags

152 version = pkgVersion . package $ localPkgDescr local

168 version = pkgVersion . package $ localPkgDescr local

153

169

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

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

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

163 generateVersionModule verb ("src") True

179 generateVersionModule verb ("src") True

164 generateTargetModule verb "src" "./libs"

180 generateTargetModule verb "src" "./libs"

181+ generateToolchainModule verb "src" Nothing

165 preSDist simpleUserHooks args flags

182 preSDist simpleUserHooks args flags

166

183

167idrisPostSDist args flags desc lbi = do

184idrisPostSDist args flags desc lbi = do

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

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

14

15import Paths_idris

16

17+import Util.System

18+

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

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

18 interface :: Bool,

20 interface :: Bool,

19 output :: FilePath }

21 output :: FilePath }

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

31 process opts [] = opts

33 process opts [] = opts

32

34

33c_main :: Opts -> Idris ()

35c_main :: Opts -> Idris ()

36+c_main opts = do runIO setupBundledCC

34−c_main opts = do elabPrims

37+ elabPrims

35 loadInputs (inputs opts) Nothing

38 loadInputs (inputs opts) Nothing

36 mainProg <- if interface opts

39 mainProg <- if interface opts

37 then liftM Just elabMain

40 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

1+CABALFLAGS += -f LLVM -f FFI -f curses --disable-documentation --disable-profiling --disable-library-profiling

2−

docs/effects/introduction.rst+2−2

@@ -16,7 +16,7 @@ exceptions, and verified resource management.

16

17This tutorial assumes familiarity with pure programming in Idris,

18as 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

20examples directory of the Idris repository.

21

22Consider, for example, the following introductory function which

@@ -66,7 +66,7 @@ library:

66 import Effects

67 import Effect.StdIO

68

69− hello : [STDIO] Eff ()

69+ hello : {[STDIO]} Eff ()

70 hello = putStrLn “Hello world!”

71

72 main : IO ()

docs/faq/faq.rst+15

@@ -131,6 +131,21 @@ choice by the developers of Idris, Idris uses the C style convention.

131That is, the names ``Float`` and ``Double`` are used to describe

132single and double precision numbers.

133

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+

134What does the name ‘Idris’ mean?

149What does the name ‘Idris’ mean?

135================================

150================================

136

151

docs/tutorial/classes.rst+1−1

@@ -399,7 +399,7 @@ to the following:

399 | Add Expr Expr -- addition

400

401Evaluation 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.

403We define a data type ``Eval`` to wrap an evaluator:

404

405.. 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

25type and ``n`` is the length of the list and can be an arbitrary term.

26

27When types can contain values, and where those values describe

28−properties (e.g. the length of a list) the type of a function can

28+properties, for example the length of a list, the type of a function

29−begin to describe its own properties. For example, concatenating two

29+can begin to describe its own properties. Take for example the

30+concatenatation of two lists. This operation has the property that the

30−lists has the property that the resulting list’s length is the sum of

31+resulting list's length is the sum of the lengths of the two input

31−the lengths of the two input lists. We can therefore give the

32+lists. We can therefore give the following type to the ``app``

32−following type to the ``app`` function, which concatenates vectors:

33+function, which concatenates vectors:

33

34

34.. code-block:: idris

35.. code-block:: idris

35

36

@@ -58,11 +59,10 @@ Example Code

58============

59============

59

60

60This tutorial includes some example code, which has been tested with

61This tutorial includes some example code, which has been tested with

61−Idris version . The files are available in the Idris

62+against Idris. These files are available with the Idris distribution,

62−distribution, and provided along side the tutorial source, so that you

63−can try them out easily, under ``tutorial/examples``. However, it is

63+so that you can try them out easily. They can be found under

64−strongly recommended that you can type them in yourself, rather than

64+``samples``. It is, however, strongly recommended that you type

65−simply loading and reading them.

65+them in yourself, rather than simply loading and reading them.

66

67.. [1]

68 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

10are to be imported, and a collection of declarations and definitions of

11types, classes and functions. For example, the listing below gives a

12module which defines a binary tree type ``BTree`` (in a file

13−``btree.idr``):

13+``Btree.idr``):

14

15.. code-block:: idris

16

17− module btree

17+ module Btree

18

19 data BTree a = Leaf

20 | Node (BTree a) a (BTree a)

@@ -40,23 +40,24 @@ Then, this gives a main program (in a file

40

41 module Main

42

43− import btree

43+ import Btree

44

45 main : IO ()

46 main = do let t = toTree [1,8,2,7,9,3]

47 print (btree.toList t)

48

49

50+

50The same names can be defined in multiple modules. This is possible

51The same names can be defined in multiple modules. This is possible

51because in practice names are *qualified* with the name of the module.

52because in practice names are *qualified* with the name of the module.

52The names defined in the ``btree`` module are, in full:

53The names defined in the ``btree`` module are, in full:

53

54

54−+ ``btree.BTree``

55++ ``Btree.BTree``

55−+ ``btree.Leaf``

56++ ``Btree.Leaf``

56−+ ``btree.Node``

57++ ``Btree.Node``

57−+ ``btree.insert``

58++ ``Btree.insert``

58−+ ``btree.toList``

59++ ``Btree.toList``

59−+ ``btree.toTree``

60++ ``Btree.toTree``

60

61

61If names are otherwise unambiguous, there is no need to give the fully

62If names are otherwise unambiguous, there is no need to give the fully

62qualified name. Names can be disambiguated either by giving an explicit

63qualified name. Names can be disambiguated either by giving an explicit

@@ -103,7 +104,7 @@ functions to be exported as ``abstract``, as we see below:

103

104

104.. code-block:: idris

105.. code-block:: idris

105

106

106− module btree

107+ module Btree

107

108

108 abstract data BTree a = Leaf

109 abstract data BTree a = Leaf

109 | Node (BTree a) a (BTree a)

110 | Node (BTree a) a (BTree a)

@@ -137,7 +138,8 @@ the ``public`` modifier on an ``import``. For example:

137

138

138 module A

139 module A

139

140

141+ import B

140− import B import public C

142+ import public C

141

143

142 public a : AType a = ...

144 public a : AType a = ...

143

145

@@ -154,7 +156,7 @@ wish to overload names within the same module:

154

156

155.. code-block:: idris

157.. code-block:: idris

156

158

157− module foo

159+ module Foo

158

160

159 namespace x

161 namespace x

160 test : Int -> Int

162 test : Int -> Int

docs/tutorial/starting.rst+10−14

@@ -10,12 +10,9 @@ Prerequisites

10Before installing Idris, you will need to make sure you have all

11of the necessary libraries and tools. You will need:

12

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

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.

15− date.

16

14

17−- The *GNU Multiple Precision Arithmetic Library* (GMP) is available

15+- The *GNU Multiple Precision Arithmetic Library* (GMP) is available from MacPorts/Homebrew and all major Linux distributions.

18− from MacPorts/Homebrew and all major Linux distributions.

19

16

20Downloading and Installing

17Downloading and Installing

21==========================

18==========================

@@ -29,11 +26,11 @@ prerequisites, is to type:

29

26

30This will install the latest version released on Hackage, along with

27This will install the latest version released on Hackage, along with

31any dependencies. If, however, you would like the most up to date

28any 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

33GitHub at: https://github.com/idris-lang/Idris-dev.

30GitHub at: https://github.com/idris-lang/Idris-dev.

34

31

35To check that installation has succeeded, and to write your first

32To 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

37following text:

34following text:

38

35

39.. code-block:: idris

36.. code-block:: idris

@@ -55,18 +52,17 @@ create an executable called ``hello``, which you can run:

55 $ ./hello

52 $ ./hello

56 Hello world

53 Hello world

57

54

58−Note that the ``$`` indicates the shell prompt! Should the Idris

55+Please note that the dollar sign ``$`` indicates the shell prompt!

59−executable not be found please ensure that you have added

56+Should the Idris executable not be found please ensure that you have

60−``~/.cabal/bin`` to your ``$PATH`` environment variable. Mac OS X

57+added ``~/.cabal/bin`` to your ``$PATH`` environment variable. Mac OS

61−users may find they need to use ``~/Library/Haskell/bin``

58+X users may find they need to add ``~/Library/Haskell/bin``

62instead. Some useful options to the Idris command are:

59instead. Some useful options to the Idris command are:

63

60

64- ``-o prog`` to compile to an executable called ``prog``.

61- ``-o prog`` to compile to an executable called ``prog``.

65

62

66−- ``--check`` type check the file and its dependencies without

63+- ``--check`` type check the file and its dependencies without starting the interactive environment.

67− starting the interactive environment.

68

64

69−- ``--help`` display usage summary and command line options

65+- ``--help`` display usage summary and command line options.

70

66

71The Interactive Environment

67The Interactive Environment

72===========================

68===========================

docs/tutorial/typesfuns.rst+43−38

@@ -12,13 +12,13 @@ Idris defines several primitive types: ``Int``, ``Integer`` and

12manipulation, and ``Ptr`` which represents foreign pointers. There are

13also several data types declared in the library, including ``Bool``,

14with 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

16into the Idris interactive environment by typing ``idris

17−prims.idr``:

17+Prims.idr``:

18

19.. code-block:: idris

20

21− module prims

21+ module Prims

22

23 x : Int

24 x = 42

@@ -33,17 +33,18 @@ prims.idr``:

33 quux = False

34

35An Idris file consists of an optional module declaration (here

36−``module prims``) followed by an optional list of imports (none here,

36+``module Prims``) followed by an optional list of imports and a

37+collection of declarations and definitions. In this example no imports

37−however Idris programs can consist of several modules, and the

38+have been specified. However Idris programs can consist of several

38−definitions in each module each have their own namespace, as we will

39+modules and the definitions in each module each have their own

39−discuss in Section :ref:`sect-namespaces`) and a collection of

40+namespace. This is discussed further in Section

40−declarations and definitions. The order of definitions is significant

41+:ref:`sect-namespaces`). When writing Idris programs both the order in which

42+definitions are given and indentation are significant. Functions and

41−— functions and data types must be defined before use. Each definition

43+data types must be defined before use, incidently each definition must

42−must have a type declaration, for example see ``x : Int``, ``foo :

44+have a type declaration, for example see ``x : Int``, ``foo :

43−String``, from the above listing. Indentation is significant — a new

45+String``, from the above listing. New declarations must begin at the

44−declaration begins at the same level of indentation as the preceding

46+same level of indentation as the preceding declaration.

45−declaration. Alternatively, declarations may be terminated with a

47+Alternatively, a semicolon ``;`` can be used to terminate declarations.

46−semicolon.

47

48

48A library module ``prelude`` is automatically imported by every

49A library module ``prelude`` is automatically imported by every

49Idris program, including facilities for IO, arithmetic, data

50Idris program, including facilities for IO, arithmetic, data

@@ -63,7 +64,7 @@ All of the usual arithmetic and comparison operators are defined for

63the primitive types. They are overloaded using type classes, as we

64the primitive types. They are overloaded using type classes, as we

64will discuss in Section :ref:`sect-classes` and can be extended to

65will discuss in Section :ref:`sect-classes` and can be extended to

65work on user defined types. Boolean expressions can be tested with the

66work on user defined types. Boolean expressions can be tested with the

66−``if...then...else`` construct:

67+``if...then...else`` construct, for example:

67

68

68::

69::

69

70

@@ -73,9 +74,9 @@ work on user defined types. Boolean expressions can be tested with the

73Data Types

74Data Types

74==========

75==========

75

76

76−Data types are declared in a similar way to Haskell data types, with a

77+Data types are declared in a similar way and with similar syntax to

77−similar syntax. Natural numbers and lists, for example, can be

78+Haskell. Natural numbers and lists, for example, can be declared as

78−declared as follows:

79+follows:

79

80

80.. code-block:: idris

81.. code-block:: idris

81

82

@@ -193,11 +194,13 @@ does not need to be visible globally:

193Indentation is significant — functions in the ``where`` block must be

194Indentation is significant — functions in the ``where`` block must be

194indented further than the outer function.

195indented further than the outer function.

195

196

197+.. note:: Scope

198+

196−**Scope:** Any names which are visible in the outer scope are also

199+ Any names which are visible in the outer scope are also visible in

197−visible in the ``where`` clause (unless they have been redefined, such

200+ the ``where`` clause (unless they have been redefined, such as ``xs``

198−as ``xs`` here). A name which appears only in the type will be in scope

201+ here). A name which appears only in the type will be in scope in the

199−in the ``where`` clause if it is a *parameter* to one of the types,

202+ ``where`` clause if it is a *parameter* to one of the types, i.e. it

200−i.e. it is fixed across the entire structure.

203+ is fixed across the entire structure.

201

204

202As well as functions, ``where`` blocks can include local data

205As well as functions, ``where`` blocks can include local data

203declarations, such as the following where ``MyLT`` is not accessible

206declarations, such as the following where ``MyLT`` is not accessible

@@ -306,16 +309,17 @@ following:

306 $ idris vbroken.idr --check

309 $ idris vbroken.idr --check

307 vbroken.idr:9:23:When elaborating right hand side of Vect.++:

310 vbroken.idr:9:23:When elaborating right hand side of Vect.++:

308 When elaborating an application of constructor Vect.:::

311 When elaborating an application of constructor Vect.:::

309− Can't unify

312+ Can't unify

310− Vect (k + k) a

313+ Vect (k + k) a (Type of xs ++ xs)

311− with

314+ with

312− Vect (plus k m) a

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

313

322

314− Specifically:

315− Can't unify

316− plus k k

317− with

318− plus k m

319

323

320This error message suggests that there is a length mismatch between

324This error message suggests that there is a length mismatch between

321two vectors — we needed a vector of length ``k + m``, but provided a

325two 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

398Implicit arguments, given in braces ``{}`` in the type declaration,

402Implicit arguments, given in braces ``{}`` in the type declaration,

399are not given in applications of ``index``; their values can be

403are not given in applications of ``index``; their values can be

400inferred from the types of the ``Fin n`` and ``Vect n a``

404inferred 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

405+arguments. Any name beginning with a lower case letter which appears

406+as a parameter or index in a

402−type declaration, but which is otherwise free, will be automatically

407+type declaration, but which is otherwise unbound, will be automatically

403bound as an implicit argument. Implicit arguments can still be given

408bound as an implicit argument. Implicit arguments can still be given

404explicitly in applications, using ``{a=value}`` and ``{n=value}``, for

409explicitly in applications, using ``{a=value}`` and ``{n=value}``, for

405example:

410example:

@@ -782,8 +787,8 @@ as “sigma types”:

782

787

783.. code-block:: idris

788.. code-block:: idris

784

789

785− data Sigma : (A : Type) -> (P : A -> Type) -> Type where

790+ data Sigma : (a : Type) -> (P : a -> Type) -> Type where

786− MkSigma : {P : A -> Type} -> (a : A) -> P a -> Sigma A P

791+ MkSigma : {P : a -> Type} -> (x : a) -> P x -> Sigma a P

787

792

788Again, there is syntactic sugar for this. ``(a : A ** P)`` is the type

793Again, there is syntactic sugar for this. ``(a : A ** P)`` is the type

789of a pair of A and P, where the name ``a`` can occur inside ``P``.

794of a pair of A and P, where the name ``a`` can occur inside ``P``.

@@ -969,8 +974,8 @@ Dependent Records

969

974

970*Records* are data types which collect several values (the record's

975*Records* are data types which collect several values (the record's

971*fields*) together. Idris provides syntax for defining records and

976*fields*) together. Idris provides syntax for defining records and

972−*automatically generating field access and update functions. For

977+*automatically generating field access and update functions*. For

973−*example, we can represent a person's name and age in a record:

978+example, we can represent a person's name and age in a record:

974

979

975.. code-block:: idris

980.. code-block:: idris

976

981

docs/tutorial/views.rst+2−2

@@ -83,8 +83,8 @@ rule:

83The value of the result of ``parity k`` affects the form of ``k``,

84because the result of ``parity k`` depends on ``k``. So, as well as

85the patterns for the result of the intermediate computation (``Even``

86−and ``odd``) right of the ``\mid``, we also write how the results

86+and ``odd``) right of the ``|``, we also write how the results

87−affect the other patterns left of the :math:`\mid`. Note that there is

87+affect the other patterns left of the ``|``. Note that there is

88a function in the patterns (``+``) and repeated occurrences of

89``j``—this is allowed because another argument has determined the form

90of these patterns.

idris.cabal+37−4

@@ -114,6 +114,7 @@ Extra-source-files:

114 libs/contrib/Classes/*.idr

115 libs/contrib/Control/*.idr

116 libs/contrib/Control/Isomorphism/*.idr

117+ libs/contrib/Control/Algebra/*.idr

117 libs/contrib/Data/*.idr

118 libs/contrib/Data/*.idr

118 libs/contrib/Decidable/*.idr

119 libs/contrib/Decidable/*.idr

119 libs/contrib/Network/*.idr

120 libs/contrib/Network/*.idr

@@ -304,6 +305,9 @@ Extra-source-files:

304 test/reg061/run

305 test/reg061/run

305 test/reg061/*.idr

306 test/reg061/*.idr

306 test/reg061/expected

307 test/reg061/expected

308+ test/reg062/run

309+ test/reg062/*.idr

310+ test/reg062/expected

307

311

308 test/basic001/run

312 test/basic001/run

309 test/basic001/*.idr

313 test/basic001/*.idr

@@ -346,6 +350,13 @@ Extra-source-files:

346 test/basic013/*.idr

350 test/basic013/*.idr

347 test/basic013/expected

351 test/basic013/expected

348

352

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+

349 test/delab001/*.idr

360 test/delab001/*.idr

350 test/delab001/run

361 test/delab001/run

351 test/delab001/expected

362 test/delab001/expected

@@ -373,6 +384,10 @@ Extra-source-files:

373 test/effects003/*.idr

384 test/effects003/*.idr

374 test/effects003/expected

385 test/effects003/expected

375 test/effects003/input

386 test/effects003/input

387+ test/effects004/run

388+ test/effects004/*.idr

389+ test/effects004/expected

390+ test/effects004/input

376

391

377 test/error001/run

392 test/error001/run

378 test/error001/*.idr

393 test/error001/*.idr

@@ -413,6 +428,10 @@ Extra-source-files:

413 test/ffi006/run

428 test/ffi006/run

414 test/ffi006/expected

429 test/ffi006/expected

415

430

431+ test/folding001/*.idr

432+ test/folding001/run

433+ test/folding001/expected

434+

416 test/idrisdoc001/run

435 test/idrisdoc001/run

417 test/idrisdoc001/expected

436 test/idrisdoc001/expected

418 test/idrisdoc001/*.idr

437 test/idrisdoc001/*.idr

@@ -494,6 +513,13 @@ Extra-source-files:

494 test/literate001/*.lidr

513 test/literate001/*.lidr

495 test/literate001/expected

514 test/literate001/expected

496

515

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+

497 test/primitives001/run

523 test/primitives001/run

498 test/primitives001/*.idr

524 test/primitives001/*.idr

499 test/primitives001/expected

525 test/primitives001/expected

@@ -550,7 +576,9 @@ Extra-source-files:

550 test/quasiquote005/run

576 test/quasiquote005/run

551 test/quasiquote005/*.idr

577 test/quasiquote005/*.idr

552 test/quasiquote005/expected

578 test/quasiquote005/expected

553−

579+ test/quasiquote006/run

580+ test/quasiquote006/*.idr

581+ test/quasiquote006/expected

554

582

555 test/records001/run

583 test/records001/run

556 test/records001/*.idr

584 test/records001/*.idr

@@ -726,6 +754,9 @@ Library

726 , Idris.Elab.Provider

754 , Idris.Elab.Provider

727 , Idris.Elab.Transform

755 , Idris.Elab.Transform

728 , Idris.Elab.Value

756 , Idris.Elab.Value

757+ , Idris.Elab.Term

758+

759+ , Idris.REPL.Browse

729

760

730 , Idris.AbsSyntax

761 , Idris.AbsSyntax

731 , Idris.AbsSyntaxTree

762 , Idris.AbsSyntaxTree

@@ -740,11 +771,11 @@ Library

740 , Idris.DataOpts

771 , Idris.DataOpts

741 , Idris.DeepSeq

772 , Idris.DeepSeq

742 , Idris.Delaborate

773 , Idris.Delaborate

774+ , Idris.Directives

743 , Idris.Docs

775 , Idris.Docs

744 , Idris.Docstrings

776 , Idris.Docstrings

745 , Idris.ElabDecls

777 , Idris.ElabDecls

746 , Idris.ElabQuasiquote

778 , Idris.ElabQuasiquote

747− , Idris.ElabTerm

748 , Idris.Erasure

779 , Idris.Erasure

749 , Idris.Error

780 , Idris.Error

750 , Idris.ErrReverse

781 , Idris.ErrReverse

@@ -806,9 +837,10 @@ Library

806 -- Auto Generated

837 -- Auto Generated

807 , Paths_idris

838 , Paths_idris

808 , Version_idris

839 , Version_idris

840+ , Tools_idris

809

841

810 Build-depends: base >=4 && <5

842 Build-depends: base >=4 && <5

811− , annotated-wl-pprint >= 0.5.3 && < 0.6

843+ , annotated-wl-pprint >= 0.5.3 && < 0.7

812 , ansi-terminal < 0.7

844 , ansi-terminal < 0.7

813 , ansi-wl-pprint < 0.7

845 , ansi-wl-pprint < 0.7

814 , base64-bytestring < 1.1

846 , base64-bytestring < 1.1

@@ -823,7 +855,7 @@ Library

823 , filepath < 1.5

855 , filepath < 1.5

824 , fingertree >= 0.1 && < 0.2

856 , fingertree >= 0.1 && < 0.2

825 , haskeline >= 0.7 && < 0.8

857 , haskeline >= 0.7 && < 0.8

826− , lens >= 4.1.1 && < 4.9

858+ , lens >= 4.1.1 && < 4.10

827 , mtl >= 2.1 && < 2.3

859 , mtl >= 2.1 && < 2.3

828 , network < 2.7

860 , network < 2.7

829 , optparse-applicative >= 0.11 && < 0.12

861 , optparse-applicative >= 0.11 && < 0.12

@@ -842,6 +874,7 @@ Library

842 , vector < 0.11

874 , vector < 0.11

843 , vector-binary-instances < 0.3

875 , vector-binary-instances < 0.3

844 , xml < 1.4

876 , xml < 1.4

877+ , zip-archive > 0.2.3.5 && < 0.2.4

845 , zlib < 0.6

878 , zlib < 0.6

846 , safe

879 , safe

847 Extensions: MultiParamTypeClasses

880 Extensions: MultiParamTypeClasses

libs/base/Control/Arrow.idr+2−7

@@ -16,9 +16,7 @@ class Category arr => Arrow (arr : Type -> Type -> Type) where

16 first : arr a b -> arr (a, c) (b, c)

17

18 second : arr a b -> arr (c, a) (c, b)

19− second f = arrow swap >>> first f >>> arrow swap where

19+ second f = arrow swap >>> first f >>> arrow swap

20− swap : (x,y) -> (y,x)

21− swap (x,y) = (y,x)

22

20

23 (***) : arr a b -> arr a' b' -> arr (a, a') (b, b')

21 (***) : arr a b -> arr a' b' -> arr (a, a') (b, b')

24 f *** g = first f >>> second g

22 f *** g = first f >>> second g

@@ -61,10 +59,7 @@ class Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where

61 left : arr a b -> arr (Either a c) (Either b c)

59 left : arr a b -> arr (Either a c) (Either b c)

62

60

63 right : arr a b -> arr (Either c a) (Either c b)

61 right : arr a b -> arr (Either c a) (Either c b)

64− right f = arrow swap >>> left f >>> arrow swap where

62+ right f = arrow mirror >>> left f >>> arrow mirror

65− swap : Either a b -> Either b a

66− swap (Left x) = Right x

67− swap (Right x) = Left x

68

63

69 (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)

64 (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d)

70 f +++ g = left f >>> right g

65 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

39

40||| Disjunction is commutative

41eitherComm : Iso (Either a b) (Either b a)

42−eitherComm = MkIso swap swap swapSwap swapSwap

42+eitherComm = MkIso mirror mirror mirrorMirror mirrorMirror

43− where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!

43+ where mirrorMirror : (e : Either a' b') -> mirror (mirror e) = e

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

44+ mirrorMirror (Left x) = Refl

48− swapSwap (Right x) = Refl

45+ mirrorMirror (Right x) = Refl

49

46

50||| Disjunction is associative

47||| Disjunction is associative

51eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))

48eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))

@@ -116,10 +113,7 @@ eitherCongRight i = eitherCong isoRefl i

116||| Conjunction is commutative

113||| Conjunction is commutative

117pairComm : Iso (a, b) (b, a)

114pairComm : Iso (a, b) (b, a)

118pairComm = MkIso swap swap swapSwap swapSwap

115pairComm = 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

123 swapSwap (x, y) = Refl

117 swapSwap (x, y) = Refl

124

118

125||| Conjunction is associative

119||| Conjunction is associative

libs/base/Control/Monad/State.idr+18−2

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

1module Control.Monad.State

2

3−import Control.Monad.Identity

3+import public Control.Monad.Identity

4import Control.Monad.Trans

5

6%access public

@@ -15,7 +15,10 @@ class Monad m => MonadState s (m : Type -> Type) | m where

15||| The transformer on which the State monad is based

16record StateT (s : Type) (m : Type -> Type) (a : Type) where

17 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

19

22

20instance Functor f => Functor (StateT s f) where

23instance Functor f => Functor (StateT s f) where

21 map f (ST g) = ST (\st => map (mapFst f) (g st)) where

24 map f (ST g) = ST (\st => map (mapFst f) (g st)) where

@@ -55,3 +58,16 @@ gets f = do s <- get

55||| The State monad. See the MonadState class

58||| The State monad. See the MonadState class

56State : Type -> Type -> Type

59State : Type -> Type -> Type

57State s a = StateT s Identity a

60State 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

4

5%default total

6

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−

12nextPow2 : Nat -> Nat

7nextPow2 : Nat -> Nat

13nextPow2 Z = Z

8nextPow2 Z = Z

14−nextPow2 x = if x == (2 `power` l2x)

9+nextPow2 (S x) = if (S x) == (2 `power` l2x)

15− then l2x

10+ then l2x

16− else S l2x

11+ else S l2x

17 where

12 where

18− l2x = log2 x

13+ l2x = log2NZ (S x) SIsNotZ

19

14

20nextBytes : Nat -> Nat

15nextBytes : Nat -> Nat

21−nextBytes bits = (nextPow2 (bits `divCeil` 8))

16+nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ))

22

17

23machineTy : Nat -> Type

18machineTy : Nat -> Type

24machineTy Z = Bits8

19machineTy Z = Bits8

libs/base/Data/List.idr+13

@@ -36,3 +36,16 @@ isElem x (y :: xs) with (decEq x y)

36 Elem x' (y' :: xs') -> Void

37 mkNo f g Here = f Refl

38 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)

372 | False = find p xs

373

374||| Find the index of the first element of the vector that satisfies some test

375−findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

375+findIndex : (a -> Bool) -> Vect n a -> Maybe (Fin n)

376−findIndex = findIndex' 0

377− where

378− findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat

379− findIndex' cnt p [] = Nothing

376+findIndex p [] = Nothing

380− findIndex' cnt p (x::xs) with (p x)

377+findIndex p (x :: xs) with (p x)

381− | True = Just cnt

378+ | True = Just 0

382− | False = findIndex' (S cnt) p xs

379+ | False = map FS (findIndex p xs)

383

380

384||| Find the indices of all elements that satisfy some test

381||| Find the indices of all elements that satisfy some test

385total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

382total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

@@ -394,10 +391,10 @@ findIndices = findIndices' 0

394 else

391 else

395 (_ ** tail)

392 (_ ** tail)

396

393

397−elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat

394+elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe (Fin m)

398elemIndexBy p e = findIndex $ p e

395elemIndexBy p e = findIndex $ p e

399

396

400−elemIndex : Eq a => a -> Vect m a -> Maybe Nat

397+elemIndex : Eq a => a -> Vect m a -> Maybe (Fin m)

401elemIndex = elemIndexBy (==)

398elemIndex = elemIndexBy (==)

402

399

403total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat)

400total 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

61binderTy (PVar t) = t

62binderTy (PVTy t) = t

63

64+mutual

64−instance Show TTName where

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

65− show (UN str) = "(UN " ++ str ++ ")"

78+ show (UN str) = "(UN " ++ str ++ ")"

66− show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"

79+ show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"

67− show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"

80+ show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"

81+ show (SN sn) = "(SN " ++ assert_total (show sn) ++ ")"

68− show NErased = "NErased"

82+ show NErased = "NErased"

69−

83+

84+mutual

70−instance Eq TTName where

85+ instance Eq TTName where

71− (UN str1) == (UN str2) = str1 == str2

86+ (UN str1) == (UN str2) = str1 == str2

72− (NS n ns) == (NS n' ns') = n == n' && ns == ns'

87+ (NS n ns) == (NS n' ns') = n == n' && ns == ns'

73− (MN i str) == (MN i' str') = i == i' && str == str'

88+ (MN i str) == (MN i' str') = i == i' && str == str'

74− NErased == NErased = True

89+ NErased == NErased = True

90+ (SN sn) == (SN sn') = assert_total $ sn == sn'

75− x == y = False

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

76

104

77instance Show TTUExp where

105instance Show TTUExp where

78 show (UVar i) = "(UVar " ++ show i ++ ")"

106 show (UVar i) = "(UVar " ++ show i ++ ")"

@@ -269,3 +297,12 @@ instance Show Err where

269 show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""

297 show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""

270 show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"

298 show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"

271

299

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 @@

1module Classes.Verified

2

3import Control.Algebra

4+import Control.Algebra.Lattice

5+import Control.Algebra.VectorSpace

4

6

5-- Due to these being basically unused and difficult to implement,

7-- Due to these being basically unused and difficult to implement,

6-- they're in contrib for a bit. Once a design is found that lets them

8-- 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

78 total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l

80 total ringWithUnityIsUnityL : (l : a) -> l <.> unity = l

79 total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r

81 total ringWithUnityIsUnityR : (r : a) -> unity <.> r = r

80

82

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+

81class JoinSemilattice a => VerifiedJoinSemilattice a where

88class JoinSemilattice a => VerifiedJoinSemilattice a where

82 total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

89 total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

83 total joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

90 total joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

@@ -100,15 +107,11 @@ class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice

100

107

101class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

108class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

102

109

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)

112

110

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)

114

116

117+--class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

libs/contrib/Control/Algebra.idr+17−159

@@ -1,11 +1,8 @@

1module Control.Algebra

2

3−import Data.Heap

4−

5−-- XXX: change?

6infixl 6 <->

3infixl 6 <->

7−infixl 6 <.>

4+infixl 7 <.>

8−infixl 5 <#>

5+

9

6

10||| Sets equipped with a single binary operation that is associative, along with

7||| Sets equipped with a single binary operation that is associative, along with

11||| a neutral element for that binary operation and inverses for all elements.

8||| a neutral element for that binary operation and inverses for all elements.

@@ -40,7 +37,6 @@ class Monoid a => Group a where

40||| forall a, inverse a <+> a == neutral

37||| forall a, inverse a <+> a == neutral

41class Group a => AbelianGroup a where { }

38class Group a => AbelianGroup a where { }

42

39

43−

44||| Sets equipped with two binary operations, one associative and commutative

40||| Sets equipped with two binary operations, one associative and commutative

45||| supplied with a neutral element, and the other associative, with

41||| supplied with a neutral element, and the other associative, with

46||| distributivity laws relating the two operations. Must satisfy the following

42||| distributivity laws relating the two operations. Must satisfy the following

@@ -64,7 +60,6 @@ class Group a => AbelianGroup a where { }

64class AbelianGroup a => Ring a where

60class AbelianGroup a => Ring a where

65 (<.>) : a -> a -> a

61 (<.>) : a -> a -> a

66

62

67−

68||| Sets equipped with two binary operations, one associative and commutative

63||| Sets equipped with two binary operations, one associative and commutative

69||| supplied with a neutral element, and the other associative supplied with a

64||| supplied with a neutral element, and the other associative supplied with a

70||| neutral element, with distributivity laws relating the two operations. Must

65||| neutral element, with distributivity laws relating the two operations. Must

@@ -91,137 +86,10 @@ class AbelianGroup a => Ring a where

91class Ring a => RingWithUnity a where

86class Ring a => RingWithUnity a where

92 unity : a

87 unity : a

93

88

94−

95−||| Sets equipped with a binary operation that is commutative, associative and

89+||| Sets equipped with two binary operations – both associative, commutative and

96−||| idempotent. Must satisfy the following laws:

90+||| possessing a neutral element – and distributivity laws relating the two

97−|||

91+||| operations. All elements except the additive identity must have a

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

92+||| multiplicative inverse. Must satisfy the following laws:

224−||| laws:

225|||

93|||

226||| + Associativity of `<+>`:

94||| + Associativity of `<+>`:

227||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

95||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

@@ -238,34 +106,24 @@ class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a w

238||| + Unity for `<.>`:

106||| + Unity for `<.>`:

239||| forall a, a <.> unity == a

107||| forall a, a <.> unity == a

240||| forall a, unity <.> a == a

108||| forall a, unity <.> a == a

241−||| + InverseM of `<.>`:

109+||| + InverseM of `<.>`, except for neutral

242−||| forall a, a <.> inverseM a == unity

110+||| forall a /= neutral, a <.> inverseM a == unity

243−||| forall a, inverseM a <.> a == unity

111+||| forall a /= neutral, inverseM a <.> a == unity

244||| + Distributivity of `<.>` and `<->`:

112||| + Distributivity of `<.>` and `<->`:

245||| forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)

113||| forall a b c, a <.> (b <+> c) == (a <.> b) <+> (a <.> c)

246||| forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)

114||| forall a b c, (a <+> b) <.> c == (a <.> c) <+> (b <.> c)

247class RingWithUnity a => Field a where

115class RingWithUnity a => Field a where

248− inverseM : a -> a

116+ inverseM : (x : a) -> Not (x = neutral) -> a

249−

250

117

251−||| A module over a ring is an additive abelian group of 'vectors' endowed with a

118+sum : (Foldable t, Monoid a) => t a -> a

252−||| scale operation multiplying vectors by ring elements, and distributivity laws

119+sum = foldr (<+>) neutral

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

265

120

121+product : (Foldable t, RingWithUnity a) => t a -> a

122+product = foldr (<.>) unity

266

123

267−||| A vector space is a module over a ring that is also a field

124+power : RingWithUnity a => a -> Nat -> a

268−class (Field a, Module a b) => VectorSpace a b where {}

125+power _ Z = unity

126+power x (S n) = x <.> (Algebra.power x n)

269

127

270

128

271-- XXX todo:

129-- 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 @@

1module Data.Matrix

2

3+import Control.Algebra

4+import Control.Algebra.VectorSpace

3−import Control.Algebra

5+import public Control.Algebra.NumericInstances

4

6

5import Data.Complex

7import Data.Complex

6import Data.ZZ

8import Data.ZZ

@@ -40,8 +42,7 @@ instance Ring a => Ring (Vect n a) where

40instance RingWithUnity a => RingWithUnity (Vect n a) where

42instance RingWithUnity a => RingWithUnity (Vect n a) where

41 unity {n} = replicate n unity

43 unity {n} = replicate n unity

42

44

43−instance Field a => Field (Vect n a) where

45+--instance Field a => Field (Vect n a) where

44− inverseM = map inverseM

45

46

46instance RingWithUnity a => Module a (Vect n a) where

47instance RingWithUnity a => Module a (Vect n a) where

47 (<#>) r v = map (r <.>) v

48 (<#>) r v = map (r <.>) v

@@ -147,104 +148,3 @@ Id {d} = map (\n => basis n) $ allN d

147

148

148-- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes

149-- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes

149

150

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

7import Control.WellFounded

8

9%default total

10+%access public

10

11

11||| A strict less-than relation on `Nat`.

12||| A strict less-than relation on `Nat`.

12|||

13|||

libs/contrib/Data/SortedMap.idr+64−53

@@ -2,72 +2,73 @@ module Data.SortedMap

2

3-- TODO: write merge and split

4

5+private

5−data Tree : Nat -> Type -> Type -> Type where

6+data Tree : Nat -> (k : Type) -> Type -> Ord k -> Type where

6− Leaf : k -> v -> Tree Z k v

7+ Leaf : k -> v -> Tree Z k v o

7− Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v

8+ Branch2 : Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o

8− Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v

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

9

10

10branch4 :

11branch4 :

11− Tree n k v -> k ->

12+ Tree n k v o -> k ->

12− Tree n k v -> k ->

13+ Tree n k v o -> k ->

13− Tree n k v -> k ->

14+ Tree n k v o -> k ->

14− Tree n k v ->

15+ Tree n k v o ->

15− Tree (S (S n)) k v

16+ Tree (S (S n)) k v o

16branch4 a b c d e f g =

17branch4 a b c d e f g =

17 Branch2 (Branch2 a b c) d (Branch2 e f g)

18 Branch2 (Branch2 a b c) d (Branch2 e f g)

18

19

19branch5 :

20branch5 :

20− Tree n k v -> k ->

21+ Tree n k v o -> k ->

21− Tree n k v -> k ->

22+ Tree n k v o -> k ->

22− Tree n k v -> k ->

23+ Tree n k v o -> k ->

23− Tree n k v -> k ->

24+ Tree n k v o -> k ->

24− Tree n k v ->

25+ Tree n k v o ->

25− Tree (S (S n)) k v

26+ Tree (S (S n)) k v o

26branch5 a b c d e f g h i =

27branch5 a b c d e f g h i =

27 Branch2 (Branch2 a b c) d (Branch3 e f g h i)

28 Branch2 (Branch2 a b c) d (Branch3 e f g h i)

28

29

29branch6 :

30branch6 :

30− Tree n k v -> k ->

31+ Tree n k v o -> k ->

31− Tree n k v -> k ->

32+ Tree n k v o -> k ->

32− Tree n k v -> k ->

33+ Tree n k v o -> k ->

33− Tree n k v -> k ->

34+ Tree n k v o -> k ->

34− Tree n k v -> k ->

35+ Tree n k v o -> k ->

35− Tree n k v ->

36+ Tree n k v o ->

36− Tree (S (S n)) k v

37+ Tree (S (S n)) k v o

37branch6 a b c d e f g h i j k =

38branch6 a b c d e f g h i j k =

38 Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

39 Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

39

40

40branch7 :

41branch7 :

41− Tree n k v -> k ->

42+ Tree n k v o -> k ->

42− Tree n k v -> k ->

43+ Tree n k v o -> k ->

43− Tree n k v -> k ->

44+ Tree n k v o -> k ->

44− Tree n k v -> k ->

45+ Tree n k v o -> k ->

45− Tree n k v -> k ->

46+ Tree n k v o -> k ->

46− Tree n k v -> k ->

47+ Tree n k v o -> k ->

47− Tree n k v ->

48+ Tree n k v o ->

48− Tree (S (S n)) k v

49+ Tree (S (S n)) k v o

49branch7 a b c d e f g h i j k l m =

50branch7 a b c d e f g h i j k l m =

50 Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

51 Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

51

52

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

53merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i

54merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i

54merge1 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

55merge1 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

55merge1 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

56merge1 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

56merge1 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

57merge1 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

57

58

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

59merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i

60merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i

60merge2 (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

61merge2 (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

61merge2 (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

62merge2 (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

62merge2 (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

63merge2 (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

63

64

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

65merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i

66merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i

66merge3 (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

67merge3 (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

67merge3 (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

68merge3 (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

68merge3 (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

69merge3 (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

69

70

70−treeLookup : Ord k => k -> Tree n k v -> Maybe v

71+treeLookup : k -> Tree n k v o -> Maybe v

71treeLookup k (Leaf k' v) =

72treeLookup k (Leaf k' v) =

72 if k == k' then

73 if k == k' then

73 Just v

74 Just v

@@ -86,7 +87,7 @@ treeLookup k (Branch3 t1 k1 t2 k2 t3) =

86 else

87 else

87 treeLookup k t3

88 treeLookup k t3

88

89

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)

90treeInsert' k v (Leaf k' v') =

91treeInsert' k v (Leaf k' v') =

91 case compare k k' of

92 case compare k k' of

92 LT => Right (Leaf k v, k, Leaf k' v')

93 LT => Right (Leaf k v, k, Leaf k' v')

@@ -116,17 +117,17 @@ treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =

116 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

117 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

117 Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

118 Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

118

119

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)

120treeInsert k v t =

121treeInsert k v t =

121 case treeInsert' k v t of

122 case treeInsert' k v t of

122 Left t' => Left t'

123 Left t' => Left t'

123 Right (a, b, c) => Right (Branch2 a b c)

124 Right (a, b, c) => Right (Branch2 a b c)

124

125

125−delType : Nat -> Type -> Type -> Type

126+delType : Nat -> (k : Type) -> Type -> Ord k -> Type

126−delType Z k v = ()

127+delType Z k v o = ()

127−delType (S n) k v = Tree n k v

128+delType (S n) k v o = Tree n k v o

128

129

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)

130treeDelete k (Leaf k' v) =

131treeDelete k (Leaf k' v) =

131 if k == k' then

132 if k == k' then

132 Right ()

133 Right ()

@@ -183,33 +184,38 @@ treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =

183 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

184 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

184 Right t3' => Left (merge3 t1 k1 t2 k2 t3')

185 Right t3' => Left (merge3 t1 k1 t2 k2 t3')

185

186

186−treeToList : Tree n k v -> List (k, v)

187+treeToList : Tree n k v o -> List (k, v)

187treeToList = treeToList' (:: [])

188treeToList = treeToList' (:: [])

188 where

189 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)

190 treeToList' cont (Leaf k v) = cont (k, v)

191 treeToList' cont (Leaf k v) = cont (k, v)

191 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

192 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

192 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

193 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

193

194

195+abstract

194data SortedMap : Type -> Type -> Type where

196data SortedMap : Type -> Type -> Type where

195− Empty : SortedMap k v

197+ Empty : Ord k => SortedMap k v

196− M : (n:Nat) -> Tree n k v -> SortedMap k v

198+ M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v

197

199

200+public

198−empty : SortedMap k v

201+empty : Ord k => SortedMap k v

199empty = Empty

202empty = Empty

200

203

204+public

201−lookup : Ord k => k -> SortedMap k v -> Maybe v

205+lookup : k -> SortedMap k v -> Maybe v

202lookup _ Empty = Nothing

206lookup _ Empty = Nothing

203lookup k (M _ t) = treeLookup k t

207lookup k (M _ t) = treeLookup k t

204

208

209+public

205−insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v

210+insert : k -> v -> SortedMap k v -> SortedMap k v

206insert k v Empty = M Z (Leaf k v)

211insert k v Empty = M Z (Leaf k v)

207insert k v (M _ t) =

212insert k v (M _ t) =

208 case treeInsert k v t of

213 case treeInsert k v t of

209 Left t' => (M _ t')

214 Left t' => (M _ t')

210 Right t' => (M _ t')

215 Right t' => (M _ t')

211

216

217+public

212−delete : Ord k => k -> SortedMap k v -> SortedMap k v

218+delete : k -> SortedMap k v -> SortedMap k v

213delete _ Empty = Empty

219delete _ Empty = Empty

214delete k (M Z t) =

220delete k (M Z t) =

215 case treeDelete k t of

221 case treeDelete k t of

@@ -220,18 +226,23 @@ delete k (M (S _) t) =

220 Left t' => (M _ t')

226 Left t' => (M _ t')

221 Right t' => (M _ t')

227 Right t' => (M _ t')

222

228

229+public

223fromList : Ord k => List (k, v) -> SortedMap k v

230fromList : Ord k => List (k, v) -> SortedMap k v

224fromList l = foldl (flip (uncurry insert)) empty l

231fromList l = foldl (flip (uncurry insert)) empty l

225

232

233+public

226toList : SortedMap k v -> List (k, v)

234toList : SortedMap k v -> List (k, v)

227toList Empty = []

235toList Empty = []

228toList (M _ t) = treeToList t

236toList (M _ t) = treeToList t

229

237

230−instance Functor (Tree n k) where

238+public

239+treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

231− map f (Leaf k v) = Leaf k (f v)

240+treeMap f (Leaf k v) = Leaf k (f v)

232− map f (Branch2 t1 k t2) = Branch2 (map f t1) k (map f t2)

241+treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

233− map f (Branch3 t1 k1 t2 k2 t3) = Branch3 (map f t1) k1 (map f t2) k2 (map f t3)

242+treeMap f (Branch3 t1 k1 t2 k2 t3)

243+ = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

234

244

235instance Functor (SortedMap k) where

245instance Functor (SortedMap k) where

236 map _ Empty = Empty

246 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

4

5-- TODO: add intersection, union, difference

6

7+abstract

7data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

8data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

8

9

10+public

9−empty : SortedSet k

11+empty : Ord k => SortedSet k

10empty = SetWrapper Data.SortedMap.empty

12empty = SetWrapper Data.SortedMap.empty

11

13

14+public

12−insert : Ord k => k -> SortedSet k -> SortedSet k

15+insert : k -> SortedSet k -> SortedSet k

13insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

16insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

14

17

18+public

15−delete : Ord k => k -> SortedSet k -> SortedSet k

19+delete : k -> SortedSet k -> SortedSet k

16delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

20delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

17

21

22+public

18−contains : Ord k => k -> SortedSet k -> Bool

23+contains : k -> SortedSet k -> Bool

19contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

24contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

20

25

26+public

21fromList : Ord k => List k -> SortedSet k

27fromList : Ord k => List k -> SortedSet k

22fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

28fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

23

29

30+public

24toList : SortedSet k -> List k

31toList : SortedSet k -> List k

25toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

32toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

26

33

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)

109 | _ = Nothing

110

111getContent : Int -> IO String

112−getContent x = getC (toNat x) "" where

112+getContent x = getC (cast x) "" where

113 getC : Nat -> String -> IO String

114 getC Z acc = return $ reverse acc

115 getC (S k) acc = do x <- getChar

libs/contrib/contrib.ipkg+5−1

@@ -2,16 +2,20 @@ package contrib

2

3opts = "--nobasepkgs --total -i ../prelude -i ../base"

4modules = Control.Algebra,

5+ Control.Algebra.Lattice, Control.Algebra.VectorSpace,

6+ Control.Algebra.NumericInstances,

5 Control.Isomorphism.Primitives,

7 Control.Isomorphism.Primitives,

8+ Control.Partial,

6 Control.WellFounded,

9 Control.WellFounded,

7 Classes.Verified,

10 Classes.Verified,

8− Data.Fun, Data.Rel,

11+ Data.Fun, Data.Rel,

9 Data.Hash, Data.Matrix,

12 Data.Hash, Data.Matrix,

10 Data.Nat,

13 Data.Nat,

11 Data.ZZ, Data.Sign,

14 Data.ZZ, Data.Sign,

12 Data.BoundedList,

15 Data.BoundedList,

13 Data.Heap,

16 Data.Heap,

14 Data.SortedMap, Data.SortedSet,

17 Data.SortedMap, Data.SortedSet,

18+ Data.CoList,

15

19

16 Decidable.Decidable, Decidable.Order,

20 Decidable.Decidable, Decidable.Order,

17

21

libs/effects/Effect/Exception.idr+2−13

@@ -5,7 +5,7 @@ import System

5import Control.IOExcept

6

7data Exception : Type -> Effect where

8− Raise : a -> { () } Exception a b

8+ Raise : a -> sig (Exception a) b

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

@@ -26,16 +26,5 @@ instance Handler (Exception a) (Either a) where

26EXCEPTION : Type -> EFFECT

27EXCEPTION t = MkEff () (Exception t)

28

29−raise : a -> { [EXCEPTION a ] } Eff b

29+raise : a -> Eff b [EXCEPTION a]

30raise 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

46 ||| @ m The file mode.

47 Open : (fname: String)

48 -> (m : Mode)

49− -> {() ==> {res} if res

49+ -> sig FileIO Bool () (\res => case res of

50− then OpenFile m

50+ True => OpenFile m

51− else ()} FileIO Bool

51+ False => ())

52

53 ||| Close a file.

54 |||

55 ||| Closing a file moves the state from Open to closed.

56− Close : {OpenFile m ==> ()} FileIO ()

56+ Close : sig FileIO () (OpenFile m) ()

57

58 ||| Read a line from the file.

59 |||

60 ||| Only files that are open for reading can be read.

61− ReadLine : {OpenFile Read} FileIO String

61+ ReadLine : sig FileIO String (OpenFile Read)

62

63 ||| Write a string to a file.

64 |||

65 ||| Only file that are open for writing can be written to.

66− WriteString : String -> {OpenFile Write} FileIO ()

66+ WriteString : String -> sig FileIO () (OpenFile Write)

67

68 ||| End of file?

69 |||

70 ||| Only files open for reading can be tested for EOF

71− EOF : {OpenFile Read} FileIO Bool

71+ EOF : sig FileIO Bool (OpenFile Read)

72

73-- ------------------------------------------------------------ [ The Handlers ]

74

@@ -117,31 +117,31 @@ FILE_IO t = MkEff t FileIO

117||| @ m The file mode.

118open : (fname : String)

119 -> (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 => ())])

124open f m = call $ Open f m

125

126

127||| Close a file.

128−close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff ()

128+close : Eff () [FILE_IO (OpenFile m)] [FILE_IO ()]

129close = call $ Close

130

131||| Read a line from the file.

132−readLine : { [FILE_IO (OpenFile Read)] } Eff String

132+readLine : Eff String [FILE_IO (OpenFile Read)]

133readLine = call $ ReadLine

134

135||| Write a string to a file.

136−writeString : String -> { [FILE_IO (OpenFile Write)] } Eff ()

136+writeString : String -> Eff () [FILE_IO (OpenFile Write)]

137writeString str = call $ WriteString str

138

139||| Write a line to a file.

140−writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff ()

140+writeLine : String -> Eff () [FILE_IO (OpenFile Write)]

141writeLine str = call $ WriteString (str ++ "\n")

142

143||| End of file?

144−eof : { [FILE_IO (OpenFile Read)] } Eff Bool

144+eof : Eff Bool [FILE_IO (OpenFile Read)]

145eof = call $ EOF

146

147-- --------------------------------------------------------------------- [ EOF ]

libs/effects/Effect/Random.idr+12−13

@@ -5,28 +5,27 @@ import Data.Vect

5import Data.Fin

6

7data Random : Effect where

8− getRandom : { Integer } Random Integer

8+ getRandom : sig Random Integer Integer

9− setSeed : Integer -> { Integer } Random ()

9+ setSeed : Integer -> sig Random () Integer

10

11−using (m : Type -> Type)

12− instance Handler Random m where

11+instance Handler Random m where

13− handle seed getRandom k

12+ handle seed getRandom k

14− = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in

13+ = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in

15− k seed' seed'

14+ k seed' seed'

16− handle seed (setSeed n) k = k () n

15+ handle seed (setSeed n) k = k () n

17

16

18RND : EFFECT

17RND : EFFECT

19RND = MkEff Integer Random

18RND = MkEff Integer Random

20

19

21||| Generates a random Integer in a given range

20||| Generates a random Integer in a given range

22−rndInt : Integer -> Integer -> { [RND] } Eff Integer

21+rndInt : Integer -> Integer -> Eff Integer [RND]

23rndInt lower upper = do v <- call $ getRandom

22rndInt lower upper = do v <- call $ getRandom

24 return ((v `prim__sremBigInt` (upper - lower)) + lower)

23 return ((v `prim__sremBigInt` (upper - lower)) + lower)

25

24

26||| Generate a random number in Fin (S `k`)

25||| Generate a random number in Fin (S `k`)

27|||

26|||

28||| Note that rndFin k takes values 0, 1, ..., k.

27||| 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]

30rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))

29rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))

31 return (toFin v)

30 return (toFin v)

32 where toFin : Integer -> Fin (S k)

31 where toFin : Integer -> Fin (S k)

@@ -35,15 +34,15 @@ rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast

35 Nothing => toFin (assert_smaller x (x - cast (S k)))

34 Nothing => toFin (assert_smaller x (x - cast (S k)))

36

35

37||| Select a random element from a vector

36||| 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]

39rndSelect' {k} xs = return (Vect.index !(rndFin k) xs)

38rndSelect' {k} xs = return (Vect.index !(rndFin k) xs)

40

39

41||| Select a random element from a list, or Nothing if the list is empty

40||| 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]

43rndSelect [] = return Nothing

42rndSelect [] = return Nothing

44rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))

43rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))

45

44

46||| Sets the random seed

45||| Sets the random seed

47−srand : Integer -> { [RND] } Eff ()

46+srand : Integer -> Eff () [RND]

48srand n = call $ setSeed n

47srand n = call $ setSeed n

49

48

libs/effects/Effect/Select.idr+2−2

@@ -3,7 +3,7 @@ module Effect.Select

3import Effects

4

5data Selection : Effect where

6− Select : List a -> { () } Selection a

6+ Select : List a -> sig Selection a ()

7

8instance Handler Selection Maybe where

9 handle _ (Select xs) k = tryAll xs where

@@ -18,6 +18,6 @@ instance Handler Selection List where

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

21−select : List a -> { [SELECT] } Eff a

21+select : List a -> Eff a [SELECT]

22select xs = call $ Select xs

23

libs/effects/Effect/State.idr+8−8

@@ -5,8 +5,8 @@ import Effects

5%access public

6

7data State : Effect where

8− Get : { a } State a

8+ Get : sig State a a

9− Put : b -> { a ==> b } State ()

9+ Put : b -> sig State () a b

10

11-- using (m : Type -> Type)

12instance Handler State m where

@@ -16,22 +16,22 @@ instance Handler State m where

16STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19−get : { [STATE x] } Eff x

19+get : Eff x [STATE x]

20get = call $ Get

21

22−put : x -> { [STATE x] } Eff ()

22+put : x -> Eff () [STATE x]

23put val = call $ Put val

24

25−putM : y -> { [STATE x] ==> [STATE y] } Eff ()

25+putM : y -> Eff () [STATE x] [STATE y]

26putM val = call $ Put val

27

28−update : (x -> x) -> { [STATE x] } Eff ()

28+update : (x -> x) -> Eff () [STATE x]

29update f = put (f !get)

30

31−updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff ()

31+updateM : (x -> y) -> Eff () [STATE x] [STATE y]

32updateM f = putM (f !get)

33

34−locally : x -> ({ [STATE x] } Eff t) -> { [STATE y] } Eff t

34+locally : x -> (Eff t [STATE x]) -> Eff t [STATE y]

35locally newst prog = do st <- get

36 putM newst

37 val <- prog

libs/effects/Effect/StdIO.idr+12−12

@@ -9,10 +9,10 @@ import Control.IOExcept

9

10||| The internal representation of StdIO effects

11data StdIO : Effect where

12− PutStr : String -> { () } StdIO ()

12+ PutStr : String -> sig StdIO ()

13− GetStr : { () } StdIO String

13+ GetStr : sig StdIO String

14− PutCh : Char -> { () } StdIO ()

14+ PutCh : Char -> sig StdIO ()

15− GetCh : { () } StdIO Char

15+ GetCh : sig StdIO Char

16

17

18-------------------------------------------------------------

@@ -39,33 +39,33 @@ STDIO : EFFECT

39STDIO = MkEff () StdIO

40

41||| Write a string to standard output.

42−putStr : String -> { [STDIO] } Eff ()

42+putStr : String -> Eff () [STDIO]

43putStr s = call $ PutStr s

44

45||| Write a string to standard output, terminating with a newline.

46−putStrLn : String -> { [STDIO] } Eff ()

46+putStrLn : String -> Eff () [STDIO]

47putStrLn s = putStr (s ++ "\n")

48

49||| Write a character to standard output.

50−putChar : Char -> { [STDIO] } Eff ()

50+putChar : Char -> Eff () [STDIO]

51putChar c = call $ PutCh c

52

53||| Write a character to standard output, terminating with a newline.

54−putCharLn : Char -> { [STDIO] } Eff ()

54+putCharLn : Char -> Eff () [STDIO]

55putCharLn c = putStrLn (singleton c)

56

57||| Read a string from standard input.

58−getStr : { [STDIO] } Eff String

58+getStr : Eff String [STDIO]

59getStr = call $ GetStr

60

61||| Read a character from standard input.

62−getChar : { [STDIO] } Eff Char

62+getChar : Eff Char [STDIO]

63getChar = call $ GetCh

64

65||| Given a parameter `a` 'show' `a` to standard output.

66−print : Show a => a -> { [STDIO] } Eff ()

66+print : Show a => a -> Eff () [STDIO]

67print a = putStr (show a)

68

69||| 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]

71printLn a = putStrLn (show a)

libs/effects/Effect/System.idr+8−8

@@ -8,10 +8,10 @@ import System

8import Control.IOExcept

9

10data System : Effect where

11− Args : { () } System (List String)

11+ Args : sig System (List String)

12− Time : { () } System Int

12+ Time : sig System Int

13− GetEnv : String -> { () } System (Maybe String)

13+ GetEnv : String -> sig System (Maybe String)

14− CSystem : String -> { () } System Int

14+ CSystem : String -> sig System Int

15

16instance Handler System IO where

17 handle () Args k = do x <- getArgs; k x ()

@@ -30,14 +30,14 @@ instance Handler System (IOExcept a) where

30SYSTEM : EFFECT

31SYSTEM = MkEff () System

32

33−getArgs : { [SYSTEM] } Eff (List String)

33+getArgs : Eff (List String) [SYSTEM]

34getArgs = call Args

35

36−time : { [SYSTEM] } Eff Int

36+time : Eff Int [SYSTEM]

37time = call Time

38

39−getEnv : String -> { [SYSTEM] } Eff (Maybe String)

39+getEnv : String -> Eff (Maybe String) [SYSTEM]

40getEnv s = call $ GetEnv s

41

42−system : String -> { [SYSTEM] } Eff Int

42+system : String -> Eff Int [SYSTEM]

43system s = call $ CSystem s

libs/effects/Effects.idr+93−33

@@ -24,6 +24,28 @@ Effect = (x : Type) -> Type -> (x -> Type) -> Type

24data EFFECT : Type where

25 MkEff : Type -> Effect -> EFFECT

26

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+

27||| Handler classes describe how an effect `e` is translated to the

49||| Handler classes describe how an effect `e` is translated to the

28||| underlying computation context `m` for execution.

50||| underlying computation context `m` for execution.

29class Handler (e : Effect) (m : Type -> Type) where

51class Handler (e : Effect) (m : Type -> Type) where

@@ -60,6 +82,7 @@ data SubList : List a -> List a -> Type where

60 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

82 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

61 Drop : SubList xs ys -> SubList xs (x :: ys)

83 Drop : SubList xs ys -> SubList xs (x :: ys)

62

84

85+%hint

63subListId : SubList xs xs

86subListId : SubList xs xs

64subListId {xs = Nil} = SubNil

87subListId {xs = Nil} = SubNil

65subListId {xs = x :: xs} = Keep subListId

88subListId {xs = x :: xs} = Keep subListId

@@ -133,26 +156,61 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

133||| @ x The return type of the result.

156||| @ x The return type of the result.

134||| @ es The list of allowed side-effects.

157||| @ es The list of allowed side-effects.

135||| @ ce Function to compute a new list of allowed side-effects.

158||| @ ce Function to compute a new list of allowed side-effects.

136−data Eff : (x : Type)

159+data EffM : (m : Type -> Type) -> (x : Type)

137− -> (es : List EFFECT)

160+ -> (es : List EFFECT)

138− -> (ce : x -> List EFFECT) -> Type where

161+ -> (ce : x -> List EFFECT) -> Type where

139− value : (val : a) -> Eff a (xs val) xs

162+ value : (val : a) -> EffM m a (xs val) xs

140− ebind : Eff a xs xs' ->

163+ ebind : EffM m a xs xs' ->

141− ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''

164+ ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

142 callP : (prf : EffElem e a xs) ->

165 callP : (prf : EffElem e a xs) ->

143 (eff : e t a b) ->

166 (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)

145

168

146 liftP : (prf : SubList ys xs) ->

169 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)

148

176

149 (:-) : (l : ty) ->

177 (:-) : (l : ty) ->

150− Eff t [x] xs' -> -- [x] (\v => xs) ->

178+ EffM m t [x] xs' -> -- [x] (\v => xs) ->

151− Eff t [l ::: x] (\v => map (l :::) (xs' v))

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+

152

210

153%no_implicit

211%no_implicit

154−(>>=) : Eff a xs xs' ->

212+(>>=) : EffM m a xs xs' ->

155− ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs''

213+ ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

156(>>=) = ebind

214(>>=) = ebind

157

215

158-- namespace SimpleBind

216-- namespace SimpleBind

@@ -161,29 +219,29 @@ data Eff : (x : Type)

161-- (>>=) = ebind

219-- (>>=) = ebind

162

220

163||| Run a subprogram which results in an effect state the same as the input.

221||| 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)

165staticEff = id

223staticEff = id

166

224

167||| Explicitly give the expected set of result effects for an effectful

225||| Explicitly give the expected set of result effects for an effectful

168||| operation.

226||| 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')

170toEff xs' = id

228toEff xs' = id

171

229

172−return : a -> Eff a xs (\v => xs)

230+return : a -> EffM m a xs (\v => xs)

173return x = value x

231return x = value x

174

232

175-- ------------------------------------------------------ [ for idiom brackets ]

233-- ------------------------------------------------------ [ for idiom brackets ]

176

234

177infixl 2 <*>

235infixl 2 <*>

178

236

179−pure : a -> Eff a xs (\v => xs)

237+pure : a -> EffM m a xs (\v => xs)

180pure = value

238pure = value

181

239

182−pureM : (val : a) -> Eff a (xs val) xs

240+pureM : (val : a) -> EffM m a (xs val) xs

183pureM = value

241pureM = value

184

242

185−(<*>) : Eff (a -> b) xs (\v => xs) ->

243+(<*>) : EffM m (a -> b) xs (\v => xs) ->

186− Eff a xs (\v => xs) -> Eff b xs (\v => xs)

244+ EffM m a xs (\v => xs) -> EffM m b xs (\v => xs)

187(<*>) prog v = do fn <- prog

245(<*>) prog v = do fn <- prog

188 arg <- v

246 arg <- v

189 return (fn arg)

247 return (fn arg)

@@ -203,7 +261,7 @@ execEff {e} {a} {res} {resk} (val :: env) (There p) eff k

203-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

261-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

204-- updates can be propagated even through failing computations?

262-- updates can be propagated even through failing computations?

205

263

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

207eff env (value x) k = k x env

265eff env (value x) k = k x env

208eff env (prog `ebind` c) k

266eff env (prog `ebind` c) k

209 = eff env prog (\p', env' => eff env' (c p') k)

267 = 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

211eff env (liftP prf effP) k

269eff env (liftP prf effP) k

212 = let env' = dropEnv env prf in

270 = let env' = dropEnv env prf in

213 eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

271 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)

214-- FIXME:

274-- FIXME:

215-- xs is needed explicitly because otherwise the pattern binding for

275-- xs is needed explicitly because otherwise the pattern binding for

216-- 'l' appears too late. Solution seems to be to reorder patterns at the

276-- 'l' appears too late. Solution seems to be to reorder patterns at the

@@ -235,14 +295,14 @@ call : {a, b: _} -> {e : Effect} ->

235 (eff : e t a b) ->

295 (eff : e t a b) ->

236 {default tactics { search 100; }

296 {default tactics { search 100; }

237 prf : EffElem e a xs} ->

297 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)

239call e {prf} = callP prf e

299call e {prf} = callP prf e

240

300

241implicit

301implicit

242−lift : Eff t ys ys' ->

302+lift : EffM m t ys ys' ->

243 {default tactics { search 100; }

303 {default tactics { search 100; }

244 prf : SubList ys xs} ->

304 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)

246lift e {prf} = liftP prf e

306lift e {prf} = liftP prf e

247

307

248

308

@@ -255,7 +315,7 @@ lift e {prf} = liftP prf e

255|||

315|||

256||| @prog The effectful program to run.

316||| @prog The effectful program to run.

257run : Applicative m => {default MkDefaultEnv env : Env m xs}

317run : 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

259run {env} prog = eff env prog (\r, env => pure r)

319run {env} prog = eff env prog (\r, env => pure r)

260

320

261||| Run an effectful program in the identity context.

321||| Run an effectful program in the identity context.

@@ -264,7 +324,7 @@ run {env} prog = eff env prog (\r, env => pure r)

264||| The `env` argument is implicit and initialised automatically.

324||| The `env` argument is implicit and initialised automatically.

265|||

325|||

266||| @prog The effectful program to run.

326||| @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

268runPure {env} prog = eff env prog (\r, env => r)

328runPure {env} prog = eff env prog (\r, env => r)

269

329

270||| Run an effectful program in a given context `m` with a default value for the environment.

330||| 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)

273|||

333|||

274||| @env The environment to use.

334||| @env The environment to use.

275||| @prog The effectful program to run.

335||| @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

277runInit env prog = eff env prog (\r, env => pure r)

337runInit env prog = eff env prog (\r, env => pure r)

278

338

279||| Run an effectful program with a given default value for the environment.

339||| 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)

282|||

342|||

283||| @env The environment to use.

343||| @env The environment to use.

284||| @prog The effectful program to run.

344||| @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

286runPureInit env prog = eff env prog (\r, env => r)

346runPureInit env prog = eff env prog (\r, env => r)

287

347

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

289runWith inj env prog = eff env prog (\r, env => inj r)

349runWith inj env prog = eff env prog (\r, env => inj r)

290

350

291−runEnv : Applicative m => Env m xs -> Eff a xs xs' ->

351+runEnv : Applicative m => Env m xs -> EffM m a xs xs' ->

292 m (x : a ** Env m (xs' x))

352 m (x : a ** Env m (xs' x))

293runEnv env prog = eff env prog (\r, env => pure (r ** env))

353runEnv env prog = eff env prog (\r, env => pure (r ** env))

294

354

295-- ----------------------------------------------- [ some higher order things ]

355-- ----------------------------------------------- [ some higher order things ]

296

356

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)

298mapE f [] = pure []

358mapE f [] = pure []

299mapE f (x :: xs) = [| f x :: mapE f xs |]

359mapE f (x :: xs) = [| f x :: mapE f xs |]

300

360

301

361

302−mapVE : (a -> {xs} Eff b) ->

362+mapVE : (a -> {xs} EffM m b) ->

303 Vect n a ->

363 Vect n a ->

304− {xs} Eff (Vect n b)

364+ {xs} EffM m (Vect n b)

305mapVE f [] = pure []

365mapVE f [] = pure []

306mapVE f (x :: xs) = [| f x :: mapVE f xs |]

366mapVE f (x :: xs) = [| f x :: mapVE f xs |]

307

367

308

368

309−when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff ()

369+when : Bool -> Lazy ({xs} EffM m ()) -> {xs} EffM m ()

310when True e = Force e

370when True e = Force e

311when False e = pure ()

371when False e = pure ()

312

372

libs/prelude/Builtins.idr+4−3

@@ -23,11 +23,11 @@ namespace Builtins

23 ||| UniqueTypes.

24 ||| @A the type of the left elements in the pair

25 ||| @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

27 ||| A pair of elements

28 ||| @a the left element of the pair

29 ||| @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

31

32 ||| Dependent pairs

33 |||

@@ -36,7 +36,8 @@ namespace Builtins

36 ||| it. Another way to see dependent pairs is as just data - for instance, the

37 ||| length of a vector paired with that vector.

38 |||

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

40 data Sigma : (a : Type) -> (P : a -> Type) -> Type where

41 data Sigma : (a : Type) -> (P : a -> Type) -> Type where

41 MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

42 MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

42

43

libs/prelude/IO.idr+32−30

@@ -120,46 +120,48 @@ prim_fwrite h s

120 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

121

122--------- The C FFI

123−

123+namespace FFI_C

124−data Raw : Type -> Type where

124+ data Raw : Type -> Type where

125− -- code generated can assume it's compiled just as 't'

125+ -- code generated can assume it's compiled just as 't'

126− MkRaw : (x : t) -> Raw t

126+ MkRaw : (x : t) -> Raw t

127−

127+

128−-- Tell erasure analysis not to erase the argument

128+ -- Tell erasure analysis not to erase the argument

129−%used MkRaw x

129+ %used MkRaw x

130−

130+

131−-- Supported C integer types

131+ -- Supported C integer types

132−data C_IntTypes : Type -> Type where

132+ data C_IntTypes : Type -> Type where

133− C_IntChar : C_IntTypes Char

133+ C_IntChar : C_IntTypes Char

134− C_IntNative : C_IntTypes Int

134+ C_IntNative : C_IntTypes Int

135− C_IntBits8 : C_IntTypes Bits8

135+ C_IntBits8 : C_IntTypes Bits8

136− C_IntBits16 : C_IntTypes Bits16

136+ C_IntBits16 : C_IntTypes Bits16

137− C_IntBits32 : C_IntTypes Bits32

137+ C_IntBits32 : C_IntTypes Bits32

138− C_IntBits64 : C_IntTypes Bits64

138+ C_IntBits64 : C_IntTypes Bits64

139−

139+

140−-- Supported C foreign types

140+ -- Supported C foreign types

141−data C_Types : Type -> Type where

141+ data C_Types : Type -> Type where

142− C_Str : C_Types String

142+ C_Str : C_Types String

143− C_Float : C_Types Float

143+ C_Float : C_Types Float

144− C_Ptr : C_Types Ptr

144+ C_Ptr : C_Types Ptr

145− C_MPtr : C_Types ManagedPtr

145+ C_MPtr : C_Types ManagedPtr

146− C_Unit : C_Types ()

146+ C_Unit : C_Types ()

147− C_Any : C_Types (Raw a)

147+ C_Any : C_Types (Raw a)

148− C_IntT : C_IntTypes i -> C_Types i

148+ C_IntT : C_IntTypes i -> C_Types i

149−

149+

150−FFI_C : FFI

150+ FFI_C : FFI

151−FFI_C = MkFFI C_Types String String

151+ FFI_C = MkFFI C_Types String String

152

153IO : Type -> Type

154IO = IO' FFI_C

155

156+-- Cannot be relaxed as is used by type providers and they expect IO a

157+-- in the first argument.

156run__provider : IO a -> PrimIO a

158run__provider : IO a -> PrimIO a

157run__provider (MkIO f) = f (TheWorld prim__TheWorld)

159run__provider (MkIO f) = f (TheWorld prim__TheWorld)

158

160

159prim_fork : PrimIO () -> PrimIO Ptr

161prim_fork : PrimIO () -> PrimIO Ptr

160prim_fork x = prim_io_return prim__vm -- compiled specially

162prim_fork x = prim_io_return prim__vm -- compiled specially

161

163

162−fork : IO () -> IO Ptr

164+fork : IO' l () -> IO' l Ptr

163fork (MkIO f) = MkIO (\w => prim_io_bind

165fork (MkIO f) = MkIO (\w => prim_io_bind

164 (prim_fork (prim_io_bind (f w)

166 (prim_fork (prim_io_bind (f w)

165 (\ x => prim_io_return x)))

167 (\ x => prim_io_return x)))

libs/prelude/Language/Reflection.idr+71−25

@@ -11,18 +11,35 @@ import Prelude.Traversable

11

12%access public

13

14+mutual

14−data TTName =

15+ data TTName =

15− ||| A user-provided name

16+ ||| A user-provided name

16− UN String |

17+ UN String |

17− ||| A name in some namespace.

18+ ||| A name in some namespace.

18− |||

19+ |||

19− ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo`

20+ ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])`

21+ ||| represents the name `A.B.foo`

20− NS TTName (List String) |

22+ NS TTName (List String) |

21− ||| Machine-chosen names

23+ ||| Machine-chosen names

22− MN Int String |

24+ MN Int String |

25+ ||| Special names, to make conflicts impossible and language features

26+ ||| predictable

27+ SN SpecialName |

23− ||| Name of something which is never used in scope

28+ ||| Name of something which is never used in scope

24− NErased

29+ NErased

25−%name TTName n, n'

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+

26

43

27implicit

44implicit

28userSuppliedName : String -> TTName

45userSuppliedName : String -> TTName

@@ -390,19 +407,48 @@ instance Quotable a Raw => Quotable (List a) Raw where

390 quote [] = `(List.Nil {a=~(quotedTy {a})})

407 quote [] = `(List.Nil {a=~(quotedTy {a})})

391 quote (x :: xs) = `(List.(::) {a=~(quotedTy {a})} ~(quote x) ~(quote xs))

408 quote (x :: xs) = `(List.(::) {a=~(quotedTy {a})} ~(quote x) ~(quote xs))

392

409

410+mutual

393−instance Quotable TTName TT where

411+ instance Quotable TTName TT where

394− quotedTy = `(TTName)

412+ quotedTy = `(TTName)

395− quote (UN x) = `(UN ~(quote x))

413+ quote (UN x) = `(UN ~(quote x))

396− quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

414+ quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

397− quote (MN x y) = `(MN ~(quote x) ~(quote y))

415+ quote (MN x y) = `(MN ~(quote x) ~(quote y))

416+ quote (SN sn) = `(SN ~(assert_total $ quote sn))

398− quote NErased = `(NErased)

417+ quote NErased = `(NErased)

399−

418+

400−instance Quotable TTName Raw where

419+ instance Quotable SpecialName TT where

401− quotedTy = `(TTName)

420+ quotedTy = `(SpecialName)

402− quote (UN x) = `(UN ~(quote {t=Raw} x))

421+ quote (WhereN i n1 n2) = `(WhereN ~(quote i) ~(quote n1) ~(quote n2))

403− quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))

422+ quote (WithN i n) = `(WithN ~(quote i) ~(quote n))

404− quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))

423+ quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

405− quote NErased = `(NErased)

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+

406

452

407instance Quotable NativeTy TT where

453instance Quotable NativeTy TT where

408 quotedTy = `(NativeTy)

454 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

134 show Nothing = "Nothing"

135 show (Just x) = "Just " ++ show x

136

137+instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

138+ show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

139+

137---- Functor instances

140---- Functor instances

138

141

139instance Functor PrimIO where

142instance Functor PrimIO where

@@ -242,8 +245,8 @@ natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc

242total natEnumFromTo : Nat -> Nat -> List Nat

245total natEnumFromTo : Nat -> Nat -> List Nat

243natEnumFromTo n m = map (plus n) (natRange ((S m) - n))

246natEnumFromTo n m = map (plus n) (natRange ((S m) - n))

244total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat

247total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat

245−natEnumFromThenTo _ Z _ = []

248+natEnumFromThenTo _ Z _ = []

246−natEnumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))

249+natEnumFromThenTo n (S inc) m = map (plus n . (* (S inc))) (natRange (S (divNatNZ (m - n) (S inc) SIsNotZ)))

247

250

248class Enum a where

251class Enum a where

249 total pred : a -> a

252 total pred : a -> a

@@ -282,7 +285,7 @@ instance Enum Integer where

282 go [] = []

285 go [] = []

283 go (x :: xs) = n + cast x :: go xs

286 go (x :: xs) = n + cast x :: go xs

284 enumFromThenTo _ 0 _ = []

287 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)))

286 where go : List Nat -> List Integer

289 where go : List Nat -> List Integer

287 go [] = []

290 go [] = []

288 go (x :: xs) = n + (cast x * inc) :: go xs

291 go (x :: xs) = n + (cast x * inc) :: go xs

@@ -302,7 +305,7 @@ instance Enum Int where

302 go acc (S k) m = go (m :: acc) k (m - 1)

305 go acc (S k) m = go (m :: acc) k (m - 1)

303 enumFromThen n inc = n :: enumFromThen (inc + n) inc

306 enumFromThen n inc = n :: enumFromThen (inc + n) inc

304 enumFromThenTo _ 0 _ = []

307 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)))

306 where go : List Nat -> List Int

309 where go : List Nat -> List Int

307 go [] = []

310 go [] = []

308 go (x :: xs) = n + (cast x * inc) :: go xs

311 go (x :: xs) = n + (cast x * inc) :: go xs

@@ -346,7 +349,7 @@ partial

346printLn : Show a => a -> IO' ffi ()

349printLn : Show a => a -> IO' ffi ()

347printLn x = putStrLn (show x)

350printLn x = putStrLn (show x)

348

351

349−||| Read one line of input from stdin

352+||| Read one line of input from stdin, without the trailing newline

350partial

353partial

351getLine : IO' ffi String

354getLine : IO' ffi String

352getLine = prim_read

355getLine = prim_read

@@ -526,7 +529,7 @@ validFile (FHandle h) = do x <- nullPtr h

526||| @ test the condition of the loop

529||| @ test the condition of the loop

527||| @ body the loop body

530||| @ body the loop body

528partial -- obviously

531partial -- obviously

529−while : (test : IO Bool) -> (body : IO ()) -> IO ()

532+while : (test : IO' l Bool) -> (body : IO' l ()) -> IO' l ()

530while t b = do v <- t

533while t b = do v <- t

531 if v then do b

534 if v then do b

532 while t b

535 while t b

@@ -545,5 +548,7 @@ readFile fn = do h <- openFile fn Read

545 readFile' h contents =

548 readFile' h contents =

546 do x <- feof h

549 do x <- feof h

547 if not x then do l <- fread h

550 if not x then do l <- fread h

551+ case contents of

552+ "" => readFile' h l

548− readFile' h (contents ++ l)

553+ _ => readFile' h (contents ++ "\n" ++ l)

549 else return contents

554 else return contents

libs/prelude/Prelude/Algebra.idr−4

@@ -2,11 +2,7 @@ module Prelude.Algebra

2

3import Builtins

4

5−-- XXX: change?

6−infixl 6 <->

7infixl 6 <+>

5infixl 6 <+>

8−infixl 6 <.>

9−infixl 5 <#>

10

6

11%access public

7%access public

12

8

libs/prelude/Prelude/Classes.idr+24−12

@@ -315,10 +315,12 @@ class Integral a where

315

316-- ---------------------------------------------------------------- [ Integers ]

317divBigInt : Integer -> Integer -> Integer

318+divBigInt x y = case y == 0 of

318−divBigInt = prim__sdivBigInt

319+ False => prim__sdivBigInt x y

319

320

320modBigInt : Integer -> Integer -> Integer

321modBigInt : Integer -> Integer -> Integer

322+modBigInt x y = case y == 0 of

321−modBigInt = prim__sremBigInt

323+ False => prim__sremBigInt x y

322

324

323instance Integral Integer where

325instance Integral Integer where

324 div = divBigInt

326 div = divBigInt

@@ -327,10 +329,12 @@ instance Integral Integer where

327-- --------------------------------------------------------------------- [ Int ]

329-- --------------------------------------------------------------------- [ Int ]

328

330

329divInt : Int -> Int -> Int

331divInt : Int -> Int -> Int

332+divInt x y = case y == 0 of

330−divInt = prim__sdivInt

333+ False => prim__sdivInt x y

331

334

332modInt : Int -> Int -> Int

335modInt : Int -> Int -> Int

336+modInt x y = case y == 0 of

333−modInt = prim__sremInt

337+ False => prim__sremInt x y

334

338

335instance Integral Int where

339instance Integral Int where

336 div = divInt

340 div = divInt

@@ -338,10 +342,12 @@ instance Integral Int where

338

342

339-- ------------------------------------------------------------------- [ Bits8 ]

343-- ------------------------------------------------------------------- [ Bits8 ]

340divB8 : Bits8 -> Bits8 -> Bits8

344divB8 : Bits8 -> Bits8 -> Bits8

345+divB8 x y = case y == 0 of

341−divB8 = prim__sdivB8

346+ False => prim__sdivB8 x y

342

347

343modB8 : Bits8 -> Bits8 -> Bits8

348modB8 : Bits8 -> Bits8 -> Bits8

349+modB8 x y = case y == 0 of

344−modB8 = prim__sremB8

350+ False => prim__sremB8 x y

345

351

346instance Integral Bits8 where

352instance Integral Bits8 where

347 div = divB8

353 div = divB8

@@ -349,10 +355,12 @@ instance Integral Bits8 where

349

355

350-- ------------------------------------------------------------------ [ Bits16 ]

356-- ------------------------------------------------------------------ [ Bits16 ]

351divB16 : Bits16 -> Bits16 -> Bits16

357divB16 : Bits16 -> Bits16 -> Bits16

358+divB16 x y = case y == 0 of

352−divB16 = prim__sdivB16

359+ False => prim__sdivB16 x y

353

360

354modB16 : Bits16 -> Bits16 -> Bits16

361modB16 : Bits16 -> Bits16 -> Bits16

362+modB16 x y = case y == 0 of

355−modB16 = prim__sremB16

363+ False => prim__sremB16 x y

356

364

357instance Integral Bits16 where

365instance Integral Bits16 where

358 div = divB16

366 div = divB16

@@ -360,10 +368,12 @@ instance Integral Bits16 where

360

368

361-- ------------------------------------------------------------------ [ Bits32 ]

369-- ------------------------------------------------------------------ [ Bits32 ]

362divB32 : Bits32 -> Bits32 -> Bits32

370divB32 : Bits32 -> Bits32 -> Bits32

371+divB32 x y = case y == 0 of

363−divB32 = prim__sdivB32

372+ False => prim__sdivB32 x y

364

373

365modB32 : Bits32 -> Bits32 -> Bits32

374modB32 : Bits32 -> Bits32 -> Bits32

375+modB32 x y = case y == 0 of

366−modB32 = prim__sremB32

376+ False => prim__sremB32 x y

367

377

368instance Integral Bits32 where

378instance Integral Bits32 where

369 div = divB32

379 div = divB32

@@ -371,10 +381,12 @@ instance Integral Bits32 where

371

381

372-- ------------------------------------------------------------------ [ Bits64 ]

382-- ------------------------------------------------------------------ [ Bits64 ]

373divB64 : Bits64 -> Bits64 -> Bits64

383divB64 : Bits64 -> Bits64 -> Bits64

384+divB64 x y = case y == 0 of

374−divB64 = prim__sdivB64

385+ False => prim__sdivB64 x y

375

386

376modB64 : Bits64 -> Bits64 -> Bits64

387modB64 : Bits64 -> Bits64 -> Bits64

388+modB64 x y = case y == 0 of

377−modB64 = prim__sremB64

389+ False => prim__sremB64 x y

378

390

379instance Integral Bits64 where

391instance Integral Bits64 where

380 div = divB64

392 div = divB64

libs/prelude/Prelude/Either.idr+5

@@ -66,6 +66,11 @@ fromEither : Either a a -> a

66fromEither (Left l) = l

67fromEither (Right r) = r

68

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+

69--------------------------------------------------------------------------------

74--------------------------------------------------------------------------------

70-- Conversions

75-- Conversions

71--------------------------------------------------------------------------------

76--------------------------------------------------------------------------------

libs/prelude/Prelude/List.idr+17−8

@@ -309,13 +309,12 @@ mapMaybe f (x::xs) =

309-- Folds

310--------------------------------------------------------------------------------

311

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−

317instance Foldable List where

312instance 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

319

318

320--------------------------------------------------------------------------------

319--------------------------------------------------------------------------------

321-- Special folds

320-- Special folds

@@ -537,10 +536,11 @@ delete = deleteBy (==)

537(\\) : (Eq a) => List a -> List a -> List a

536(\\) : (Eq a) => List a -> List a -> List a

538(\\) = foldl (flip delete)

537(\\) = foldl (flip delete)

539

538

539+||| The unionBy function returns the union of two lists by user-supplied equality predicate.

540unionBy : (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

542

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.

544|||

545||| ```idris example

546||| union ['d', 'o', 'g'] ['c', 'o', 'w']

@@ -809,6 +809,15 @@ hasAnyByNilFalse p (x::xs) =

809hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

810hasAnyNilFalse l = ?hasAnyNilFalseBody

811

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+

812

821

813--------------------------------------------------------------------------------

822--------------------------------------------------------------------------------

814-- Proofs

823-- Proofs

libs/prelude/Prelude/Maybe.idr+18−10

@@ -78,17 +78,25 @@ instance (Eq a) => Eq (Maybe a) where

78 (Just _) == Nothing = False

79 (Just a) == (Just b) = a == b

80

81−-- Lift a semigroup into 'Maybe' forming a 'Monoid' according to

81+||| Prioritised choice. Just like the `Alternative` instance, the

82−-- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be

82+||| `Semigroup` for `Maybe a` keeps the first succeeding computation.

83−-- turned into a monoid simply by adjoining an element i not in S

83+|||

84−-- and defining i+i = i and i+s = s = s+i for all s in S."

84+||| **NB**: This is a different choice than in the Haskell libraries.

85−

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.

86−instance (Semigroup a) => Semigroup (Maybe a) where

94+instance [collectJust] Semigroup a => Semigroup (Maybe a) where

87− Nothing <+> m = m

95+ Nothing <+> m = m

88− m <+> Nothing = m

96+ m <+> Nothing = m

89 (Just m1) <+> (Just m2) = Just (m1 <+> m2)

97 (Just m1) <+> (Just m2) = Just (m1 <+> m2)

90

98

91−instance (Semigroup a) => Monoid (Maybe a) where

99+instance Monoid (Maybe a) where

92 neutral = Nothing

100 neutral = Nothing

93

101

94instance (Monoid a, Eq a) => Cast a (Maybe a) where

102instance (Monoid a, Eq a) => Cast a (Maybe a) where

@@ -98,5 +106,5 @@ instance (Monoid a) => Cast (Maybe a) a where

98 cast = lowerMaybe

106 cast = lowerMaybe

99

107

100instance Foldable Maybe where

108instance Foldable Maybe where

101− foldr _ z Nothing = z

109+ foldr _ z Nothing = z

102 foldr f z (Just x) = f x z

110 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

290-- Division and modulus

291--------------------------------------------------------------------------------

292

293−total

293+SIsNotZ : {x: Nat} -> (S x = Z) -> Void

294+SIsNotZ Refl impossible

295+

294−modNat : Nat -> Nat -> Nat

296+modNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat

295−modNat left Z = left

297+modNatNZ left Z p = void (p Refl)

296−modNat left (S right) = mod' left left right

298+modNatNZ left (S right) _ = mod' left left right

297 where

299 where

298 total mod' : Nat -> Nat -> Nat -> Nat

300 total mod' : Nat -> Nat -> Nat -> Nat

299 mod' Z centre right = centre

301 mod' Z centre right = centre

@@ -303,10 +305,13 @@ modNat left (S right) = mod' left left right

303 else

305 else

304 mod' left (centre - (S right)) right

306 mod' left (centre - (S right)) right

305

307

306−total

308+partial

309+modNat : Nat -> Nat -> Nat

310+modNat left (S right) = modNatNZ left (S right) SIsNotZ

311+

307−divNat : Nat -> Nat -> Nat

312+divNatNZ : Nat -> (y: Nat) -> Not (y = Z) -> Nat

308−divNat left Z = S left -- div by zero

313+divNatNZ left Z p = void (p Refl)

309−divNat left (S right) = div' left left right

314+divNatNZ left (S right) _ = div' left left right

310 where

315 where

311 total div' : Nat -> Nat -> Nat -> Nat

316 total div' : Nat -> Nat -> Nat -> Nat

312 div' Z centre right = Z

317 div' Z centre right = Z

@@ -316,23 +321,42 @@ divNat left (S right) = div' left left right

316 else

321 else

317 S (div' left (centre - (S right)) right)

322 S (div' left (centre - (S right)) right)

318

323

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+

319instance Integral Nat where

337instance Integral Nat where

320 div = divNat

338 div = divNat

321 mod = modNat

339 mod = modNat

322

340

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

323log2 : Nat -> Nat

347log2 : Nat -> Nat

324−log2 Z = Z

348+log2 (S n) = log2NZ (S n) SIsNotZ

325−log2 (S Z) = Z

326−log2 n = S (log2 (assert_smaller n (n `divNat` 2)))

327

349

328--------------------------------------------------------------------------------

350--------------------------------------------------------------------------------

329-- GCD and LCM

351-- GCD and LCM

330--------------------------------------------------------------------------------

352--------------------------------------------------------------------------------

353+partial

331gcd : Nat -> Nat -> Nat

354gcd : Nat -> Nat -> Nat

332gcd a Z = a

355gcd a Z = a

333gcd a b = assert_total (gcd b (a `modNat` b))

356gcd a b = assert_total (gcd b (a `modNat` b))

334

357

358+partial

335−total lcm : Nat -> Nat -> Nat

359+lcm : Nat -> Nat -> Nat

336lcm _ Z = Z

360lcm _ Z = Z

337lcm Z _ = Z

361lcm Z _ = Z

338lcm x y = divNat (x * y) (gcd x y)

362lcm x y = divNat (x * y) (gcd x y)

@@ -726,11 +750,6 @@ total sucMinR : (l : Nat) -> minimum l (S l) = l

726sucMinR Z = Refl

750sucMinR Z = Refl

727sucMinR (S l) = cong (sucMinR l)

751sucMinR (S l) = cong (sucMinR l)

728

752

729−-- div and mod

730−total modZeroZero : (n : Nat) -> mod 0 n = Z

731−modZeroZero Z = Refl

732−modZeroZero (S n) = Refl

733−

734--------------------------------------------------------------------------------

753--------------------------------------------------------------------------------

735-- Proofs

754-- Proofs

736--------------------------------------------------------------------------------

755--------------------------------------------------------------------------------

libs/prelude/Prelude/Pairs.idr+3

@@ -5,6 +5,9 @@ import Builtins

5%access public

6%default total

7

8+swap : (a, b) -> (b, a)

9+swap (x, y) = (y, x)

10+

8using (a : Type, P : a -> Type)

11using (a : Type, P : a -> Type)

9

12

10 ||| Dependent pair where the first field is erased.

13 ||| Dependent pair where the first field is erased.

libs/prelude/prelude.ipkg+1−1

@@ -10,7 +10,7 @@ modules = Builtins, Prelude, IO,

10 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

11 Prelude.Uninhabited, Prelude.Pairs, Prelude.Providers,

12

13− Language.Reflection, Language.Reflection.Errors, Language.Reflection.Tactical,

13+ Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,

14

15 Decidable.Equality

16

main/Main.hs+2

@@ -29,6 +29,7 @@ import Idris.CmdOptions

29import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )

30

31import Util.DynamicLinker

32+import Util.System

32

33

33import Pkg.Package

34import Pkg.Package

34

35

@@ -43,6 +44,7 @@ main = do opts <- runArgParser

43

44

44runIdris :: [Opt] -> Idris ()

45runIdris :: [Opt] -> Idris ()

45runIdris opts = do

46runIdris opts = do

47+ runIO setupBundledCC

46 when (ShowIncs `elem` opts) $ runIO showIncs

48 when (ShowIncs `elem` opts) $ runIO showIncs

47 when (ShowLibs `elem` opts) $ runIO showLibs

49 when (ShowLibs `elem` opts) $ runIO showLibs

48 when (ShowLibdir `elem` opts) $ runIO showLibdir

50 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 \

5HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \

6 idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h \

7 idris_utf8.h getline.h

8−CFLAGS:=-fPIC $(CFLAGS)

8+CFLAGS := $(CFLAGS)

9CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""

10CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""

11

@@ -21,6 +21,7 @@ endif

21ifeq ($(OS), windows)

22 OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o

23else

24+ CFLAGS += -fPIC

24 OBJS += idris_stdfgn.o idris_net.o

25 OBJS += idris_stdfgn.o idris_net.o

25endif

26endif

26

27

rts/idris_gc.c+7

@@ -53,6 +53,13 @@ VAL copy(VM* vm, VAL x) {

53 break;

54 case FWD:

55 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;

56 default:

63 default:

57 break;

64 break;

58 }

65 }

rts/idris_rts.c+16−3

@@ -143,7 +143,10 @@ int space(VM* vm, size_t size) {

143}

144

145void* 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);

147}

150}

148

151

149void* idris_realloc(void* old, size_t old_size, size_t size) {

152void* idris_realloc(void* old, size_t old_size, size_t size) {

@@ -501,17 +504,20 @@ VAL idris_strlen(VM* vm, VAL l) {

501}

504}

502

505

503VAL idris_readStr(VM* vm, FILE* h) {

506VAL idris_readStr(VM* vm, FILE* h) {

507+ VAL ret;

504 char *buffer = NULL;

508 char *buffer = NULL;

505 size_t n = 0;

509 size_t n = 0;

506 ssize_t len;

510 ssize_t len;

507 len = getline(&buffer, &n, h);

511 len = getline(&buffer, &n, h);

512+ strtok(buffer, "\n");

508

513

509 if (len <= 0) {

514 if (len <= 0) {

510− return MKSTR(vm, "");

515+ ret = MKSTR(vm, "");

511 } else {

516 } else {

512− return MKSTR(vm, buffer);

517+ ret = MKSTR(vm, buffer);

513 }

518 }

514 free(buffer);

519 free(buffer);

520+ return ret;

515}

521}

516

522

517VAL idris_strHead(VM* vm, VAL str) {

523VAL idris_strHead(VM* vm, VAL str) {

@@ -712,6 +718,13 @@ VAL doCopyTo(VM* vm, VAL x) {

712 case BITS64:

718 case BITS64:

713 cl = idris_b64CopyForGC(vm, x);

719 cl = idris_b64CopyForGC(vm, x);

714 break;

720 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;

715 default:

728 default:

716 assert(0); // We're in trouble if this happens...

729 assert(0); // We're in trouble if this happens...

717 }

730 }

rts/idris_rts.h+2−34

@@ -10,8 +10,6 @@

10#endif

11#include <stdint.h>

12

13−#include <emmintrin.h>

14−

15#include "idris_heap.h"

13#include "idris_heap.h"

16#include "idris_stats.h"

14#include "idris_stats.h"

17

15

@@ -26,7 +24,7 @@

26typedef enum {

24typedef enum {

27 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

25 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

28 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

26 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

29− MANAGEDPTR

27+ MANAGEDPTR, RAWDATA

30} ClosureType;

28} ClosureType;

31

29

32typedef struct Closure *VAL;

30typedef struct Closure *VAL;

@@ -41,14 +39,6 @@ typedef struct {

41 size_t offset;

39 size_t offset;

42} StrOffset;

40} StrOffset;

43

41

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−

52// A foreign pointer, managed by the idris GC

42// A foreign pointer, managed by the idris GC

53typedef struct {

43typedef struct {

54 size_t size;

44 size_t size;

@@ -73,9 +63,8 @@ typedef struct Closure {

73 uint16_t bits16;

63 uint16_t bits16;

74 uint32_t bits32;

64 uint32_t bits32;

75 uint64_t bits64;

65 uint64_t bits64;

76− __m128i* bits128p;

77− Buffer* buf;

78 ManagedPtr* mptr;

66 ManagedPtr* mptr;

67+ size_t size;

79 } info;

68 } info;

80} Closure;

69} Closure;

81

70

@@ -315,27 +304,6 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs);

315VAL idris_strIndex(VM* vm, VAL str, VAL i);

304VAL idris_strIndex(VM* vm, VAL str, VAL i);

316VAL idris_strRev(VM* vm, VAL str);

305VAL idris_strRev(VM* vm, VAL str);

317

306

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−

339// system infox

307// system infox

340// used indices:

308// used indices:

341// 0 returns backend

309// 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)

220 indent i ++ "}\n"

221

222 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

223− showCase i Nothing [(t, c)] = showCode i c

223+ showCase i Nothing [(t, c)] = indent i ++ showCode i c

224− showCase i (Just def) [] = showCode i def

224+ showCase i (Just def) [] = indent i ++ showCode i def

225 showCase i def ((t, c) : cs)

226 = 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

228

229bcc i (CASE safe r code def)

230 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

@@ -307,7 +307,7 @@ bcc i (FOREIGNCALL l rty (FStr fn) args)

307 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

308 where fcall (t, arg) = irts_c (toFType t) (creg arg)

309bcc 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"

311-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

312

313-- Deconstruct the Foreign type in the defunctionalised expression and build

@@ -647,7 +647,7 @@ codegenH es = mapM_ writeIFace es

647

648writeIFace :: ExportIFace -> IO ()

649writeIFace (Export ffic hdr exps)

650− | ffic == sUN "FFI_C"

650+ | ffic == sNS (sUN "FFI_C") ["FFI_C"]

651 = do let hfile = "#ifndef " ++ hdr_guard hdr ++ "\n" ++

652 "#define " ++ hdr_guard hdr ++ "\n\n" ++

653 "#include <idris_rts.h>\n\n" ++

src/IRTS/CodegenJavaScript.hs+4−4

@@ -47,7 +47,7 @@ initCompileInfo bc =

47 lookupBigInt = any (needsBigInt . snd)

48 where

49 needsBigInt :: [BC] -> Bool

50− needsBigInt bc = or $ map testBCForBigInt bc

50+ needsBigInt bc = any testBCForBigInt bc

51 where

52 testBCForBigInt :: BC -> Bool

53 testBCForBigInt (ASSIGNCONST _ c) =

@@ -55,12 +55,12 @@ initCompileInfo bc =

55

56 testBCForBigInt (CONSTCASE _ c d) =

57 maybe False needsBigInt d

58− || (or $ map (needsBigInt . snd) c)

58+ || any (needsBigInt . snd) c

59− || (or $ map (testConstForBigInt . fst) c)

59+ || any (testConstForBigInt . fst) c

60

61 testBCForBigInt (CASE _ _ c d) =

62 maybe False needsBigInt d

63− || (or $ map (needsBigInt . snd) c)

63+ || any (needsBigInt . snd) c

64

65 testBCForBigInt _ = False

66

src/IRTS/Compiler.hs+8−4

@@ -51,8 +51,12 @@ compile codegen f mtm

51 = do checkMVs -- check for undefined metavariables

52 checkTotality -- refuse to compile if there are totality problems

53 exports <- findExports

54+ let rootNames = case mtm of

55+ Nothing -> []

56+ Just t -> freeNames t

54

57

55− reachableNames <- performUsageAnalysis (getExpNames exports)

58+ reachableNames <- performUsageAnalysis

59+ (rootNames ++ getExpNames exports)

56 maindef <- case mtm of

60 maindef <- case mtm of

57 Nothing -> return []

61 Nothing -> return []

58 Just tm -> do md <- irMain tm

62 Just tm -> do md <- irMain tm

@@ -231,7 +235,7 @@ data VarInfo = VI

231type Vars = M.Map Name VarInfo

235type Vars = M.Map Name VarInfo

232

236

233irTerm :: Vars -> [Name] -> Term -> Idris LExp

237irTerm :: Vars -> [Name] -> Term -> Idris LExp

234−irTerm vs env tm@(App f a) = do

238+irTerm vs env tm@(App _ f a) = do

235 ist <- getIState

239 ist <- getIState

236 case unApply tm of

240 case unApply tm of

237 (P _ (UN m) _, args)

241 (P _ (UN m) _, args)

@@ -293,8 +297,8 @@ irTerm vs env tm@(App f a) = do

293

297

294 -- This case is here until we get more general inlining. It's just

298 -- This case is here until we get more general inlining. It's just

295 -- a really common case, and the laziness hurts...

299 -- a really common case, and the laziness hurts...

296− (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),

300+ (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),

297− (App (App (App (P _ (UN d') _) _) _) e)])

301+ (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])

298 | be == txt "boolElim"

302 | be == txt "boolElim"

299 , d == txt "Delay"

303 , d == txt "Delay"

300 , d' == txt "Delay"

304 , d' == txt "Delay"

src/IRTS/Defunctionalise.hs+6−6

@@ -162,21 +162,21 @@ addApps defs (n, LFun _ _ args e)

162 | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)

163 | otherwise = preEval xs t

164

165− needsEval x (DApp _ _ args) = or (map (needsEval x) args)

165+ needsEval x (DApp _ _ args) = any (needsEval x) args

166− needsEval x (DC _ _ _ args) = or (map (needsEval x) args)

166+ needsEval x (DC _ _ _ args) = any (needsEval x) args

167− needsEval x (DCase up e alts) = needsEval x e || or (map nec alts)

167+ needsEval x (DCase up e alts) = needsEval x e || any nec alts

168 where nec (DConCase _ _ _ e) = needsEval x e

169 nec (DConstCase _ e) = needsEval x e

170 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

172 where nec (DConCase _ _ _ e) = needsEval x e

173 nec (DConstCase _ e) = needsEval x e

174 nec (DDefaultCase e) = needsEval x e

175 needsEval x (DLet n v e)

176 | x == n = needsEval x v

177 | otherwise = needsEval x v || needsEval x e

178− needsEval x (DForeign _ _ args) = or (map (needsEval x) (map snd args))

178+ needsEval x (DForeign _ _ args) = any (needsEval x) (map snd args)

179− needsEval x (DOp op args) = or (map (needsEval x) args)

179+ needsEval x (DOp op args) = any (needsEval x) args

180 needsEval x (DProj (DV (Glob x')) _) = x == x'

181 needsEval x _ = False

182

src/IRTS/Lang.hs+1−1

@@ -132,7 +132,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

132

133lname (NS n x) i = NS (lname n i) x

134lname (UN n) i = MN i n

135−lname x i = sMN i (show x)

135+lname x i = sMN i (show x ++ "_lam")

136

137liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

138liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

src/Idris/AbsSyntax.hs+8−5

@@ -816,7 +816,9 @@ targetCPU = do i <- getIState

816

817verbose :: Idris Bool

818verbose = do i <- getIState

819+ -- Quietness overrides verbosity

820+ return (not (opt_quiet (idris_options i)) &&

819− return (opt_verbose (idris_options i))

821+ opt_verbose (idris_options i))

820

822

821setVerbose :: Bool -> Idris ()

823setVerbose :: Bool -> Idris ()

822setVerbose t = do i <- getIState

824setVerbose t = do i <- getIState

@@ -1009,7 +1011,7 @@ expandParams dec ps ns infs tm = en tm

1009 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

1011 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

1010 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

1012 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

1011 en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)

1013 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)

1013 en t = t

1015 en t = t

1014

1016

1015 nselem x [] = False

1017 nselem x [] = False

@@ -1478,7 +1480,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1478 imps top env (PHidden tm) = imps False env tm

1480 imps top env (PHidden tm) = imps False env tm

1479 imps top env (PUnifyLog tm) = imps False env tm

1481 imps top env (PUnifyLog tm) = imps False env tm

1480 imps top env (PNoImplicits tm) = imps False env tm

1482 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

1482 imps top env _ = return ()

1484 imps top env _ = return ()

1483

1485

1484 pibind using [] sc = sc

1486 pibind using [] sc = sc

@@ -1605,7 +1607,7 @@ addImpl' inpat env infns imp_meths ist ptm

1605 ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)

1607 ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)

1606 (fmap (ai True env ds) g)

1608 (fmap (ai True env ds) g)

1607 ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)

1609 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)

1609 ai qq env ds tm = tm

1611 ai qq env ds tm = tm

1610

1612

1611 handleErr (Left err) = PElabError err

1613 handleErr (Left err) = PElabError err

@@ -2016,6 +2018,7 @@ substMatchShadow n shs tm t = sm shs t where

2016 sm xs (PHidden x) = PHidden (sm xs x)

2018 sm xs (PHidden x) = PHidden (sm xs x)

2017 sm xs (PUnifyLog x) = PUnifyLog (sm xs x)

2019 sm xs (PUnifyLog x) = PUnifyLog (sm xs x)

2018 sm xs (PNoImplicits x) = PNoImplicits (sm xs x)

2020 sm xs (PNoImplicits x) = PNoImplicits (sm xs x)

2021+ sm xs (PRunElab fc script) = PRunElab fc (sm xs script)

2019 sm xs x = x

2022 sm xs x = x

2020

2023

2021 fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))

2024 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

2142 mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

2145 mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

2143 mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

2146 mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

2144 mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

2147 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)

2146 mkUniq t = return t

2149 mkUniq t = return t

src/Idris/AbsSyntaxTree.hs+74−59

@@ -369,7 +369,7 @@ data Command = Quit

369 | ModImport String

370 | Edit

371 | Compile Codegen String

372− | Execute

372+ | Execute PTerm

373 | ExecVal PTerm

374 | Metavars

375 | Prove Name

@@ -408,6 +408,7 @@ data Command = Quit

408 | Apropos [String] String

409 | WhoCalls Name

410 | CallsWho Name

411+ | Browse [String]

411 | MakeDoc String -- IdrisDoc

412 | MakeDoc String -- IdrisDoc

412 | Warranty

413 | Warranty

413 | PrintDef Name

414 | PrintDef Name

@@ -580,14 +581,6 @@ inlinable = elem Inlinable

580dictionary :: FnOpts -> Bool

581dictionary :: FnOpts -> Bool

581dictionary = elem Dictionary

582dictionary = elem Dictionary

582

583

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]

591

584

592-- | Type provider - what to provide

585-- | Type provider - what to provide

593data ProvideWhat' t = ProvTerm t t -- ^ the first is the goal type, the second is the term

586data ProvideWhat' t = ProvTerm t t -- ^ the first is the goal type, the second is the term

@@ -642,7 +635,7 @@ data PDecl' t

642 | PDSL Name (DSL' t) -- ^ DSL declaration

635 | PDSL Name (DSL' t) -- ^ DSL declaration

643 | PSyntax FC Syntax -- ^ Syntax definition

636 | PSyntax FC Syntax -- ^ Syntax definition

644 | PMutual FC [PDecl' t] -- ^ Mutual block

637 | 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.

646 | PProvider (Docstring (Either Err PTerm)) SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term

639 | PProvider (Docstring (Either Err PTerm)) SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term

647 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

640 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

648 -- bool is True, lhs and rhs must be convertible

641 -- bool is True, lhs and rhs must be convertible

@@ -652,11 +645,32 @@ deriving instance Binary PDecl'

652deriving instance NFData PDecl'

645deriving instance NFData PDecl'

653!-}

646!-}

654

647

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+

655−-- For elaborator state

669+-- | For elaborator state

656data EState = EState {

670data EState = EState {

657− case_decls :: [PDecl],

671+ case_decls :: [(Name, PDecl)],

658 delayed_elab :: [Elab' EState ()],

672 delayed_elab :: [Elab' EState ()],

659− new_tyDecls :: [(Name, FC, [PArg], Type)]

673+ new_tyDecls :: [RDeclInstructions]

660 }

674 }

661

675

662initEState :: EState

676initEState :: EState

@@ -829,7 +843,8 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

829 | PNoImplicits PTerm -- ^ never run implicit converions on the term

843 | PNoImplicits PTerm -- ^ never run implicit converions on the term

830 | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])

844 | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])

831 | PUnquote PTerm -- ^ ~Term

845 | PUnquote PTerm -- ^ ~Term

846+ | PQuoteName Name -- ^ `{n}

832− | PRunTactics FC PTerm -- ^ %runTactics tm - New-style proof script

847+ | PRunElab FC PTerm -- ^ %runElab tm - New-style proof script

833 deriving (Eq, Data, Typeable)

848 deriving (Eq, Data, Typeable)

834

849

835

850

@@ -1048,6 +1063,7 @@ highestFC (PUnifyLog tm) = highestFC tm

1048highestFC (PNoImplicits tm) = highestFC tm

1063highestFC (PNoImplicits tm) = highestFC tm

1049highestFC (PQuasiquote _ _) = Nothing

1064highestFC (PQuasiquote _ _) = Nothing

1050highestFC (PUnquote tm) = highestFC tm

1065highestFC (PUnquote tm) = highestFC tm

1066+highestFC (PQuoteName _) = Nothing

1051

1067

1052-- Type class data

1068-- Type class data

1053

1069

@@ -1086,20 +1102,7 @@ deriving instance Binary OptInfo

1086deriving instance NFData OptInfo

1102deriving instance NFData OptInfo

1087!-}

1103!-}

1088

1104

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

1105+-- | Syntactic sugar info

1102−

1103data DSL' t = DSL { dsl_bind :: t,

1106data DSL' t = DSL { dsl_bind :: t,

1104 dsl_return :: t,

1107 dsl_return :: t,

1105 dsl_apply :: t,

1108 dsl_apply :: t,

@@ -1261,14 +1264,14 @@ infP = P (TCon 6 0) inferTy (TType (UVal 0))

1261

1264

1262getInferTerm, getInferType :: Term -> Term

1265getInferTerm, getInferType :: Term -> Term

1263getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

1266getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

1264−getInferTerm (App (App _ _) tm) = tm

1267+getInferTerm (App _ (App _ _ _) tm) = tm

1265getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1268getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1266

1269

1267getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1270getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1268 where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1271 where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1269 toTy (PVar t) = PVTy t

1272 toTy (PVar t) = PVTy t

1270 toTy b = b

1273 toTy b = b

1271−getInferType (App (App _ ty) _) = ty

1274+getInferType (App _ (App _ _ ty) _) = ty

1272

1275

1273

1276

1274

1277

@@ -1436,16 +1439,16 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1436 prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n

1439 prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n

1437 prettySe p bnd (PLam fc n ty sc) =

1440 prettySe p bnd (PLam fc n ty sc) =

1438 bracket p startPrec . group . align . hang 2 $

1441 bracket p startPrec . group . align . hang 2 $

1439− text "\\" <> bindingOf n False <+> text "=>" <$>

1442+ text "\\" <> prettyBindingOf n False <+> text "=>" <$>

1440 prettySe startPrec ((n, False):bnd) sc

1443 prettySe startPrec ((n, False):bnd) sc

1441 prettySe p bnd (PLet fc n ty v sc) =

1444 prettySe p bnd (PLet fc n ty v sc) =

1442 bracket p startPrec . group . align $

1445 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) </>

1444 kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)

1447 kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc)

1445 prettySe p bnd (PPi (Exp l s _) n ty sc)

1448 prettySe p bnd (PPi (Exp l s _) n ty sc)

1446 | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1449 | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1447 bracket p startPrec . group $

1450 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) <+>

1449 st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc

1452 st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc

1450 | otherwise =

1453 | otherwise =

1451 bracket p startPrec . group $

1454 bracket p startPrec . group $

@@ -1458,7 +1461,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1458 prettySe p bnd (PPi (Imp l s _ fa) n ty sc)

1461 prettySe p bnd (PPi (Imp l s _ fa) n ty sc)

1459 | ppopt_impl ppo =

1462 | ppopt_impl ppo =

1460 bracket p startPrec $

1463 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 <+>

1462 st <> text "->" </> prettySe startPrec ((n, True):bnd) sc

1465 st <> text "->" </> prettySe startPrec ((n, True):bnd) sc

1463 | otherwise = prettySe startPrec ((n, True):bnd) sc

1466 | otherwise = prettySe startPrec ((n, True):bnd) sc

1464 where

1467 where

@@ -1612,9 +1615,18 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1612 prettySe p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe p [] t <> text ")"

1615 prettySe p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe p [] t <> text ")"

1613 prettySe p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe p [] t <+> colon <+> prettySe p [] g <> text ")"

1616 prettySe p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe p [] t <+> colon <+> prettySe p [] g <> text ")"

1614 prettySe p bnd (PUnquote t) = text "~" <> prettySe p bnd t

1617 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 "}"

1615

1619

1616 prettySe p bnd _ = text "missing pretty-printer for term"

1620 prettySe p bnd _ = text "missing pretty-printer for term"

1617

1621

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+

1618 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1630 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1619 prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1631 prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1620 prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

1632 prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

@@ -1636,6 +1648,8 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1636 basename (NS n _) = basename n

1648 basename (NS n _) = basename n

1637 basename n = n

1649 basename n = n

1638

1650

1651+ slist' _ _ e

1652+ | containsHole e = Nothing

1639 slist' p bnd (PApp _ (PRef _ nil) _)

1653 slist' p bnd (PApp _ (PRef _ nil) _)

1640 | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

1654 | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

1641 slist' p bnd (PRef _ nil)

1655 slist' p bnd (PRef _ nil)

@@ -1765,9 +1779,6 @@ showDeclImp o (PInstance _ _ _ _ cs n _ t _ ds)

1765showDeclImp _ _ = text "..."

1779showDeclImp _ _ = text "..."

1766-- showDeclImp (PImport o) = "import " ++ o

1780-- showDeclImp (PImport o) = "import " ++ o

1767

1781

1768−instance Show (Doc OutputAnnotation) where

1769− show = flip (displayS . renderCompact) ""

1770−

1771getImps :: [PArg] -> [(Name, PTerm)]

1782getImps :: [PArg] -> [(Name, PTerm)]

1772getImps [] = []

1783getImps [] = []

1773getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

1784getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

@@ -1905,31 +1916,35 @@ allNamesIn tm = nub $ ni [] tm

1905 niTacImp env (TacImp _ _ scr) = ni env scr

1916 niTacImp env (TacImp _ _ scr) = ni env scr

1906 niTacImp _ _ = []

1917 niTacImp _ _ = []

1907

1918

1919+

1908-- Return all names defined in binders in the given term

1920-- Return all names defined in binders in the given term

1909boundNamesIn :: PTerm -> [Name]

1921boundNamesIn :: PTerm -> [Name]

1910−boundNamesIn tm = nub $ ni tm

1922+boundNamesIn tm = S.toList (ni S.empty tm)

1911 where -- TODO THINK Added niTacImp, but is it right?

1923 where -- TODO THINK Added niTacImp, but is it right?

1912− ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1924+ ni set (PApp _ f as) = niTms (ni set f) (map getTm as)

1913− ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1925+ ni set (PAppBind _ f as) = niTms (ni set f) (map getTm as)

1914− ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1926+ ni set (PCase _ c os) = niTms (ni set c) (map snd os)

1915− ni (PLam fc n ty sc) = n : (ni ty ++ ni sc)

1927+ ni set (PLam fc n ty sc) = S.insert n $ ni (ni set ty) sc

1916− ni (PLet fc n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1928+ ni set (PLet fc n ty val sc) = S.insert n $ ni (ni (ni set ty) val) sc

1917− ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))

1929+ ni set (PPi p n ty sc) = niTacImp (S.insert n $ ni (ni set ty) sc) p

1918− ni (PEq _ _ _ l r) = ni l ++ ni r

1930+ ni set (PEq _ _ _ l r) = ni (ni set l) r

1919− ni (PRewrite _ l r _) = ni l ++ ni r

1931+ ni set (PRewrite _ l r _) = ni (ni set l) r

1920− ni (PTyped l r) = ni l ++ ni r

1932+ ni set (PTyped l r) = ni (ni set l) r

1921− ni (PPair _ _ l r) = ni l ++ ni r

1933+ ni set (PPair _ _ l r) = ni (ni set l) r

1922− ni (PDPair _ _ (PRef _ n) t r) = ni t ++ ni r

1934+ ni set (PDPair _ _ (PRef _ n) t r) = ni (ni set t) r

1923− ni (PDPair _ _ l t r) = ni l ++ ni t ++ ni r

1935+ ni set (PDPair _ _ l t r) = ni (ni (ni set l) t) r

1924− ni (PAlternative a as) = concatMap (ni) as

1936+ ni set (PAlternative a as) = niTms set as

1925− ni (PHidden tm) = ni tm

1937+ ni set (PHidden tm) = ni set tm

1926− ni (PUnifyLog tm) = ni tm

1938+ ni set (PUnifyLog tm) = ni set tm

1927− ni (PDisamb _ tm) = ni tm

1939+ ni set (PDisamb _ tm) = ni set tm

1928− ni (PNoImplicits tm) = ni tm

1940+ ni set (PNoImplicits tm) = ni set tm

1929− ni _ = []

1941+ ni set _ = set

1930−

1942+

1943+ niTms set [] = set

1944+ niTms set (x : xs) = niTms (ni set x) xs

1945+

1931− niTacImp (TacImp _ _ scr) = ni scr

1946+ niTacImp set (TacImp _ _ scr) = ni set scr

1932− niTacImp _ = []

1947+ niTacImp set _ = set

1933

1948

1934-- Return names which are valid implicits in the given term (type).

1949-- Return names which are valid implicits in the given term (type).

1935implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]

1950implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]

src/Idris/Apropos.hs+1−1

@@ -77,7 +77,7 @@ instance Apropos (TT Name) where

77 isApropos str (P (DCon _ _ _) n ty) = isApropos str n || isApropos str ty

78 isApropos str (P Bound _ ty) = isApropos str ty

79 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

81 isApropos str (Constant const) = isApropos str const

82 isApropos str _ = False

83

src/Idris/CaseSplit.hs+2−2

@@ -10,13 +10,13 @@ module Idris.CaseSplit(splitOnLine, replaceSplits,

10import Idris.AbsSyntax

11import Idris.AbsSyntaxTree (Idris, IState, PTerm)

12import Idris.ElabDecls

13−import Idris.ElabTerm

14import Idris.Delaborate

13import Idris.Delaborate

15import Idris.Parser

14import Idris.Parser

16import Idris.Error

15import Idris.Error

17import Idris.Output

16import Idris.Output

18

17

19import Idris.Elab.Value

18import Idris.Elab.Value

19+import Idris.Elab.Term

20

21import Idris.Core.TT

22import Idris.Core.Typecheck

@@ -69,7 +69,7 @@ split n t'

69 let t = mergeUserImpl (addImplPat ist t') (delab ist tm)

70 let ctxt = tt_ctxt ist

71 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"

73 Just ty ->

74 do let splits = findPats ist ty

75 iLOG ("New patterns " ++ showSep ", "

src/Idris/Chaser.hs+13−2

@@ -15,6 +15,7 @@ import Control.Monad.State

15import Data.List

16

17import Debug.Trace

18+import Util.System (readSource, writeSource)

18

19

19data ModuleTree = MTree { mod_path :: IFileType,

20data ModuleTree = MTree { mod_path :: IFileType,

20 mod_needsRecheck :: Bool,

21 mod_needsRecheck :: Bool,

@@ -64,6 +65,16 @@ getModuleFiles ts = nub $ execState (modList ts) [] where

64 then getSrc x : updateToSrc path xs

65 then getSrc x : updateToSrc path xs

65 else x : updateToSrc path xs

66 else x : updateToSrc path xs

66

67

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+

67getIModTime (IBC i _) = getModificationTime i

78getIModTime (IBC i _) = getModificationTime i

68getIModTime (IDR i) = getModificationTime i

79getIModTime (IDR i) = getModificationTime i

69getIModTime (LIDR i) = getModificationTime i

80getIModTime (LIDR i) = getModificationTime i

@@ -78,7 +89,7 @@ buildTree built fp = btree [] fp

78 where

89 where

79 btree done f =

90 btree done f =

80 do i <- getIState

91 do i <- getIState

81− let file = takeWhile (/= ' ') f

92+ let file = extractFileName f

82 iLOG $ "CHASING " ++ show file

93 iLOG $ "CHASING " ++ show file

83 ibcsd <- valIBCSubDir i

94 ibcsd <- valIBCSubDir i

84 ids <- allImportDirs

95 ids <- allImportDirs

@@ -133,7 +144,7 @@ buildTree built fp = btree [] fp

133 children lit f done = -- idrisCatch

144 children lit f done = -- idrisCatch

134 do exist <- runIO $ doesFileExist f

145 do exist <- runIO $ doesFileExist f

135 if exist then do

146 if exist then do

136− file_in <- runIO $ readFile f

147+ file_in <- runIO $ readSource f

137 file <- if lit then tclift $ unlit f file_in else return file_in

148 file <- if lit then tclift $ unlit f file_in else return file_in

138 (_, _, modules, _) <- parseImports f file

149 (_, _, modules, _) <- parseImports f file

139 -- The chaser should never report warnings from sub-modules

150 -- The chaser should never report warnings from sub-modules

src/Idris/Core/Binary.hs+48−14

@@ -3,10 +3,13 @@

3{-| Binary instances for the core datatypes -}

4module Idris.Core.Binary where

5

6+import Control.Applicative ((<*>), (<$>))

7+import Control.Monad (liftM2)

8+

6import Data.Binary

9import Data.Binary

7import Data.Vector.Binary

10import Data.Vector.Binary

8import qualified Data.Text as T

11import qualified Data.Text as T

9−

12+import qualified Data.Text.Encoding as E

10import Idris.Core.TT

13import Idris.Core.TT

11

14

12instance Binary ErrorReportPart where

15instance Binary ErrorReportPart where

@@ -43,6 +46,22 @@ instance Binary Provenance where

43 return (TooManyArgs x1)

46 return (TooManyArgs x1)

44 _ -> error "Corrupted binary data for Provenance"

47 _ -> error "Corrupted binary data for Provenance"

45

48

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+

46instance Binary a => Binary (Err' a) where

65instance Binary a => Binary (Err' a) where

47 put (Msg str) = do putWord8 0

66 put (Msg str) = do putWord8 0

48 put str

67 put str

@@ -97,7 +116,12 @@ instance Binary a => Binary (Err' a) where

97 put ns

116 put ns

98 put (IncompleteTerm t) = do putWord8 17

117 put (IncompleteTerm t) = do putWord8 17

99 put t

118 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

101 put (UniqueError u n) = do putWord8 19

125 put (UniqueError u n) = do putWord8 19

102 put u

126 put u

103 put n

127 put n

@@ -142,16 +166,18 @@ instance Binary a => Binary (Err' a) where

142 put t

166 put t

143 put (CantMatch t) = do putWord8 35

167 put (CantMatch t) = do putWord8 35

144 put t

168 put t

145− put (ElabDebug x1 x2 x3) = do putWord8 36

169+ put (ElabScriptDebug x1 x2 x3) = do putWord8 36

146− put x1

170+ put x1

147− put x2

171+ put x2

148− put x3

172+ put x3

149 put (NoEliminator s t) = do putWord8 37

173 put (NoEliminator s t) = do putWord8 37

150 put s

174 put s

151 put t

175 put t

152 put (InvalidTCArg n t) = do putWord8 38

176 put (InvalidTCArg n t) = do putWord8 38

153 put n

177 put n

154 put t

178 put t

179+ put (ElabScriptStuck x1) = do putWord8 39

180+ put x1

155

181

156 get = do i <- getWord8

182 get = do i <- getWord8

157 case i of

183 case i of

@@ -181,7 +207,7 @@ instance Binary a => Binary (Err' a) where

181 15 -> fmap (CantResolve False) get

207 15 -> fmap (CantResolve False) get

182 16 -> fmap CantResolveAlts get

208 16 -> fmap CantResolveAlts get

183 17 -> fmap IncompleteTerm get

209 17 -> fmap IncompleteTerm get

184− 18 -> return UniverseError

210+ 18 -> UniverseError <$> get <*> get <*> get <*> get <*> get

185 19 -> do x <- get ; y <- get

211 19 -> do x <- get ; y <- get

186 return $ UniqueError x y

212 return $ UniqueError x y

187 20 -> do x <- get ; y <- get

213 20 -> do x <- get ; y <- get

@@ -210,13 +236,15 @@ instance Binary a => Binary (Err' a) where

210 36 -> do x1 <- get

236 36 -> do x1 <- get

211 x2 <- get

237 x2 <- get

212 x3 <- get

238 x3 <- get

213− return (ElabDebug x1 x2 x3)

239+ return (ElabScriptDebug x1 x2 x3)

214 37 -> do x1 <- get

240 37 -> do x1 <- get

215 x2 <- get

241 x2 <- get

216 return (NoEliminator x1 x2)

242 return (NoEliminator x1 x2)

217 38 -> do x1 <- get

243 38 -> do x1 <- get

218 x2 <- get

244 x2 <- get

219 return (InvalidTCArg x1 x2)

245 return (InvalidTCArg x1 x2)

246+ 39 -> do x1 <- get

247+ return (ElabScriptStuck x1)

220 _ -> error "Corrupted binary data for Err'"

248 _ -> error "Corrupted binary data for Err'"

221----- Generated by 'derive'

249----- Generated by 'derive'

222

250

@@ -267,9 +295,9 @@ instance Binary Name where

267 _ -> error "Corrupted binary data for Name"

295 _ -> error "Corrupted binary data for Name"

268

296

269instance Binary T.Text where

297instance Binary T.Text where

270− put x = put (str x)

298+ put x = put (E.encodeUtf8 x)

271 get = do x <- get

299 get = do x <- get

272− return (txt x)

300+ return (E.decodeUtf8 x)

273

301

274instance Binary SpecialName where

302instance Binary SpecialName where

275 put x

303 put x

@@ -292,6 +320,9 @@ instance Binary SpecialName where

292 WithN x1 x2 -> do putWord8 7

320 WithN x1 x2 -> do putWord8 7

293 put x1

321 put x1

294 put x2

322 put x2

323+ MetaN x1 x2 -> do putWord8 8

324+ put x1

325+ put x2

295 get

326 get

296 = do i <- getWord8

327 = do i <- getWord8

297 case i of

328 case i of

@@ -316,6 +347,9 @@ instance Binary SpecialName where

316 7 -> do x1 <- get

347 7 -> do x1 <- get

317 x2 <- get

348 x2 <- get

318 return (WithN x1 x2)

349 return (WithN x1 x2)

350+ 8 -> do x1 <- get

351+ x2 <- get

352+ return (MetaN x1 x2)

319 _ -> error "Corrupted binary data for SpecialName"

353 _ -> error "Corrupted binary data for SpecialName"

320

354

321

355

@@ -555,9 +589,9 @@ instance {- (Binary n) => -} Binary (TT Name) where

555 put x1

589 put x1

556 put x2

590 put x2

557 put x3

591 put x3

558− App x1 x2 -> do putWord8 3

592+ App _ x1 x2 -> do putWord8 3

559− put x1

593+ put x1

560− put x2

594+ put x2

561 Constant x1 -> do putWord8 4

595 Constant x1 -> do putWord8 4

562 put x1

596 put x1

563 Proj x1 x2 -> do putWord8 5

597 Proj x1 x2 -> do putWord8 5

@@ -584,7 +618,7 @@ instance {- (Binary n) => -} Binary (TT Name) where

584 return (Bind x1 x2 x3)

618 return (Bind x1 x2 x3)

585 3 -> do x1 <- get

619 3 -> do x1 <- get

586 x2 <- get

620 x2 <- get

587− return (App x1 x2)

621+ return (App Complete x1 x2)

588 4 -> do x1 <- get

622 4 -> do x1 <- get

589 return (Constant x1)

623 return (Constant x1)

590 5 -> do x1 <- get

624 5 -> do x1 <- get

src/Idris/Core/CaseTree.hs+13−14

@@ -130,16 +130,15 @@ namesUsed sc = nub $ nu' [] sc where

130

131 nut ps (P _ n _) | n `elem` ps = []

132 | 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

134 nut ps (Proj t _) = nut ps t

135 nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc

136 nut ps (Bind n b sc) = nut (n:ps) sc

137 nut ps _ = []

138

139−-- Return all called functions, and which arguments are used in each argument position

139+-- | Return all called functions, and which arguments are used

140+-- in each argument position for the call, in order to help reduce

140−-- for the call, in order to help reduce compilation time, and trace all unused

141+-- compilation time, and trace all unused arguments

141−-- arguments

142−

143findCalls :: SC -> [Name] -> [(Name, [[Name]])]

142findCalls :: SC -> [Name] -> [(Name, [[Name]])]

144findCalls sc topargs = nub $ nu' topargs sc where

143findCalls sc topargs = nub $ nu' topargs sc where

145 nu' ps (Case _ n alts) = nub (concatMap (nua (n : ps)) alts)

144 nu' ps (Case _ n alts) = nub (concatMap (nua (n : ps)) alts)

@@ -155,7 +154,7 @@ findCalls sc topargs = nub $ nu' topargs sc where

155

154

156 nut ps (P Ref n _) | n `elem` ps = []

155 nut ps (P Ref n _) | n `elem` ps = []

157 | otherwise = [(n, [])] -- tmp

156 | otherwise = [(n, [])] -- tmp

158− nut ps fn@(App f a)

157+ nut ps fn@(App _ f a)

159 | (P Ref n _, args) <- unApply fn

158 | (P Ref n _, args) <- unApply fn

160 = if n `elem` ps then nut ps f ++ nut ps a

159 = if n `elem` ps then nut ps f ++ nut ps a

161 else [(n, map argNames args)] ++ concatMap (nut ps) args

160 else [(n, map argNames args)] ++ concatMap (nut ps) args

@@ -176,8 +175,8 @@ directUse (P _ n _) = [n]

176directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

175directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

177 ++ directUse t

176 ++ directUse t

178directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

177directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

179−directUse fn@(App f a)

178+directUse fn@(App _ f a)

180− | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

179+ | (P Ref (UN pfk) _, [App _ e w]) <- unApply fn,

181 pfk == txt "prim_fork"

180 pfk == txt "prim_fork"

182 = directUse e ++ directUse w -- HACK so that fork works

181 = directUse e ++ directUse w -- HACK so that fork works

183 | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,

182 | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,

@@ -210,8 +209,8 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

210isUsed :: SC -> Name -> Bool

209isUsed :: SC -> Name -> Bool

211isUsed sc n = used sc where

210isUsed sc n = used sc where

212

211

213− used (Case _ n' alts) = n == n' || or (map usedA alts)

212+ used (Case _ n' alts) = n == n' || any usedA alts

214− used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)

213+ used (ProjCase t alts) = n `elem` freeNames t || any usedA alts

215 used (STerm t) = n `elem` freeNames t

214 used (STerm t) = n `elem` freeNames t

216 used _ = False

215 used _ = False

217

216

@@ -337,7 +336,7 @@ data Pat = PCon Bool Name Int [Pat]

337

336

338toPats :: Bool -> Bool -> Term -> [Pat]

337toPats :: Bool -> Bool -> Term -> [Pat]

339toPats reflect tc f = reverse (toPat reflect tc (getArgs f)) where

338toPats 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

341 getArgs _ = []

340 getArgs _ = []

342

341

343toPat :: Bool -> Bool -> [Term] -> [Pat]

342toPat :: Bool -> Bool -> [Term] -> [Pat]

@@ -362,7 +361,7 @@ toPat reflect tc = map $ toPat' []

362 = PSuc $ toPat' [] p

361 = PSuc $ toPat' [] p

363

362

364 toPat' [] (P Bound n ty) = PV n ty

363 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

366 toPat' [] (Constant x) | isTypeConst x = PTyPat

365 toPat' [] (Constant x) | isTypeConst x = PTyPat

367 | otherwise = PConst x

366 | otherwise = PConst x

368

367

@@ -639,7 +638,7 @@ depatt ns tm = dp [] tm

639 dpa ms x (SucCase n sc) = SucCase n (dp ms sc)

638 dpa ms x (SucCase n sc) = SucCase n (dp ms sc)

640 dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)

639 dpa ms x (DefaultCase sc) = DefaultCase (dp ms sc)

641

640

642− applyMaps ms f@(App _ _)

641+ applyMaps ms f@(App _ _ _)

643 | (P nt cn pty, args) <- unApply f

642 | (P nt cn pty, args) <- unApply f

644 = let args' = map (applyMaps ms) args in

643 = let args' = map (applyMaps ms) args in

645 applyMap ms nt cn pty args'

644 applyMap ms nt cn pty args'

@@ -652,7 +651,7 @@ depatt ns tm = dp [] tm

652 same n (P _ n' _) = n == n'

651 same n (P _ n' _) = n == n'

653 same _ _ = False

652 same _ _ = False

654

653

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)

656 applyMaps ms t = t

655 applyMaps ms t = t

657

656

658-- FIXME: Do this for SucCase too

657-- FIXME: Do this for SucCase too

src/Idris/Core/Constraints.hs+8−7

@@ -145,18 +145,19 @@ solve maxUniverseLevel ucs =

145 domainOf (UVar var) = gets (fst . (M.! Var var) . domainStore)

146 domainOf (UVal val) = return (Domain val val)

147

148+ asPair :: Domain -> (Int, Int)

149+ asPair (Domain x y) = (x, y)

150+

148 updateUpperBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()

151 updateUpperBoundOf :: ConstraintFC -> UExp -> Int -> StateT SolverState TC ()

149 updateUpperBoundOf suspect (UVar var) upper = do

152 updateUpperBoundOf suspect (UVar var) upper = do

150 doms <- gets domainStore

153 doms <- gets domainStore

151 let (oldDom@(Domain lower _), suspects) = doms M.! Var var

154 let (oldDom@(Domain lower _), suspects) = doms M.! Var var

152 let newDom = Domain lower upper

155 let newDom = Domain lower upper

153− when (wipeOut newDom) $ lift $ Error $ At (ufc suspect) $ Msg $ unlines

156+ when (wipeOut newDom) $

154− $ "Universe inconsistency."

157+ lift $ Error $

155− : ("Working on: " ++ show (UVar var))

158+ UniverseError (ufc suspect) (UVar var)

156− : ("Old domain: " ++ show oldDom)

159+ (asPair oldDom) (asPair newDom)

157− : ("New domain: " ++ show newDom)

158− : "Involved constraints: "

159− : map (("\t"++) . show) (suspect : S.toList suspects)

160+ (suspect : S.toList suspects)

160 modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }

161 modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }

161 addToQueueRHS (uconstraint suspect) (Var var)

162 addToQueueRHS (uconstraint suspect) (Var var)

162 updateUpperBoundOf _ UVal{} _ = return ()

163 updateUpperBoundOf _ UVal{} _ = return ()

src/Idris/Core/DeepSeq.hs+12−3

@@ -25,6 +25,7 @@ instance NFData SpecialName where

25 rnf (CaseN x1) = rnf x1 `seq` ()

26 rnf (ElimN x1) = rnf x1 `seq` ()

27 rnf (InstanceCtorN x1) = rnf x1 `seq` ()

28+ rnf (MetaN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

28

29

29instance NFData Universe where

30instance NFData Universe where

30 rnf NullType = ()

31 rnf NullType = ()

@@ -50,6 +51,13 @@ instance NFData Provenance where

50 rnf (SourceTerm x1) = rnf x1 `seq` ()

51 rnf (SourceTerm x1) = rnf x1 `seq` ()

51 rnf (TooManyArgs x1) = rnf x1 `seq` ()

52 rnf (TooManyArgs x1) = rnf x1 `seq` ()

52

53

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+

53instance NFData Err where

61instance NFData Err where

54 rnf (Msg x1) = rnf x1 `seq` ()

62 rnf (Msg x1) = rnf x1 `seq` ()

55 rnf (InternalMsg x1) = rnf x1 `seq` ()

63 rnf (InternalMsg x1) = rnf x1 `seq` ()

@@ -85,7 +93,7 @@ instance NFData Err where

85 rnf (CantResolveAlts x1) = rnf x1 `seq` ()

93 rnf (CantResolveAlts x1) = rnf x1 `seq` ()

86 rnf (IncompleteTerm x1) = rnf x1 `seq` ()

94 rnf (IncompleteTerm x1) = rnf x1 `seq` ()

87 rnf (NoEliminator x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

95 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` ()

89 rnf ProgramLineComment = ()

97 rnf ProgramLineComment = ()

90 rnf (Inaccessible x1) = rnf x1 `seq` ()

98 rnf (Inaccessible x1) = rnf x1 `seq` ()

91 rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

99 rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

@@ -97,7 +105,8 @@ instance NFData Err where

97 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

105 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

98 rnf (ProviderError x1) = rnf x1 `seq` ()

106 rnf (ProviderError x1) = rnf x1 `seq` ()

99 rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

107 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` ()

101

110

102instance NFData ImplicitInfo where

111instance NFData ImplicitInfo where

103 rnf (Impl x1) = rnf x1 `seq` ()

112 rnf (Impl x1) = rnf x1 `seq` ()

@@ -160,7 +169,7 @@ instance (NFData n) => NFData (TT n) where

160 rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

169 rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

161 rnf (V x1) = rnf x1 `seq` ()

170 rnf (V x1) = rnf x1 `seq` ()

162 rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

171 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` ()

164 rnf (Constant x1) = rnf x1 `seq` ()

173 rnf (Constant x1) = rnf x1 `seq` ()

165 rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

174 rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

166 rnf Erased = ()

175 rnf Erased = ()

src/Idris/Core/Elaborate.hs+19−10

@@ -115,13 +115,13 @@ runElab a e ps = runStateT e (ES (ps, a) "" Nothing)

115execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux)

116execElab a e ps = execStateT e (ES (ps, a) "" Nothing)

117

118−initElaborator :: Name -> Context -> Type -> ProofState

118+initElaborator :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

119initElaborator = newProof

120

121−elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

121+elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

122−elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

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

123+ (a, ES ps' str _) <- runElab d elab ps

124− return $! (a, str)

124+ return $! (a, str)

125

126-- | Modify the auxiliary state

127updateAux :: (aux -> aux) -> Elab' aux ()

@@ -178,6 +178,14 @@ set_context :: Context -> Elab' aux ()

178set_context ctxt = do ES (p, a) logs prev <- get

179 put (ES (p { context = ctxt }, a) logs prev)

180

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+

181-- | get the proof term

189-- | get the proof term

182get_term :: Elab' aux Term

190get_term :: Elab' aux Term

183get_term = do ES p _ _ <- get

191get_term = do ES p _ _ <- get

@@ -258,7 +266,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

258 else lift $ tfail (NotInjective tm l r)

266 else lift $ tfail (NotInjective tm l r)

259 where isInj ctxt (P _ n _)

267 where isInj ctxt (P _ n _)

260 | isConName n ctxt = True

268 | isConName n ctxt = True

261− isInj ctxt (App f a) = isInj ctxt f

269+ isInj ctxt (App _ f a) = isInj ctxt f

262 isInj ctxt (Constant _) = True

270 isInj ctxt (Constant _) = True

263 isInj ctxt (TType _) = True

271 isInj ctxt (TType _) = True

264 isInj ctxt (Bind _ (Pi _ _ _) sc) = True

272 isInj ctxt (Bind _ (Pi _ _ _) sc) = True

@@ -431,7 +439,7 @@ dotterm = do ES (p, a) s m <- get

431 where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v)

439 where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v)

432 foB (Let t v) = union (findOuter h env t) (findOuter h env v)

440 foB (Let t v) = union (findOuter h env t) (findOuter h env v)

433 foB b = findOuter h env (binderTy b)

441 foB b = findOuter h env (binderTy b)

434− findOuter h env (App f a)

442+ findOuter h env (App _ f a)

435 = union (findOuter h env f) (findOuter h env a)

443 = union (findOuter h env f) (findOuter h env a)

436 findOuter h env _ = []

444 findOuter h env _ = []

437

445

@@ -541,7 +549,7 @@ prepare_apply fn imps =

541 | n `elem` hs = let n' = uniqueName n hs in

549 | n `elem` hs = let n' = uniqueName n hs in

542 Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc)

550 Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc)

543 | otherwise = Bind n (fmap (rebind hs) t) (rebind (n:hs) sc)

551 | 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)

545 rebind hs t = t

553 rebind hs t = t

546

554

547apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]

555apply, match_apply :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]

@@ -759,6 +767,7 @@ try' t1 t2 proofSearch

759 = do s <- get

767 = do s <- get

760 ps <- get_probs

768 ps <- get_probs

761 ulog <- getUnifyLog

769 ulog <- getUnifyLog

770+ ivs <- get_instances

762 case prunStateT 999999 False ps t1 s of

771 case prunStateT 999999 False ps t1 s of

763 OK ((v, _, _), s') -> do put s'

772 OK ((v, _, _), s') -> do put s'

764 return $! v

773 return $! v

@@ -779,7 +788,7 @@ try' t1 t2 proofSearch

779 recoverableErr (ProofSearchFail _) = False

788 recoverableErr (ProofSearchFail _) = False

780 recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

789 recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

781 recoverableErr (At _ e) = recoverableErr e

790 recoverableErr (At _ e) = recoverableErr e

782− recoverableErr (ElabDebug _ _ _) = False

791+ recoverableErr (ElabScriptDebug _ _ _) = False

783 recoverableErr _ = True

792 recoverableErr _ = True

784

793

785tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a

794tryCatch :: Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a

@@ -863,7 +872,7 @@ debugElaborator msg = do ps <- fmap proof get

863 hs <- get_holes

872 hs <- get_holes

864 holeInfo <- mapM getHoleInfo hs

873 holeInfo <- mapM getHoleInfo hs

865 loadState

874 loadState

866− lift . Error $ ElabDebug msg (getProofTerm (pterm ps)) holeInfo

875+ lift . Error $ ElabScriptDebug msg (getProofTerm (pterm ps)) holeInfo

867 where getHoleInfo :: Name -> Elab' aux (Name, Type, [(Name, Binder Type)])

876 where getHoleInfo :: Name -> Elab' aux (Name, Type, [(Name, Binder Type)])

868 getHoleInfo h = do focus h

877 getHoleInfo h = do focus h

869 g <- goal

878 g <- goal

src/Idris/Core/Evaluate.hs+25−23

@@ -74,12 +74,12 @@ instance Show (a -> b) where

74-- | Normalise fully type checked terms (so, assume all names/let bindings resolved)

75normaliseC :: Context -> Env -> TT Name -> TT Name

76normaliseC ctxt env t

77− = evalState (do val <- eval False ctxt [] env t []

77+ = evalState (do val <- eval False ctxt [] (map finalEntry env) t []

78 quote 0 val) initEval

79

80normaliseAll :: Context -> Env -> TT Name -> TT Name

81normaliseAll 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]

83 quote 0 val) initEval

84

85normalise :: Context -> Env -> TT Name -> TT Name

@@ -285,7 +285,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

285 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

286 -- block reduction immediately under codata (and not forced)

287 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)

289 | dly == txt "Delay" && lco == txt "LazyCodata" && not (simpl || atRepl)

290 = do let (f, _) = unApply arg

291 let ntimes' = case f of

@@ -299,11 +299,11 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

299 when spec $ setBlock False

300 evApply ntimes' stk top env [l',t',arg'] d'

301 -- 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)

303 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

304 at == txt "assert_total" && not simpl

305 = 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)

307 = do f' <- ev ntimes stk False env f

308 a' <- ev ntimes stk False env a

309 evApply ntimes stk top env [a'] f'

@@ -434,7 +434,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

434 Just (altmap, sc) -> evTree ntimes stk top env altmap sc

435 _ -> return Nothing

436

437− conHeaded tm@(App _ _)

437+ conHeaded tm@(App _ _ _)

438 | (P (DCon _ _ _) _ _, args) <- unApply tm = True

439 conHeaded t = False

440

@@ -540,7 +540,7 @@ instance Quote Value where

540 v' <- quote i v

541 let sc'' = pToV (sMN vd "vlet") (addBinder sc')

542 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)

544 quote i (VType u) = return $ TType u

545 quote i (VUType u) = return $ UType u

546 quote i VErased = return $ Erased

@@ -576,13 +576,13 @@ convEq ctxt holes topx topy = ceq [] topx topy where

576 | x `elem` holes || y `elem` holes = return True

577 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

578 | 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)))

580 = 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

582 = 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' _)))

584 | 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

586 | n == n' = ceq ps x y

587

588 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

604 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

605 ceqB ps (Pi i v t) (Pi i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

606 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)

608 ceq ps (Constant x) (Constant y) = return (x == y)

609 ceq ps (TType x) (TType y) = do (v, cs) <- get

610 put (v, ULE x y : cs)

@@ -887,11 +887,13 @@ addCasedef n ei ci@(CaseInfo inline alwaysInline tcdict)

887 cdef = CaseDefs (args_tot, sc_tot)

888 (args_ct, sc_ct)

889 (args_inl, sc_inl)

890− (args_rt, sc_rt) in

890+ (args_rt, sc_rt)

891− addDef n (CaseOp (ci { case_inlinable = inlc })

891+ op = (CaseOp (ci { case_inlinable = inlc })

892− ty argtys ps_in ps_tot cdef,

892+ ty argtys ps_in ps_tot cdef,

893− access, Unchecked, EmptyMI) ctxt in

893+ access, Unchecked, EmptyMI)

894+ in addDef n op ctxt

895+ other -> error ("Error adding case def: " ++ show other)

894− uctxt { definitions = ctxt' }

896+ in uctxt { definitions = ctxt' }

895

897

896-- simplify a definition for totality checking

898-- simplify a definition for totality checking

897simplifyCasedef :: Name -> ErasureInfo -> Context -> Context

899simplifyCasedef :: Name -> ErasureInfo -> Context -> Context

@@ -1009,12 +1011,12 @@ lookupP = lookupP_all False

1009

1011

1010lookupP_all :: Bool -> Name -> Context -> [Term]

1012lookupP_all :: Bool -> Name -> Context -> [Term]

1011lookupP_all all n ctxt

1013lookupP_all all n ctxt

1012− = do def <- lookupCtxt n (definitions ctxt)

1014+ = do (n', def) <- lookupCtxtName n (definitions ctxt)

1013 p <- case def of

1015 p <- case def of

1014− (Function ty tm, a, _, _) -> return (P Ref n ty, a)

1016+ (Function ty tm, a, _, _) -> return (P Ref n' ty, a)

1015− (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)

1017+ (TyDecl nt ty, a, _, _) -> return (P nt n' ty, a)

1016− (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a)

1018+ (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n' ty, a)

1017− (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)

1019+ (Operator ty _ _, a, _, _) -> return (P Ref n' ty, a)

1018 case snd p of

1020 case snd p of

1019 Hidden -> if all then return (fst p) else []

1021 Hidden -> if all then return (fst p) else []

1020 _ -> return (fst p)

1022 _ -> return (fst p)

@@ -1083,5 +1085,5 @@ uniqueBindersCtxt :: Context -> [Name] -> TT Name -> TT Name

1083uniqueBindersCtxt ctxt ns (Bind n b sc)

1085uniqueBindersCtxt ctxt ns (Bind n b sc)

1084 = let n' = uniqueNameCtxt ctxt n ns in

1086 = let n' = uniqueNameCtxt ctxt n ns in

1085 Bind n' (fmap (uniqueBindersCtxt ctxt (n':ns)) b) (uniqueBindersCtxt ctxt ns sc)

1087 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)

1087uniqueBindersCtxt ctxt ns t = t

1089uniqueBindersCtxt ctxt ns t = t

src/Idris/Core/Execute.hs+2−2

@@ -103,7 +103,7 @@ toTT (EBind n b body) = do n' <- newN n

103 return n'

104toTT (EApp e1 e2) = do e1' <- toTT e1

105 e2' <- toTT e2

106− return $ App e1' e2'

106+ return $ App Complete e1' e2'

107toTT (EType u) = return $ TType u

108toTT (EUType u) = return $ UType u

109toTT EErased = return Erased

@@ -192,7 +192,7 @@ doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

192doExec env ctxt tm@(Bind n b body) = do b' <- forM b (doExec env ctxt)

193 return $

194 EBind n b' (\arg -> doExec ((n, arg):env) ctxt body)

195−doExec env ctxt a@(App _ _) =

195+doExec env ctxt a@(App _ _ _) =

196 do let (f, args) = unApply a

197 f' <- doExec env ctxt f

198 args' <- case f' of

src/Idris/Core/ProofState.hs+44−19

@@ -41,6 +41,7 @@ data ProofState = PS { thname :: Name,

41 autos :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes

42 previous :: Maybe ProofState, -- ^ for undo

43 context :: Context,

44+ datatypes :: Ctxt TypeInfo,

44 plog :: String,

45 plog :: String,

45 unifylog :: Bool,

46 unifylog :: Bool,

46 done :: Bool,

47 done :: Bool,

@@ -292,14 +293,15 @@ query q = do ps <- get

292addLog :: Monad m => String -> StateT TState m ()

293addLog :: Monad m => String -> StateT TState m ()

293addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

294addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

294

295

295−newProof :: Name -> Context -> Type -> ProofState

296+newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

297+newProof n ctxt datatypes ty =

296−newProof n ctxt ty = let h = holeName 0

298+ let h = holeName 0

297− ty' = vToP ty

299+ ty' = vToP ty

298− in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

300+ in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

299− (P Bound h ty'))) ty [] (h, []) [] []

301+ (P Bound h ty'))) ty [] (h, []) [] []

300− Nothing [] []

302+ Nothing [] []

301− [] [] []

303+ [] [] []

302− Nothing ctxt "" False False [] []

304+ Nothing ctxt datatypes "" False False [] []

303

305

304type TState = ProofState -- [TacticAction])

306type TState = ProofState -- [TacticAction])

305type RunTactic = RunTactic' TState

307type RunTactic = RunTactic' TState

@@ -328,7 +330,7 @@ computeLet ctxt n tm = cl [] tm where

328 | n' == n = let v' = normalise ctxt env v in

330 | n' == n = let v' = normalise ctxt env v in

329 Bind n' (Let t v') sc

331 Bind n' (Let t v') sc

330 cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, b):env) sc)

332 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)

332 cl env t = t

334 cl env t = t

333

335

334attack :: RunTactic

336attack :: RunTactic

@@ -551,13 +553,36 @@ solve ctxt env (Bind x (Guess ty val) sc)

551 recents = x : recents ps,

553 recents = x : recents ps,

552 instances = instances ps \\ [x],

554 instances = instances ps \\ [x],

553 dotted = dropUnified dropdots (dotted ps) })

555 dotted = dropUnified dropdots (dotted ps) })

554− let tm' = subst x val sc in

556+ let (locked, did) = tryLock (holes ps \\ [x]) (updsubst x val sc) in

555− return tm'

557+ return locked

556 where dropUnified ddots [] = []

558 where dropUnified ddots [] = []

557 dropUnified ddots ((x, es) : ds)

559 dropUnified ddots ((x, es) : ds)

558 | x `elem` ddots || any (\e -> e `elem` ddots) es

560 | x `elem` ddots || any (\e -> e `elem` ddots) es

559 = dropUnified ddots ds

561 = dropUnified ddots ds

560 | otherwise = (x, es) : dropUnified ddots ds

562 | 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+

561solve _ _ h@(Bind x t sc)

586solve _ _ h@(Bind x t sc)

562 = do ps <- get

587 = do ps <- get

563 case findType x sc of

588 case findType x sc of

@@ -581,7 +606,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

581 (tyv, tyt) <- lift $ check ctxt env ty

606 (tyv, tyt) <- lift $ check ctxt env ty

582-- ns <- lift $ unify ctxt env tyv t'

607-- ns <- lift $ unify ctxt env tyv t'

583 case t' of

608 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

585 do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)

610 do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)

586 ps <- get

611 ps <- get

587 let (uh, uns) = unified ps

612 let (uh, uns) = unified ps

@@ -600,7 +625,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

600 _ -> hnf ctxt env t

625 _ -> hnf ctxt env t

601 case t' of

626 case t' of

602 Bind y (Pi _ s _) t -> -- trace ("in type " ++ show t') $

627 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

604 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

629 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

605 _ -> lift $ tfail $ CantIntroduce t'

630 _ -> lift $ tfail $ CantIntroduce t'

606intro n ctxt env _ = fail "Can't introduce here."

631intro n ctxt env _ = fail "Can't introduce here."

@@ -623,7 +648,7 @@ patvar n ctxt env (Bind x (Hole t) sc) =

623 (notunified ps),

648 (notunified ps),

624 injective = addInj n x (injective ps)

649 injective = addInj n x (injective ps)

625 })

650 })

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)

627 where addInj n x ps | x `elem` ps = n : ps

652 where addInj n x ps | x `elem` ps = n : ps

628 | otherwise = ps

653 | otherwise = ps

629patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

654patvar 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"

638

663

639expandLet :: Name -> Term -> RunTactic

664expandLet :: Name -> Term -> RunTactic

640expandLet n v ctxt env tm =

665expandLet n v ctxt env tm =

641− return $ subst n v tm

666+ return $ updsubst n v tm

642

667

643rewrite :: Raw -> RunTactic

668rewrite :: Raw -> RunTactic

644rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

669rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

@@ -661,9 +686,9 @@ rewrite _ _ _ _ = fail "Can't rewrite here"

661-- an x, and put \x : lt in front

686-- an x, and put \x : lt in front

662mkP :: TT Name -> TT Name -> TT Name -> TT Name -> TT Name

687mkP :: TT Name -> TT Name -> TT Name -> TT Name -> TT Name

663mkP lt l r ty | l == ty = lt

688mkP 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

689+mkP lt l r (App s 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

690+ a' = if (r /= a) then mkP lt l r a else a in

666− App f' a'

691+ App s f' a'

667mkP lt l r (Bind n b sc)

692mkP lt l r (Bind n b sc)

668 = let b' = mkPB b

693 = let b' = mkPB b

669 sc' = if (r /= sc) then mkP lt l r sc else sc in

694 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' =

750 x@(Bind y (PVTy s) t) -> x

775 x@(Bind y (PVTy s) t) -> x

751 _ -> hnf ctxt env t

776 _ -> hnf ctxt env t

752 case t' of

777 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

754 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

779 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

755 _ -> fail "Nothing to pattern bind"

780 _ -> fail "Nothing to pattern bind"

756patbind n ctxt env _ = fail "Can't pattern bind here"

781patbind 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.

7

8module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,

9 updateSolved, updateSolvedTerm, updateSolvedTerm',

10− bound_in, bound_in_term, refocus,

10+ bound_in, bound_in_term, refocus, updsubst,

11 Hole, RunTactic',

12 goal, atHole) where

13

@@ -21,8 +21,8 @@ import Debug.Trace

21

22-- | A zipper over terms, in order to efficiently update proof terms.

23data TermPath = Top

24− | AppL TermPath Term

24+ | AppL (AppStatus Name) TermPath Term

25− | AppR Term TermPath

25+ | AppR (AppStatus Name) Term TermPath

26 | InBind Name BinderPath Term

27 | InScope Name (Binder Term) TermPath

28 deriving Show

@@ -39,8 +39,8 @@ data BinderPath = Binder (Binder TermPath)

39-- words, "graft" one term path into another.

40replaceTop :: TermPath -> TermPath -> TermPath

41replaceTop p Top = p

42−replaceTop p (AppL l t) = AppL (replaceTop p l) t

42+replaceTop p (AppL s l t) = AppL s (replaceTop p l) t

43−replaceTop p (AppR t r) = AppR t (replaceTop p r)

43+replaceTop p (AppR s t r) = AppR s t (replaceTop p r)

44replaceTop p (InBind n bp sc) = InBind n (replaceTopB p bp) sc

45 where

46 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)

53-- | Build a term from a zipper, given something to put in the hole.

54rebuildTerm :: Term -> TermPath -> Term

55rebuildTerm tm Top = tm

56−rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a

56+rebuildTerm tm (AppL s p a) = App s (rebuildTerm tm p) a

57−rebuildTerm tm (AppR f p) = App f (rebuildTerm tm p)

57+rebuildTerm tm (AppR s f p) = App s f (rebuildTerm tm p)

58rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p)

59rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc

60

@@ -73,9 +73,10 @@ findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term)

73findHole n env t = fh' env Top t where

74 fh' env path tm@(Bind x h sc)

75 | hole h && n == x = Just (path, env, tm)

76− fh' env path (App f a)

76+ fh' env path (App Complete _ _) = Nothing

77+ fh' env path (App s 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 a = Just (AppR s f p, env', tm)

78− | Just (p, env', tm) <- fh' env path f = Just (AppL p a, env', tm)

79+ | Just (p, env', tm) <- fh' env path f = Just (AppL s p a, env', tm)

79 fh' env path (Bind x b sc)

80 fh' env path (Bind x b sc)

80 | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)

81 | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)

81 | Just (p, env', tm) <- fh' ((x,b):env) path sc = Just (InScope x b p, env', tm)

82 | 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)

112 -- First look for the hole in the proof term as-is

113 -- First look for the hole in the proof term as-is

113 | Just (p', env', tm') <- findHole n env tm

114 | Just (p', env', tm') <- findHole n env tm

114 = PT (replaceTop p' path) env' tm' ups

115 = 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

116 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))

117 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))

117 = PT p' env' tm' []

118 = PT p' env' tm' []

118 | otherwise = pt

119 | otherwise = pt

@@ -156,19 +157,20 @@ updateSolvedTerm' xs x = updateSolved' xs x where

156 updateSolved' xs (Bind n (Hole ty) t)

157 updateSolved' xs (Bind n (Hole ty) t)

157 | Just v <- lookup n xs

158 | Just v <- lookup n xs

158 = case xs of

159 = 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

160 -- explicit names

161 -- explicit names

161 _ -> let (t', _) = updateSolved' xs t in

162 _ -> let (t', _) = updateSolved' xs t in

162− (subst n v t', True)

163+ (updsubst n v t', True)

163 updateSolved' xs tm@(Bind n b t)

164 updateSolved' xs tm@(Bind n b t)

164 | otherwise = let (t', ut) = updateSolved' xs t

165 | otherwise = let (t', ut) = updateSolved' xs t

165 (b', ub) = updateSolvedB' xs b in

166 (b', ub) = updateSolvedB' xs b in

166 if ut || ub then (Bind n b' t', True)

167 if ut || ub then (Bind n b' t', True)

167 else (tm, False)

168 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)

169 = let (f', uf) = updateSolved' xs f

171 = let (f', uf) = updateSolved' xs f

170 (a', ua) = updateSolved' xs a in

172 (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)

172 else (t, False)

174 else (t, False)

173 updateSolved' xs t@(P _ n@(MN _ _) _)

175 updateSolved' xs t@(P _ n@(MN _ _) _)

174 | Just v <- lookup n xs = (v, True)

176 | Just v <- lookup n xs = (v, True)

@@ -189,7 +191,7 @@ updateSolvedTerm' xs x = updateSolved' xs x where

189 if u then (b { binderTy = ty' }, u) else (b, False)

191 if u then (b { binderTy = ty' }, u) else (b, False)

190

192

191 noneOf ns (P _ n _) | n `elem` ns = False

193 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

193 noneOf ns (Bind n (Hole ty) t) = n `notElem` ns && noneOf ns ty && noneOf ns t

195 noneOf ns (Bind n (Hole ty) t) = n `notElem` ns && noneOf ns ty && noneOf ns t

194 noneOf ns (Bind n b t) = noneOf ns t && noneOfB ns b

196 noneOf ns (Bind n b t) = noneOf ns t && noneOfB ns b

195 where

197 where

@@ -198,6 +200,49 @@ updateSolvedTerm' xs x = updateSolved' xs x where

198 noneOfB ns b = noneOf ns (binderTy b)

200 noneOfB ns b = noneOf ns (binderTy b)

199 noneOf ns _ = True

201 noneOf ns _ = True

200

202

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+

201-- | Apply solutions to an environment.

246-- | Apply solutions to an environment.

202updateEnv :: [(Name, Term)] -> Env -> Env

247updateEnv :: [(Name, Term)] -> Env -> Env

203updateEnv [] e = e

248updateEnv [] e = e

@@ -208,8 +253,10 @@ updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns e

208updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath

253updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath

209updateSolvedPath [] t = t

254updateSolvedPath [] t = t

210updateSolvedPath ns Top = Top

255updateSolvedPath ns Top = Top

256+updateSolvedPath ns t@(AppL Complete _ _) = t

257+updateSolvedPath ns t@(AppR Complete _ _) = t

211−updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)

258+updateSolvedPath ns (AppL s p r) = AppL s (updateSolvedPath ns p) (updateSolvedTerm ns r)

212−updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) (updateSolvedPath ns p)

259+updateSolvedPath ns (AppR s l p) = AppR s (updateSolvedTerm ns l) (updateSolvedPath ns p)

213updateSolvedPath ns (InBind n b sc)

260updateSolvedPath ns (InBind n b sc)

214 = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc)

261 = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc)

215 where

262 where

@@ -246,7 +293,8 @@ goal h pt@(PT path env sub ups)

246 g env (Bind n b sc) | hole b && same h n = return $ GD env b

293 g env (Bind n b sc) | hole b && same h n = return $ GD env b

247 | otherwise

294 | otherwise

248 = g ((n, b):env) sc `mplus` gb env b

295 = g ((n, b):env) sc `mplus` gb env b

296+ g env (App Complete f a) = fail "Can't find hole"

249− g env (App f a) = g env a `mplus` g env f

297+ g env (App _ f a) = g env a `mplus` g env f

250 g env t = fail "Can't find hole"

298 g env t = fail "Can't find hole"

251

299

252 gb env (Let t v) = g env v `mplus` g env t

300 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)

291 if u then return (Bind n b sc', True)

339 if u then return (Bind n b sc', True)

292 else do (b', u) <- atHb f c env b

340 else do (b', u) <- atHb f c env b

293 return (Bind n b' sc', u)

341 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

295 atH tac c env t = return (t, False)

343 atH tac c env t = return (t, False)

296

344

297 atHb f c env (Let t v) = ulift2 f c env Let t v

345 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

308 bi (Let t v) = bound_in_term t ++ bound_in_term v

356 bi (Let t v) = bound_in_term t ++ bound_in_term v

309 bi (Guess t v) = bound_in_term t ++ bound_in_term v

357 bi (Guess t v) = bound_in_term t ++ bound_in_term v

310 bi b = bound_in_term (binderTy b)

358 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

312bound_in_term _ = []

360bound_in_term _ = []

313

361

src/Idris/Core/TT.hs+111−56

@@ -1,5 +1,5 @@

1{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable #-}

2−

2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3{-| TT is the core language of Idris. The language has:

4

5 * Full dependent types

@@ -117,9 +117,6 @@ data ErrorReportPart = TextPart String

117 deriving (Show, Eq, Data, Typeable)

118

119

120−-- Please remember to keep Err synchronised with

121−-- Language.Reflection.Errors.Err in the stdlib!

122−

123data Provenance = ExpectedType

120data Provenance = ExpectedType

124 | TooManyArgs Term

121 | TooManyArgs Term

125 | InferredVal

122 | InferredVal

@@ -131,6 +128,10 @@ deriving instance NFData Err

131deriving instance Binary Err

128deriving instance Binary Err

132!-}

129!-}

133

130

131+

132+-- NB: Please remember to keep Err synchronised with

133+-- Language.Reflection.Errors.Err in the stdlib!

134+

134-- | Idris errors. Used as exceptions in the compiler, but reported to users

135-- | Idris errors. Used as exceptions in the compiler, but reported to users

135-- if they reach the top level.

136-- if they reach the top level.

136data Err' t

137data Err' t

@@ -161,7 +162,8 @@ data Err' t

161 | CantResolveAlts [Name]

162 | CantResolveAlts [Name]

162 | IncompleteTerm t

163 | IncompleteTerm t

163 | NoEliminator String t

164 | NoEliminator String t

164− | UniverseError

165+ | UniverseError FC UExp (Int, Int) (Int, Int) [ConstraintFC]

166+ -- ^ Location, bad universe, old domain, new domain, suspects

165 | UniqueError Universe Name

167 | UniqueError Universe Name

166 | UniqueKindError Universe Name

168 | UniqueKindError Universe Name

167 | ProgramLineComment

169 | ProgramLineComment

@@ -178,8 +180,9 @@ data Err' t

178 | LoadingFailed String (Err' t)

180 | LoadingFailed String (Err' t)

179 | ReflectionError [[ErrorReportPart]] (Err' t)

181 | ReflectionError [[ErrorReportPart]] (Err' t)

180 | ReflectionFailed String (Err' t)

182 | ReflectionFailed String (Err' t)

181− | ElabDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]

183+ | ElabScriptDebug (Maybe String) t [(Name, t, [(Name, Binder t)])]

182 -- ^ User-specified message, proof term, goals with context (first goal is focused)

184 -- ^ User-specified message, proof term, goals with context (first goal is focused)

185+ | ElabScriptStuck t

183 deriving (Eq, Functor, Data, Typeable)

186 deriving (Eq, Functor, Data, Typeable)

184

187

185type Err = Err' Term

188type Err = Err' Term

@@ -238,7 +241,6 @@ instance Sized Err where

238 size (NoRewriting trm) = size trm

241 size (NoRewriting trm) = size trm

239 size (CantResolveAlts _) = 1

242 size (CantResolveAlts _) = 1

240 size (IncompleteTerm trm) = size trm

243 size (IncompleteTerm trm) = size trm

241− size UniverseError = 1

242 size ProgramLineComment = 1

244 size ProgramLineComment = 1

243 size (At fc err) = size fc + size err

245 size (At fc err) = size fc + size err

244 size (Elaborating _ n err) = size err

246 size (Elaborating _ n err) = size err

@@ -365,6 +367,7 @@ data SpecialName = WhereN Int Name Name

365 | CaseN Name

367 | CaseN Name

366 | ElimN Name

368 | ElimN Name

367 | InstanceCtorN Name

369 | InstanceCtorN Name

370+ | MetaN Name Name

368 deriving (Eq, Ord, Data, Typeable)

371 deriving (Eq, Ord, Data, Typeable)

369{-!

372{-!

370deriving instance Binary SpecialName

373deriving instance Binary SpecialName

@@ -389,6 +392,9 @@ instance Pretty Name OutputAnnotation where

389 pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

392 pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

390 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

393 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

391 pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

394 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 "_"

392

398

393instance Pretty [Name] OutputAnnotation where

399instance Pretty [Name] OutputAnnotation where

394 pretty = encloseSep empty empty comma . map pretty

400 pretty = encloseSep empty empty comma . map pretty

@@ -399,6 +405,7 @@ instance Show Name where

399 show (MN _ u) | u == txt "underscore" = "_"

405 show (MN _ u) | u == txt "underscore" = "_"

400 show (MN i s) = "{" ++ str s ++ show i ++ "}"

406 show (MN i s) = "{" ++ str s ++ show i ++ "}"

401 show (SN s) = show s

407 show (SN s) = show s

408+ show (SymRef i) = "##symbol" ++ show i ++ "##"

402 show NErased = "_"

409 show NErased = "_"

403

410

404instance Show SpecialName where

411instance Show SpecialName where

@@ -410,6 +417,7 @@ instance Show SpecialName where

410 show (CaseN n) = "case block in " ++ show n

417 show (CaseN n) = "case block in " ++ show n

411 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

418 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

412 show (InstanceCtorN n) = "constructor of " ++ show n

419 show (InstanceCtorN n) = "constructor of " ++ show n

420+ show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>"

413

421

414-- Show a name in a way decorated for code generation, not human reading

422-- Show a name in a way decorated for code generation, not human reading

415showCG :: Name -> String

423showCG :: Name -> String

@@ -425,6 +433,9 @@ showCG (SN s) = showCG' s

425 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

433 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

426 showCG' (CaseN c) = showCG c ++ "_case"

434 showCG' (CaseN c) = showCG c ++ "_case"

427 showCG' (ElimN sn) = showCG sn ++ "_elim"

435 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"

428showCG NErased = "_"

439showCG NErased = "_"

429

440

430

441

@@ -643,7 +654,7 @@ data Universe = NullType | UniqueType | AllTypes

643instance Show Universe where

654instance Show Universe where

644 show UniqueType = "UniqueType"

655 show UniqueType = "UniqueType"

645 show NullType = "NullType"

656 show NullType = "NullType"

646− show AllTypes = "Type*"

657+ show AllTypes = "AnyType"

647

658

648data Raw = Var Name

659data Raw = Var Name

649 | RBind Name (Binder Raw) Raw

660 | RBind Name (Binder Raw) Raw

@@ -765,11 +776,11 @@ instance Show UExp where

765-- | Universe constraints

776-- | Universe constraints

766data UConstraint = ULT UExp UExp -- ^ Strictly less than

777data UConstraint = ULT UExp UExp -- ^ Strictly less than

767 | ULE UExp UExp -- ^ Less than or equal to

778 | ULE UExp UExp -- ^ Less than or equal to

768− deriving (Eq, Ord)

779+ deriving (Eq, Ord, Data, Typeable)

769

780

770data ConstraintFC = ConstraintFC { uconstraint :: UConstraint,

781data ConstraintFC = ConstraintFC { uconstraint :: UConstraint,

771 ufc :: FC }

782 ufc :: FC }

772− deriving Show

783+ deriving (Show, Data, Typeable)

773

784

774instance Eq ConstraintFC where

785instance Eq ConstraintFC where

775 x == y = uconstraint x == uconstraint y

786 x == y = uconstraint x == uconstraint y

@@ -806,6 +817,11 @@ instance Eq NameType where

806 TCon _ a == TCon _ b = (a == b) -- ignore tag

817 TCon _ a == TCon _ b = (a == b) -- ignore tag

807 _ == _ = False

818 _ == _ = False

808

819

820+data AppStatus n = Complete

821+ | MaybeHoles

822+ | Holes [n]

823+ deriving (Eq, Ord, Functor, Data, Typeable, Show)

824+

809-- | Terms in the core language. The type parameter is the type of

825-- | Terms in the core language. The type parameter is the type of

810-- identifiers used for bindings and explicit named references;

826-- identifiers used for bindings and explicit named references;

811-- usually we use @TT 'Name'@.

827-- usually we use @TT 'Name'@.

@@ -814,7 +830,7 @@ data TT n = P NameType n (TT n) -- ^ named references with type

814 -- Pure Type Systems Formalized)

830 -- Pure Type Systems Formalized)

815 | V !Int -- ^ a resolved de Bruijn-indexed variable

831 | V !Int -- ^ a resolved de Bruijn-indexed variable

816 | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

832 | 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

818 | Constant Const -- ^ constant

834 | Constant Const -- ^ constant

819 | Proj (TT n) !Int -- ^ argument projection; runtime only

835 | Proj (TT n) !Int -- ^ argument projection; runtime only

820 -- (-1) is a special case for 'subtract one from BI'

836 -- (-1) is a special case for 'subtract one from BI'

@@ -850,18 +866,24 @@ instance TermSize (TT Name) where

850 termsize n (Bind n' b sc)

866 termsize n (Bind n' b sc)

851 = let rn = if n == n' then sMN 0 "noname" else n in

867 = let rn = if n == n' then sMN 0 "noname" else n in

852 termsize rn sc

868 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

854 termsize n (Proj t i) = termsize n t

870 termsize n (Proj t i) = termsize n t

855 termsize n _ = 1

871 termsize n _ = 1

856

872

873+instance Sized Universe where

874+ size u = 1

875+

857instance Sized a => Sized (TT a) where

876instance Sized a => Sized (TT a) where

858 size (P name n trm) = 1 + size name + size n + size trm

877 size (P name n trm) = 1 + size name + size n + size trm

859 size (V v) = 1

878 size (V v) = 1

860 size (Bind nm binder bdy) = 1 + size nm + size binder + size bdy

879 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

862 size (Constant c) = size c

881 size (Constant c) = size c

863 size Erased = 1

882 size Erased = 1

864 size (TType u) = 1 + size u

883 size (TType u) = 1 + size u

884+ size (Proj a _) = 1 + size a

885+ size Impossible = 1

886+ size (UType u) = 1 + size u

865

887

866instance Pretty a o => Pretty (TT a) o where

888instance Pretty a o => Pretty (TT a) o where

867 pretty _ = text "test"

889 pretty _ = text "test"

@@ -875,12 +897,32 @@ data Datatype n = Data { d_typename :: n,

875 d_cons :: [(n, TT n)] }

897 d_cons :: [(n, TT n)] }

876 deriving (Show, Functor, Eq)

898 deriving (Show, Functor, Eq)

877

899

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+

878instance Eq n => Eq (TT n) where

920instance Eq n => Eq (TT n) where

879 (==) (P xt x _) (P yt y _) = x == y

921 (==) (P xt x _) (P yt y _) = x == y

880 (==) (V x) (V y) = x == y

922 (==) (V x) (V y) = x == y

881 (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

923 (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

882− (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

924+ (==) (App _ fx ax) (App _ fy ay) = ax == ay && fx == fy

883− (==) (TType _) (TType _) = True -- deal with constraints later

925+ (==) (TType _) (TType _) = True -- deal with constraints later

884 (==) (Constant x) (Constant y) = x == y

926 (==) (Constant x) (Constant y) = x == y

885 (==) (Proj x i) (Proj y j) = x == y && i == j

927 (==) (Proj x i) (Proj y j) = x == y && i == j

886 (==) Erased _ = True

928 (==) Erased _ = True

@@ -896,15 +938,15 @@ isInjective :: TT n -> Bool

896isInjective (P (DCon _ _ _) _ _) = True

938isInjective (P (DCon _ _ _) _ _) = True

897isInjective (P (TCon _ _) _ _) = True

939isInjective (P (TCon _ _) _ _) = True

898isInjective (Constant _) = True

940isInjective (Constant _) = True

899−isInjective (TType x) = True

941+isInjective (TType x) = True

900isInjective (Bind _ (Pi _ _ _) sc) = True

942isInjective (Bind _ (Pi _ _ _) sc) = True

901−isInjective (App f a) = isInjective f

943+isInjective (App _ f a) = isInjective f

902isInjective _ = False

944isInjective _ = False

903

945

904-- | Count the number of instances of a de Bruijn index in a term

946-- | Count the number of instances of a de Bruijn index in a term

905vinstances :: Int -> TT n -> Int

947vinstances :: Int -> TT n -> Int

906vinstances i (V x) | i == x = 1

948vinstances 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

908vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc

950vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc

909 where instancesB (Let t v) = vinstances i v

951 where instancesB (Let t v) = vinstances i v

910 instancesB _ = 0

952 instancesB _ = 0

@@ -916,7 +958,7 @@ instantiate e = subst 0 where

916 subst i (P nt x ty) = P nt x (subst i ty)

958 subst i (P nt x ty) = P nt x (subst i ty)

917 subst i (V x) | i == x = e

959 subst i (V x) | i == x = e

918 subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc)

960 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)

920 subst i (Proj x idx) = Proj (subst i x) idx

962 subst i (Proj x idx) = Proj (subst i x) idx

921 subst i t = t

963 subst i t = t

922

964

@@ -925,11 +967,11 @@ instantiate e = subst 0 where

925-- that has been substituted.

967-- that has been substituted.

926substV :: TT n -> TT n -> TT n

968substV :: TT n -> TT n -> TT n

927substV x tm = dropV 0 (instantiate x tm) where

969substV 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)

929 dropV i (V x) | x > i = V (x - 1)

971 dropV i (V x) | x > i = V (x - 1)

930 | otherwise = V x

972 | otherwise = V x

931 dropV i (Bind x b sc) = Bind x (fmap (dropV i) b) (dropV (i+1) sc)

973 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)

933 dropV i (Proj x idx) = Proj (dropV i x) idx

975 dropV i (Proj x idx) = Proj (dropV i x) idx

934 dropV i t = t

976 dropV i t = t

935

977

@@ -940,7 +982,7 @@ explicitNames (Bind x b sc) = let b' = fmap explicitNames b in

940 Bind x b'

982 Bind x b'

941 (explicitNames (instantiate

983 (explicitNames (instantiate

942 (P Bound x (binderTy b')) sc))

984 (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)

944explicitNames (Proj x idx) = Proj (explicitNames x) idx

986explicitNames (Proj x idx) = Proj (explicitNames x) idx

945explicitNames t = t

987explicitNames t = t

946

988

@@ -954,7 +996,7 @@ pToV' n i (Bind x b sc)

954-- resolve names from the *outer* scope which may happen to have the same id.

996-- resolve names from the *outer* scope which may happen to have the same id.

955 | n == x = Bind x (fmap (pToV' n i) b) sc

997 | n == x = Bind x (fmap (pToV' n i) b) sc

956 | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc)

998 | 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)

958pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

1000pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

959pToV' n i t = t

1001pToV' n i t = t

960

1002

@@ -965,7 +1007,7 @@ addBinder t = ab 0 t

965 ab top (V i) | i >= top = V (i + 1)

1007 ab top (V i) | i >= top = V (i + 1)

966 | otherwise = V i

1008 | otherwise = V i

967 ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc)

1009 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)

969 ab top (Proj t idx) = Proj (ab top t) idx

1011 ab top (Proj t idx) = Proj (ab top t) idx

970 ab top t = t

1012 ab top t = t

971

1013

@@ -984,14 +1026,14 @@ vToP = vToP' [] where

984 P Bound n (binderTy b)

1026 P Bound n (binderTy b)

985 vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in

1027 vToP' env (Bind n b sc) = let b' = fmap (vToP' env) b in

986 Bind n b' (vToP' ((n, b'):env) sc)

1028 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)

988 vToP' env t = t

1030 vToP' env t = t

989

1031

990-- | Replace every non-free reference to the name of a binding in

1032-- | Replace every non-free reference to the name of a binding in

991-- the given term with a de Bruijn index.

1033-- the given term with a de Bruijn index.

992finalise :: Eq n => TT n -> TT n

1034finalise :: Eq n => TT n -> TT n

993finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc))

1035finalise (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)

995finalise t = t

1037finalise t = t

996

1038

997-- Once we've finished checking everything about a term we no longer need

1039-- Once we've finished checking everything about a term we no longer need

@@ -999,7 +1041,7 @@ finalise t = t

999

1041

1000pEraseType :: TT n -> TT n

1042pEraseType :: TT n -> TT n

1001pEraseType (P nt t _) = P nt t Erased

1043pEraseType (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)

1003pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc)

1045pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc)

1004pEraseType t = t

1046pEraseType t = t

1005

1047

@@ -1026,9 +1068,9 @@ subst n v tm = fst $ subst' 0 tm

1026 = let (b', ub) = substB' i b

1068 = let (b', ub) = substB' i b

1027 (sc', usc) = subst' (i+1) sc in

1069 (sc', usc) = subst' (i+1) sc in

1028 if ub || usc then (Bind x b' sc', True) else (t, False)

1070 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

1071+ subst' i t@(App s f a) = let (f', uf) = subst' i f

1030− (a', ua) = subst' i a in

1072+ (a', ua) = subst' i a in

1031− if uf || ua then (App f' a', True) else (t, False)

1073+ if uf || ua then (App s f' a', True) else (t, False)

1032 subst' i t@(Proj x idx) = let (x', u) = subst' i x in

1074 subst' i t@(Proj x idx) = let (x', u) = subst' i x in

1033 if u then (Proj x' idx, u) else (t, False)

1075 if u then (Proj x' idx, u) else (t, False)

1034 subst' i t = (t, False)

1076 subst' i t = (t, False)

@@ -1053,7 +1095,7 @@ psubst n v tm = s' 0 tm where

1053 s' i (P _ x _) | n == x = v

1095 s' i (P _ x _) | n == x = v

1054 s' i (Bind x b sc) | n == x = Bind x (fmap (s' i) b) sc

1096 s' i (Bind x b sc) | n == x = Bind x (fmap (s' i) b) sc

1055 | otherwise = Bind x (fmap (s' i) b) (s' (i+1) sc)

1097 | 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)

1057 s' i (Proj t idx) = Proj (s' i t) idx

1099 s' i (Proj t idx) = Proj (s' i t) idx

1058 s' i t = t

1100 s' i t = t

1059

1101

@@ -1071,7 +1113,7 @@ substTerm :: Eq n => TT n {-^ Old term -} ->

1071 -> TT n

1113 -> TT n

1072substTerm old new = st where

1114substTerm old new = st where

1073 st t | t == old = new

1115 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)

1075 st (Bind x b sc) = Bind x (fmap st b) (st sc)

1117 st (Bind x b sc) = Bind x (fmap st b) (st sc)

1076 st t = t

1118 st t = t

1077

1119

@@ -1085,7 +1127,7 @@ occurrences n t = execState (no' 0 t) 0

1085 where noB' i (Let t v) = do no' i t; no' i v

1127 where noB' i (Let t v) = do no' i t; no' i v

1086 noB' i (Guess t v) = do no' i t; no' i v

1128 noB' i (Guess t v) = do no' i t; no' i v

1087 noB' i b = no' i (binderTy b)

1129 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

1089 no' i (Proj x _) = no' i x

1131 no' i (Proj x _) = no' i x

1090 no' i _ = return ()

1132 no' i _ = return ()

1091

1133

@@ -1099,7 +1141,7 @@ noOccurrence n t = no' 0 t

1099 where noB' i (Let t v) = no' i t && no' i v

1141 where noB' i (Let t v) = no' i t && no' i v

1100 noB' i (Guess t v) = no' i t && no' i v

1142 noB' i (Guess t v) = no' i t && no' i v

1101 noB' i b = no' i (binderTy b)

1143 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

1103 no' i (Proj x _) = no' i x

1145 no' i (Proj x _) = no' i x

1104 no' i _ = True

1146 no' i _ = True

1105

1147

@@ -1111,7 +1153,7 @@ freeNames t = nub $ freeNames' t

1111 freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n])

1153 freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n])

1112 ++ freeNames' t

1154 ++ freeNames' t

1113 freeNames' (Bind n b sc) = freeNames' (binderTy b) ++ (freeNames' sc \\ [n])

1155 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

1115 freeNames' (Proj x i) = freeNames' x

1157 freeNames' (Proj x i) = freeNames' x

1116 freeNames' _ = []

1158 freeNames' _ = []

1117

1159

@@ -1123,14 +1165,14 @@ arity _ = 0

1123-- | Deconstruct an application; returns the function and a list of arguments

1165-- | Deconstruct an application; returns the function and a list of arguments

1124unApply :: TT n -> (TT n, [TT n])

1166unApply :: TT n -> (TT n, [TT n])

1125unApply t = ua [] t where

1167unApply t = ua [] t where

1126− ua args (App f a) = ua (a:args) f

1168+ ua args (App _ f a) = ua (a:args) f

1127 ua args t = (t, args)

1169 ua args t = (t, args)

1128

1170

1129-- | Returns a term representing the application of the first argument

1171-- | Returns a term representing the application of the first argument

1130-- (a function) to every element of the second argument.

1172-- (a function) to every element of the second argument.

1131mkApp :: TT n -> [TT n] -> TT n

1173mkApp :: TT n -> [TT n] -> TT n

1132mkApp f [] = f

1174mkApp f [] = f

1133−mkApp f (a:as) = mkApp (App f a) as

1175+mkApp f (a:as) = mkApp (App MaybeHoles f a) as

1134

1176

1135unList :: Term -> Maybe [Term]

1177unList :: Term -> Maybe [Term]

1136unList tm = case unApply tm of

1178unList tm = case unApply tm of

@@ -1159,23 +1201,25 @@ forgetEnv env tm = case safeForgetEnv env tm of

1159safeForgetEnv :: [Name] -> TT Name -> Maybe Raw

1201safeForgetEnv :: [Name] -> TT Name -> Maybe Raw

1160safeForgetEnv env (P _ n _) = Just $ Var n

1202safeForgetEnv env (P _ n _) = Just $ Var n

1161safeForgetEnv env (V i) | i < length env = Just $ Var (env !! i)

1203safeForgetEnv env (V i) | i < length env = Just $ Var (env !! i)

1162− | otherwise = Nothing

1204+ | otherwise = Nothing

1163−safeForgetEnv env (Bind n b sc)

1205+safeForgetEnv env (Bind n b sc)

1164 = do let n' = uniqueName n env

1206 = do let n' = uniqueName n env

1165 b' <- safeForgetEnvB env b

1207 b' <- safeForgetEnvB env b

1166 sc' <- safeForgetEnv (n':env) sc

1208 sc' <- safeForgetEnv (n':env) sc

1167 Just $ RBind n' b' sc'

1209 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)

1169 (safeForgetEnv env v)

1211 (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)

1171 (safeForgetEnv env v)

1213 (safeForgetEnv env v)

1172 safeForgetEnvB env b = do ty' <- safeForgetEnv env (binderTy b)

1214 safeForgetEnvB env b = do ty' <- safeForgetEnv env (binderTy b)

1173− Just $ fmap (\_ -> ty') b

1215+ Just $ fmap (\_ -> ty') b

1174−safeForgetEnv env (App f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a)

1216+safeForgetEnv env (App _ f a) = liftM2 RApp (safeForgetEnv env f) (safeForgetEnv env a)

1175safeForgetEnv env (Constant c) = Just $ RConstant c

1217safeForgetEnv env (Constant c) = Just $ RConstant c

1176safeForgetEnv env (TType i) = Just RType

1218safeForgetEnv env (TType i) = Just RType

1177safeForgetEnv env (UType u) = Just $ RUType u

1219safeForgetEnv env (UType u) = Just $ RUType u

1178safeForgetEnv env Erased = Just $ RConstant Forgot

1220safeForgetEnv 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"

1179

1223

1180-- | Introduce a 'Bind' into the given term for each element of the

1224-- | Introduce a 'Bind' into the given term for each element of the

1181-- given list of (name, binder) pairs.

1225-- given list of (name, binder) pairs.

@@ -1224,10 +1268,11 @@ uniqueBinders ns = ubSet (fromList ns) where

1224 = let n' = uniqueNameSet n ns

1268 = let n' = uniqueNameSet n ns

1225 ns' = insert n' ns in

1269 ns' = insert n' ns in

1226 Bind n' (fmap (ubSet ns') b) (ubSet ns' sc)

1270 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)

1228 ubSet ns t = t

1272 ubSet ns t = t

1229

1273

1230

1274

1275+nextName :: Name -> Name

1231nextName (NS x s) = NS (nextName x) s

1276nextName (NS x s) = NS (nextName x) s

1232nextName (MN i n) = MN (i+1) n

1277nextName (MN i n) = MN (i+1) n

1233nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

1278nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

@@ -1247,6 +1292,9 @@ nextName (SN x) = SN (nextName' x)

1247 nextName' (ElimN n) = ElimN (nextName n)

1292 nextName' (ElimN n) = ElimN (nextName n)

1248 nextName' (MethodN n) = MethodN (nextName n)

1293 nextName' (MethodN n) = MethodN (nextName n)

1249 nextName' (InstanceCtorN n) = InstanceCtorN (nextName n)

1294 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"

1250

1298

1251type Term = TT Name

1299type Term = TT Name

1252type Type = Term

1300type Type = Term

@@ -1286,11 +1334,13 @@ instance Show Const where

1286 show WorldType = "prim__WorldType"

1334 show WorldType = "prim__WorldType"

1287 show StrType = "String"

1335 show StrType = "String"

1288 show VoidType = "Void"

1336 show VoidType = "Void"

1337+ show Forgot = "Forgot"

1289

1338

1290showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String

1339showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String

1291showEnv env t = showEnv' env t False

1340showEnv env t = showEnv' env t False

1292showEnvDbg env t = showEnv' env t True

1341showEnvDbg env t = showEnv' env t True

1293

1342

1343+prettyEnv :: Env -> Term -> Doc OutputAnnotation

1294prettyEnv env t = prettyEnv' env t False

1344prettyEnv env t = prettyEnv' env t False

1295 where

1345 where

1296 prettyEnv' env t dbg = prettySe 10 env t dbg

1346 prettyEnv' env t dbg = prettySe 10 env t dbg

@@ -1317,21 +1367,25 @@ prettyEnv env t = prettyEnv' env t False

1317 bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug

1367 bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug

1318 prettySe p env (Bind n b sc) debug =

1368 prettySe p env (Bind n b sc) debug =

1319 bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug

1369 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 =

1321 bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug

1371 bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug

1322 prettySe p env (Proj x i) debug =

1372 prettySe p env (Proj x i) debug =

1323 prettySe 1 env x debug <+> text ("!" ++ show i)

1373 prettySe 1 env x debug <+> text ("!" ++ show i)

1324 prettySe p env (Constant c) debug = pretty c

1374 prettySe p env (Constant c) debug = pretty c

1325 prettySe p env Erased debug = text "[_]"

1375 prettySe p env Erased debug = text "[_]"

1326 prettySe p env (TType i) debug = text "Type" <+> (text . show $ i)

1376 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)

1327

1379

1328 -- Render a `Binder` and its name

1380 -- Render a `Binder` and its name

1329 prettySb env n (Lam t) = prettyB env "λ" "=>" n t

1381 prettySb env n (Lam t) = prettyB env "λ" "=>" n t

1330 prettySb env n (Hole t) = prettyB env "?defer" "." n t

1382 prettySb env n (Hole t) = prettyB env "?defer" "." n t

1383+ prettySb env n (GHole _ t) = prettyB env "?gdefer" "." n t

1331 prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t

1384 prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t

1332 prettySb env n (PVar t) = prettyB env "pat" "." n t

1385 prettySb env n (PVar t) = prettyB env "pat" "." n t

1333 prettySb env n (PVTy t) = prettyB env "pty" "." n t

1386 prettySb env n (PVTy t) = prettyB env "pty" "." n t

1334 prettySb env n (Let t v) = prettyBv env "let" "in" n t v

1387 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

1335 prettySb env n (Guess t v) = prettyBv env "??" "in" n t v

1389 prettySb env n (Guess t v) = prettyBv env "??" "in" n t v

1336

1390

1337 -- Use `op` and `sc` to delimit `n` (a binding name) and its type

1391 -- 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

1361 where arrow (TType _) = " -> "

1415 where arrow (TType _) = " -> "

1362 arrow u = " [" ++ show u ++ "] -> "

1416 arrow u = " [" ++ show u ++ "] -> "

1363 se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc

1417 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

1365 se p env (Proj x i) = se 1 env x ++ "!" ++ show i

1419 se p env (Proj x i) = se 1 env x ++ "!" ++ show i

1366 se p env (Constant c) = show c

1420 se p env (Constant c) = show c

1367 se p env Erased = "[__]"

1421 se p env Erased = "[__]"

@@ -1377,6 +1431,7 @@ showEnv' env t dbg = se 10 env t where

1377 sb env n (PVar t) = showb env "pat " ". " n t

1431 sb env n (PVar t) = showb env "pat " ". " n t

1378 sb env n (PVTy t) = showb env "pty " ". " n t

1432 sb env n (PVTy t) = showb env "pty " ". " n t

1379 sb env n (Let t v) = showbv env "let " " in " n t v

1433 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

1380 sb env n (Guess t v) = showbv env "?? " " in " n t v

1435 sb env n (Guess t v) = showbv env "?? " " in " n t v

1381

1436

1382 showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc

1437 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

1386 bracket outer inner str | inner > outer = "(" ++ str ++ ")"

1441 bracket outer inner str | inner > outer = "(" ++ str ++ ")"

1387 | otherwise = str

1442 | otherwise = str

1388

1443

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

1390pureTerm :: TT Name -> Bool

1445pureTerm :: TT Name -> Bool

1391−pureTerm (App f a) = pureTerm f && pureTerm a

1446+pureTerm (App _ f a) = pureTerm f && pureTerm a

1392pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

1447pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

1393 pureBinder (Hole _) = False

1448 pureBinder (Hole _) = False

1394 pureBinder (Guess _ _) = False

1449 pureBinder (Guess _ _) = False

@@ -1404,7 +1459,7 @@ pureTerm _ = True

1404weakenTm :: Int -> TT n -> TT n

1459weakenTm :: Int -> TT n -> TT n

1405weakenTm i t = wk i 0 t

1460weakenTm i t = wk i 0 t

1406 where wk i min (V x) | x >= min = V (i + x)

1461 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)

1408 wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc)

1463 wk i m (Bind x b sc) = Bind x (wkb i m b) (wk i (m + 1) sc)

1409 wk i m t = t

1464 wk i m t = t

1410 wkb i m t = fmap (wk i m) t

1465 wkb i m t = fmap (wk i m) t

@@ -1429,7 +1484,7 @@ weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b))

1429orderPats :: Term -> Term

1484orderPats :: Term -> Term

1430orderPats tm = op [] tm

1485orderPats tm = op [] tm

1431 where

1486 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

1433

1488

1434 op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc

1489 op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc

1435 op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc

1490 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

1454 where nb (Let t v) = nub (refsIn t) ++ nub (refsIn v)

1509 where nb (Let t v) = nub (refsIn t) ++ nub (refsIn v)

1455 nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v)

1510 nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v)

1456 nb t = refsIn (binderTy t)

1511 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)

1458refsIn _ = []

1513refsIn _ = []

1459

1514

1460-- Make sure all the pattern bindings are as far out as possible

1515-- 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

1491 return (Bind n (Hole t') sc')

1546 return (Bind n (Hole t') sc')

1492

1547

1493

1548

1494− getPats (App f a) = do f' <- getPats f

1549+ getPats (App s f a) = do f' <- getPats f

1495− a' <- getPats a

1550+ a' <- getPats a

1496− return (App f' a')

1551+ return (App s f' a')

1497 getPats t = return t

1552 getPats t = return t

1498

1553

1499allTTNames :: Eq n => TT n -> [n]

1554allTTNames :: Eq n => TT n -> [n]

@@ -1503,7 +1558,7 @@ allTTNames = nub . allNamesIn

1503 where nb (Let t v) = allNamesIn t ++ allNamesIn v

1558 where nb (Let t v) = allNamesIn t ++ allNamesIn v

1504 nb (Guess t v) = allNamesIn t ++ allNamesIn v

1559 nb (Guess t v) = allNamesIn t ++ allNamesIn v

1505 nb t = allNamesIn (binderTy t)

1560 nb t = allNamesIn (binderTy t)

1506− allNamesIn (App f a) = allNamesIn f ++ allNamesIn a

1561+ allNamesIn (App _ f a) = allNamesIn f ++ allNamesIn a

1507 allNamesIn _ = []

1562 allNamesIn _ = []

1508

1563

1509

1564

@@ -1526,7 +1581,7 @@ pprintTT bound tm = pp startPrec bound tm

1526 | otherwise = text ("{{{V" ++ show i ++ "}}}")

1581 | otherwise = text ("{{{V" ++ show i ++ "}}}")

1527 pp p bound (Bind n b sc) = ppb p bound n b $

1582 pp p bound (Bind n b sc) = ppb p bound n b $

1528 pp startPrec (n:bound) sc

1583 pp startPrec (n:bound) sc

1529− pp p bound (App tm1 tm2) =

1584+ pp p bound (App _ tm1 tm2) =

1530 bracket p appPrec . group . hang 2 $

1585 bracket p appPrec . group . hang 2 $

1531 pp appPrec bound tm1 <> line <>

1586 pp appPrec bound tm1 <> line <>

1532 pp (appPrec + 1) bound tm2

1587 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

77 smaller _ (UType u) = UType u

78 smaller x _ = x

79

80+ astate | holes = MaybeHoles

81+ | otherwise = Complete

82+

80 chk :: Type -> -- uniqueness level

83 chk :: Type -> -- uniqueness level

81 Env -> Raw -> StateT UCs TC (Term, Type)

84 Env -> Raw -> StateT UCs TC (Term, Type)

82 chk u env (Var n)

85 chk u env (Var n)

83 | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)

86 | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)

84 -- If we're elaborating, we don't want the private names; if we're

87 -- If we're elaborating, we don't want the private names; if we're

85 -- checking an already elaborated term, we do

88 -- checking an already elaborated term, we do

86− | (P nt n' ty : _) <- lookupP_all (not holes) n ctxt

89+ | [P nt n' ty] <- lookupP_all (not holes) n ctxt

87− = return (P nt n' ty, ty)

90+ = return (P nt n' ty, ty)

88 | otherwise = do lift $ tfail $ NoSuchVariable n

91 | otherwise = do lift $ tfail $ NoSuchVariable n

89 chk u env ap@(RApp f RType) | not holes

92 chk u env ap@(RApp f RType) | not holes

90 -- special case to reduce constraintss

93 -- special case to reduce constraintss

@@ -101,13 +104,13 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

101 put (v+1, ULT (UVar v) v' : cs)

104 put (v+1, ULT (UVar v) v' : cs)

102 let apty = simplify initContext env

105 let apty = simplify initContext env

103 (Bind x (Let (TType v') (TType (UVar v))) t)

106 (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)

105 Bind x (Pi i s k) t ->

108 Bind x (Pi i s k) t ->

106 do (av, aty) <- chk u env RType

109 do (av, aty) <- chk u env RType

107 convertsC ctxt env aty s

110 convertsC ctxt env aty s

108 let apty = simplify initContext env

111 let apty = simplify initContext env

109 (Bind x (Let aty av) t)

112 (Bind x (Let aty av) t)

110− return (App fv av, apty)

113+ return (App astate fv av, apty)

111 t -> lift $ tfail $ NonFunctionType fv fty

114 t -> lift $ tfail $ NonFunctionType fv fty

112 chk u env ap@(RApp f a)

115 chk u env ap@(RApp f a)

113 = do (fv, fty) <- chk u env f

116 = do (fv, fty) <- chk u env f

@@ -123,7 +126,7 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

123 do convertsC ctxt env aty s

126 do convertsC ctxt env aty s

124 let apty = simplify initContext env

127 let apty = simplify initContext env

125 (Bind x (Let aty av) t)

128 (Bind x (Let aty av) t)

126− return (App fv av, apty)

129+ return (App astate fv av, apty)

127 t -> lift $ tfail $ NonFunctionType fv fty

130 t -> lift $ tfail $ NonFunctionType fv fty

128 chk u env RType

131 chk u env RType

129 | holes = return (TType (UVal 0), TType (UVal 0))

132 | holes = return (TType (UVal 0), TType (UVal 0))

@@ -298,7 +301,7 @@ checkUnique borrowed ctxt env tm

298 chkBinders env (P _ n _) = chkName n

301 chkBinders env (P _ n _) = chkName n

299 -- 'lending' a unique or nulltype variable doesn't count as a use,

302 -- 'lending' a unique or nulltype variable doesn't count as a use,

300 -- but we still can't lend something that's already been used.

303 -- 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)

302 | isVar a && owner == txt "Ownership" &&

305 | isVar a && owner == txt "Ownership" &&

303 (lend == txt "lend" || lend == txt "Read")

306 (lend == txt "lend" || lend == txt "Read")

304 = do chkBinders env t -- Check the type normally

307 = do chkBinders env t -- Check the type normally

@@ -307,7 +310,7 @@ checkUnique borrowed ctxt env tm

307 put (filter (\(n, (ok, _)) -> ok /= LendOnly) st)

310 put (filter (\(n, (ok, _)) -> ok /= LendOnly) st)

308 chkBinders env a

311 chkBinders env a

309 put st -- Reset the old state after checking the argument

312 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

311 chkBinders env (Bind n b t)

314 chkBinders env (Bind n b t)

312 = do chkBinderName env n b

315 = do chkBinderName env n b

313 st <- get

316 st <- get

src/Idris/Core/Unify.hs+33−35

@@ -96,22 +96,22 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

96 -- but it scares me. However, matching is never guaranteed to give a unique

97 -- answer, merely a valid one, so perhaps we're okay.

98 -- 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)

100 | (P (TCon _ _) _ _, _) <- unApply x,

101 holeIn env f || f `elem` holes

102 = let n' = uniqueName (sMN 0 "mv") (map fst env) in

103 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

105 | (P (TCon _ _) _ _, _) <- unApply x,

106 holeIn env f || f `elem` holes

107 = let n' = uniqueName fn (map fst env) in

108 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)

110 | (P (DCon _ _ _) _ _, _) <- unApply x,

111 holeIn env f || f `elem` holes

112 = let n' = uniqueName (sMN 0 "mv") (map fst env) in

113 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

115 | (P (DCon _ _ _) _ _, _) <- unApply x,

116 holeIn env f || f `elem` holes

117 = let n' = uniqueName fn (map fst env) in

@@ -135,7 +135,7 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

135 = do h1 <- uB bnames bx by

136 h2 <- un (((x, y), binderTy bx) : bnames) sx sy

137 combine bnames h1 h2

138− un names (App fx ax) (App fy ay)

138+ un names (App _ fx ax) (App _ fy ay)

139 = do hf <- un names fx fy

140 ha <- un names ax ay

141 combine names hf ha

@@ -218,7 +218,7 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =

218 bind i ns tm

219 | i < 0 = tm

220 | 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))

222 (P Bound x ty)

223

224renameBinders env (x, t) = (x, renameBindersTm env t)

@@ -233,12 +233,12 @@ renameBindersTm env tm = uniqueBinders (map fst env) tm

233 (uniqueBinders (n':env) (rename n n' sc))

234 | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)

235 (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)

237 uniqueBinders env t = t

238

239 rename n n' (P nt x ty) | n == x = P nt n' ty

240 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)

242 rename n n' t = t

243

244 explicitHole (Bind n (Hole ty) sc)

@@ -280,7 +280,7 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

280

281hasv :: TT Name -> Bool

282hasv (V x) = True

283−hasv (App f a) = hasv f || hasv a

283+hasv (App _ f a) = hasv f || hasv a

284hasv (Bind x b sc) = hasv (binderTy b) || hasv sc

285hasv _ = False

286

@@ -315,14 +315,12 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

315

316 injective (P (DCon _ _ _) _ _) = True

317 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

321 injective _ = False

319 injective _ = False

322

320

323-- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK

321-- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK

324 injectiveVar (P _ n _) = n `elem` inj

322 injectiveVar (P _ n _) = n `elem` inj

325− injectiveVar (App f a) = injectiveVar f -- && injective a

323+ injectiveVar (App _ f a) = injectiveVar f -- && injective a

326 injectiveVar _ = False

324 injectiveVar _ = False

327

325

328 injectiveApp x = injective x || injectiveVar x

326 injectiveApp x = injective x || injectiveVar x

@@ -426,18 +424,18 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

426 un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y

424 un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y

427 un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy

425 un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy

428

426

429− un' fn bnames appx@(App _ _) appy@(App _ _)

427+ un' fn bnames appx@(App _ _ _) appy@(App _ _ _)

430 = unApp fn bnames appx appy

428 = unApp fn bnames appx appy

431-- = uplus (unApp fn bnames appx appy)

429-- = uplus (unApp fn bnames appx appy)

432-- (unifyTmpFail appx appy) -- take the whole lot

430-- (unifyTmpFail appx appy) -- take the whole lot

433

431

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' _)))

435 | n == n' = un' False bnames x y

433 | 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

437 | n == n' = un' False bnames x y

435 | 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)))

439 = un' False bnames x y

437 = 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

441 = un' False bnames x y

439 = un' False bnames x y

442-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)

440-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)

443-- = un' False ((x,y):bnames) sx sy

441-- = un' False ((x,y):bnames) sx sy

@@ -447,14 +445,14 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

447 -- f D unifies with t -> D. This is dubious, but it helps with type

445 -- f D unifies with t -> D. This is dubious, but it helps with type

448 -- class resolution for type classes over functions.

446 -- class resolution for type classes over functions.

449

447

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)

451 | noOccurrence n y && injectiveApp f

449 | noOccurrence n y && injectiveApp f

452 = do ux <- un' False bnames x y

450 = do ux <- un' False bnames x y

453 uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

451 uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

454 (Bind n (Pi i t k) (V 1)))

452 (Bind n (Pi i t k) (V 1)))

455 combine bnames ux uf

453 combine bnames ux uf

456

454

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)

458 | noOccurrence n y && injectiveApp f

456 | noOccurrence n y && injectiveApp f

459 = do ux <- un' False bnames y x

457 = do ux <- un' False bnames y x

460 uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

458 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 =

481 else do put (UI s ((x, y, True, env, err, from, Unify) : f))

479 else do put (UI s ((x, y, True, env, err, from, Unify) : f))

482 return [] -- lift $ tfail err

480 return [] -- lift $ tfail err

483

481

484− unApp fn bnames appx@(App fx ax) appy@(App fy ay)

482+ unApp fn bnames appx@(App _ fx ax) appy@(App _ fy ay)

485 -- shortcut for the common case where we just want to check the

483 -- shortcut for the common case where we just want to check the

486 -- arguments are correct

484 -- arguments are correct

487 | (injectiveApp fx && fx == fy)

485 | (injectiveApp fx && fx == fy)

@@ -545,7 +543,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

545 rigid (P (TCon _ _) _ _) = True

543 rigid (P (TCon _ _) _ _) = True

546 rigid t@(P Ref _ _) = inenv t || globmetavar t

544 rigid t@(P Ref _ _) = inenv t || globmetavar t

547 rigid (Constant _) = True

545 rigid (Constant _) = True

548− rigid (App f a) = rigid f && rigid a

546+ rigid (App _ f a) = rigid f && rigid a

549 rigid t = not (metavar t) || globmetavar t

547 rigid t = not (metavar t) || globmetavar t

550

548

551 globmetavar t = case unApply t of

549 globmetavar t = case unApply t of

@@ -636,7 +634,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =

636 bind i ns tm

634 bind i ns tm

637 | i < 0 = tm

635 | i < 0 = tm

638 | otherwise = let ((x,y),ty) = ns!!i in

636 | 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))

640 (P Bound x ty)

638 (P Bound x ty)

641

639

642 combineArgs bnames args = ca [] args where

640 combineArgs bnames args = ca [] args where

@@ -658,16 +656,16 @@ boundVs :: Int -> Term -> [Int]

658boundVs i (V j) | j < i = []

656boundVs i (V j) | j < i = []

659 | otherwise = [j]

657 | otherwise = [j]

660boundVs i (Bind n b sc) = boundVs (i + 1) sc

658boundVs i (Bind n b sc) = boundVs (i + 1) sc

661−boundVs i (App f x) = let fs = boundVs i f

659+boundVs i (App _ f x) = let fs = boundVs i f

662− xs = boundVs i x in

660+ xs = boundVs i x in

663− nub (fs ++ xs)

661+ nub (fs ++ xs)

664boundVs i _ = []

662boundVs i _ = []

665

663

666highV :: Int -> Term -> Int

664highV :: Int -> Term -> Int

667highV i (V j) | j > i = j

665highV i (V j) | j > i = j

668 | otherwise = i

666 | otherwise = i

669highV i (Bind n b sc) = maximum [i, highV i (binderTy b), (highV i sc - 1)]

667highV 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)

671highV i _ = i

669highV i _ = i

672

670

673envPos x i [] = 0

671envPos x i [] = 0

@@ -683,9 +681,9 @@ envPos x i ((y, _) : ys) | x == y = i

683--

681--

684-- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722

682-- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722

685--

683--

686−recoverable t@(App _ _) _

684+recoverable t@(App _ _ _) _

687 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

685 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

688−recoverable _ t@(App _ _)

686+recoverable _ t@(App _ _ _)

689 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

687 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False

690recoverable (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x == y

688recoverable (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x == y

691recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y

689recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y

@@ -696,13 +694,13 @@ recoverable (Constant _) (P (TCon _ _) y _) = False

696recoverable (P (TCon _ _) x _) (Constant _) = False

694recoverable (P (TCon _ _) x _) (Constant _) = False

697recoverable (P (DCon _ _ _) x _) (P (TCon _ _) y _) = False

695recoverable (P (DCon _ _ _) x _) (P (TCon _ _) y _) = False

698recoverable (P (TCon _ _) x _) (P (DCon _ _ _) y _) = False

696recoverable (P (TCon _ _) x _) (P (DCon _ _ _) y _) = False

699−recoverable p@(Constant _) (App f a) = recoverable p f

697+recoverable p@(Constant _) (App _ f a) = recoverable p f

700−recoverable (App f a) p@(Constant _) = recoverable f p

698+recoverable (App _ f a) p@(Constant _) = recoverable f p

701−recoverable p@(P _ n _) (App f a) = recoverable p f

699+recoverable p@(P _ n _) (App _ f a) = recoverable p f

702−recoverable (App f a) p@(P _ _ _) = recoverable f p

700+recoverable (App _ f a) p@(P _ _ _) = recoverable f p

703−recoverable (App f a) (App f' a')

701+recoverable (App _ f a) (App _ f' a')

704 | f == f' = recoverable a a'

702 | f == f' = recoverable a a'

705−recoverable (App f a) (App f' a')

703+recoverable (App _ f a) (App _ f' a')

706 = recoverable f f' -- && recoverable a a'

704 = recoverable f f' -- && recoverable a a'

707recoverable f (Bind _ (Pi _ _ _) sc)

705recoverable f (Bind _ (Pi _ _ _) sc)

708 | (P (DCon _ _ _) _ _, _) <- unApply f = False

706 | (P (DCon _ _ _) _ _, _) <- unApply f = False

src/Idris/Coverage.hs+63−18

@@ -1,5 +1,6 @@

1{-# LANGUAGE PatternGuards #-}

2−

2+{-| The coverage and totality checkers for Idris are in this module.

3+-}

3module Idris.Coverage where

4module Idris.Coverage where

4

5

5import Idris.Core.TT

6import Idris.Core.TT

@@ -120,6 +121,52 @@ genClauses fc n xs given

120 as' <- mkArg as

121 as' <- mkArg as

121 return (a':as')

122 return (a':as')

122

123

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+

123-- FIXME: Just look for which one is the deepest, then generate all

170-- FIXME: Just look for which one is the deepest, then generate all

124-- possibilities up to that depth.

171-- possibilities up to that depth.

125-- This and below issues for this function are tracked as Issue #1741 on the issue tracker.

172-- 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

317 prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

364 prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

318

365

319 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

366 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

320− prod n done ok ap@(App _ _)

367+ prod n done ok ap@(App _ _ _)

321 | (P nt f _, args) <- unApply ap

368 | (P nt f _, args) <- unApply ap

322 = do recOK <- checkProdRec (n:done) f

369 = do recOK <- checkProdRec (n:done) f

323 let ctxt = tt_ctxt i

370 let ctxt = tt_ctxt i

@@ -329,8 +376,8 @@ calcProd i fc topn pats

329 return (and (ok : argsprod) )

376 return (and (ok : argsprod) )

330 else do argsprod <- mapM (prod n done co) args

377 else do argsprod <- mapM (prod n done co) args

331 return (and argsprod)

378 return (and argsprod)

332− prod n done ok (App f a) = liftM2 (&&) (prod n done False f)

379+ prod n done ok (App _ f a) = liftM2 (&&) (prod n done False f)

333− (prod n done False a)

380+ (prod n done False a)

334 prod n done ok (Bind _ (Let t v) sc)

381 prod n done ok (Bind _ (Let t v) sc)

335 = liftM2 (&&) (prod n done False v) (prod n done False v)

382 = liftM2 (&&) (prod n done False v) (prod n done False v)

336 prod n done ok (Bind _ b sc) = prod n done ok sc

383 prod n done ok (Bind _ b sc) = prod n done ok sc

@@ -350,10 +397,9 @@ calcProd i fc topn pats

350 _ -> False

397 _ -> False

351 cotype nt n ty = False

398 cotype nt n ty = False

352

399

353−-- Calculate the totality of a function from its patterns.

400+-- | Calculate the totality of a function from its patterns.

354-- Either follow the size change graph (if inductive) or check for

401-- Either follow the size change graph (if inductive) or check for

355-- productivity (if coinductive)

402-- productivity (if coinductive)

356−

357calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

403calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

358calcTotality fc n pats

404calcTotality fc n pats

359 = do i <- getIState

405 = do i <- getIState

@@ -368,7 +414,7 @@ calcTotality fc n pats

368 = case lookupTotal fn (tt_ctxt i) of

414 = case lookupTotal fn (tt_ctxt i) of

369 [Partial _] -> return (Partial (Other [fn]))

415 [Partial _] -> return (Partial (Other [fn]))

370 _ -> Nothing

416 _ -> 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)

372 checkLHS _ _ = Nothing

418 checkLHS _ _ = Nothing

373

419

374checkTotality :: [Name] -> FC -> Name -> Idris Totality

420checkTotality :: [Name] -> FC -> Name -> Idris Totality

@@ -450,17 +496,16 @@ checkDeclTotality (fc, n)

450 return t

496 return t

451

497

452

498

453−-- Calculate the size change graph for this definition

499+-- | Calculate the size change graph for this definition

454−

500+--

455-- SCG for a function f consists of a list of:

501-- SCG for a function f consists of a list of:

456-- (g, [(a1, sizechange1), (a2, sizechange2), ..., (an, sizechangen)])

502-- (g, [(a1, sizechange1), (a2, sizechange2), ..., (an, sizechangen)])

457−

503+--

458-- where g is a function called

504-- where g is a function called

459-- a1 ... an are the arguments of f in positions 1..n of g

505-- a1 ... an are the arguments of f in positions 1..n of g

460-- sizechange1 ... sizechange2 is how their size has changed wrt the input

506-- sizechange1 ... sizechange2 is how their size has changed wrt the input

461-- to f

507-- to f

462-- Nothing, if the argument is unrelated to the input

508-- Nothing, if the argument is unrelated to the input

463−

464buildSCG :: (FC, Name) -> Idris ()

509buildSCG :: (FC, Name) -> Idris ()

465buildSCG (_, n) = do

510buildSCG (_, n) = do

466 ist <- getIState

511 ist <- getIState

@@ -477,14 +522,14 @@ buildSCG (_, n) = do

477 x -> error $ "buildSCG: " ++ show (n, x)

522 x -> error $ "buildSCG: " ++ show (n, x)

478

523

479delazy = delazy' False -- not lazy codata

524delazy = delazy' False -- not lazy codata

480−delazy' all t@(App f a)

525+delazy' all t@(App _ f a)

481 | (P _ (UN l) _, [_, _, arg]) <- unApply t,

526 | (P _ (UN l) _, [_, _, arg]) <- unApply t,

482 l == txt "Force" = delazy' all arg

527 l == txt "Force" = delazy' all arg

483 | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

528 | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

484 l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

529 l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

485 | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

530 | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

486 l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

531 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)

488delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

533delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

489delazy' all t = t

534delazy' all t = t

490

535

@@ -498,7 +543,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

498 (f, pargs) = unApply (dePat lhs') in

543 (f, pargs) = unApply (dePat lhs') in

499 findCalls Toplevel (dePat rhs') (patvars lhs') pargs

544 findCalls Toplevel (dePat rhs') (patvars lhs') pargs

500

545

501− findCalls guarded ap@(App f a) pvs pargs

546+ findCalls guarded ap@(App _ f a) pvs pargs

502 -- under a call to "assert_total", don't do any checking, just believe

547 -- under a call to "assert_total", don't do any checking, just believe

503 -- that it is total.

548 -- that it is total.

504 | (P _ (UN at) _, [_, _]) <- unApply ap,

549 | (P _ (UN at) _, [_, _]) <- unApply ap,

@@ -519,7 +564,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

519 else Unguarded in

564 else Unguarded in

520 mkChange n args pargs ++

565 mkChange n args pargs ++

521 concatMap (\x -> findCalls nguarded x pvs pargs) args

566 concatMap (\x -> findCalls nguarded x pvs pargs) args

522− findCalls guarded (App f a) pvs pargs

567+ findCalls guarded (App _ f a) pvs pargs

523 = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

568 = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

524 findCalls guarded (Bind n (Let t v) e) pvs pargs

569 findCalls guarded (Bind n (Let t v) e) pvs pargs

525 = findCalls Unguarded t pvs pargs ++

570 = findCalls Unguarded t pvs pargs ++

@@ -561,13 +606,13 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

561 smaller (Just tyn) a (t, Just tyt)

606 smaller (Just tyn) a (t, Just tyt)

562 | a == t = isInductive (fst (unApply (getRetTy tyn)))

607 | a == t = isInductive (fst (unApply (getRetTy tyn)))

563 (fst (unApply (getRetTy tyt)))

608 (fst (unApply (getRetTy tyt)))

564− smaller ty a (ap@(App f s), _)

609+ smaller ty a (ap@(App _ f s), _)

565 | (P (DCon _ _ _) n _, args) <- unApply ap

610 | (P (DCon _ _ _) n _, args) <- unApply ap

566 = let tyn = getType n in

611 = let tyn = getType n in

567 any (smaller (ty `mplus` Just tyn) a)

612 any (smaller (ty `mplus` Just tyn) a)

568 (zip args (map toJust (getArgTys tyn)))

613 (zip args (map toJust (getArgTys tyn)))

569 -- check higher order recursive arguments

614 -- 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

571 smaller _ _ _ = False

616 smaller _ _ _ = False

572

617

573 toJust (n, t) = Just t

618 toJust (n, t) = Just t

@@ -660,7 +705,7 @@ checkMP ist i mp = if i > 0

660 = case lookupTotal f (tt_ctxt ist) of

705 = case lookupTotal f (tt_ctxt ist) of

661 [Total _] -> Unchecked -- okay so far

706 [Total _] -> Unchecked -- okay so far

662 [Partial _] -> Partial (Other [f])

707 [Partial _] -> Partial (Other [f])

663− x -> error $ "CAN'T HAPPEN: " ++ (show x)

708+ x -> error $ "CAN'T HAPPEN: " ++ show x ++ " for " ++ show f

664 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

709 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

665 = Total []

710 = Total []

666 tryPath desc path (e@(f, args) : es) arg

711 tryPath desc path (e@(f, args) : es) arg

src/Idris/DSL.hs+2−2

@@ -108,7 +108,7 @@ expandDo dsl (PDoBlock ds)

108 block b _ = PElabError (Msg "Invalid statement in do block")

109

110expandDo 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

112expandDo dsl t = t

113

114-- | Replace DSL-bound variable in a term

@@ -195,7 +195,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

195 db' (PDPair fc p l t r) = do l' <- db' l

196 r' <- db' r

197 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)

199 db' t = return t

200

201 dbArg a = do t' <- db' (getTm a)

src/Idris/DataOpts.hs+12−6

@@ -63,21 +63,27 @@ instance Optimisable (TT Name) where

63 applyOpts (P _ (NS (UN fn) mod) _)

64 | fn == txt "mult" && mod == prel

65 = return (P Ref (sUN "prim__mulBigInt") Erased)

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)

66− applyOpts (App (P _ (NS (UN fn) mod) _) x)

72+ applyOpts (App _ (P _ (NS (UN fn) mod) _) x)

67 | fn == txt "fromIntegerNat" && mod == prel

73 | fn == txt "fromIntegerNat" && mod == prel

68 = applyOpts x

74 = applyOpts x

69 applyOpts (P _ (NS (UN fn) mod) _)

75 applyOpts (P _ (NS (UN fn) mod) _)

70 | fn == txt "fromIntegerNat" && mod == prel

76 | 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)

72 applyOpts (P _ (NS (UN fn) mod) _)

78 applyOpts (P _ (NS (UN fn) mod) _)

73 | fn == txt "toIntegerNat" && mod == prel

79 | 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)

75 applyOpts c@(P (DCon t arity uniq) n _)

81 applyOpts c@(P (DCon t arity uniq) n _)

76 = return $ applyDataOptRT n t arity uniq []

82 = return $ applyDataOptRT n t arity uniq []

77− applyOpts t@(App f a)

83+ applyOpts t@(App s f a)

78 | (c@(P (DCon t arity uniq) n _), args) <- unApply t

84 | (c@(P (DCon t arity uniq) n _), args) <- unApply t

79 = applyDataOptRT n t arity uniq <$> mapM applyOpts args

85 = applyDataOptRT n t arity uniq <$> mapM applyOpts args

80− | otherwise = App <$> applyOpts f <*> applyOpts a

86+ | otherwise = App s <$> applyOpts f <*> applyOpts a

81 applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

87 applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

82 applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

88 applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

83 applyOpts t = return t

89 applyOpts t = return t

@@ -103,6 +109,6 @@ applyDataOptRT n tag arity uniq args

103 = Constant (BI 0)

109 = Constant (BI 0)

104 doOpts (NS (UN s) [nat, prelude]) [k]

110 doOpts (NS (UN s) [nat, prelude]) [k]

105 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

111 | 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))

107

113

108 doOpts n args = mkApp (P (DCon tag arity uniq) n Erased) args

114 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

243 rnf (PNoImplicits x1) = rnf x1 `seq` ()

244 rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

245 rnf (PUnquote x1) = rnf x1 `seq` ()

246+ rnf (PQuoteName x1) = rnf x1 `seq` ()

246− rnf (PRunTactics x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

247+ rnf (PRunElab x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

247

248

248instance (NFData t) => NFData (PTactic' t) where

249instance (NFData t) => NFData (PTactic' t) where

249 rnf (Intro x1) = rnf x1 `seq` ()

250 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

49 where

50 un = fileFC "(val)"

51

52− de env _ (App f a) = deFn env f [a]

52+ de env _ (App _ f a) = deFn env f [a]

53 de env _ (V i) | i < length env = PRef un (snd (env!!i))

54 | otherwise = PRef un (sUN ("v" ++ show i ++ ""))

55 de env _ (P _ n _) | n == unitTy = PTrue un IsType

@@ -103,7 +103,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

103 _ -> ns

104 dens n = n

105

106− deFn env (App f a) args = deFn env f (a:args)

106+ deFn env (App _ f a) args = deFn env f (a:args)

107 deFn env (P _ n _) [l,r]

108 | n == pairTy = PPair un IsType (de env [] l) (de env [] r)

109 | n == eqCon = PRefl un (de env [] r)

@@ -163,7 +163,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

163 | otherwise = tm

164 nonVar [] = error "Tried to delaborate empty case list"

165 nonVar [x] = x

166− nonVar (x@(App _ _) : _) = x

166+ nonVar (x@(App _ _ _) : _) = x

167 nonVar (x@(P (DCon _ _ _) _ _) : _) = x

168 nonVar (x:xs) = nonVar xs

169-- | How far to indent sub-errors

@@ -256,9 +256,9 @@ pprintErr' i (CantConvert x_in y_in env) =

256 y)) <>

257 if (opt_errContext (idris_options i)) then line <> showSc i env else empty

258 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)

260 (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)

262 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)

263 flagUnique t = t

264pprintErr' i (CantSolveGoal x env) =

@@ -311,7 +311,14 @@ pprintErr' i (NoEliminator s t)

311 text "Please note that 'induction' is experimental." <$>

312 text "Only types declared with '%elim' can be used." <$>

313 text "Consider writing a pattern matching definition instead."

314+pprintErr' i (UniverseError fc uexp old new suspects) =

314−pprintErr' i UniverseError = text "Universe inconsistency"

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+ ]

315pprintErr' i (UniqueError NullType n)

322pprintErr' i (UniqueError NullType n)

316 = text "Borrowed name" <+> annName' n (showbasic n)

323 = text "Borrowed name" <+> annName' n (showbasic n)

317 <+> text "must not be used on RHS"

324 <+> text "must not be used on RHS"

@@ -373,12 +380,13 @@ pprintErr' i (ReflectionFailed msg err) =

373 text "When attempting to perform error reflection, the following internal error occurred:" <>

380 text "When attempting to perform error reflection, the following internal error occurred:" <>

374 indented (pprintErr' i err) <>

381 indented (pprintErr' i err) <>

375 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

382 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) =

377 text "Elaboration halted." <>

384 text "Elaboration halted." <>

378− maybe empty (indented . text) msg <> line <>

385+ maybe empty (indented . text) msg <>

379− text "Term: " <> indented (pprintTT [] tm) <> line <>

386+ line <> line <>

380 text "Holes:" <>

387 text "Holes:" <>

381− indented (vsep (map ppHole holes))

388+ indented (vsep (map ppHole holes)) <> line <> line <>

389+ text "Term: " <> indented (pprintTT [] tm)

382

390

383 where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation

391 where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation

384 ppHole (hn, goal, env) =

392 ppHole (hn, goal, env) =

@@ -394,6 +402,9 @@ pprintErr' i (ElabDebug msg tm holes) =

394 pprintTT ns (binderTy b) <>

402 pprintTT ns (binderTy b) <>

395 line <>

403 line <>

396 ppAssumptions (n:ns) rest

404 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?"

397

408

398-- | Make sure the machine invented names are shown helpfully to the user, so

409-- | Make sure the machine invented names are shown helpfully to the user, so

399-- that any names which differ internally also differ visibly

410-- that any names which differ internally also differ visibly

@@ -423,7 +434,7 @@ renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y

423

434

424 rename :: [(Name, Name)] -> Term -> Term

435 rename :: [(Name, Name)] -> Term -> Term

425 rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t

436 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)

427 rename ns (Bind x b sc)

438 rename ns (Bind x b sc)

428 = let b' = fmap (rename ns) b

439 = let b' = fmap (rename ns) b

429 sc' = rename ns sc in

440 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

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

11import Idris.Coverage

12import Idris.DataOpts

13import Idris.Providers

@@ -106,7 +106,14 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

106 where

107 nodoc (n, (_, o, t)) = (n, (o, t))

108 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

110

117

111 mdec :: Name -> Name

118 mdec :: Name -> Name

112 mdec (UN n) = SN (MethodN (UN n))

119 mdec (UN n) = SN (MethodN (UN n))

@@ -175,8 +182,8 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

175 let lhs = PApp fc (PRef fc cfn) [pconst capp]

182 let lhs = PApp fc (PRef fc cfn) [pconst capp]

176 let rhs = PResolveTC (fileFC "HACK")

183 let rhs = PResolveTC (fileFC "HACK")

177 let ty = PPi constraint cnm c con

184 let ty = PPi constraint cnm c con

178− iLOG (showTmImpls ty)

185+ logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

179− iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

186+ logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

180 i <- getIState

187 i <- getIState

181 let conn = case con of

188 let conn = case con of

182 PRef _ n -> n

189 PRef _ n -> n

@@ -193,16 +200,16 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

193 -- Generate a top level function which looks up a method in a given

200 -- Generate a top level function which looks up a method in a given

194 -- dictionary (this is inlinable, always)

201 -- dictionary (this is inlinable, always)

195 tfun cn c syn all (m, (doc, o, ty))

202 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)

197 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

204 let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

198 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

205 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

199 let margs = getMArgs ty

206 let margs = getMArgs ty

200 let anames = map (\x -> sMN x "arg") [0..]

207 let anames = map (\x -> sMN x "arg") [0..]

201 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

208 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

202 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

209 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

203− iLOG (showTmImpls ty')

210+ logLvl 2 ("Top level type: " ++ showTmImpls ty')

204 iLOG (show (m, ty', capp, margs))

211 iLOG (show (m, ty', capp, margs))

205− iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

212+ logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

206 return [PTy doc [] syn fc o m ty',

213 return [PTy doc [] syn fc o m ty',

207 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

214 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

208

215

@@ -236,6 +243,15 @@ elabClass info syn_in doc fc constraints tn ps pDocs fds ds

236 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

243 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

237 toExp ns e sc = sc

244 toExp ns e sc = sc

238

245

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+

239findDets :: Name -> [Name] -> Idris [Int]

255findDets :: Name -> [Name] -> Idris [Int]

240findDets n ns =

256findDets n ns =

241 do i <- getIState

257 do i <- getIState

src/Idris/Elab/Clause.hs+26−69

@@ -7,7 +7,7 @@ import Idris.DSL

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

11import Idris.Coverage

12import Idris.DataOpts

13import Idris.Providers

@@ -433,7 +433,7 @@ elabPE info fc caller r =

433 showArg _ = ""

434

435 qshow (Bind _ _ _) = "fn"

436− qshow (App f a) = qshow f ++ qshow a

436+ qshow (App _ f a) = qshow f ++ qshow a

437 qshow (P _ n _) = show n

438 qshow (Constant c) = show c

439 qshow _ = ""

@@ -444,71 +444,27 @@ elabPE info fc caller r =

444 qhash hash [] = showHex (abs hash `mod` 0xffffffff) ""

445 qhash hash (x:xs) = qhash (hash * 33 + fromEnum x) xs

446

447−-- checks if the clause is a possible left hand side. Returns the term if

447+-- | Checks if the clause is a possible left hand side.

448−-- possible, otherwise Nothing.

449−

450checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool

448checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool

451checkPossible info fc tcgen fname lhs_in

449checkPossible info fc tcgen fname lhs_in

452 = do ctxt <- getContext

450 = do ctxt <- getContext

453 i <- getIState

451 i <- getIState

454 let lhs = addImplPat i lhs_in

452 let lhs = addImplPat i lhs_in

455 -- if the LHS type checks, it is possible

453 -- 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

457 (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

455 (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

458 OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->

456 OK (ElabResult lhs' _ _ ctxt' newDecls, _) ->

459 do setContext ctxt'

457 do setContext ctxt'

460− processTacticDecls newDecls

458+ processTacticDecls info newDecls

461 let lhs_tm = orderPats (getInferTerm lhs')

459 let lhs_tm = orderPats (getInferTerm lhs')

462 case recheck ctxt [] (forget lhs_tm) lhs_tm of

460 case recheck ctxt [] (forget lhs_tm) lhs_tm of

463 OK _ -> return True

461 OK _ -> return True

464 err -> return False

462 err -> return False

465 -- if it's a recoverable error, the case may become possible

463 -- if it's a recoverable error, the case may become possible

466− Error err -> if tcgen then return (recoverable ctxt err)

464+ Error err -> if tcgen then return (recoverableCoverage ctxt err)

467− else return (validCase ctxt err ||

465+ else return (validCoverageCase ctxt err ||

468− recoverable ctxt err)

466+ recoverableCoverage ctxt err)

469− where validCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

467+

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

512

468

513propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm

469propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm

514propagateParams i ps t tm@(PApp _ (PRef fc n) args)

470propagateParams 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

582 "\n" ++ show (fn_ty, fn_is))

538 "\n" ++ show (fn_ty, fn_is))

583

539

584 ((ElabResult lhs' dlhs [] ctxt' newDecls, probs, inj), _) <-

540 ((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

586 (do res <- errAt "left hand side of " fname

542 (do res <- errAt "left hand side of " fname

587 (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

543 (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

588 probs <- get_probs

544 probs <- get_probs

589 inj <- get_inj

545 inj <- get_inj

590 return (res, probs, inj))

546 return (res, probs, inj))

591 setContext ctxt'

547 setContext ctxt'

592− processTacticDecls newDecls

548+ processTacticDecls info newDecls

593 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

549 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

594

550

595 let lhs_tm = orderPats (getInferTerm lhs')

551 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

657 ctxt <- getContext -- new context with where block added

613 ctxt <- getContext -- new context with where block added

658 logLvl 5 "STARTING CHECK"

614 logLvl 5 "STARTING CHECK"

659 ((rhs', defer, is, probs, ctxt', newDecls), _) <-

615 ((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

661 (do pbinds ist lhs_tm

617 (do pbinds ist lhs_tm

662 mapM_ setinj (nub (params ++ inj))

618 mapM_ setinj (nub (params ++ inj))

663 setNextName

619 setNextName

@@ -667,14 +623,15 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

667 errAt "right hand side of " fname

623 errAt "right hand side of " fname

668 (erun fc $ psolve lhs_tm)

624 (erun fc $ psolve lhs_tm)

669 hs <- get_holes

625 hs <- get_holes

670− aux <- getAux

671− mapM_ (elabCaseHole (case_decls aux)) hs

626+ mapM_ (elabCaseHole is) hs

672 tt <- get_term

627 tt <- get_term

628+ aux <- getAux

673− let (tm, ds) = runState (collectDeferred (Just fname) tt) []

629+ let (tm, ds) = runState (collectDeferred (Just fname)

630+ (map fst $ case_decls aux) ctxt tt) []

674 probs <- get_probs

631 probs <- get_probs

675 return (tm, ds, is, probs, ctxt', newDecls))

632 return (tm, ds, is, probs, ctxt', newDecls))

676 setContext ctxt'

633 setContext ctxt'

677− processTacticDecls newDecls

634+ processTacticDecls info newDecls

678 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

635 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

679

636

680 logLvl 5 "DONE CHECK"

637 logLvl 5 "DONE CHECK"

@@ -745,14 +702,14 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

745 -- Find the variable names which appear under a 'Ownership.Read' so that

702 -- Find the variable names which appear under a 'Ownership.Read' so that

746 -- we know they can't be used on the RHS

703 -- we know they can't be used on the RHS

747 borrowedNames :: [Name] -> Term -> [Name]

704 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)

749 | owner == txt "Ownership" &&

706 | owner == txt "Ownership" &&

750 (lend == txt "lend" || lend == txt "Read") = getVs arg

707 (lend == txt "lend" || lend == txt "Read") = getVs arg

751 where

708 where

752 getVs (V i) = [env!!i]

709 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

754 getVs _ = []

711 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

756 borrowedNames env (Bind n b sc) = nub $ borrowedB b ++ borrowedNames (n:env) sc

713 borrowedNames env (Bind n b sc) = nub $ borrowedB b ++ borrowedNames (n:env) sc

757 where borrowedB (Let t v) = nub $ borrowedNames env t ++ borrowedNames env v

714 where borrowedB (Let t v) = nub $ borrowedNames env t ++ borrowedNames env v

758 borrowedB b = borrowedNames env (binderTy b)

715 borrowedB b = borrowedNames env (binderTy b)

@@ -818,11 +775,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

818 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

775 let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

819 logLvl 2 ("LHS: " ++ show lhs)

776 logLvl 2 ("LHS: " ++ show lhs)

820 (ElabResult lhs' dlhs [] ctxt' newDecls, _) <-

777 (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

822 (errAt "left hand side of with in " fname

779 (errAt "left hand side of with in " fname

823 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

780 (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

824 setContext ctxt'

781 setContext ctxt'

825− processTacticDecls newDecls

782+ processTacticDecls info newDecls

826 let lhs_tm = orderPats (getInferTerm lhs')

783 let lhs_tm = orderPats (getInferTerm lhs')

827 let lhs_ty = getInferType lhs'

784 let lhs_ty = getInferType lhs'

828 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

785 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)

835 logLvl 5 ("Checking " ++ showTmImpls wval)

792 logLvl 5 ("Checking " ++ showTmImpls wval)

836 -- Elaborate wval in this context

793 -- Elaborate wval in this context

837 ((wval', defer, is, ctxt', newDecls), _) <-

794 ((wval', defer, is, ctxt', newDecls), _) <-

838− tclift $ elaborate ctxt (sMN 0 "withRHS")

795+ tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

839 (bindTyArgs PVTy bargs infP) initEState

796 (bindTyArgs PVTy bargs infP) initEState

840 (do pbinds i lhs_tm

797 (do pbinds i lhs_tm

841 setNextName

798 setNextName

@@ -846,7 +803,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

846 tt <- get_term

803 tt <- get_term

847 return (tt, d, is, ctxt', newDecls))

804 return (tt, d, is, ctxt', newDecls))

848 setContext ctxt'

805 setContext ctxt'

849− processTacticDecls newDecls

806+ processTacticDecls info newDecls

850 def' <- checkDef fc iderr defer

807 def' <- checkDef fc iderr defer

851 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

808 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

852 addDeferred def''

809 addDeferred def''

@@ -933,7 +890,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

933 ctxt <- getContext -- New context with block added

890 ctxt <- getContext -- New context with block added

934 i <- getIState

891 i <- getIState

935 ((rhs', defer, is, ctxt', newDecls), _) <-

892 ((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

937 (do pbinds i lhs_tm

894 (do pbinds i lhs_tm

938 setNextName

895 setNextName

939 (ElabResult _ d is ctxt' newDecls) <- erun fc (build i info ERHS opts fname rhs)

896 (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)

941 tt <- get_term

898 tt <- get_term

942 return (tt, d, is, ctxt', newDecls))

899 return (tt, d, is, ctxt', newDecls))

943 setContext ctxt'

900 setContext ctxt'

944− processTacticDecls newDecls

901+ processTacticDecls info newDecls

945

902

946 def' <- checkDef fc iderr defer

903 def' <- checkDef fc iderr defer

947 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

904 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

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

10+import Idris.Elab.Term

11import Idris.Coverage

12import Idris.DataOpts

13import Idris.Providers

@@ -174,7 +174,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

174 update ((n, _) : as) (_ : args) = (n, Nothing) : update as args

175

176 getDataApp :: Type -> [[Maybe Name]]

177− getDataApp f@(App _ _)

177+ getDataApp f@(App _ _ _)

178 | (P _ d _, args) <- unApply f

179 = if (d == n) then [mParam args args] else []

180 getDataApp (Bind n (Pi _ t _) sc)

@@ -271,7 +271,8 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, t_in, fc, forcenames)

271 getNamePos _ _ _ = Nothing

272

273 -- 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

275 checkUniqueKind (UType NullType) (UType NullType) = return ()

276 checkUniqueKind (UType NullType) (UType NullType) = return ()

276 checkUniqueKind (UType NullType) _

277 checkUniqueKind (UType NullType) _

277 = tclift $ tfail (At fc (UniqueKindError NullType n))

278 = 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)

279 checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()

280 checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()

280 checkUniqueKind (UType UniqueType) _

281 checkUniqueKind (UType UniqueType) _

281 = tclift $ tfail (At fc (UniqueKindError UniqueType n))

282 = 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))

283 checkUniqueKind _ _ = return ()

287 checkUniqueKind _ _ = return ()

284

288

285 -- Constructor's kind must be <= expected kind

289 -- Constructor's kind must be <= expected kind

src/Idris/Elab/Instance.hs+7−7

@@ -7,7 +7,6 @@ import Idris.DSL

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

11import Idris.Coverage

10import Idris.Coverage

12import Idris.DataOpts

11import Idris.DataOpts

13import Idris.Providers

12import Idris.Providers

@@ -21,6 +20,7 @@ import IRTS.Lang

21import Idris.Elab.Type

20import Idris.Elab.Type

22import Idris.Elab.Data

21import Idris.Elab.Data

23import Idris.Elab.Utils

22import Idris.Elab.Utils

23+import Idris.Elab.Term

24

25import Idris.Core.TT

26import Idris.Core.Elaborate hiding (Tactic(..))

@@ -177,10 +177,10 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

177 let ty = addImpl [] i ty'

178 ctxt <- getContext

179 (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

181 (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

182 setContext ctxt'

183− processTacticDecls newDecls

183+ processTacticDecls info newDecls

184 ctxt <- getContext

185 (cty, _) <- recheckC fc id [] tyT

186 let nty = normalise ctxt [] cty

@@ -280,19 +280,19 @@ elabInstance info syn doc argDocs what fc cs n ps t expn ds = do

280 = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds)

281

282 insertDef i meth def clauses ns iname decls

283− | null $ filter (clauseFor meth iname ns) decls

283+ | not $ any (clauseFor meth iname ns) decls

284 = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in

285 -- trace (show newd) $

286 decls ++ [newd]

287 | otherwise = decls

288

289 warnMissing decls ns iname meth

290− | null $ filter (clauseFor meth iname ns) decls

290+ | not $ any (clauseFor meth iname ns) decls

291 = iWarn fc . text $ "method " ++ show meth ++ " not defined"

292 | otherwise = return ()

293

294 checkInClass ns meth

295− | not (null (filter (eqRoot meth) ns)) = return ()

295+ | any (eqRoot meth) ns = return ()

296 | otherwise = tclift $ tfail (At fc (Msg $

297 show meth ++ " not a method of class " ++ show n))

298

@@ -317,7 +317,7 @@ checkInjectiveArgs fc n ds (Just ty)

317

318 isInj i (P Bound n _) = True

319 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

321 isInj i (V _) = True

322 isInj i (Bind n b sc) = isInj i sc

323 isInj _ _ = True

src/Idris/Elab/Provider.hs+3−3

@@ -7,7 +7,6 @@ import Idris.DSL

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

11import Idris.Coverage

10import Idris.Coverage

12import Idris.DataOpts

11import Idris.DataOpts

13import Idris.Providers

12import Idris.Providers

@@ -22,6 +21,7 @@ import Idris.Elab.Type

22import Idris.Elab.Clause

21import Idris.Elab.Clause

23import Idris.Elab.Value

22import Idris.Elab.Value

24import Idris.Elab.Utils

23import Idris.Elab.Utils

24+import Idris.Elab.Term

25

26import Idris.Core.TT

27import Idris.Core.Elaborate hiding (Tactic(..))

@@ -111,8 +111,8 @@ elabProvider doc info syn fc what n

111 -- (MkFFI C_FFI) (Providers.Provider ty) in hopes of better

112 -- error messages with less normalisation

113 providerOf :: Type -> Type

114− providerOf ty = App (P Ref (sUN "IO") Erased) $

114+ providerOf ty = App Complete (P Ref (sUN "IO") Erased) $

115− App (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)

115+ App Complete (P Ref (sNS (sUN "Provider") ["Providers", "Prelude"]) Erased)

116 ty

117

118 isProviderOf :: Context -> TT Name -> TT Name -> Bool

src/Idris/Elab/Record.hs+20−2

@@ -5,7 +5,24 @@ import Idris.AbsSyntax

5import Idris.Docstrings

6import Idris.Error

7import 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+

9import Idris.Core.TT

26import Idris.Core.TT

10import Idris.Core.Evaluate

27import Idris.Core.Evaluate

11

28

@@ -427,4 +444,5 @@ projectInType xs = mapPT st

427

444

428-- | Creates an PArg from a plicity and a name where the term is a PRef.

445-- | Creates an PArg from a plicity and a name where the term is a PRef.

429asPRefArg :: Plicity -> Name -> PArg

446asPRefArg :: 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 #-}

2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3−module Idris.ElabTerm where

3+module Idris.Elab.Term where

4

5import Idris.AbsSyntax

6import Idris.AbsSyntaxTree

@@ -10,11 +10,13 @@ import Idris.Error

10import Idris.ProofSearch

11import Idris.Output (pshow)

12

13+import Idris.Core.CaseTree (SC, SC'(STerm), findCalls, findUsedArgs)

13import Idris.Core.Elaborate hiding (Tactic(..))

14import Idris.Core.Elaborate hiding (Tactic(..))

14import Idris.Core.TT

15import Idris.Core.TT

15import Idris.Core.Evaluate

16import Idris.Core.Evaluate

16import Idris.Core.Unify

17import 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)

18import Idris.ErrReverse (errReverse)

20import Idris.ErrReverse (errReverse)

19import Idris.ElabQuasiquote (extractUnquotes)

21import Idris.ElabQuasiquote (extractUnquotes)

20import Idris.Elab.Utils

22import Idris.Elab.Utils

@@ -26,7 +28,7 @@ import Control.Monad

26import Control.Monad.State.Strict

28import Control.Monad.State.Strict

27import Data.List

29import Data.List

28import qualified Data.Map as M

30import qualified Data.Map as M

29−import Data.Maybe (mapMaybe, fromMaybe)

31+import Data.Maybe (mapMaybe, fromMaybe, catMaybes)

30import qualified Data.Set as S

32import qualified Data.Set as S

31import qualified Data.Text as T

33import qualified Data.Text as T

32

34

@@ -35,6 +37,7 @@ import Debug.Trace

35data ElabMode = ETyDecl | ELHS | ERHS

37data ElabMode = ETyDecl | ELHS | ERHS

36 deriving Eq

38 deriving Eq

37

39

40+

38data ElabResult =

41data ElabResult =

39 ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration

42 ElabResult { resultTerm :: Term -- ^ The term resulting from elaboration

40 , resultMetavars :: [(Name, (Int, Maybe Name, Type))]

43 , resultMetavars :: [(Name, (Int, Maybe Name, Type))]

@@ -43,23 +46,10 @@ data ElabResult =

43 -- ^ Deferred declarations as the meaning of case blocks

46 -- ^ Deferred declarations as the meaning of case blocks

44 , resultContext :: Context

47 , resultContext :: Context

45 -- ^ The potentially extended context from new definitions

48 -- ^ The potentially extended context from new definitions

46− , resultTyDecls :: [(Name, FC, [PArg], Type)]

49+ , resultTyDecls :: [RDeclInstructions]

47 -- ^ Meta-info about the new type declarations

50 -- ^ Meta-info about the new type declarations

48 }

51 }

49

52

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−

63

53

64-- Using the elaborator, convert a term in raw syntax to a fully

54-- Using the elaborator, convert a term in raw syntax to a fully

65-- elaborated, typechecked term.

55-- elaborated, typechecked term.

@@ -122,11 +112,11 @@ build ist info emode opts fn tm

122 update_term orderPats)

112 update_term orderPats)

123 EState is _ impls <- getAux

113 EState is _ impls <- getAux

124 tt <- get_term

114 tt <- get_term

125− let (tm, ds) = runState (collectDeferred (Just fn) tt) []

126− log <- getLog

127 ctxt <- get_context

115 ctxt <- get_context

116+ let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

117+ log <- getLog

128− if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)

118+ if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

129− else return (ElabResult tm ds is ctxt impls)

119+ else return (ElabResult tm ds (map snd is) ctxt impls)

130 where pattern = emode == ELHS

120 where pattern = emode == ELHS

131 tydecl = emode == ETyDecl

121 tydecl = emode == ETyDecl

132

122

@@ -164,11 +154,11 @@ buildTC ist info emode opts fn tm

164 lift (Error (CantMatch (getInferTerm tm)))

154 lift (Error (CantMatch (getInferTerm tm)))

165 EState is _ impls <- getAux

155 EState is _ impls <- getAux

166 tt <- get_term

156 tt <- get_term

167− let (tm, ds) = runState (collectDeferred (Just fn) tt) []

168− log <- getLog

169 ctxt <- get_context

157 ctxt <- get_context

158+ let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

159+ log <- getLog

170− if (log /= "") then trace log $ return (ElabResult tm ds is ctxt impls)

160+ if (log /= "") then trace log $ return (ElabResult tm ds (map snd is) ctxt impls)

171− else return (ElabResult tm ds is ctxt impls)

161+ else return (ElabResult tm ds (map snd is) ctxt impls)

172 where pattern = emode == ELHS

162 where pattern = emode == ELHS

173

163

174-- return whether arguments of the given constructor name can be

164-- return whether arguments of the given constructor name can be

@@ -213,7 +203,7 @@ goal_polymorphic =

213

203

214-- | Returns the set of declarations we need to add to complete the

204-- | Returns the set of declarations we need to add to complete the

215-- definition (most likely case blocks to elaborate) as well as

205-- 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)

217elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->

207elab :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->

218 ElabD ()

208 ElabD ()

219elab ist info emode opts fn tm

209elab ist info emode opts fn tm

@@ -262,9 +252,7 @@ elab ist info emode opts fn tm

262 -- normally correct to call elabE - the ones that don't are desugarings

252 -- normally correct to call elabE - the ones that don't are desugarings

263 -- typically

253 -- typically

264 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()

254 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()

265− elabE ina fc' t =

255+ elabE ina fc' t =

266− --do g <- goal

267− --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

268 do solved <- get_recents

256 do solved <- get_recents

269 as <- get_autos

257 as <- get_autos

270 -- If any of the autos use variables which have recently been solved,

258 -- If any of the autos use variables which have recently been solved,

@@ -430,7 +418,7 @@ elab ist info emode opts fn tm

430 [pimp (sMN 0 "a") t False,

418 [pimp (sMN 0 "a") t False,

431 pimp (sMN 0 "P") Placeholder True,

419 pimp (sMN 0 "P") Placeholder True,

432 pexp l, pexp r])

420 pexp l, pexp r])

433− elab' ina fc (PAlternative True as)

421+ elab' ina fc (PAlternative True as)

434 = do hnf_compute

422 = do hnf_compute

435 ty <- goal

423 ty <- goal

436 ctxt <- get_context

424 ctxt <- get_context

@@ -953,7 +941,7 @@ elab ist info emode opts fn tm

953 (caseBlock fc cname'

941 (caseBlock fc cname'

954 (map (isScr scr) (reverse args')) opts)

942 (map (isScr scr) (reverse args')) opts)

955 -- elaborate case

943 -- elaborate case

956− updateAux (\e -> e { case_decls = newdef : case_decls e } )

944+ updateAux (\e -> e { case_decls = (cname', newdef) : case_decls e } )

957 -- if we haven't got the type yet, hopefully we'll get it later!

945 -- if we haven't got the type yet, hopefully we'll get it later!

958 movelast tyn

946 movelast tyn

959 solve

947 solve

@@ -967,7 +955,7 @@ elab ist info emode opts fn tm

967 _ -> n

955 _ -> n

968

956

969 inApp (P _ n _) = [n]

957 inApp (P _ n _) = [n]

970− inApp (App f a) = inApp f ++ inApp a

958+ inApp (App _ f a) = inApp f ++ inApp a

971 inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

959 inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

972 inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc

960 inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc

973 inApp (Bind n b sc) = inApp sc

961 inApp (Bind n b sc) = inApp sc

@@ -1012,9 +1000,10 @@ elab ist info emode opts fn tm

1012 -- Save the old state - we need a fresh proof state to avoid

1000 -- Save the old state - we need a fresh proof state to avoid

1013 -- capturing lexically available variables in the quoted term.

1001 -- capturing lexically available variables in the quoted term.

1014 ctxt <- get_context

1002 ctxt <- get_context

1003+ datatypes <- get_datatypes

1015 saveState

1004 saveState

1016 updatePS (const .

1005 updatePS (const .

1017− newProof (sMN 0 "q") ctxt $

1006+ newProof (sMN 0 "q") ctxt datatypes $

1018 P Ref (reflm "TT") Erased)

1007 P Ref (reflm "TT") Erased)

1019

1008

1020 -- Re-add the unquotes, letting Idris infer the (fictional)

1009 -- Re-add the unquotes, letting Idris infer the (fictional)

@@ -1085,6 +1074,17 @@ elab ist info emode opts fn tm

1085

1074

1086

1075

1087 elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote"

1076 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

1088 elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"

1089 elab' ina fc (PHidden t)

1090 | reflection = elab' ina fc t

@@ -1100,11 +1100,13 @@ elab ist info emode opts fn tm

1100 delayElab $ do focus h

1101 dotterm

1102 elab' ina fc t

1103− elab' ina fc (PRunTactics fc' tm) =

1103+ elab' ina fc (PRunElab fc' tm) =

1104 do attack

1105 n <- getNameFrom (sMN 0 "tacticScript")

1106 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)

1108 claim n scriptTy

1110 claim n scriptTy

1109 movelast n

1111 movelast n

1110 letbind n' scriptTy (Var n)

1112 letbind n' scriptTy (Var n)

@@ -1112,11 +1114,10 @@ elab ist info emode opts fn tm

1112 elab' ina (Just fc') tm

1114 elab' ina (Just fc') tm

1113 env <- get_env

1115 env <- get_env

1114 runTactical (maybe fc' id fc) env (P Bound n' Erased)

1116 runTactical (maybe fc' id fc) env (P Bound n' Erased)

1115− EState _ _ todo <- getAux

1116 solve

1117 solve

1117 elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x

1118 elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x

1118

1119

1119− delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

1120+ delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

1120

1121

1121 isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))

1122 isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))

1122 isScr (PRef _ n) (n', b) = (n', (n == n', b))

1123 isScr (PRef _ n) (n', b) = (n', (n == n', b))

@@ -1378,7 +1379,7 @@ pruneByType _ t _ as = as

1378

1379

1379findInstances :: IState -> Term -> [Name]

1380findInstances :: IState -> Term -> [Name]

1380findInstances ist t

1381findInstances ist t

1381− | (P _ n _, _) <- unApply t

1382+ | (P _ n _, _) <- unApply (getRetTy t)

1382 = case lookupCtxt n (idris_classes ist) of

1383 = case lookupCtxt n (idris_classes ist) of

1383 [CI _ _ _ _ _ ins _] -> filter accessible ins

1384 [CI _ _ _ _ _ ins _] -> filter accessible ins

1384 _ -> []

1385 _ -> []

@@ -1429,17 +1430,17 @@ resTC' tcs defaultOn topholes depth topg fn ist

1429 = do compute

1430 = do compute

1430 g <- goal

1431 g <- goal

1431 let argsok = tcArgsOK g topholes

1432 let argsok = tcArgsOK g topholes

1432−-- trace (show (g,hs,argsok,topholes)) $

1433 if not argsok -- && not mvok)

1434 then lift $ tfail $ CantResolve True topg

1435 else do

1436 ptm <- get_term

1437 ulog <- getUnifyLog

1438 hs <- get_holes

1439+ env <- get_env

1439− traceWhen ulog ("Resolving class " ++ show g) $

1440+ traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env) $

1440 try' (trivial' ist)

1441 try' (trivial' ist)

1441 (do t <- goal

1442 (do t <- goal

1442− let (tc, ttypes) = unApply t

1443+ let (tc, ttypes) = unApply (getRetTy t)

1443 scopeOnly <- needsDefault t tc ttypes

1444 scopeOnly <- needsDefault t tc ttypes

1444 let stk = elab_stack ist

1445 let stk = elab_stack ist

1445 let insts_in = findInstances ist t

1446 let insts_in = findInstances ist t

@@ -1449,10 +1450,10 @@ resTC' tcs defaultOn topholes depth topg fn ist

1449 let depth' = if scopeOnly then 2 else depth

1450 let depth' = if scopeOnly then 2 else depth

1450 blunderbuss t depth' stk (stk ++ insts)) True

1451 blunderbuss t depth' stk (stk ++ insts)) True

1451 where

1452 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

1453 = True

1454 = True

1454 tcArgsOK ty hs -- if any arguments are metavariables, postpone

1455 tcArgsOK ty hs -- if any arguments are metavariables, postpone

1455− = let (f, as) = unApply ty in

1456+ = let (f, as) = unApply (getRetTy ty) in

1456 case f of

1457 case f of

1457 P _ cn _ -> case lookupCtxtExact cn (idris_classes ist) of

1458 P _ cn _ -> case lookupCtxtExact cn (idris_classes ist) of

1458 Just ci -> tcDetArgsOK 0 (class_determiners ci) hs as

1459 Just ci -> tcDetArgsOK 0 (class_determiners ci) hs as

@@ -1469,7 +1470,7 @@ resTC' tcs defaultOn topholes depth topg fn ist

1469 isMeta _ _ = False

1470 isMeta _ _ = False

1470

1471

1471 notHole hs (P _ n _, c)

1472 notHole hs (P _ n _, c)

1472− | (P _ cn _, _) <- unApply c,

1473+ | (P _ cn _, _) <- unApply (getRetTy c),

1473 n `elem` hs && isConName cn (tt_ctxt ist) = False

1474 n `elem` hs && isConName cn (tt_ctxt ist) = False

1474 | Constant _ <- c = not (n `elem` hs)

1475 | Constant _ <- c = not (n `elem` hs)

1475 notHole _ _ = True

1476 notHole _ _ = True

@@ -1510,11 +1511,22 @@ resTC' tcs defaultOn topholes depth topg fn ist

1510 _ -> blunderbuss t d stk ns)

1511 _ -> blunderbuss t d stk ns)

1511 | otherwise = blunderbuss t d stk ns

1512 | otherwise = blunderbuss t d stk ns

1512

1513

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+

1513 resolve n depth

1524 resolve n depth

1514 | depth == 0 = fail $ "Can't resolve type class"

1525 | depth == 0 = fail $ "Can't resolve type class"

1515 | otherwise

1526 | otherwise

1527+ = do lams <- introImps

1516− = do t <- goal

1528+ t <- goal

1517− let (tc, ttypes) = unApply t

1529+ let (tc, ttypes) = trace (show t) $ unApply (getRetTy t)

1518-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

1530-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

1519-- else do

1531-- else do

1520 -- if there's a hole in the goal, don't even try

1532 -- if there's a hole in the goal, don't even try

@@ -1526,14 +1538,15 @@ resTC' tcs defaultOn topholes depth topg fn ist

1526 tm <- get_term

1538 tm <- get_term

1527 args <- map snd <$> try' (apply (Var n) imps)

1539 args <- map snd <$> try' (apply (Var n) imps)

1528 (match_apply (Var n) imps) True

1540 (match_apply (Var n) imps) True

1541+ solven lams -- close any implicit lambdas we introduced

1529 ps' <- get_probs

1542 ps' <- get_probs

1530 when (length ps < length ps' || unrecoverable ps') $

1543 when (length ps < length ps' || unrecoverable ps') $

1531 fail "Can't apply type class"

1544 fail "Can't apply type class"

1532-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

1545-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

1533 mapM_ (\ (_,n) -> do focus n

1546 mapM_ (\ (_,n) -> do focus n

1534 t' <- goal

1547 t' <- goal

1535− let (tc', ttype) = unApply t'

1548+ let (tc', ttype) = unApply (getRetTy t')

1536− let got = fst (unApply t)

1549+ let got = fst (unApply (getRetTy t))

1537 let depth' = if tc' `elem` tcs

1550 let depth' = if tc' `elem` tcs

1538 then depth - 1 else depth

1551 then depth - 1 else depth

1539 resTC' (got : tcs) defaultOn topholes depth' topg fn ist)

1552 resTC' (got : tcs) defaultOn topholes depth' topg fn ist)

@@ -1546,23 +1559,49 @@ resTC' tcs defaultOn topholes depth topg fn ist

1546 where isImp (PImp p _ _ _ _) = (True, p)

1559 where isImp (PImp p _ _ _ _) = (True, p)

1547 isImp arg = (False, priority arg)

1560 isImp arg = (False, priority arg)

1548

1561

1549−collectDeferred :: Maybe Name ->

1562+collectDeferred :: Maybe Name -> [Name] -> Context ->

1550 Term -> State [(Name, (Int, Maybe Name, Type))] Term

1563 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) =

1552 do ds <- get

1565 do ds <- get

1553− t' <- collectDeferred top t

1566+ t' <- collectDeferred top casenames ctxt t

1554− when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, t'))])

1567+ when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, tidyArg [] t'))])

1555− collectDeferred top app

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+

1556−collectDeferred top (Bind n b t) = do b' <- cdb b

1593+collectDeferred top ns ctxt (Bind n b t)

1594+ = do b' <- cdb b

1557− t' <- collectDeferred top t

1595+ t' <- collectDeferred top ns ctxt t

1558− return (Bind n b' t')

1596+ return (Bind n b' t')

1559 where

1597 where

1560− cdb (Let t v) = liftM2 Let (collectDeferred top t) (collectDeferred top v)

1598+ cdb (Let t v) = liftM2 Let (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1561− cdb (Guess t v) = liftM2 Guess (collectDeferred top t) (collectDeferred top v)

1599+ cdb (Guess t v) = liftM2 Guess (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1562− cdb b = do ty' <- collectDeferred top (binderTy b)

1600+ cdb b = do ty' <- collectDeferred top ns ctxt (binderTy b)

1563 return (b { binderTy = ty' })

1601 return (b { binderTy = ty' })

1564−collectDeferred top (App f a) = liftM2 App (collectDeferred top f) (collectDeferred top a)

1602+collectDeferred top ns ctxt (App s f a) = liftM2 (App s) (collectDeferred top ns ctxt f)

1603+ (collectDeferred top ns ctxt a)

1565−collectDeferred top t = return t

1604+collectDeferred top ns ctxt t = return t

1566

1605

1567case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()

1606case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()

1568case_ ind autoSolve ist fn tm = do

1607case_ ind autoSolve ist fn tm = do

@@ -1582,8 +1621,6 @@ case_ ind autoSolve ist fn tm = do

1582 else casetac (forget val)

1621 else casetac (forget val)

1583 when autoSolve solveAll

1622 when autoSolve solveAll

1584

1623

1585−tacN :: String -> Name

1586−tacN str = sNS (sUN str) ["Tactical", "Reflection", "Language"]

1587

1624

1588runTactical :: FC -> Env -> Term -> ElabD ()

1625runTactical :: FC -> Env -> Term -> ElabD ()

1589runTactical fc env tm = do tm' <- eval tm

1626runTactical fc env tm = do tm' <- eval tm

@@ -1591,10 +1628,50 @@ runTactical fc env tm = do tm' <- eval tm

1591 return ()

1628 return ()

1592 where

1629 where

1593 eval tm = do ctxt <- get_context

1630 eval tm = do ctxt <- get_context

1631+ env <- get_env

1594 return $ normaliseAll ctxt env (finalise tm)

1632 return $ normaliseAll ctxt env (finalise tm)

1595

1633

1596 returnUnit = fmap fst $ get_type_val (Var unitCon)

1634 returnUnit = fmap fst $ get_type_val (Var unitCon)

1597

1635

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+

1598 -- | Do a step in the reflected elaborator monad. The input is the

1675 -- | Do a step in the reflected elaborator monad. The input is the

1599 -- step, the output is the (reflected) term returned.

1676 -- step, the output is the (reflected) term returned.

1600 runTacTm :: Term -> ElabD Term

1677 runTacTm :: Term -> ElabD Term

@@ -1623,6 +1700,35 @@ runTactical fc env tm = do tm' <- eval tm

1623 else fmap fst . get_type_val $

1700 else fmap fst . get_type_val $

1624 RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))

1701 RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))

1625 (Var (reflm "TT"))

1702 (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'))

1626 | n == tacN "prim__SourceLocation", [] <- args

1732 | n == tacN "prim__SourceLocation", [] <- args

1627 = fmap fst . get_type_val $

1733 = fmap fst . get_type_val $

1628 reflectFC fc

1734 reflectFC fc

@@ -1633,19 +1739,23 @@ runTactical fc env tm = do tm' <- eval tm

1633 = do errs' <- eval errs

1739 = do errs' <- eval errs

1634 parts <- reifyReportParts errs'

1740 parts <- reifyReportParts errs'

1635 lift . tfail $ ReflectionError [parts] (Msg "")

1741 lift . tfail $ ReflectionError [parts] (Msg "")

1636− | n == tacN "prim__PureTactical", [_a, tm] <- args

1742+ | n == tacN "prim__PureElab", [_a, tm] <- args

1637 = return tm

1743 = return tm

1638− | n == tacN "prim__BindTactical", [_a, _b, first, andThen] <- args

1744+ | n == tacN "prim__BindElab", [_a, _b, first, andThen] <- args

1639 = do first' <- eval first

1745 = do first' <- eval first

1640− res <- runTacTm first'

1746+ res <- eval =<< runTacTm first'

1641− next <- eval (App andThen res)

1747+ next <- eval (App Complete andThen res)

1642 runTacTm next

1748 runTacTm next

1643 | n == tacN "prim__Try", [_a, first, alt] <- args

1749 | n == tacN "prim__Try", [_a, first, alt] <- args

1644 = do first' <- eval first

1750 = do first' <- eval first

1645 alt' <- eval alt

1751 alt' <- eval alt

1646 try' (runTacTm first') (runTacTm alt') True

1752 try' (runTacTm first') (runTacTm alt') True

1647 | n == tacN "prim__Fill", [raw] <- args

1753 | 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

1649 apply raw' []

1759 apply raw' []

1650 returnUnit

1760 returnUnit

1651 | n == tacN "prim__Gensym", [hint] <- args

1761 | n == tacN "prim__Gensym", [hint] <- args

@@ -1662,7 +1772,7 @@ runTactical fc env tm = do tm' <- eval tm

1662 returnUnit

1772 returnUnit

1663 | n == tacN "prim__Forget", [tt] <- args

1773 | n == tacN "prim__Forget", [tt] <- args

1664 = do tt' <- reifyTT tt

1774 = do tt' <- reifyTT tt

1665− fmap fst . get_type_val $ reflect tt'

1775+ fmap fst . get_type_val . reflectRaw $ forget tt'

1666 | n == tacN "prim__Attack", [] <- args

1776 | n == tacN "prim__Attack", [] <- args

1667 = do attack

1777 = do attack

1668 returnUnit

1778 returnUnit

@@ -1684,6 +1794,21 @@ runTactical fc env tm = do tm' <- eval tm

1684 Just name -> fmap Just $ reifyTTName name

1794 Just name -> fmap Just $ reifyTTName name

1685 intro n

1795 intro n

1686 returnUnit

1796 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

1687 | n == tacN "prim__DeclareType", [decl] <- args

1812 | n == tacN "prim__DeclareType", [decl] <- args

1688 = do (RDeclare n args res) <- reifyTyDecl decl

1813 = do (RDeclare n args res) <- reifyTyDecl decl

1689 ctxt <- get_context

1814 ctxt <- get_context

@@ -1693,9 +1818,10 @@ runTactical fc env tm = do tm' <- eval tm

1693 rty = foldr mkPi res args

1818 rty = foldr mkPi res args

1694 (checked, ty') <- lift $ check ctxt [] rty

1819 (checked, ty') <- lift $ check ctxt [] rty

1695 case normaliseAll ctxt [] (finalise ty') of

1820 case normaliseAll ctxt [] (finalise ty') of

1821+ UType _ -> return ()

1822+ TType _ -> return ()

1696− TType _ -> lift . tfail . InternalMsg $

1823+ ty'' -> lift . tfail . InternalMsg $

1697− show checked ++ " is not a type: it's " ++ show ty'

1824+ show checked ++ " is not a type: it's " ++ show ty''

1698− _ -> return ()

1699 case lookupDefExact n ctxt of

1825 case lookupDefExact n ctxt of

1700 Just _ -> lift . tfail . InternalMsg $

1826 Just _ -> lift . tfail . InternalMsg $

1701 show n ++ " is already defined."

1827 show n ++ " is already defined."

@@ -1703,17 +1829,41 @@ runTactical fc env tm = do tm' <- eval tm

1703 let decl = TyDecl Ref checked

1829 let decl = TyDecl Ref checked

1704 ctxt' = addCtxtDef n decl ctxt

1830 ctxt' = addCtxtDef n decl ctxt

1705 set_context ctxt'

1831 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) :

1707 new_tyDecls e }

1833 new_tyDecls e }

1708 aux <- getAux

1834 aux <- getAux

1709 returnUnit

1835 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')

1710 | n == tacN "prim__Debug", [ty, msg] <- args

1860 | n == tacN "prim__Debug", [ty, msg] <- args

1711 = do let msg' = fromTTMaybe msg

1861 = do let msg' = fromTTMaybe msg

1712 case msg' of

1862 case msg' of

1713 Nothing -> debugElaborator Nothing

1863 Nothing -> debugElaborator Nothing

1714 Just (Constant (Str m)) -> debugElaborator (Just m)

1864 Just (Constant (Str m)) -> debugElaborator (Just m)

1715 Just x -> lift . tfail . InternalMsg $ "Can't reify message for debugging: " ++ show x

1865 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

1717

1867

1718-- Running tactics directly

1868-- Running tactics directly

1719-- if a tactic adds unification problems, return an error

1869-- if a tactic adds unification problems, return an error

@@ -1968,781 +2118,6 @@ runTac autoSolve ist perhapsFC fn tac

1968 runReflected t = do t' <- reify ist t

2118 runReflected t = do t' <- reify ist t

1969 runTac autoSolve ist perhapsFC fn t'

2119 runTac autoSolve ist perhapsFC fn t'

1970

2120

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−

2746elaboratingArgErr :: [(Name, Name)] -> Err -> Err

2121elaboratingArgErr :: [(Name, Name)] -> Err -> Err

2747elaboratingArgErr [] err = err

2122elaboratingArgErr [] err = err

2748elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

2123elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

@@ -2813,70 +2188,108 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2813 [] -> e

2188 [] -> e

2814 parts -> ReflectionError errorparts e

2189 parts -> ReflectionError errorparts e

2815

2190

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−

2882solveAll = try (do solve; solveAll) (return ())

2191solveAll = 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

7import Idris.Error

8import Idris.Delaborate

9import Idris.Imports

10−import Idris.ElabTerm

11import Idris.Coverage

10import Idris.Coverage

12import Idris.DataOpts

11import Idris.DataOpts

13import Idris.Providers

12import Idris.Providers

@@ -19,6 +18,7 @@ import Idris.Output (iputStrLn, pshow, iWarn)

19import IRTS.Lang

18import IRTS.Lang

20

19

21import Idris.Elab.Utils

20import Idris.Elab.Utils

21+import Idris.Elab.Term

22

23import Idris.Core.TT

24import Idris.Core.Elaborate hiding (Tactic(..))

@@ -54,11 +54,11 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

54 i <- getIState

55 let lhs = addImplPat i lhs_in

56 (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

58 (erun fc (buildTC i info ELHS [] (sUN "transform")

59 (infTerm lhs)))

60 setContext ctxt'

61− processTacticDecls newDecls

61+ processTacticDecls info newDecls

62 let lhs_tm = orderPats (getInferTerm lhs')

63 let lhs_ty = getInferType lhs'

64 let newargs = pvars i lhs_tm

@@ -69,16 +69,16 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ tf) _) rhs_in

69

70 let rhs = addImplBound i (map fst newargs) rhs_in

71 ((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

73 (do pbinds i lhs_tm

74 setNextName

75 (ElabResult _ _ _ ctxt' newDecls) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

76 erun fc $ psolve lhs_tm

77 tt <- get_term

78− let (rhs', defer) = runState (collectDeferred Nothing tt) []

78+ let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

79 return (rhs', defer, ctxt', newDecls))

80 setContext ctxt'

81− processTacticDecls newDecls

81+ processTacticDecls info newDecls

82

83 (crhs_tm_in, crhs_ty) <- recheckC fc id [] rhs'

84 let crhs_tm = renamepats pnames crhs_tm_in

src/Idris/Elab/Type.hs+5−5

@@ -8,7 +8,7 @@ import Idris.DSL

8import Idris.Error

9import Idris.Delaborate

10import Idris.Imports

11−import Idris.ElabTerm

11+import Idris.Elab.Term

12import Idris.Coverage

13import Idris.DataOpts

14import Idris.Providers

@@ -67,10 +67,10 @@ buildType info syn fc opts n ty' = do

67 logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

68

69 (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

71 (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))

72 setContext ctxt'

73− processTacticDecls newDecls

73+ processTacticDecls info newDecls

74

75 let tyT = patToImp tyT'

76

@@ -215,8 +215,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

215 errrep = txt "ErrorReportPart"

216

217 tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _)

218− (App (P _ (NS (UN m) ns2) _)

218+ (App _ (P _ (NS (UN m) ns2) _)

219− (App (P _ (NS (UN l) ns3) _)

219+ (App _ (P _ (NS (UN l) ns3) _)

220 (P _ (NS (UN r) ns4) _))))

221 | e == err && m == maybe && l == lst && r == errrep

222 , 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)

171 _ -> []

172getFixedInType i env (_ : is) (Bind n (Pi _ t _) sc)

173 = 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)

175 | (P _ tn _, args) <- unApply tm

176 = case lookupCtxt tn (idris_datatypes i) of

177 [t] -> nub $ paramNames args env (param_pos t) ++

@@ -186,27 +186,29 @@ getFixedInType i _ _ _ = []

186getFlexInType i env ps (Bind n (Pi _ t _) sc)

187 = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++

188 getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)

189+

189−getFlexInType i env ps tm@(App f a)

190+getFlexInType i env ps tm@(App _ f a)

190− | (P _ tn _, args) <- unApply tm

191+ | (P nt tn _, args) <- unApply tm, nt /= Bound

191 = case lookupCtxt tn (idris_datatypes i) of

192 = case lookupCtxt tn (idris_datatypes i) of

192 [t] -> nub $ paramNames args env [x | x <- [0..length args],

193 [t] -> nub $ paramNames args env [x | x <- [0..length args],

193 not (x `elem` param_pos t)]

194 not (x `elem` param_pos t)]

194 ++ getFlexInType i env ps f ++

195 ++ getFlexInType i env ps f ++

195 getFlexInType i env ps a

196 getFlexInType i env ps a

196− [] -> let ppos = case lookupCtxt tn (idris_fninfo i) of

197+ [] -> let ppos = case lookupCtxtName tn (idris_fninfo i) of

197− [fi] -> fn_params fi

198+ [fi] -> fn_params (snd fi)

198− [] -> [] in

199+ [] -> []

200+ xs -> error ("Too much function info: " ++ show xs)

199− nub $ paramNames args env [x | x <- [0..length args],

201+ in nub $ paramNames args env [x | x <- [0..length args],

200− not (x `elem` ppos)]

202+ not (x `elem` ppos)]

201− ++ getFlexInType i env ps f ++

203+ ++ getFlexInType i env ps f ++

202− getFlexInType i env ps a

204+ getFlexInType i env ps a

203 | otherwise = nub $ getFlexInType i env ps f ++

205 | otherwise = nub $ getFlexInType i env ps f ++

204 getFlexInType i env ps a

206 getFlexInType i env ps a

205getFlexInType i _ _ _ = []

207getFlexInType i _ _ _ = []

206

208

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

208-- types, and never in a non-parameter position in a (non-param) argument type.

210-- types, and never in a non-parameter position in a (non-param) argument type.

209−

211+getParamsInType :: IState -> [Name] -> [PArg] -> Type -> [Name]

210getParamsInType i env ps t = let fix = getFixedInType i env ps t

212getParamsInType i env ps t = let fix = getFixedInType i env ps t

211 flex = getFlexInType i env fix t in

213 flex = getFlexInType i env fix t in

212 [x | x <- fix, not (x `elem` flex)]

214 [x | x <- fix, not (x `elem` flex)]

@@ -232,7 +234,7 @@ getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []

232 _ -> False in

234 _ -> False in

233 do getUniqB env us b

235 do getUniqB env us b

234 getUniq ((n,b):env) ((n, uniq):us) sc

236 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

236 getUniq env us (V i)

238 getUniq env us (V i)

237 | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()

239 | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()

238 getUniq env us (P _ n _)

240 getUniq env us (P _ n _)

src/Idris/Elab/Value.hs+19−4

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

1{-# LANGUAGE PatternGuards #-}

2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3−module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where

3+module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms, elabExec) where

4

5import Idris.AbsSyntax

6import Idris.ASTUtils

@@ -8,7 +8,6 @@ import Idris.DSL

8import Idris.Error

9import Idris.Delaborate

10import Idris.Imports

11−import Idris.ElabTerm

12import Idris.Coverage

11import Idris.Coverage

13import Idris.DataOpts

12import Idris.DataOpts

14import Idris.Providers

13import Idris.Providers

@@ -20,6 +19,7 @@ import Idris.Output (iputStrLn, pshow, iWarn)

20import IRTS.Lang

19import IRTS.Lang

21

20

22import Idris.Elab.Utils

21import Idris.Elab.Utils

22+import Idris.Elab.Term

23

24import Idris.Core.TT

25import Idris.Core.Elaborate hiding (Tactic(..))

@@ -64,12 +64,12 @@ elabValBind info aspat norm tm_in

64 -- * elaboration as a function a -> b

65

66 (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

68 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

69

70 -- Extend the context with new definitions created

71 setContext ctxt'

72− processTacticDecls newDecls

72+ processTacticDecls info newDecls

73

74 let vtm = orderPats (getInferTerm tm')

75

@@ -114,3 +114,18 @@ elabDocTerms info str = do typechecked <- Traversable.mapM decorate str

114 then Example tm

115 else Checked tm

116 | 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

8import Idris.DSL

9import Idris.Error

10import Idris.Delaborate

11+import Idris.Directives

11import Idris.Imports

12import Idris.Imports

12−import Idris.ElabTerm

13+import Idris.Elab.Term

13import Idris.Coverage

14import Idris.Coverage

14import Idris.DataOpts

15import Idris.DataOpts

15import Idris.Providers

16import Idris.Providers

@@ -252,7 +253,7 @@ elabDecl' _ info (PDSL n dsl)

252 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

253 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

253 addIBC (IBCDSL n)

254 addIBC (IBCDSL n)

254elabDecl' what info (PDirective i)

255elabDecl' what info (PDirective i)

255− | what /= EDefns = i

256+ | what /= EDefns = directiveAction i

256elabDecl' what info (PProvider doc syn fc provWhat n)

257elabDecl' what info (PProvider doc syn fc provWhat n)

257 | what /= EDefns

258 | what /= EDefns

258 = do iLOG $ "Elaborating type provider " ++ show n

259 = do iLOG $ "Elaborating type provider " ++ show n

src/Idris/ElabQuasiquote.hs+2−2

@@ -170,8 +170,8 @@ extractUnquotes n (PUnquote tm)

170 return (PRef (fileFC "(unquote)") n, [(n, tm)])

171 | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $

172 extractUnquotes (n-1) tm

173−extractUnquotes n (PRunTactics fc tm)

173+extractUnquotes n (PRunElab fc tm)

174− = fmap (\(tm', ex) -> (PRunTactics fc tm', ex)) $ extractUnquotes n tm

174+ = fmap (\(tm', ex) -> (PRunElab fc tm', ex)) $ extractUnquotes n tm

175extractUnquotes n x = return (x, []) -- no subterms!

176

177

src/Idris/Erasure.hs+13−27

@@ -66,13 +66,11 @@ type Vars = Map Name VarInfo

66-- Perform usage analysis, write the relevant information in the internal

67-- structures, returning the list of reachable names.

68performUsageAnalysis :: [Name] -> Idris [Name]

69−performUsageAnalysis roots = do

69+performUsageAnalysis startNames = do

70 ctx <- tt_ctxt <$> getIState

71− startNames <- getStartNames <$> getIState

72−

73 case startNames of

71 case startNames of

74− Left reason -> return [] -- no main -> not compiling -> reachability irrelevant

72+ [] -> return [] -- no main -> not compiling -> reachability irrelevant

75− Right main -> do

73+ main -> do

76 ci <- idris_classes <$> getIState

74 ci <- idris_classes <$> getIState

77 cg <- idris_callgraph <$> getIState

75 cg <- idris_callgraph <$> getIState

78 opt <- idris_optimisation <$> getIState

76 opt <- idris_optimisation <$> getIState

@@ -107,17 +105,6 @@ performUsageAnalysis roots = do

107

105

108 return $ S.toList reachableNames

106 return $ S.toList reachableNames

109 where

107 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−

121 indent = (" " ++)

108 indent = (" " ++)

122

109

123 fmtItem :: (Cond, DepSet) -> String

110 fmtItem :: (Cond, DepSet) -> String

@@ -292,7 +279,7 @@ buildDepMap ci used externs ctx startNames

292

279

293 etaExpand :: [Name] -> Term -> Term

280 etaExpand :: [Name] -> Term -> Term

294 etaExpand [] t = t

281 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))

296

283

297 getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps

284 getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps

298 getDepsSC fn es vs ImpossibleCase = M.empty

285 getDepsSC fn es vs ImpossibleCase = M.empty

@@ -383,7 +370,7 @@ buildDepMap ci used externs ctx startNames

383 var t cd = getDepsTerm vs bs cd t

370 var t cd = getDepsTerm vs bs cd t

384

371

385 -- applications may add items to Cond

372 -- applications may add items to Cond

386− getDepsTerm vs bs cd app@(App _ _)

373+ getDepsTerm vs bs cd app@(App _ _ _)

387 | (fun, args) <- unApply app = case fun of

374 | (fun, args) <- unApply app = case fun of

388 -- instance constructors -> create metamethod deps

375 -- instance constructors -> create metamethod deps

389 P (DCon _ _ _) ctorName@(SN (InstanceCtorN className)) _

376 P (DCon _ _ _) ctorName@(SN (InstanceCtorN className)) _

@@ -395,12 +382,11 @@ buildDepMap ci used externs ctx startNames

395 P (DCon _ _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used

382 P (DCon _ _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used

396

383

397 -- mkForeign* calls must be special-cased because they are variadic

384 -- mkForeign* calls must be special-cased because they are variadic

398− -- All arguments must be marked as used, except for the first one,

385+ -- All arguments must be marked as used, except for the first four,

399− -- which is the (Foreign a) spec that defines the type

400− -- and is not needed at runtime.

386+ -- which define the call type and are not needed at runtime.

401 P _ (UN n) _

387 P _ (UN n) _

402− | n `elem` map T.pack ["mkForeignPrim"]

388+ | n == T.pack "mkForeignPrim"

403− -> unconditionalDeps args -- (drop 1 args)

389+ -> unconditionalDeps $ drop 4 args

404

390

405 -- a bound variable might draw in additional dependencies,

391 -- a bound variable might draw in additional dependencies,

406 -- think: f x = x 0 <-- here, `x' _is_ used

392 -- think: f x = x 0 <-- here, `x' _is_ used

@@ -431,8 +417,8 @@ buildDepMap ci used externs ctx startNames

431 Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

417 Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

432

418

433 -- and we interpret applied lets as lambdas

419 -- 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')

420+ Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')

435− Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (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')

436

422

437 Proj t i

423 Proj t i

438 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t

424 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t

@@ -506,9 +492,9 @@ buildDepMap ci used externs ctx startNames

506 -- convert applications of lambdas to lets

492 -- convert applications of lambdas to lets

507 -- Note that this transformation preserves de bruijn numbering

493 -- Note that this transformation preserves de bruijn numbering

508 lamToLet :: [Term] -> Term -> Term

494 lamToLet :: [Term] -> Term -> Term

509− lamToLet xs (App f x) = lamToLet (x:xs) f

495+ lamToLet xs (App _ f x) = lamToLet (x:xs) f

510 lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)

496 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

512 lamToLet [] t = t

498 lamToLet [] t = t

513

499

514 -- split "\x_i -> T(x_i)" into [x_i] and T

500 -- 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)

35

36 matchTerm ns l r t

37 | Just nmap <- match ns l t = substNames nmap r

38− matchTerm ns l r (App f a) = let f' = matchTerm ns l r f

38+ matchTerm ns l r (App s f a) = let f' = matchTerm ns l r f

39− a' = matchTerm ns l r a in

39+ a' = matchTerm ns l r a in

40− App f' a'

40+ App s f' a'

41 matchTerm ns l r (Bind n b sc) = let b' = fmap (matchTerm ns l r) b

42 sc' = matchTerm ns l r sc in

43 Bind n b' sc'

@@ -54,16 +54,16 @@ errReverse ist t = rewrite 5 t -- (elideLambdas t)

54 Just ((x, t) : xs')

55

56 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'

57+ match' ns (App _ f a) (App _ f' a') = do fs <- match' ns f f'

58− as <- match' ns a a'

58+ as <- match' ns a a'

59− Just (fs ++ as)

59+ Just (fs ++ as)

60 -- no matching Binds, for now...

61 match' ns x y = if x == y then Just [] else Nothing

62

63 -- if the term under a lambda is huge, there's no much point in showing

64 -- it as it won't be very enlightening.

65

66− elideLambdas (App f a) = App (elideLambdas f) (elideLambdas a)

66+ elideLambdas (App s f a) = App s (elideLambdas f) (elideLambdas a)

67 elideLambdas (Bind n (Lam t) sc)

68 | size sc > 200 = P Ref (sUN "...") Erased

69 elideLambdas (Bind n b sc)

src/Idris/Error.hs+8−4

@@ -32,8 +32,9 @@ iucheck = do tit <- typeInType

32 logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs

33 when (not tit) $

34 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

35− (\e -> do setErrSpan (getErrSpan e)

35+ (\e -> do let fc = getErrSpan e

36− iputStrLn (pshow ist e))

36+ setErrSpan fc

37+ iWarn fc $ pprintErr ist e)

37

38

38showErr :: Err -> Idris String

39showErr :: Err -> Idris String

39showErr e = getIState >>= return . flip pshow e

40showErr e = getIState >>= return . flip pshow e

@@ -67,6 +68,7 @@ ierror = throwError

67tclift :: TC a -> Idris a

68tclift :: TC a -> Idris a

68tclift (OK v) = return v

69tclift (OK v) = return v

69tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err

70tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err

71+tclift (Error err@(UniverseError fc _ _ _ _)) = do setErrSpan fc; throwError err

70tclift (Error err) = throwError err

72tclift (Error err) = throwError err

71

73

72tctry :: TC a -> TC a -> Idris a

74tctry :: TC a -> TC a -> Idris a

@@ -77,6 +79,7 @@ tctry tc1 tc2

77

79

78getErrSpan :: Err -> FC

80getErrSpan :: Err -> FC

79getErrSpan (At fc _) = fc

81getErrSpan (At fc _) = fc

82+getErrSpan (UniverseError fc _ _ _ _) = fc

80getErrSpan _ = emptyFC

83getErrSpan _ = emptyFC

81

84

82--------------------------------------------------------------------

85--------------------------------------------------------------------

@@ -133,7 +136,7 @@ warnDisamb ist (PCoerced tm) = warnDisamb ist tm

133warnDisamb ist (PDisamb ds tm) = warnDisamb ist tm >>

136warnDisamb ist (PDisamb ds tm) = warnDisamb ist tm >>

134 mapM_ warnEmpty ds

137 mapM_ warnEmpty ds

135 where warnEmpty d =

138 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)))) $

137 ierror . Msg $

140 ierror . Msg $

138 "Nothing found in namespace \"" ++

141 "Nothing found in namespace \"" ++

139 intercalate "." (map T.unpack d) ++

142 intercalate "." (map T.unpack d) ++

@@ -146,6 +149,7 @@ warnDisamb ist (PNoImplicits tm) = warnDisamb ist tm

146warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>

149warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>

147 Foldable.mapM_ (warnDisamb ist) goal

150 Foldable.mapM_ (warnDisamb ist) goal

148warnDisamb ist (PUnquote tm) = warnDisamb ist tm

151warnDisamb ist (PUnquote tm) = warnDisamb ist tm

152+warnDisamb ist (PQuoteName _) = return ()

149warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm

153warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm

150warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm

154warnDisamb 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 @@

1{-# LANGUAGE TypeSynonymInstances #-}

2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3

4−module Idris.IBC where

4+module Idris.IBC (loadIBC, loadPkgIndex,

5+ writeIBC, writePkgIndex) where

5

6

6import Idris.Core.Evaluate

7import Idris.Core.Evaluate

7import Idris.Core.TT

8import Idris.Core.TT

@@ -21,8 +22,10 @@ import Paths_idris

21import qualified Cheapskate.Types as CT

22import qualified Cheapskate.Types as CT

22

23

23import Data.Binary

24import Data.Binary

25+import Data.Functor

24import Data.Vector.Binary

26import Data.Vector.Binary

25−import Data.List

27+import Data.List as L

28+import Data.Maybe (catMaybes)

26import Data.ByteString.Lazy as B hiding (length, elem, map)

29import Data.ByteString.Lazy as B hiding (length, elem, map)

27import qualified Data.Text as T

30import qualified Data.Text as T

28import qualified Data.Set as S

31import qualified Data.Set as S

@@ -34,12 +37,13 @@ import qualified Control.Monad.State.Strict as ST

34import System.FilePath

37import System.FilePath

35import System.Directory

38import System.Directory

36import Codec.Compression.Zlib (compress)

39import Codec.Compression.Zlib (compress)

40+import Codec.Archive.Zip

37import Util.Zlib (decompressEither)

41import Util.Zlib (decompressEither)

38

42

39−ibcVersion :: Word8

43+ibcVersion :: Word16

40−ibcVersion = 104

44+ibcVersion = 107

41

45

42−data IBCFile = IBCFile { ver :: Word8,

46+data IBCFile = IBCFile { ver :: Word16,

43 sourcefile :: FilePath,

47 sourcefile :: FilePath,

44 symbols :: ![Name],

48 symbols :: ![Name],

45 ibc_imports :: ![(Bool, FilePath)],

49 ibc_imports :: ![(Bool, FilePath)],

@@ -102,9 +106,12 @@ loadIBC reexport fp

102 Just p -> not p && reexport

106 Just p -> not p && reexport

103 when redo $

107 when redo $

104 do iLOG $ "Loading ibc " ++ fp ++ " " ++ show reexport

108 do iLOG $ "Loading ibc " ++ fp ++ " " ++ show reexport

105− ibcf <- runIO $ (bdecode fp :: IO IBCFile)

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."

106− process reexport ibcf fp

113+ Right archive -> do process reexport archive fp

107− addImported reexport fp

114+ addImported reexport fp

108

115

109-- | Load an entire package from its index file

116-- | Load an entire package from its index file

110loadPkgIndex :: String -> Idris ()

117loadPkgIndex :: String -> Idris ()

@@ -113,15 +120,63 @@ loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

113 fp <- findPkgIndex pkg

120 fp <- findPkgIndex pkg

114 loadIBC True fp

121 loadIBC True fp

115

122

116−bencode :: Binary a => FilePath -> a -> IO ()

117−bencode f d = B.writeFile f (compress (encode d))

118

123

119−bdecode :: Binary b => FilePath -> IO b

124+makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

120−bdecode f = do d' <- B.readFile f

125+makeEntry name val = if L.null val

121− either

126+ then Nothing

122− (\(_, e) -> error $ "Invalid / corrupted zip format on " ++ show f ++ ": " ++ e)

127+ else Just $ toEntry name 0 (encode val)

123− (return . decode)

128+

124− (decompressEither d')

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)

125

180

126writeIBC :: FilePath -> FilePath -> Idris ()

181writeIBC :: FilePath -> FilePath -> Idris ()

127writeIBC src f

182writeIBC src f

@@ -133,7 +188,7 @@ writeIBC src f

133 resetNameIdx

188 resetNameIdx

134 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

189 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

135 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

190 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

136− runIO $ bencode f ibcf

191+ writeArchive f ibcf

137 iLOG "Written")

192 iLOG "Written")

138 (\c -> do iLOG $ "Failed " ++ pshow i c)

193 (\c -> do iLOG $ "Failed " ++ pshow i c)

139 return ()

194 return ()

@@ -149,7 +204,7 @@ writePkgIndex f

149 resetNameIdx

204 resetNameIdx

150 let ibcf = initIBC { ibc_imports = imps }

205 let ibcf = initIBC { ibc_imports = imps }

151 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

206 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

152− runIO $ bencode f ibcf

207+ writeArchive f ibcf

153 iLOG "Written")

208 iLOG "Written")

154 (\c -> do iLOG $ "Failed " ++ pshow i c)

209 (\c -> do iLOG $ "Failed " ++ pshow i c)

155 return ()

210 return ()

@@ -157,7 +212,7 @@ writePkgIndex f

157mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

212mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

158mkIBC [] f = return f

213mkIBC [] f = return f

159mkIBC (i:is) f = do ist <- getIState

214mkIBC (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)

161 f' <- ibc ist i f

216 f' <- ibc ist i f

162 mkIBC is f'

217 mkIBC is f'

163

218

@@ -240,65 +295,68 @@ ibc i (IBCUsage n) f = return f { ibc_usage = n : ibc_usage f }

240ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }

295ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }

241ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f }

296ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f }

242

297

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+

243process :: Bool -- ^ Reexporting

303process :: Bool -- ^ Reexporting

244− -> IBCFile -> FilePath -> Idris ()

304+ -> Archive -> FilePath -> Idris ()

245−process reexp i fn

305+process reexp i fn = do

306+ ver <- getEntry 0 "ver" i

246− | ver i /= ibcVersion

307+ when (ver /= ibcVersion) $ do

247− = do iLOG "ibc out of date"

308+ iLOG "ibc out of date"

309+ let e = if ver < ibcVersion

248− let e = if ver i < ibcVersion then " an earlier " else " a later "

310+ then " an earlier " else " a later "

249− ifail $ "Incompatible ibc version.\nThis library was built with"

311+ ifail $ "Incompatible ibc version.\nThis library was built with"

250− ++ e ++ "version of Idris.\n" ++

251− "Please clean and rebuild."

312+ ++ e ++ "version of Idris.\n" ++ "Please clean and rebuild."

252−

313+ source <- getEntry "" "sourcefile" i

253− --- please rebuild"

254− | otherwise =

255− do srcok <- runIO $ doesFileExist (sourcefile i)

314+ srcok <- runIO $ doesFileExist source

256− when srcok $ timestampOlder (sourcefile i) fn

315+ when srcok $ timestampOlder source fn

257− v <- verbose

258− quiet <- getQuiet

259−-- when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i

260− pImportDirs $ force (ibc_importdirs i)

316+ pImportDirs =<< getEntry [] "ibc_importdirs" i

261− pImports $ force (ibc_imports i)

317+ pImports =<< getEntry [] "ibc_imports" i

262− pImps $ force (ibc_implicits i)

318+ pImps =<< getEntry [] "ibc_implicits" i

263− pFixes $ force (ibc_fixes i)

319+ pFixes =<< getEntry [] "ibc_fixes" i

264− pStatics $ force (ibc_statics i)

320+ pStatics =<< getEntry [] "ibc_statics" i

265− pClasses $ force (ibc_classes i)

321+ pClasses =<< getEntry [] "ibc_classes" i

266− pInstances $ force (ibc_instances i)

322+ pInstances =<< getEntry [] "ibc_instances" i

267− pDSLs $ force (ibc_dsls i)

323+ pDSLs =<< getEntry [] "ibc_dsls" i

268− pDatatypes $ force (ibc_datatypes i)

324+ pDatatypes =<< getEntry [] "ibc_datatypes" i

269− pOptimise $ force (ibc_optimise i)

325+ pOptimise =<< getEntry [] "ibc_optimise" i

270− pSyntax $ force (ibc_syntax i)

326+ pSyntax =<< getEntry [] "ibc_syntax" i

271− pKeywords $ force (ibc_keywords i)

327+ pKeywords =<< getEntry [] "ibc_keywords" i

272− pObjs $ force (ibc_objs i)

328+ pObjs =<< getEntry [] "ibc_objs" i

273− pLibs $ force (ibc_libs i)

329+ pLibs =<< getEntry [] "ibc_libs" i

274− pCGFlags $ force (ibc_cgflags i)

330+ pCGFlags =<< getEntry [] "ibc_cgflags" i

275− pDyLibs $ force (ibc_dynamic_libs i)

331+ pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

276− pHdrs $ force (ibc_hdrs i)

332+ pHdrs =<< getEntry [] "ibc_hdrs" i

277− pDefs reexp (symbols i) $ force (ibc_defs i)

333+ symbols <- getEntry [] "symbols" i

334+ defs <- getEntry [] "ibc_defs" i

335+ pDefs reexp symbols defs

278− pPatdefs $ force (ibc_patdefs i)

336+ pPatdefs =<< getEntry [] "ibc_patdefs" i

279− pAccess reexp $ force (ibc_access i)

337+ pAccess reexp =<< getEntry [] "ibc_access" i

280− pFlags $ force (ibc_flags i)

338+ pFlags =<< getEntry [] "ibc_flags" i

281− pFnInfo $ force (ibc_fninfo i)

339+ pFnInfo =<< getEntry [] "ibc_fninfo" i

282− pTotal $ force (ibc_total i)

340+ pTotal =<< getEntry [] "ibc_total" i

283− pTotCheckErr $ force (ibc_totcheckfail i)

341+ pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

284− pCG $ force (ibc_cg i)

342+ pCG =<< getEntry [] "ibc_cg" i

285− pDocs $ force (ibc_docstrings i)

343+ pDocs =<< getEntry [] "ibc_docstrings" i

286− pMDocs $ force (ibc_moduledocs i)

344+ pMDocs =<< getEntry [] "ibc_moduledocs" i

287− pCoercions $ force (ibc_coercions i)

345+ pCoercions =<< getEntry [] "ibc_coercions" i

288− pTrans $ force (ibc_transforms i)

346+ pTrans =<< getEntry [] "ibc_transforms" i

289− pErrRev $ force (ibc_errRev i)

347+ pErrRev =<< getEntry [] "ibc_errRev" i

290− pLineApps $ force (ibc_lineapps i)

348+ pLineApps =<< getEntry [] "ibc_lineapps" i

291− pNameHints $ force (ibc_namehints i)

349+ pNameHints =<< getEntry [] "ibc_namehints" i

292− pMetaInformation $ force (ibc_metainformation i)

350+ pMetaInformation =<< getEntry [] "ibc_metainformation" i

293− pErrorHandlers $ force (ibc_errorhandlers i)

351+ pErrorHandlers =<< getEntry [] "ibc_errorhandlers" i

294− pFunctionErrorHandlers $ force (ibc_function_errorhandlers i)

352+ pFunctionErrorHandlers =<< getEntry [] "ibc_function_errorhandlers" i

295− pMetavars $ force (ibc_metavars i)

353+ pMetavars =<< getEntry [] "ibc_metavars" i

296− pPostulates $ force (ibc_postulates i)

354+ pPostulates =<< getEntry [] "ibc_postulates" i

297− pExterns $ force (ibc_externs i)

355+ pExterns =<< getEntry [] "ibc_externs" i

298− pParsedSpan $ force (ibc_parsedSpan i)

356+ pParsedSpan =<< getEntry Nothing "ibc_parsedSpan" i

299− pUsage $ force (ibc_usage i)

357+ pUsage =<< getEntry [] "ibc_usage" i

300− pExports $ force (ibc_exports i)

358+ pExports =<< getEntry [] "ibc_exports" i

301− pAutoHints $ force (ibc_autohints i)

359+ pAutoHints =<< getEntry [] "ibc_autohints" i

302

360

303timestampOlder :: FilePath -> FilePath -> Idris ()

361timestampOlder :: FilePath -> FilePath -> Idris ()

304timestampOlder src ibc = do srct <- runIO $ getModificationTime src

362timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -308,26 +366,20 @@ timestampOlder src ibc = do srct <- runIO $ getModificationTime src

308 else return ()

366 else return ()

309

367

310pPostulates :: [Name] -> Idris ()

368pPostulates :: [Name] -> Idris ()

311−pPostulates ns = do

369+pPostulates ns = updateIState

312− i <- getIState

313− putIState i{ idris_postulates = idris_postulates i `S.union` S.fromList ns }

370+ (\i -> i { idris_postulates = idris_postulates i `S.union` S.fromList ns })

314

371

315pExterns :: [(Name, Int)] -> Idris ()

372pExterns :: [(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 })

319

374

320pParsedSpan :: Maybe FC -> Idris ()

375pParsedSpan :: Maybe FC -> Idris ()

321−pParsedSpan fc = do ist <- getIState

322− putIState ist { idris_parsedSpan = fc }

376+pParsedSpan fc = updateIState (\i -> i { idris_parsedSpan = fc })

323

377

324pUsage :: [(Name, Int)] -> Idris ()

378pUsage :: [(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 })

327

380

328pExports :: [Name] -> Idris ()

381pExports :: [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 })

331

383

332pAutoHints :: [(Name, Name)] -> Idris ()

384pAutoHints :: [(Name, Name)] -> Idris ()

333pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns

385pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns

@@ -391,33 +443,22 @@ pInstances :: [(Bool, Name, Name)] -> Idris ()

391pInstances cs = mapM_ (\ (i, n, ins) -> addInstance i n ins) cs

443pInstances cs = mapM_ (\ (i, n, ins) -> addInstance i n ins) cs

392

444

393pDSLs :: [(Name, DSL)] -> Idris ()

445pDSLs :: [(Name, DSL)] -> Idris ()

394−pDSLs cs = mapM_ (\ (n, c) ->

446+pDSLs cs = mapM_ (\ (n, c) -> updateIState (\i ->

395− do i <- getIState

396− putIState (i { idris_dsls

397− = addDef n c (idris_dsls i) }))

447+ i { idris_dsls = addDef n c (idris_dsls i) })) cs

398− cs

399

448

400pDatatypes :: [(Name, TypeInfo)] -> Idris ()

449pDatatypes :: [(Name, TypeInfo)] -> Idris ()

401−pDatatypes cs = mapM_ (\ (n, c) ->

450+pDatatypes cs = mapM_ (\ (n, c) -> updateIState (\i ->

402− do i <- getIState

403− putIState (i { idris_datatypes

404− = addDef n c (idris_datatypes i) }))

451+ i { idris_datatypes = addDef n c (idris_datatypes i) })) cs

405− cs

406

452

407pOptimise :: [(Name, OptInfo)] -> Idris ()

453pOptimise :: [(Name, OptInfo)] -> Idris ()

408−pOptimise cs = mapM_ (\ (n, c) ->

454+pOptimise cs = mapM_ (\ (n, c) -> updateIState (\i ->

409− do i <- getIState

410− putIState (i { idris_optimisation

411− = addDef n c (idris_optimisation i) }))

455+ i { idris_optimisation = addDef n c (idris_optimisation i) })) cs

412− cs

413

456

414pSyntax :: [Syntax] -> Idris ()

457pSyntax :: [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) })

417

459

418pKeywords :: [String] -> Idris ()

460pKeywords :: [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 })

421

462

422pObjs :: [(Codegen, FilePath)] -> Idris ()

463pObjs :: [(Codegen, FilePath)] -> Idris ()

423pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs

464pObjs os = mapM_ (\ (cg, obj) -> do dirs <- allImportDirs

@@ -441,11 +482,8 @@ pHdrs :: [(Codegen, String)] -> Idris ()

441pHdrs hs = mapM_ (uncurry addHdr) hs

482pHdrs hs = mapM_ (uncurry addHdr) hs

442

483

443pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()

484pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()

444−pPatdefs ds

485+pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->

445− = mapM_ (\ (n, d) ->

446− do i <- getIState

447− putIState (i { idris_patdefs = addDef n (force d) (idris_patdefs i) }))

486+ i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds

448− ds

449

487

450pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()

488pDefs :: Bool -> [Name] -> [(Name, Def)] -> Idris ()

451pDefs reexp syms ds

489pDefs reexp syms ds

@@ -455,9 +493,8 @@ pDefs reexp syms ds

455 TyDecl _ _ -> return ()

493 TyDecl _ _ -> return ()

456 _ -> do iLOG $ "SOLVING " ++ show n

494 _ -> do iLOG $ "SOLVING " ++ show n

457 solveDeferred n

495 solveDeferred n

458− i <- getIState

496+ updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

459-- logLvl 1 $ "Added " ++ show (n, d')

497-- logLvl 1 $ "Added " ++ show (n, d')

460− putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

461 if (not reexp) then do iLOG $ "Not exporting " ++ show n

498 if (not reexp) then do iLOG $ "Not exporting " ++ show n

462 setAccessibility n Hidden

499 setAccessibility n Hidden

463 else iLOG $ "Exporting " ++ show n) ds

500 else iLOG $ "Exporting " ++ show n) ds

@@ -501,7 +538,7 @@ pDefs reexp syms ds

501

538

502 update (P t n ty) = do n' <- getSymbol n

539 update (P t n ty) = do n' <- getSymbol n

503 return $ P t n' ty

540 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)

505 update (Bind n b sc) = do b' <- updateB b

542 update (Bind n b sc) = do b' <- updateB b

506 sc' <- update sc

543 sc' <- update sc

507 return $ Bind n b' sc'

544 return $ Bind n b' sc'

@@ -517,9 +554,8 @@ pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris

517pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

554pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

518

555

519pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()

556pMDocs :: [(Name, Docstring D.DocTerm)] -> Idris ()

520−pMDocs ds = mapM_ addMDocStr ds

557+pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

521− where addMDocStr (n, d) = do ist <- getIState

522− putIState ist { idris_moduledocs = addDef n d (idris_moduledocs ist) }

558+ i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

523

559

524pAccess :: Bool -- ^ Reexporting?

560pAccess :: Bool -- ^ Reexporting?

525 -> [(Name, Accessibility)] -> Idris ()

561 -> [(Name, Accessibility)] -> Idris ()

@@ -527,9 +563,7 @@ pAccess reexp ds

527 = mapM_ (\ (n, a_in) ->

563 = mapM_ (\ (n, a_in) ->

528 do let a = if reexp then a_in else Hidden

564 do let a = if reexp then a_in else Hidden

529 logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

565 logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

530− i <- getIState

531− putIState (i { tt_ctxt = setAccess n a (tt_ctxt i) }))

566+ updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

532− ds

533

567

534pFlags :: [(Name, [FnOpt])] -> Idris ()

568pFlags :: [(Name, [FnOpt])] -> Idris ()

535pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

569pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -538,14 +572,10 @@ pFnInfo :: [(Name, FnInfo)] -> Idris ()

538pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds

572pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds

539

573

540pTotal :: [(Name, Totality)] -> Idris ()

574pTotal :: [(Name, Totality)] -> Idris ()

541−pTotal ds = mapM_ (\ (n, a) ->

542− do i <- getIState

543− putIState (i { tt_ctxt = setTotal n a (tt_ctxt i) }))

575+pTotal ds = mapM_ (\ (n, a) -> updateIState (\i -> i { tt_ctxt = setTotal n a (tt_ctxt i) })) ds

544− ds

545

576

546pTotCheckErr :: [(FC, String)] -> Idris ()

577pTotCheckErr :: [(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 })

549

579

550pCG :: [(Name, CGInfo)] -> Idris ()

580pCG :: [(Name, CGInfo)] -> Idris ()

551pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds

581pCG ds = mapM_ (\ (n, a) -> addToCG n a) ds

@@ -566,24 +596,19 @@ pNameHints :: [(Name, Name)] -> Idris ()

566pNameHints ns = mapM_ (\ (n, ty) -> addNameHint n ty) ns

596pNameHints ns = mapM_ (\ (n, ty) -> addNameHint n ty) ns

567

597

568pMetaInformation :: [(Name, MetaInformation)] -> Idris ()

598pMetaInformation :: [(Name, MetaInformation)] -> Idris ()

569−pMetaInformation ds = mapM_ (\ (n, m) ->

599+pMetaInformation ds = mapM_ (\ (n, m) -> updateIState (\i ->

570− do i <- getIState

571− putIState (i { tt_ctxt = setMetaInformation n m (tt_ctxt i) }))

600+ i { tt_ctxt = setMetaInformation n m (tt_ctxt i) })) ds

572− ds

573

601

574pErrorHandlers :: [Name] -> Idris ()

602pErrorHandlers :: [Name] -> Idris ()

575−pErrorHandlers ns = do i <- getIState

603+pErrorHandlers ns = updateIState (\i ->

576− putIState $ i { idris_errorhandlers = idris_errorhandlers i ++ ns }

604+ i { idris_errorhandlers = idris_errorhandlers i ++ ns })

577

605

578pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()

606pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()

579−pFunctionErrorHandlers [] = return ()

607+pFunctionErrorHandlers ns = mapM_ (\ (fn,arg,handler) ->

580−pFunctionErrorHandlers ((fn, arg, handler):ns) = do addFunctionErrorHandlers fn arg [handler]

608+ addFunctionErrorHandlers fn arg [handler]) ns

581− pFunctionErrorHandlers ns

582

609

583pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()

610pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()

584−pMetavars ns = do i <- getIState

585− putIState $ i { idris_metavars = Data.List.reverse ns

611+pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })

586− ++ idris_metavars i }

587

612

588----- For Cheapskate and docstrings

613----- For Cheapskate and docstrings

589

614

@@ -947,105 +972,6 @@ instance Binary MetaInformation where

947 return (DataMI x1)

972 return (DataMI x1)

948 _ -> error "Corrupted binary data for MetaInformation"

973 _ -> error "Corrupted binary data for MetaInformation"

949

974

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−

1049instance Binary DataOpt where

975instance Binary DataOpt where

1050 put x = case x of

976 put x = case x of

1051 Codata -> putWord8 0

977 Codata -> putWord8 0

@@ -1678,9 +1604,9 @@ instance Binary PTerm where

1678 put x2

1604 put x2

1679 PUniverse x1 -> do putWord8 38

1605 PUniverse x1 -> do putWord8 38

1680 put x1

1606 put x1

1681− PRunTactics x1 x2 -> do putWord8 39

1607+ PRunElab x1 x2 -> do putWord8 39

1682− put x1

1608+ put x1

1683− put x2

1609+ put x2

1684 PAs x1 x2 x3 -> do putWord8 40

1610 PAs x1 x2 x3 -> do putWord8 40

1685 put x1

1611 put x1

1686 put x2

1612 put x2

@@ -1692,6 +1618,8 @@ instance Binary PTerm where

1692 put x2

1618 put x2

1693 PUnquote x1 -> do putWord8 43

1619 PUnquote x1 -> do putWord8 43

1694 put x1

1620 put x1

1621+ PQuoteName x1 -> do putWord8 44

1622+ put x1

1695

1623

1696

1624

1697 get

1625 get

@@ -1813,7 +1741,7 @@ instance Binary PTerm where

1813 return (PUniverse x1)

1741 return (PUniverse x1)

1814 39 -> do x1 <- get

1742 39 -> do x1 <- get

1815 x2 <- get

1743 x2 <- get

1816− return (PRunTactics x1 x2)

1744+ return (PRunElab x1 x2)

1817 40 -> do x1 <- get

1745 40 -> do x1 <- get

1818 x2 <- get

1746 x2 <- get

1819 x3 <- get

1747 x3 <- get

@@ -1825,6 +1753,8 @@ instance Binary PTerm where

1825 return (PQuasiquote x1 x2)

1753 return (PQuasiquote x1 x2)

1826 43 -> do x1 <- get

1754 43 -> do x1 <- get

1827 return (PUnquote x1)

1755 return (PUnquote x1)

1756+ 44 -> do x1 <- get

1757+ return (PQuoteName x1)

1828 _ -> error "Corrupted binary data for PTerm"

1758 _ -> error "Corrupted binary data for PTerm"

1829

1759

1830instance (Binary t) => Binary (PTactic' t) where

1760instance (Binary t) => Binary (PTactic' t) where

src/Idris/IdeMode.hs+2

@@ -222,6 +222,7 @@ data IdeModeCommand = REPLCompletions String

222 | Metavariables Int -- ^^ the Int is the column count for pretty-printing

223 | WhoCalls String

224 | CallsWho String

225+ | BrowseNS String

225 | TermNormalise [(Name, Bool)] Term

226 | TermNormalise [(Name, Bool)] Term

226 | TermShowImplicits [(Name, Bool)] Term

227 | TermShowImplicits [(Name, Bool)] Term

227 | TermNoImplicits [(Name, Bool)] Term

228 | TermNoImplicits [(Name, Bool)] Term

@@ -269,6 +270,7 @@ sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

269sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols]) = Just (Metavariables (fromIntegral cols))

270sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols]) = Just (Metavariables (fromIntegral cols))

270sexpToCommand (SexpList [SymbolAtom "who-calls", StringAtom name]) = Just (WhoCalls name)

271sexpToCommand (SexpList [SymbolAtom "who-calls", StringAtom name]) = Just (WhoCalls name)

271sexpToCommand (SexpList [SymbolAtom "calls-who", StringAtom name]) = Just (CallsWho name)

272sexpToCommand (SexpList [SymbolAtom "calls-who", StringAtom name]) = Just (CallsWho name)

273+sexpToCommand (SexpList [SymbolAtom "browse-namespace", StringAtom ns]) = Just (BrowseNS ns)

272sexpToCommand (SexpList [SymbolAtom "normalise-term", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

274sexpToCommand (SexpList [SymbolAtom "normalise-term", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

273 Just (TermNormalise bnd tm)

275 Just (TermNormalise bnd tm)

274sexpToCommand (SexpList [SymbolAtom "show-term-implicits", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

276sexpToCommand (SexpList [SymbolAtom "show-term-implicits", StringAtom encoded]) = let (bnd, tm) = decodeTerm encoded in

src/Idris/IdrisDoc.hs+10−5

@@ -1,5 +1,6 @@

1{-# LANGUAGE PatternGuards #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3

4

4-- | Generation of HTML documentation for Idris code

5-- | Generation of HTML documentation for Idris code

5module Idris.IdrisDoc (generateDocs) where

6module Idris.IdrisDoc (generateDocs) where

@@ -217,9 +218,11 @@ referredNss (n, Just d, _) =

217 names = concatMap (extractPTermNames) ts

218 names = concatMap (extractPTermNames) ts

218 in S.map getNs $ S.fromList names

219 in S.map getNs $ S.fromList names

219

220

220− where getFunDocs (FunDoc f) = [f]

221+ where getFunDocs (FunDoc f) = [f]

221− getFunDocs (DataDoc f fs) = f:fs

222+ getFunDocs (DataDoc f fs) = f:fs

222 getFunDocs (ClassDoc _ _ fs _ _ _ _) = fs

223 getFunDocs (ClassDoc _ _ fs _ _ _ _) = fs

224+ getFunDocs (NamedInstanceDoc _ fd) = [fd]

225+ getFunDocs (ModDoc _ _) = []

223 types (FD _ _ args t _) = t:(map second args)

226 types (FD _ _ args t _) = t:(map second args)

224 second (_, x, _, _) = x

227 second (_, x, _, _) = x

225

228

@@ -318,7 +321,7 @@ extractPTermNames (PCoerced p) = extract p

318extractPTermNames (PDisamb _ p) = extract p

321extractPTermNames (PDisamb _ p) = extract p

319extractPTermNames (PUnifyLog p) = extract p

322extractPTermNames (PUnifyLog p) = extract p

320extractPTermNames (PNoImplicits p) = extract p

323extractPTermNames (PNoImplicits p) = extract p

321−extractPTermNames (PRunTactics _ p) = extract p

324+extractPTermNames (PRunElab _ p) = extract p

322extractPTermNames _ = []

325extractPTermNames _ = []

323

326

324-- | Shorter name for extractPTermNames

327-- | Shorter name for extractPTermNames

@@ -417,7 +420,7 @@ createIndex nss out =

417 BS2.hPut h $ renderHtml $ wrapper Nothing $ do

420 BS2.hPut h $ renderHtml $ wrapper Nothing $ do

418 H.h1 $ "Namespaces"

421 H.h1 $ "Namespaces"

419 H.ul ! class_ "names" $ do

422 H.ul ! class_ "names" $ do

420− let path ns = "docs" </> genRelNsPath ns "html"

423+ let path ns = "docs" ++ "/" ++ genRelNsPath ns "html"

421 item ns = do let n = toHtml $ nsName2Str ns

424 item ns = do let n = toHtml $ nsName2Str ns

422 link = toValue $ path ns

425 link = toValue $ path ns

423 H.li $ H.a ! href link ! class_ "code" $ n

426 H.li $ H.a ! href link ! class_ "code" $ n

@@ -609,6 +612,8 @@ createOtherDoc ist (DataDoc fd@(FD n docstring args _ _) fds) = do

609 H.dt $ toHtml $ show name

612 H.dt $ toHtml $ show name

610 H.dd $ Docstrings.renderHtml docstring

613 H.dd $ Docstrings.renderHtml docstring

611

614

615+createOtherDoc ist (NamedInstanceDoc _ fd) = createFunDoc ist fd

616+

612createOtherDoc ist (ModDoc _ docstring) = do

617createOtherDoc ist (ModDoc _ docstring) = do

613 Docstrings.renderHtml docstring

618 Docstrings.renderHtml docstring

614

619

@@ -658,7 +663,7 @@ existingNamespaces :: FilePath -- ^ The base directory containing the

658 -- namespace pages

663 -- namespace pages

659 -> IO (S.Set NsName)

664 -> IO (S.Set NsName)

660existingNamespaces out = do

665existingNamespaces out = do

661− let docs = out </> "docs"

666+ let docs = out ++ "/" ++ "docs"

662 str2Ns s | s == rootNsStr = []

667 str2Ns s | s == rootNsStr = []

663 str2Ns s = reverse $ T.splitOn (T.singleton '.') (txt s)

668 str2Ns s = reverse $ T.splitOn (T.singleton '.') (txt s)

664 toNs fp = do isFile <- doesFileExist $ docs </> fp

669 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

21inlineTerm :: IState -> Term -> Term

22inlineTerm ist tm = inl tm where

23 inl orig@(P _ n _) = inlApp n [] orig

24− inl orig@(App f a)

24+ inl orig@(App _ f a)

25 | (P _ fn _, args) <- unApply orig = inlApp fn args orig

26 inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc)

27 inl (Bind n b sc) = Bind n b (inl sc)

src/Idris/Interactive.hs+17−18

@@ -12,13 +12,12 @@ import Idris.Core.Evaluate

12import Idris.CaseSplit

13import Idris.AbsSyntax

14import Idris.ElabDecls

15−import Idris.ElabTerm

16import Idris.Error

15import Idris.Error

17import Idris.Delaborate

16import Idris.Delaborate

18import Idris.Output

17import Idris.Output

19import Idris.IdeMode hiding (IdeModeCommand(..))

18import Idris.IdeMode hiding (IdeModeCommand(..))

20−

21import Idris.Elab.Value

19import Idris.Elab.Value

20+import Idris.Elab.Term

22

21

23import Util.Pretty

22import Util.Pretty

24import Util.System

23import Util.System

@@ -34,7 +33,7 @@ import Debug.Trace

34

33

35caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris ()

34caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris ()

36caseSplitAt fn updatefile l n

35caseSplitAt fn updatefile l n

37− = do src <- runIO $ readFile fn

36+ = do src <- runIO $ readSource fn

38 res <- splitOnLine l n fn

37 res <- splitOnLine l n fn

39 iLOG (showSep "\n" (map show res))

38 iLOG (showSep "\n" (map show res))

40 let (before, (ap : later)) = splitAt (l-1) (lines src)

39 let (before, (ap : later)) = splitAt (l-1) (lines src)

@@ -42,14 +41,14 @@ caseSplitAt fn updatefile l n

42 let new = concat res'

41 let new = concat res'

43 if updatefile

42 if updatefile

44 then do let fb = fn ++ "~" -- make a backup!

43 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)

46 runIO $ copyFile fb fn

45 runIO $ copyFile fb fn

47 else -- do iputStrLn (show res)

46 else -- do iputStrLn (show res)

48 iPrintResult new

47 iPrintResult new

49

48

50addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

49addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

51addClauseFrom fn updatefile l n

50addClauseFrom fn updatefile l n

52− = do src <- runIO $ readFile fn

51+ = do src <- runIO $ readSource fn

53 let (before, tyline : later) = splitAt (l-1) (lines src)

52 let (before, tyline : later) = splitAt (l-1) (lines src)

54 let indent = getIndent 0 (show n) tyline

53 let indent = getIndent 0 (show n) tyline

55 cl <- getClause l n fn

54 cl <- getClause l n fn

@@ -57,7 +56,7 @@ addClauseFrom fn updatefile l n

57 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

56 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

58 if updatefile

57 if updatefile

59 then do let fb = fn ++ "~"

58 then do let fb = fn ++ "~"

60− runIO $ writeFile fb (unlines (before ++ nonblank) ++

59+ runIO $ writeSource fb (unlines (before ++ nonblank) ++

61 replicate indent ' ' ++

60 replicate indent ' ' ++

62 cl ++ "\n" ++

61 cl ++ "\n" ++

63 unlines rest)

62 unlines rest)

@@ -71,7 +70,7 @@ addClauseFrom fn updatefile l n

71

70

72addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

71addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

73addProofClauseFrom fn updatefile l n

72addProofClauseFrom fn updatefile l n

74− = do src <- runIO $ readFile fn

73+ = do src <- runIO $ readSource fn

75 let (before, tyline : later) = splitAt (l-1) (lines src)

74 let (before, tyline : later) = splitAt (l-1) (lines src)

76 let indent = getIndent 0 (show n) tyline

75 let indent = getIndent 0 (show n) tyline

77 cl <- getProofClause l n fn

76 cl <- getProofClause l n fn

@@ -79,7 +78,7 @@ addProofClauseFrom fn updatefile l n

79 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

78 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

80 if updatefile

79 if updatefile

81 then do let fb = fn ++ "~"

80 then do let fb = fn ++ "~"

82− runIO $ writeFile fb (unlines (before ++ nonblank) ++

81+ runIO $ writeSource fb (unlines (before ++ nonblank) ++

83 replicate indent ' ' ++

82 replicate indent ' ' ++

84 cl ++ "\n" ++

83 cl ++ "\n" ++

85 unlines rest)

84 unlines rest)

@@ -92,7 +91,7 @@ addProofClauseFrom fn updatefile l n

92

91

93addMissing :: FilePath -> Bool -> Int -> Name -> Idris ()

92addMissing :: FilePath -> Bool -> Int -> Name -> Idris ()

94addMissing fn updatefile l n

93addMissing fn updatefile l n

95− = do src <- runIO $ readFile fn

94+ = do src <- runIO $ readSource fn

96 let (before, tyline : later) = splitAt (l-1) (lines src)

95 let (before, tyline : later) = splitAt (l-1) (lines src)

97 let indent = getIndent 0 (show n) tyline

96 let indent = getIndent 0 (show n) tyline

98 i <- getIState

97 i <- getIState

@@ -106,7 +105,7 @@ addMissing fn updatefile l n

106 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

105 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

107 if updatefile

106 if updatefile

108 then do let fb = fn ++ "~"

107 then do let fb = fn ++ "~"

109− runIO $ writeFile fb (unlines (before ++ nonblank)

108+ runIO $ writeSource fb (unlines (before ++ nonblank)

110 ++ extras ++ unlines rest)

109 ++ extras ++ unlines rest)

111 runIO $ copyFile fb fn

110 runIO $ copyFile fb fn

112 else iPrintResult extras

111 else iPrintResult extras

@@ -141,7 +140,7 @@ addMissing fn updatefile l n

141

140

142makeWith :: FilePath -> Bool -> Int -> Name -> Idris ()

141makeWith :: FilePath -> Bool -> Int -> Name -> Idris ()

143makeWith fn updatefile l n

142makeWith fn updatefile l n

144− = do src <- runIO $ readFile fn

143+ = do src <- runIO $ readSource fn

145 let (before, tyline : later) = splitAt (l-1) (lines src)

144 let (before, tyline : later) = splitAt (l-1) (lines src)

146 let ind = getIndent tyline

145 let ind = getIndent tyline

147 let with = mkWith tyline n

146 let with = mkWith tyline n

@@ -151,7 +150,7 @@ makeWith fn updatefile l n

151 not (ind == getIndent x)) later

150 not (ind == getIndent x)) later

152 if updatefile then

151 if updatefile then

153 do let fb = fn ++ "~"

152 do let fb = fn ++ "~"

154− runIO $ writeFile fb (unlines (before ++ nonblank)

153+ runIO $ writeSource fb (unlines (before ++ nonblank)

155 ++ with ++ "\n" ++

154 ++ with ++ "\n" ++

156 unlines rest)

155 unlines rest)

157 runIO $ copyFile fb fn

156 runIO $ copyFile fb fn

@@ -164,7 +163,7 @@ doProofSearch :: FilePath -> Bool -> Bool ->

164doProofSearch fn updatefile rec l n hints Nothing

163doProofSearch fn updatefile rec l n hints Nothing

165 = doProofSearch fn updatefile rec l n hints (Just 10)

164 = doProofSearch fn updatefile rec l n hints (Just 10)

166doProofSearch fn updatefile rec l n hints (Just depth)

165doProofSearch fn updatefile rec l n hints (Just depth)

167− = do src <- runIO $ readFile fn

166+ = do src <- runIO $ readSource fn

168 let (before, tyline : later) = splitAt (l-1) (lines src)

167 let (before, tyline : later) = splitAt (l-1) (lines src)

169 ctxt <- getContext

168 ctxt <- getContext

170 mn <- case lookupNames n ctxt of

169 mn <- case lookupNames n ctxt of

@@ -192,7 +191,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

192 (\e -> return ("?" ++ show n))

191 (\e -> return ("?" ++ show n))

193 if updatefile then

192 if updatefile then

194 do let fb = fn ++ "~"

193 do let fb = fn ++ "~"

195− runIO $ writeFile fb (unlines before ++

194+ runIO $ writeSource fb (unlines before ++

196 updateMeta False tyline (show n) newmv ++ "\n"

195 updateMeta False tyline (show n) newmv ++ "\n"

197 ++ unlines later)

196 ++ unlines later)

198 runIO $ copyFile fb fn

197 runIO $ copyFile fb fn

@@ -241,7 +240,7 @@ addBracket True new | any isSpace new = '(' : new ++ ")"

241

240

242makeLemma :: FilePath -> Bool -> Int -> Name -> Idris ()

241makeLemma :: FilePath -> Bool -> Int -> Name -> Idris ()

243makeLemma fn updatefile l n

242makeLemma fn updatefile l n

244− = do src <- runIO $ readFile fn

243+ = do src <- runIO $ readSource fn

245 let (before, tyline : later) = splitAt (l-1) (lines src)

244 let (before, tyline : later) = splitAt (l-1) (lines src)

246

245

247 -- if the name is in braces, rather than preceded by a ?, treat it

246 -- if the name is in braces, rather than preceded by a ?, treat it

@@ -267,7 +266,7 @@ makeLemma fn updatefile l n

267

266

268 if updatefile then

267 if updatefile then

269 do let fb = fn ++ "~"

268 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)

271 runIO $ copyFile fb fn

270 runIO $ copyFile fb fn

272 else case idris_outputmode i of

271 else case idris_outputmode i of

273 RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app

272 RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app

@@ -285,7 +284,7 @@ makeLemma fn updatefile l n

285 " = ?" ++ show n ++ "_rhs"

284 " = ?" ++ show n ++ "_rhs"

286 if updatefile then

285 if updatefile then

287 do let fb = fn ++ "~"

286 do let fb = fn ++ "~"

288− runIO $ writeFile fb (addProv before tyline lem_app later)

287+ runIO $ writeSource fb (addProv before tyline lem_app later)

289 runIO $ copyFile fb fn

288 runIO $ copyFile fb fn

290 else case idris_outputmode i of

289 else case idris_outputmode i of

291 RawOutput _ -> iPrintResult $ lem_app

290 RawOutput _ -> iPrintResult $ lem_app

@@ -323,7 +322,7 @@ makeLemma fn updatefile l n

323 guessImps ctxt _ = []

322 guessImps ctxt _ = []

324

323

325 guarded ctxt n (P _ n' _) | n == n' = True

324 guarded ctxt n (P _ n' _) | n == n' = True

326− guarded ctxt n ap@(App _ _)

325+ guarded ctxt n ap@(App _ _ _)

327 | (P _ f _, args) <- unApply ap,

326 | (P _ f _, args) <- unApply ap,

328 isConName f ctxt = any (guarded ctxt n) args

327 isConName f ctxt = any (guarded ctxt n) args

329-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

328-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

src/Idris/ParseExpr.hs+84−53

@@ -1,5 +1,4 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−{-# OPTIONS_GHC -O0 #-}

3module Idris.ParseExpr where

2module Idris.ParseExpr where

4

3

5import Prelude hiding (pi)

4import Prelude hiding (pi)

@@ -221,7 +220,7 @@ InternalExpr ::=

221internalExpr :: SyntaxInfo -> IdrisParser PTerm

220internalExpr :: SyntaxInfo -> IdrisParser PTerm

222internalExpr syn =

221internalExpr syn =

223 unifyLog syn

222 unifyLog syn

224− <|> runTactics syn

223+ <|> runElab syn

225 <|> disamb syn

224 <|> disamb syn

226 <|> noImplicits syn

225 <|> noImplicits syn

227 <|> recordType syn

226 <|> recordType syn

@@ -312,6 +311,7 @@ SimpleExpr ::=

312 | Type

311 | Type

313 | 'Void'

312 | 'Void'

314 | Quasiquote

313 | Quasiquote

314+ | NameQuote

315 | Unquote

316 | '_'

317 ;

@@ -330,6 +330,7 @@ simpleExpr syn =

330 <|> proofExpr syn

331 <|> tacticsExpr syn

332 <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes)

333+ <|> do reserved "AnyType"; return $ PUniverse AllTypes

333 <|> do reserved "Type"; return PType

334 <|> do reserved "Type"; return PType

334 <|> do reserved "UniqueType"; return $ PUniverse UniqueType

335 <|> do reserved "UniqueType"; return $ PUniverse UniqueType

335 <|> do reserved "NullType"; return $ PUniverse NullType

336 <|> do reserved "NullType"; return $ PUniverse NullType

@@ -356,6 +357,7 @@ simpleExpr syn =

356 return (PAppBind fc s [])

357 return (PAppBind fc s [])

357 <|> bracketed (disallowImp syn)

358 <|> bracketed (disallowImp syn)

358 <|> quasiquote syn

359 <|> quasiquote syn

360+ <|> namequote syn

359 <|> unquote syn

361 <|> unquote syn

360 <|> do lchar '_'; return Placeholder

362 <|> do lchar '_'; return Placeholder

361 <?> "expression"

363 <?> "expression"

@@ -498,16 +500,16 @@ unifyLog syn = do try (lchar '%' *> reserved "unifyLog")

498

500

499{- | Parses a new-style tactics expression

501{- | Parses a new-style tactics expression

500RunTactics ::=

502RunTactics ::=

501− '%' 'runTactics' SimpleExpr

503+ '%' 'runElab' SimpleExpr

502 ;

504 ;

503-}

505-}

504−runTactics :: SyntaxInfo -> IdrisParser PTerm

506+runElab :: SyntaxInfo -> IdrisParser PTerm

505−runTactics syn = do try (lchar '%' *> reserved "runTactics")

507+runElab syn = do try (lchar '%' *> reserved "runElab")

506− fc <- getFC

508+ fc <- getFC

507− tm <- simpleExpr syn

509+ tm <- simpleExpr syn

508− i <- get

510+ i <- get

509− return $ PRunTactics fc tm

511+ return $ PRunElab fc tm

510− <?> "new-style tactics expression"

512+ <?> "new-style tactics expression"

511

513

512{- | Parses a disambiguation expression

514{- | Parses a disambiguation expression

513Disamb ::=

515Disamb ::=

@@ -640,6 +642,18 @@ unquote syn = do guard (syn_in_quasiquote syn > 0)

640 return $ PUnquote e

642 return $ PUnquote e

641 <?> "unquotation"

643 <?> "unquotation"

642

644

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+

643

657

644{-| Parses a record field setter expression

658{-| Parses a record field setter expression

645@

659@

@@ -869,49 +883,67 @@ bindsymbol opts st syn

869 = do symbol "->"

883 = do symbol "->"

870 return (Exp opts st False)

884 return (Exp opts st False)

871

885

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+

872pi :: SyntaxInfo -> IdrisParser PTerm

940pi :: SyntaxInfo -> IdrisParser PTerm

873pi syn =

941pi syn =

874 do opts <- piOpts syn

942 do opts <- piOpts syn

875 st <- static

943 st <- static

876− (do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')

877− binder <- bindsymbol opts st syn

944+ explicitPi opts st syn

878− sc <- expr syn

945+ <|> try (do lchar '{'; implicitPi opts st syn)

879− return (bindList (PPi binder) xt sc)) <|> (do

946+ <|> unboundPi opts st syn

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)

915 <?> "dependent type signature"

947 <?> "dependent type signature"

916

948

917{- | Parses Possible Options for Pi Expressions

949{- | Parses Possible Options for Pi Expressions

@@ -944,14 +976,14 @@ constraintList1 syn = try (do lchar '('

944 lchar ')'

976 lchar ')'

945 reservedOp "=>"

977 reservedOp "=>"

946 return tys)

978 return tys)

947− <|> try (do t <- expr (disallowImp syn)

979+ <|> try (do t <- opExpr (disallowImp syn)

948 reservedOp "=>"

980 reservedOp "=>"

949 return [(defname, t)])

981 return [(defname, t)])

950 <?> "type constraint list"

982 <?> "type constraint list"

951 where nexpr = try (do n <- name; lchar ':'

983 where nexpr = try (do n <- name; lchar ':'

952− e <- expr' (disallowImp syn)

984+ e <- expr syn

953 return (n, e))

985 return (n, e))

954− <|> do e <- expr' (disallowImp syn)

986+ <|> do e <- expr syn

955 return (defname, e)

987 return (defname, e)

956 defname = sMN 0 "constrarg"

988 defname = sMN 0 "constrarg"

957

989

@@ -1148,7 +1180,6 @@ Constant ::=

1148 | 'String'

1180 | 'String'

1149 | 'Ptr'

1181 | 'Ptr'

1150 | 'ManagedPtr'

1182 | 'ManagedPtr'

1151− | 'prim__UnsafeBuffer'

1152 | 'Bits8'

1183 | 'Bits8'

1153 | 'Bits16'

1184 | 'Bits16'

1154 | 'Bits32'

1185 | 'Bits32'

src/Idris/Parser.hs+20−45

@@ -25,8 +25,8 @@ import Idris.Imports

25import Idris.Delaborate

26import Idris.Error

27import Idris.Elab.Value

28+import Idris.Elab.Term

28import Idris.ElabDecls

29import Idris.ElabDecls

29−import Idris.ElabTerm

30import Idris.Coverage

31import Idris.IBC

32import Idris.Unlit

@@ -43,6 +43,7 @@ import Idris.Docstrings hiding (Unchecked)

43import Paths_idris

44

45import Util.DynamicLinker

46+import Util.System (readSource, writeSource)

46import qualified Util.Pretty as P

47import qualified Util.Pretty as P

47

48

48import Idris.Core.TT

49import Idris.Core.TT

@@ -1076,71 +1077,44 @@ Directive' ::= 'lib' CodeGen String_t

1076-}

1077-}

1077directive :: SyntaxInfo -> IdrisParser [PDecl]

1078directive :: SyntaxInfo -> IdrisParser [PDecl]

1078directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;

1079directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- stringLiteral;

1079− return [PDirective (do addLib cgn lib

1080+ return [PDirective (DLib cgn lib)]

1080− addIBC (IBCLib cgn lib))]

1081 <|> do try (lchar '%' *> reserved "link"); cgn <- codegen_; obj <- stringLiteral;

1082− return [PDirective (do dirs <- allImportDirs

1082+ return [PDirective (DLink cgn obj)]

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_;

1083+ <|> do try (lchar '%' *> reserved "flag"); cgn <- codegen_; flag <- stringLiteral

1087− flag <- stringLiteral

1088− return [PDirective (do addIBC (IBCCGFlag cgn flag)

1084+ return [PDirective (DFlag cgn flag)]

1089− addFlag cgn flag)]

1090 <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;

1085 <|> do try (lchar '%' *> reserved "include"); cgn <- codegen_; hdr <- stringLiteral;

1091− return [PDirective (do addHdr cgn hdr

1086+ return [PDirective (DInclude cgn hdr)]

1092− addIBC (IBCHeader cgn hdr))]

1093 <|> do try (lchar '%' *> reserved "hide"); n <- fnName

1087 <|> do try (lchar '%' *> reserved "hide"); n <- fnName

1094− return [PDirective (do setAccessibility n Hidden

1088+ return [PDirective (DHide n)]

1095− addIBC (IBCAccess n Hidden))]

1096 <|> do try (lchar '%' *> reserved "freeze"); n <- iName []

1089 <|> do try (lchar '%' *> reserved "freeze"); n <- iName []

1097− return [PDirective (do setAccessibility n Frozen

1090+ return [PDirective (DFreeze n)]

1098− addIBC (IBCAccess n Frozen))]

1099 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1091 <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1100− return [PDirective (do i <- get

1092+ return [PDirective (DAccess acc)]

1101− put(i { default_access = acc }))]

1102 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1093 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1103 i <- get

1094 i <- get

1104 put (i { default_total = tot } )

1095 put (i { default_total = tot } )

1105− return [PDirective (do i <- get

1096+ return [PDirective (DDefault tot)]

1106− put(i { default_total = tot }))]

1107 <|> do try (lchar '%' *> reserved "logging"); i <- natural;

1097 <|> do try (lchar '%' *> reserved "logging"); i <- natural;

1108− return [PDirective (setLogLevel (fromInteger i))]

1098+ return [PDirective (DLogging i)]

1109 <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');

1099 <|> do try (lchar '%' *> reserved "dynamic"); libs <- sepBy1 stringLiteral (lchar ',');

1110− return [PDirective (do added <- addDyLib libs

1100+ return [PDirective (DDynamicLibs libs)]

1111− case added of

1112− Left lib -> addIBC (IBCDyLib (lib_name lib))

1113− Right msg ->

1114− fail $ msg)]

1115 <|> do try (lchar '%' *> reserved "name")

1101 <|> do try (lchar '%' *> reserved "name")

1116 ty <- fnName

1102 ty <- fnName

1117 ns <- sepBy1 name (lchar ',')

1103 ns <- sepBy1 name (lchar ',')

1118− return [PDirective (do ty' <- disambiguate ty

1104+ return [PDirective (DNameHint ty ns)]

1119− mapM_ (addNameHint ty') ns

1120− mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

1121 <|> do try (lchar '%' *> reserved "error_handlers")

1105 <|> do try (lchar '%' *> reserved "error_handlers")

1122 fn <- fnName

1106 fn <- fnName

1123 arg <- fnName

1107 arg <- fnName

1124 ns <- sepBy1 name (lchar ',')

1108 ns <- sepBy1 name (lchar ',')

1125− return [PDirective (do fn' <- disambiguate fn

1109+ return [PDirective (DErrorHandlers fn arg ns) ]

1126− ns' <- mapM disambiguate ns

1127− addFunctionErrorHandlers fn' arg ns'

1128− mapM_ (addIBC . IBCFunctionErrorHandler fn' arg) ns')]

1129 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1110 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1130− return [PDirective (addLangExt ext)]

1111+ return [PDirective (DLanguage ext)]

1131 <|> do fc <- getFC

1112 <|> do fc <- getFC

1132 try (lchar '%' *> reserved "used")

1113 try (lchar '%' *> reserved "used")

1133 fn <- fnName

1114 fn <- fnName

1134 arg <- iName []

1115 arg <- iName []

1135− return [PDirective (addUsedName fc fn arg)]

1116+ return [PDirective (DUsed fc fn arg)]

1136−

1137 <?> "directive"

1117 <?> "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))

1144

1118

1145pLangExt :: IdrisParser LanguageExt

1119pLangExt :: IdrisParser LanguageExt

1146pLangExt = (reserved "TypeProviders" >> return TypeProviders)

1120pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1345,7 +1319,7 @@ loadSource lidr f toline

1345 = do iLOG ("Reading " ++ f)

1319 = do iLOG ("Reading " ++ f)

1346 i <- getIState

1320 i <- getIState

1347 let def_total = default_total i

1321 let def_total = default_total i

1348− file_in <- runIO $ readFile f

1322+ file_in <- runIO $ readSource f

1349 file <- if lidr then tclift $ unlit f file_in else return file_in

1323 file <- if lidr then tclift $ unlit f file_in else return file_in

1350 (mdocs, mname, imports_in, pos) <- parseImports f file

1324 (mdocs, mname, imports_in, pos) <- parseImports f file

1351 ai <- getAutoImports

1325 ai <- getAutoImports

@@ -1364,7 +1338,7 @@ loadSource lidr f toline

1364 -- process and check module aliases

1338 -- process and check module aliases

1365 let modAliases = M.fromList

1339 let modAliases = M.fromList

1366 [(prep alias, prep realName) | (reexport, realName, Just alias, fc) <- imports]

1340 [(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]

1368 aliasNames = [(alias, fc) | (_, _, Just alias, fc) <- imports]

1342 aliasNames = [(alias, fc) | (_, _, Just alias, fc) <- imports]

1369 histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames

1343 histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames

1370 case map head . filter ((/= 1) . length) $ histogram of

1344 case map head . filter ((/= 1) . length) $ histogram of

@@ -1470,6 +1444,7 @@ loadSource lidr f toline

1470 case x of

1444 case x of

1471 PClauses{} -> r

1445 PClauses{} -> r

1472 PClass{} -> r

1446 PClass{} -> r

1447+ PData{} -> r

1473 PInstance{} -> r

1448 PInstance{} -> r

1474 _ -> x

1449 _ -> x

1475

1450

src/Idris/PartialEval.hs+2−2

@@ -146,7 +146,7 @@ mkPE_TyDecl ist args ty = mkty args ty

146 = do nm <- get

147 put (nm + 1)

148 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

150 gen tm = return tm

151

152-- | Checks if a given argument is a type class constraint argument

@@ -291,7 +291,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

291

292 -- if we have a *defined* function that has static arguments,

293 -- 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,

295 n `notElem` map fst (idris_metavars ist) =

296 ga env f ++ ga env a ++

297 case (lookupCtxtExact n (idris_statics ist),

src/Idris/ProofSearch.hs+37−24

@@ -15,6 +15,7 @@ import Idris.Error

15import Control.Applicative ((<$>))

16import Control.Monad

17import Control.Monad.State.Strict

18+import qualified Data.Set as S

18import Data.List

19import Data.List

19import Debug.Trace

20import Debug.Trace

20

21

@@ -91,7 +92,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

91 if ambigok || argsok then

92 if ambigok || argsok then

92 case lookupCtxt nroot (idris_tyinfodata ist) of

93 case lookupCtxt nroot (idris_tyinfodata ist) of

93 [TISolution ts] -> findInferredTy ts

94 [TISolution ts] -> findInferredTy ts

94− _ -> psRec rec maxDepth []

95+ _ -> psRec rec maxDepth [] S.empty

95 else autoArg (sUN "auto") -- not enough info in the type yet

96 else autoArg (sUN "auto") -- not enough info in the type yet

96 where

97 where

97 findInferredTy (t : _) = elab (delab ist (toUN t))

98 findInferredTy (t : _) = elab (delab ist (toUN t))

@@ -127,20 +128,28 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

127 toUN t@(P nt (MN i n) ty)

128 toUN t@(P nt (MN i n) ty)

128 | ('_':xs) <- str n = t

129 | ('_':xs) <- str n = t

129 | otherwise = P nt (UN n) ty

130 | 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)

131 toUN t = t

132 toUN t = t

132

133

133 -- psRec counts depth and the local variable applications we're under

134 -- psRec counts depth and the local variable applications we're under

134 -- (so we don't try a pointless application of something to itself,

135 -- (so we don't try a pointless application of something to itself,

135 -- which obviously won't work anyway but might lead us on a wild

136 -- which obviously won't work anyway but might lead us on a wild

136 -- goose chase...)

137 -- goose chase...)

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 ()

137− psRec _ 0 locs | fromProver = cantSolveGoal

142+ psRec _ 0 locs tys | fromProver = cantSolveGoal

138− psRec rec 0 locs = do attack; defer [] nroot; solve --fail "Maximum depth reached"

143+ psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"

139− psRec False d locs = tryCons d locs hints

144+ psRec False d locs tys = tryCons d locs tys hints

140− psRec True d locs

145+ psRec True d locs tys

141 = do compute

146 = do compute

147+ ty <- goal

148+ when (S.member ty tys) $ fail "Been here before"

149+ let tys' = S.insert ty tys

142 try' (trivial elab ist)

150 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')

144 True)

153 True)

145 -- if all else fails, make a new metavariable

154 -- if all else fails, make a new metavariable

146 (if fromProver

155 (if fromProver

@@ -151,7 +160,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

151 getFn d (Just f) | d < maxDepth-1 = [f]

160 getFn d (Just f) | d < maxDepth-1 = [f]

152 | otherwise = []

161 | otherwise = []

153

162

154− resolveByCon d locs

163+ resolveByCon d locs tys

155 = do t <- goal

164 = do t <- goal

156 let (f, _) = unApply t

165 let (f, _) = unApply t

157 case f of

166 case f of

@@ -160,7 +169,8 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

160 Nothing -> []

169 Nothing -> []

161 Just hs -> hs

170 Just hs -> hs

162 case lookupCtxtExact n (idris_datatypes ist) of

171 case lookupCtxtExact n (idris_datatypes ist) of

163− Just t -> tryCons d locs (hints ++

172+ Just t -> tryCons d locs tys

173+ (hints ++

164 con_names t ++

174 con_names t ++

165 autohints ++

175 autohints ++

166 getFn d fn)

176 getFn d fn)

@@ -169,28 +179,31 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

169

179

170 -- if there are local variables which have a function type, try

180 -- if there are local variables which have a function type, try

171 -- applying them too

181 -- applying them too

172− resolveByLocals d locs

182+ resolveByLocals d locs tys

173 = do env <- get_env

183 = do env <- get_env

174− tryLocals d locs env

184+ tryLocals d locs tys env

175

185

176− tryLocals d locs [] = fail "Locals failed"

186+ tryLocals d locs tys [] = fail "Locals failed"

177− tryLocals d locs ((x, t) : xs)

187+ tryLocals d locs tys ((x, t) : xs)

178− | x `elem` locs = tryLocals d locs xs

188+ | x `elem` locs = tryLocals d locs tys xs

179− | otherwise = try' (tryLocal d (x : locs) x t) (tryLocals d locs xs) True

189+ | otherwise = try' (tryLocal d (x : locs) tys x t)

190+ (tryLocals d locs tys xs) True

180

191

181− tryCons d locs [] = fail "Constructors failed"

192+ tryCons d locs tys [] = fail "Constructors failed"

193+ tryCons d locs tys (c : cs)

182− tryCons d locs (c : cs) = try' (tryCon d locs c) (tryCons d locs cs) True

194+ = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

183

195

184− tryLocal d locs n t

196+ tryLocal d locs tys n t

185 = do let a = getPArity (delab ist (binderTy t))

197 = do let a = getPArity (delab ist (binderTy t))

186− tryLocalArg d locs n a

198+ tryLocalArg d locs tys n a

187

199

188− tryLocalArg d locs n 0 = elab (PRef (fileFC "prf") n)

200+ tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") n)

201+ tryLocalArg d locs tys n i

189− tryLocalArg d locs n i = simple_app False (tryLocalArg d locs n (i - 1))

202+ = simple_app False (tryLocalArg d locs tys n (i - 1))

190− (psRec True d locs) "proof search local apply"

203+ (psRec True d locs tys) "proof search local apply"

191

204

192 -- Like type class resolution, but searching with constructors

205 -- Like type class resolution, but searching with constructors

193− tryCon d locs n =

206+ tryCon d locs tys n =

194 do ty <- goal

207 do ty <- goal

195 let imps = case lookupCtxtExact n (idris_implicits ist) of

208 let imps = case lookupCtxtExact n (idris_implicits ist) of

196 Nothing -> []

209 Nothing -> []

@@ -204,7 +217,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot hints ist

204 when (length ps < length ps') $ fail "Can't apply constructor"

217 when (length ps < length ps') $ fail "Can't apply constructor"

205 mapM_ (\ (_, h) -> do focus h

218 mapM_ (\ (_, h) -> do focus h

206 aty <- goal

219 aty <- goal

207− psRec True d locs)

220+ psRec True d locs tys)

208 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

221 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

209 solve

222 solve

210

223

src/Idris/Prover.hs+2−2

@@ -9,13 +9,13 @@ import Idris.Core.Typecheck

9

10import Idris.Elab.Utils

11import Idris.Elab.Value

12+import Idris.Elab.Term

12

13

13import Idris.AbsSyntax

14import Idris.AbsSyntax

14import Idris.AbsSyntaxTree

15import Idris.AbsSyntaxTree

15import Idris.Delaborate

16import Idris.Delaborate

16import Idris.Docs (getDocs, pprintDocs, pprintConstDocs)

17import Idris.Docs (getDocs, pprintDocs, pprintConstDocs)

17import Idris.ElabDecls

18import Idris.ElabDecls

18−import Idris.ElabTerm

19import Idris.Parser hiding (params)

20import Idris.Error

21import Idris.DataOpts

@@ -66,7 +66,7 @@ assumptionNames e

66

67prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

68prove 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

70 idemodePutSExp "start-proof-mode" n

71 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing

72 iLOG $ "Adding " ++ show tm

src/Idris/REPL.hs+45−15

@@ -8,7 +8,6 @@ import Idris.ASTUtils

8import Idris.Apropos (apropos, aproposModules)

9import Idris.REPLParser

10import Idris.ElabDecls

11−import Idris.ElabTerm

12import Idris.Erasure

11import Idris.Erasure

13import Idris.Error

12import Idris.Error

14import Idris.ErrReverse

13import Idris.ErrReverse

@@ -35,10 +34,13 @@ import Idris.WhoCalls

35import Idris.TypeSearch (searchByType)

34import Idris.TypeSearch (searchByType)

36import Idris.IBC (loadPkgIndex, writePkgIndex)

35import Idris.IBC (loadPkgIndex, writePkgIndex)

37

36

37+import Idris.REPL.Browse (namesInNS, namespacesInNS)

38+

38import Idris.Elab.Type

39import Idris.Elab.Type

39import Idris.Elab.Clause

40import Idris.Elab.Clause

40import Idris.Elab.Data

41import Idris.Elab.Data

41import Idris.Elab.Value

42import Idris.Elab.Value

43+import Idris.Elab.Term

42

44

43import Version_idris (gitHash)

45import Version_idris (gitHash)

44import Util.System

46import Util.System

@@ -463,6 +465,7 @@ runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) =

463 renderPretty 0.9 1000 .

465 renderPretty 0.9 1000 .

464 fmap (fancifyAnnots ist) .

466 fmap (fancifyAnnots ist) .

465 prettyName True True []

467 prettyName True True []

468+

466runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

469runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

467 case splitName n of

470 case splitName n of

468 Left err -> iPrintError err

471 Left err -> iPrintError err

@@ -476,6 +479,20 @@ runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

476 fmap (fancifyAnnots ist) .

479 fmap (fancifyAnnots ist) .

477 prettyName True True []

480 prettyName True True []

478

481

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 []

479runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

496runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

480 do ctxt <- getContext

497 do ctxt <- getContext

481 ist <- getIState

498 ist <- getIState

@@ -582,8 +599,8 @@ idemodeProcess fn (HNF t) = process fn (HNF t)

582--idemodeProcess fn TTShell = process fn TTShell -- need some prove mode!

599--idemodeProcess fn TTShell = process fn TTShell -- need some prove mode!

583idemodeProcess fn (TestInline t) = process fn (TestInline t)

600idemodeProcess fn (TestInline t) = process fn (TestInline t)

584

601

585−idemodeProcess fn Execute = do process fn Execute

602+idemodeProcess fn (Execute t) = do process fn (Execute t)

586− iPrintResult ""

603+ iPrintResult ""

587idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)

604idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)

588 iPrintResult ""

605 iPrintResult ""

589idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)

606idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)

@@ -1059,7 +1076,7 @@ process fn' (AddProof prf)

1059 else ifail $ "Neither \""++fn''++"\" nor \""++fnExt++"\" exist"

1076 else ifail $ "Neither \""++fn''++"\" nor \""++fnExt++"\" exist"

1060 let fb = fn ++ "~"

1077 let fb = fn ++ "~"

1061 runIO $ copyFile fn fb -- make a backup in case something goes wrong!

1078 runIO $ copyFile fn fb -- make a backup in case something goes wrong!

1062− prog <- runIO $ readFile fb

1079+ prog <- runIO $ readSource fb

1063 i <- getIState

1080 i <- getIState

1064 let proofs = proof_list i

1081 let proofs = proof_list i

1065 n' <- case prf of

1082 n' <- case prf of

@@ -1071,7 +1088,7 @@ process fn' (AddProof prf)

1071 case lookup n proofs of

1088 case lookup n proofs of

1072 Nothing -> iputStrLn "No proof to add"

1089 Nothing -> iputStrLn "No proof to add"

1073 Just p -> do let prog' = insertScript (showProof (lit fn) n p) ls

1090 Just p -> do let prog' = insertScript (showProof (lit fn) n p) ls

1074− runIO $ writeFile fn (unlines prog')

1091+ runIO $ writeSource fn (unlines prog')

1075 removeProof n

1092 removeProof n

1076 iputStrLn $ "Added proof " ++ show n

1093 iputStrLn $ "Added proof " ++ show n

1077 where ls = (lines prog)

1094 where ls = (lines prog)

@@ -1115,13 +1132,10 @@ process fn (TestInline t)

1115 let tm' = inlineTerm ist tm

1132 let tm' = inlineTerm ist tm

1116 c <- colourise

1133 c <- colourise

1117 iPrintResult (showTm ist (delab ist tm'))

1134 iPrintResult (showTm ist (delab ist tm'))

1118−process fn Execute

1135+process fn (Execute tm)

1119 = idrisCatch

1136 = idrisCatch

1120 (do ist <- getIState

1137 (do ist <- getIState

1121− (m, _) <- elabVal recinfo ERHS

1138+ (m, _) <- elabVal recinfo ERHS (elabExec fc tm)

1122− (PApp fc

1123− (PRef fc (sUN "run__IO"))

1124− [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

1125 (tmpn, tmph) <- runIO tempfile

1139 (tmpn, tmph) <- runIO tempfile

1126 runIO $ hClose tmph

1140 runIO $ hClose tmph

1127 t <- codegen

1141 t <- codegen

@@ -1232,10 +1246,11 @@ process fn (Apropos pkgs a) =

1232 delabTy ist n,

1246 delabTy ist n,

1233 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

1247 fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

1234 | n <- sort names, isUN n ]

1248 | n <- sort names, isUN n ]

1249+ if (not (null mods)) || (not (null aproposInfo))

1235− iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>

1250+ then iRenderResult $ vsep (map (\(m, d) -> text "Module" <+> text m <$>

1236− ppD ist d <> line) mods) <$>

1251+ ppD ist d <> line) mods) <$>

1237− vsep (map (prettyDocumentedIst ist) aproposInfo)

1252+ vsep (map (prettyDocumentedIst ist) aproposInfo)

1238− putIState orig

1253+ else iRenderError $ text "No results found"

1239 where isUN (UN _) = True

1254 where isUN (UN _) = True

1240 isUN (NS n _) = isUN n

1255 isUN (NS n _) = isUN n

1241 isUN _ = False

1256 isUN _ = False

@@ -1259,6 +1274,21 @@ process fn (CallsWho n) =

1259 prettyName True True [] n <+> text "calls:" <$>

1274 prettyName True True [] n <+> text "calls:" <$>

1260 indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))

1275 indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns)))

1261 calls

1276 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+

1262-- IdrisDoc

1292-- IdrisDoc

1263process fn (MakeDoc s) =

1293process fn (MakeDoc s) =

1264 do istate <- getIState

1294 do istate <- getIState

@@ -1557,7 +1587,7 @@ idrisMain opts =

1557

1587

1558 when (DefaultTotal `elem` opts) $ do i <- getIState

1588 when (DefaultTotal `elem` opts) $ do i <- getIState

1559 putIState (i { default_total = True })

1589 putIState (i { default_total = True })

1560− setColourise $ not quiet && last (True : opt getColour opts)

1590+ setColourise $ not quiet && last ((not isWindows) : opt getColour opts)

1561

1591

1562

1592

1563

1593

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 =

52 , " Search for values by type", cmd_search)

53 , nameArgCmd ["wc", "whocalls"] WhoCalls "List the callers of some name"

54 , nameArgCmd ["cw", "callswho"] CallsWho "List the callees of some name"

55+ , namespaceArgCmd ["browse"] Browse "List the contents of some namespace"

55 , nameArgCmd ["total"] TotCheck "Check the totality of a name"

56 , nameArgCmd ["total"] TotCheck "Check the totality of a name"

56 , noArgCmd ["r", "reload"] Reload "Reload current file"

57 , noArgCmd ["r", "reload"] Reload "Reload current file"

57 , (["l", "load"], FileArg, "Load a new file"

58 , (["l", "load"], FileArg, "Load a new file"

@@ -71,7 +72,7 @@ parserCommandsForHelp =

71 , noArgCmd ["proofs"] Proofs "Show available proofs"

72 , noArgCmd ["proofs"] Proofs "Show available proofs"

72 , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"

73 , exprArgCmd ["x"] ExecVal "Execute IO actions resulting from an expression using the interpreter"

73 , (["c", "compile"], FileArg, "Compile to an executable [codegen] <filename>", cmd_compile)

74 , (["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)

75 , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)

76 , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)

76 , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)

77 , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)

77 , noArgCmd ["?", "h", "help"] Help "Display this help text"

78 , noArgCmd ["?", "h", "help"] Help "Display this help text"

@@ -136,17 +137,19 @@ parserCommands =

136 )

137 )

137 ]

138 ]

138

139

139−noArgCmd names command doc =

140+noArgCmd names command doc =

140 (names, NoArg, doc, noArgs command)

141 (names, NoArg, doc, noArgs command)

141−nameArgCmd names command doc =

142+nameArgCmd names command doc =

142 (names, NameArg, doc, fnNameArg command)

143 (names, NameArg, doc, fnNameArg command)

144+namespaceArgCmd names command doc =

145+ (names, NamespaceArg, doc, namespaceArg command)

143−exprArgCmd names command doc =

146+exprArgCmd names command doc =

144 (names, ExprArg, doc, exprArg command)

147 (names, ExprArg, doc, exprArg command)

145−metavarArgCmd names command doc =

148+metavarArgCmd names command doc =

146 (names, MetaVarArg, doc, fnNameArg command)

149 (names, MetaVarArg, doc, fnNameArg command)

147−optArgCmd names command doc =

150+optArgCmd names command doc =

148 (names, OptionArg, doc, optArg command)

151 (names, OptionArg, doc, optArg command)

149−proofArgCmd names command doc =

152+proofArgCmd names command doc =

150 (names, NoArg, doc, proofArg command)

153 (names, NoArg, doc, proofArg command)

151

154

152pCmd :: P.IdrisParser (Either String Command)

155pCmd :: P.IdrisParser (Either String Command)

@@ -220,6 +223,11 @@ moduleArg = genArg "module" (fmap toPath P.identifier)

220 where

223 where

221 toPath n = foldl1' (</>) $ splitOn "." n

224 toPath n = foldl1' (</>) $ splitOn "." n

222

225

226+namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)

227+namespaceArg = genArg "namespace" (fmap toNS P.identifier)

228+ where

229+ toNS = splitOn "."

230+

223optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)

231optArg :: (Opt -> Command) -> String -> P.IdrisParser (Either String Command)

224optArg cmd name = do

232optArg cmd name = do

225 let emptyArgs = do

233 let emptyArgs = do

@@ -276,6 +284,14 @@ cmd_consolewidth name = do

276 <|> do discard (P.symbol "infinite"); return InfinitelyWide

284 <|> do discard (P.symbol "infinite"); return InfinitelyWide

277 <|> do n <- fmap fromInteger P.natural; return (ColsWide n)

285 <|> do n <- fmap fromInteger P.natural; return (ColsWide n)

278

286

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+

279cmd_dynamic :: String -> P.IdrisParser (Either String Command)

295cmd_dynamic :: String -> P.IdrisParser (Either String Command)

280cmd_dynamic name = do

296cmd_dynamic name = do

281 let emptyArgs = noArgs ListDynamic name

297 let emptyArgs = noArgs ListDynamic name

src/Idris/Reflection.hs+990−6

@@ -1,18 +1,1002 @@

1−{-|

1+{-| Code related to Idris's reflection system. This module contains

2−Handy tools for doing reflection.

2+quoters and unquoters along with some supporting datatypes.

3-}

4+{-# LANGUAGE PatternGuards #-}

5+{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-}

4module Idris.Reflection where

6module Idris.Reflection where

5

7

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)

6import Idris.Core.TT

17import Idris.Core.TT

7−import Idris.AbsSyntaxTree (PArg'(..), PArg, PTerm(Placeholder))

8

18

19+import Idris.AbsSyntaxTree (ElabD, IState, PArg'(..), PArg, PTactic, PTactic'(..),

20+ PTerm(..), initEState, pairCon, pairTy)

21+import Idris.Delaborate (delab)

22+

9−data RArg = RExplicit { argName :: Name, argTy :: Raw }

23+data RArg = RExplicit { argName :: Name, argTy :: Raw }

10− | RImplicit { argName :: Name, argTy :: Raw }

24+ | RImplicit { argName :: Name, argTy :: Raw }

11 | RConstraint { argName :: Name, argTy :: Raw }

25 | RConstraint { argName :: Name, argTy :: Raw }

26+ deriving Show

27+

28+data RTyDecl = RDeclare Name [RArg] Raw deriving Show

12

29

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

14

35

15rArgToPArg :: RArg -> PArg

36rArgToPArg :: RArg -> PArg

16rArgToPArg (RExplicit n _) = PExp 0 [] n Placeholder

37rArgToPArg (RExplicit n _) = PExp 0 [] n Placeholder

17rArgToPArg (RImplicit n _) = PImp 0 False [] n Placeholder

38rArgToPArg (RImplicit n _) = PImp 0 False [] n Placeholder

18rArgToPArg (RConstraint n _) = PConstraint 0 [] n Placeholder

39rArgToPArg (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

39 = finalise $ applyAll rules emptyContext (vToP tm)

40

41applyAll :: [(Term, Term)] -> Ctxt [(Term, Term)] -> Term -> Term

42−applyAll extra ts ap@(App f a)

42+applyAll extra ts ap@(App s f a)

43 | (P _ fn ty, args) <- unApply ap

44 = let rules = case lookupCtxtExact fn ts of

45 Just r -> extra ++ r

46 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

48 case rules of

49 [] -> ap'

50 rs -> case applyFnRules rs ap of

51− Just tm'@(App f' a') ->

51+ Just tm'@(App s f' a') ->

52− App (applyAll extra ts f')

52+ App s (applyAll extra ts f')

53− (applyAll extra ts a')

53+ (applyAll extra ts a')

54 Just tm' -> tm'

55− _ -> App (applyAll extra ts f)

55+ _ -> App s (applyAll extra ts f)

56− (applyAll extra ts a)

56+ (applyAll extra ts a)

57applyAll extra ts (Bind n b sc) = Bind n (fmap (applyAll extra ts) b)

58 (applyAll extra ts sc)

59applyAll extra ts t = t

@@ -94,7 +94,7 @@ matchTerm lhs tm = matchVars [] lhs tm

94 doMatch :: [Name] -> Term -> Term -> Maybe [(Name, Term)]

95 doMatch ns (P _ n _) tm

96 | n `elem` ns = return [(n, tm)]

97− doMatch ns (App f a) (App f' a')

97+ doMatch ns (App _ f a) (App _ f' a')

98 = do fm <- doMatch ns f f'

99 am <- doMatch ns a a'

100 return (fm ++ am)

src/Idris/TypeSearch.hs+14−11

@@ -30,7 +30,7 @@ import Idris.Core.Unify (match_unify)

30import Idris.Delaborate (delabTy)

31import Idris.Docstrings (noDocs, overview)

32import Idris.Elab.Type (elabType)

33−import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderResult, prettyDocumentedIst)

33+import Idris.Output (iputStrLn, iRenderOutput, iPrintResult, iRenderError, iRenderResult, prettyDocumentedIst)

34import Idris.IBC

35

36import Prelude hiding (pred)

@@ -54,10 +54,12 @@ searchByType pkgs pterm = do

54 [ let docInfo = (n, delabTy i n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings i))) in

55 displayScore theScore <> char ' ' <> prettyDocumentedIst i docInfo

56 | (n, theScore) <- names']

57+ if (not (null docs))

57− case idris_outputmode i of

58+ then case idris_outputmode i of

58− RawOutput _ -> do mapM_ iRenderOutput docs

59+ RawOutput _ -> do mapM_ iRenderOutput docs

59− iPrintResult ""

60+ iPrintResult ""

60− IdeMode _ _ -> iRenderResult (vsep docs)

61+ IdeMode _ _ -> iRenderResult (vsep docs)

62+ else iRenderError $ text "No results found"

61 putIState i -- don't actually make any changes

63 putIState i -- don't actually make any changes

62 where

64 where

63 numLimit = 50

65 numLimit = 50

@@ -102,9 +104,9 @@ typeFromDef (def, _, _, _) = get def where

102-- Replace all occurences of `Lazy' s t` with `t` in a type

104-- Replace all occurences of `Lazy' s t` with `t` in a type

103unLazy :: Type -> Type

105unLazy :: Type -> Type

104unLazy typ = case typ of

106unLazy 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

106 Bind name binder ty -> Bind name (fmap unLazy binder) (unLazy ty)

108 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)

108 Proj ty i -> Proj (unLazy ty) i

110 Proj ty i -> Proj (unLazy ty) i

109 _ -> typ

111 _ -> typ

110

112

@@ -144,7 +146,7 @@ usedVars = f True where

144 Let t v -> f b t `M.union` f b v

146 Let t v -> f b t `M.union` f b v

145 Guess t v -> f b t `M.union` f b v

147 Guess t v -> f b t `M.union` f b v

146 bind -> f b (binderTy bind)

148 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

148 f b (Proj t _) = f b t

150 f b (Proj t _) = f b t

149 f _ (V _) = error "unexpected! run vToP first"

151 f _ (V _) = error "unexpected! run vToP first"

150 f _ _ = M.empty

152 f _ _ = M.empty

@@ -305,13 +307,14 @@ subsets (x : xs) = let ss = subsets xs in map (x :) ss ++ ss

305-- recalls the number of flips that have been made

307-- recalls the number of flips that have been made

306flipEqualities :: Type -> [(Int, Type)]

308flipEqualities :: Type -> [(Int, Type)]

307flipEqualities t = case t of

309flipEqualities t = case t of

308− eq1@(App (App (App (App eq@(P _ eqty _) tyL) tyR) valL) valR) | eqty == eqTy ->

310+ 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)]

311+ [(0, eq1), (1, app (app (app (app eq tyR) tyL) valR) valL)]

310 Bind n binder sc -> (\bind' (j, sc') -> (fst (binderTy bind') + j, Bind n (fmap snd bind') sc'))

312 Bind n binder sc -> (\bind' (j, sc') -> (fst (binderTy bind') + j, Bind n (fmap snd bind') sc'))

311 <$> traverse flipEqualities binder <*> flipEqualities sc

313 <$> 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'))

313 <$> flipEqualities f <*> flipEqualities x

315 <$> flipEqualities f <*> flipEqualities x

314 t' -> [(0, t')]

316 t' -> [(0, t')]

317+ where app = App Complete

315

318

316--DONT run vToP first!

319--DONT run vToP first!

317-- | Try to match two types together in a unification-like procedure.

320-- | 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

13occurs n (P Bound _ _) = False

14occurs n (P _ n' _) = n == n'

15occurs 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

17occurs n (Proj t _) = occurs n t

18occurs n _ = False

19

@@ -21,7 +21,7 @@ names :: Term -> [Name]

21names (P Bound _ _) = []

22names (P _ n _) = [n]

23names (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

25names (Proj t _) = names t

26names _ = []

27

src/Util/System.hs+41−2

@@ -1,4 +1,6 @@

1+{-# LANGUAGE CPP #-}

1−module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows) where

2+module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,

3+ writeSource, readSource, setupBundledCC) where

2

4

3-- System helper functions.

5-- System helper functions.

4import Control.Monad (when)

6import Control.Monad (when)

@@ -6,13 +8,19 @@ import System.Directory (getTemporaryDirectory

6 , removeFile

8 , removeFile

7 , removeDirectoryRecursive

9 , removeDirectoryRecursive

8 , createDirectoryIfMissing

10 , createDirectoryIfMissing

11+ , doesDirectoryExist

9 )

12 )

10−import System.FilePath ((</>), normalise)

13+import System.FilePath ((</>), normalise, isAbsolute, dropFileName)

11import System.IO

14import System.IO

12import System.Info

15import System.Info

13import System.IO.Error

16import System.IO.Error

14import Control.Exception as CE

17import Control.Exception as CE

15

18

19+#ifdef FREESTANDING

20+import Tools_idris

21+import System.Environment (getEnv, setEnv, getExecutablePath)

22+#endif

23+

16catchIO :: IO a -> (IOError -> IO a) -> IO a

24catchIO :: IO a -> (IOError -> IO a) -> IO a

17catchIO = CE.catch

25catchIO = CE.catch

18

26

@@ -26,6 +34,16 @@ tempfile :: IO (FilePath, Handle)

26tempfile = do dir <- getTemporaryDirectory

34tempfile = do dir <- getTemporaryDirectory

27 openTempFile (normalise dir) "idris"

35 openTempFile (normalise dir) "idris"

28

36

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+

29withTempdir :: String -> (FilePath -> IO a) -> IO a

47withTempdir :: String -> (FilePath -> IO a) -> IO a

30withTempdir subdir callback

48withTempdir subdir callback

31 = do dir <- getTemporaryDirectory

49 = do dir <- getTemporaryDirectory

@@ -43,3 +61,24 @@ rmFile f = do putStrLn $ "Removing " ++ f

43 catchIO (removeFile f)

61 catchIO (removeFile f)

44 (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

62 (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

45 ++ f ++ ", Error msg:" ++ show ioerr)

63 ++ 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)

8 @perl ./runtest.pl $(patsubst %.test,%,$@)

9

10test_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

12

13update:

14 /usr/bin/env perl ./runtest.pl all -u

test/README+1

@@ -1,6 +1,7 @@

1Tests are categorised as follows:

2

3basic: Basic language features, some complete programs

4+bignum: Bignums and GMP

4dsl: Embedded DSLs and features to support DSL development

5dsl: Embedded DSLs and features to support DSL development

5effects: Effects package

6effects: Effects package

6error: Error messages and error reflection

7error: Error messages and error reflection

test/basic010/Main.idr+1−1

@@ -38,6 +38,6 @@ fmt (axiom n) = "axiom " ++ show n

38

39main : IO ()

40main = do

41− n <- map (const 10000) (putStrLn "*oink*")

41+ n <- map (const (the Nat 10000)) (putStrLn "*oink*")

42 putStrLn . show $ getWitness (f 4 n)

43 putStrLn . fmt $ getProof (g 4 n)

test/basic010/run+31−25

@@ -1,28 +1,5 @@

1#!/usr/bin/env bash

2

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−}

26

3

27declare -a extraargs

4declare -a extraargs

28for arg in "$@"

5for arg in "$@"

@@ -30,6 +7,35 @@ do

30 extraargs=("${extraargs[@]}" "'$arg'")

7 extraargs=("${extraargs[@]}" "'$arg'")

31done

8done

32

9

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+

33−timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"

38+ timeout 10 "idris ${extraargs[*]} Main.idr --nocolour --check --warnreach -o basic010"

34−timeout 5 "./basic010"

39+ timeout 5 "./basic010"

40+fi

35rm -f *.ibc basic010

41rm -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

2foo : Nat -> String

1foo : Nat -> String

3foo n = case n of

2foo n = case n of

4 0 => "z"

3 0 => "z"

test/docs001/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./docs001.idr

2Type class C

1Type class C

3 class

2 class

4

3

test/docs002/expected+3−5

@@ -1,11 +1,9 @@

1−Type checking ./docs002.idr

2−*docs002> T1 : Type

1+T1 : Type

3 Some documentation

2 Some documentation

4

3

5−*docs002> T2 : Type

4+T2 : Type

6 Some other documentation

5 Some other documentation

7

6

8−*docs002> T3 : Int

7+T3 : Int

9 Some provided postulate

8 Some provided postulate

10

9

11−*docs002> Bye bye

test/docs002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nobanner --nocolor docs002.idr < input

2+idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input

3rm *.ibc

test/docs003/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./docs003.idr

2Type class Functor

1Type class Functor

3 Functors

2 Functors

4

3

test/dsl002/expected−1

@@ -1,2 +1 @@

1foo

2−

test/effects001/expected+1−1

@@ -1,4 +1,4 @@

1−["HELLO!!!\n", "WORLD!!!\n", ""]

1+["HELLO!!!", "WORLD!!!", ""]

23

315

4Answer: 99

test/effects001/test021.idr+1−2

@@ -9,8 +9,7 @@ import Control.IOExcept

9data Count : Type where

10

11FileIO : 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]

14

13

15readFile : FileIO (OpenFile Read) (List String)

14readFile : FileIO (OpenFile Read) (List String)

16readFile = readAcc [] where

15readFile = readAcc [] where

test/effects001/test021a.idr+1−1

@@ -18,7 +18,7 @@ Env = List (String, Integer)

18-- Evaluator t

19-- = Eff m [EXCEPTION String, RND, STATE Env] t

20

21−eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff Integer

21+eval : Expr -> Eff Integer [EXCEPTION String, STDIO, RND, STATE Env]

22eval (Var x) = do vs <- get

23 case lookup x vs of

24 Nothing => raise ("No such variable " ++ x)

test/effects002/test025.idr+2−2

@@ -6,8 +6,8 @@ import Control.IOExcept

6import Data.Vect

7

8MemoryIO : Type -> Type -> Type -> Type

9−MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td

9+MemoryIO td ts r = Eff r [Dst ::: RAW_MEMORY td,

10− , Src ::: RAW_MEMORY ts ] } Eff r

10+ Src ::: RAW_MEMORY ts]

11

12inpVect : Vect 5 Bits8

13inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]

test/effects003/hangman.idr+28−26

@@ -74,55 +74,59 @@ data HangmanRules : Effect where

74-- the number of missing letters, if not, reduce the number of guesses left

75

76 Guess : (x : Char) ->

77+ sig HangmanRules Bool

77− { Hangman (Running (S g) (S w)) ==>

78+ (Hangman (Running (S g) (S w)))

79+ (\inword =>

78− {inword} (case inword of

80+ case inword of

79 True => Hangman (Running (S g) w)

81 True => Hangman (Running (S g) w)

80− False => Hangman (Running g (S w))) }

82+ False => Hangman (Running g (S w)))

81− HangmanRules Bool

82

83

83-- The 'Won' operation requires that there are no missing letters

84-- The 'Won' operation requires that there are no missing letters

84

85

86+ Won : sig HangmanRules ()

87+ (Hangman (Running g 0))

85− Won : { Hangman (Running g 0) ==> Hangman NotRunning } HangmanRules ()

88+ (Hangman NotRunning)

86

89

87-- The 'Lost' operation requires that there are no guesses left

90-- The 'Lost' operation requires that there are no guesses left

88

91

92+ Lost : sig HangmanRules ()

93+ (Hangman (Running 0 g))

89− Lost : { Hangman (Running 0 g) ==> Hangman NotRunning } HangmanRules ()

94+ (Hangman NotRunning)

90

95

91-- Set up a new game, initialised with 6 guesses and the missing letters in

96-- Set up a new game, initialised with 6 guesses and the missing letters in

92-- the given word. Note that if there are no letters in the word, we won't

97-- the given word. Note that if there are no letters in the word, we won't

93-- be able to run 'Guess'!

98-- be able to run 'Guess'!

94

99

95 NewWord : (w : String) ->

100 NewWord : (w : String) ->

96− { h ==> Hangman (Running 6 (length (letters w))) } HangmanRules ()

101+ sig HangmanRules () h (Hangman (Running 6 (length (letters w))))

97

102

98-- Finally, allow us to get the current game state

103-- Finally, allow us to get the current game state

99

104

100− Get : { h } HangmanRules h

105+ Get : sig HangmanRules h h

101

106

102HANGMAN : HState -> EFFECT

107HANGMAN : HState -> EFFECT

103HANGMAN h = MkEff (Hangman h) HangmanRules

108HANGMAN h = MkEff (Hangman h) HangmanRules

104

109

105-- Promote explicit effecst to Eff programs

110-- Promote explicit effecst to Eff programs

106

111

107−guess : Char ->

112+guess : Char -> Eff Bool

108− { [HANGMAN (Running (S g) (S w))] ==>

113+ [HANGMAN (Running (S g) (S w))]

109− {inword} [HANGMAN (case inword of

114+ (\inword => [HANGMAN (case inword of

110− True => Running (S g) w

115+ True => Running (S g) w

111− False => Running g (S w))] } Eff Bool

116+ False => Running g (S w))])

112guess c = call (Main.Guess c)

117guess c = call (Main.Guess c)

113

118

114−won : { [HANGMAN (Running g 0)] ==> [HANGMAN NotRunning]} Eff ()

119+won : Eff () [HANGMAN (Running g 0)] [HANGMAN NotRunning]

115won = call Won

120won = call Won

116

121

117−lost : { [HANGMAN (Running 0 g)] ==> [HANGMAN NotRunning]} Eff ()

122+lost : Eff () [HANGMAN (Running 0 g)] [HANGMAN NotRunning]

118lost = call Lost

123lost = call Lost

119

124

120−new_word : (w : String) ->

125+new_word : (w : String) -> Eff () [HANGMAN h]

121− { [HANGMAN h] ==>

122− [HANGMAN (Running 6 (length (letters w)))]} Eff ()

126+ [HANGMAN (Running 6 (length (letters w)))]

123new_word w = call (NewWord w)

127new_word w = call (NewWord w)

124

128

125−get : { [HANGMAN h] } Eff (Hangman h)

129+get : Eff (Hangman h) [HANGMAN h]

126get = call Get

130get = call Get

127

131

128-----------------------------------------------------------------------

132-----------------------------------------------------------------------

@@ -163,8 +167,8 @@ were valid letters in it!

163soRefl : So x -> (x = True)

167soRefl : So x -> (x = True)

164soRefl Oh = Refl

168soRefl Oh = Refl

165

169

166−game : { [HANGMAN (Running (S g) w), STDIO] ==>

170+game : Eff () [HANGMAN (Running (S g) w), STDIO]

167− [HANGMAN NotRunning, STDIO] } Eff ()

171+ [HANGMAN NotRunning, STDIO]

168game {w=Z} = won

172game {w=Z} = won

169game {w=S _}

173game {w=S _}

170 = do putStrLn (show !get)

174 = do putStrLn (show !get)

@@ -175,10 +179,8 @@ game {w=S _}

175 (Right p) => do putStrLn "Invalid input!"

179 (Right p) => do putStrLn "Invalid input!"

176 game

180 game

177 where

181 where

178− processGuess : -- {g,w:_} ->

179− Char -> { [HANGMAN (Running (S g) (S w)), STDIO] ==>

182+ processGuess : Char -> Eff () [HANGMAN (Running (S g) (S w)), STDIO]

180− [HANGMAN NotRunning, STDIO] }

183+ [HANGMAN NotRunning, STDIO]

181− Eff ()

182 processGuess {g} c {w}

184 processGuess {g} c {w}

183 = case !(guess c) of

185 = case !(guess c) of

184 True => do putStrLn "Good guess!"

186 True => do putStrLn "Good guess!"

@@ -203,7 +205,7 @@ wlen = proof search

203

205

204{- It typechecks! Ship it! -}

206{- It typechecks! Ship it! -}

205

207

206−runGame : { [HANGMAN NotRunning, RND, STDIO] } Eff ()

208+runGame : Eff () [HANGMAN NotRunning, RND, STDIO]

207runGame = do srand 1234567890

209runGame = do srand 1234567890

208 let w = index !(rndFin _) words

210 let w = index !(rndFin _) words

209 new_word w

211 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 @@

1test002.idr:1:6:Universe inconsistency.

2−Working on: z

2+ Working on: z

3−Old domain: Domain 6 6

3+ Old domain: (6,6)

4−New domain: Domain 6 5

4+ New domain: (6,5)

5−Involved constraints:

5+ Involved constraints:

6− ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

6+ ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

7− ConstraintFC {uconstraint = y < z, 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}

8+ ConstraintFC {uconstraint = z <= a1, ufc = test002.idr:1:6}

9−

test/error001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ test002.idr --check --noprelude

2+idris $@ test002.idr --check --noprelude --consolewidth 70

3rm -f *.ibc

test/ffi001/expected−1

@@ -1,2 +1 @@

1−Type checking ./test022.idr

20.9995736030415051

10.9995736030415051

test/ffi003/expected−1

@@ -1,2 +1 @@

1−Type checking ./test024.idr

2testtest

1testtest

test/ffi006/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2idris $@ 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

4./ffi006

5rm -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

3Warning: Ignoring empty or non-existing namespace 'TestEmpty'

1Warning: Ignoring empty or non-existing namespace 'TestEmpty'

4Warning: Ignoring empty or non-existing namespace 'TestPrivate'

2Warning: Ignoring empty or non-existing namespace 'TestPrivate'

5No namespaces to generate documentation for

3No namespaces to generate documentation for

test/idrisdoc001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2# Tests that no documentation is built for empty and/or private-only namespaces

3idris --mkdoc test_empty.ipkg

4−rm -rf *.ibc *_doc

4+rm -rf *.ibc *_doc

test/idrisdoc001/test_empty.ipkg+2

@@ -1,4 +1,6 @@

1package test_empty

2

3+opts = "--quiet"

4+

3modules = TestEmpty, TestPrivate

5modules = TestEmpty, TestPrivate

4

6

test/idrisdoc002/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestFunctions.idr

2Functions are documented

1Functions are documented

test/idrisdoc002/test_functions.ipkg+2

@@ -1,4 +1,6 @@

1package test_functions

2

3+opts = "--quiet"

4+

3modules = TestFunctions

5modules = TestFunctions

4

6

test/idrisdoc003/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestDatatypes.idr

2Data types are documented

1Data types are documented

test/idrisdoc003/test_datatypes.ipkg+2

@@ -1,4 +1,6 @@

1package test_datatypes

2

3+opts = "--quiet"

4+

3modules = TestDatatypes

5modules = TestDatatypes

4

6

test/idrisdoc004/expected−1

@@ -1,2 +1 @@

1−Type checking ./TestTypeclasses.idr

2Typeclasses are documented

1Typeclasses are documented

test/idrisdoc004/test_typeclasses.ipkg+2

@@ -1,4 +1,6 @@

1package test_typeclasses

2

3+opts = "--quiet"

4+

3modules = TestTypeclasses

5modules = TestTypeclasses

4

6

test/idrisdoc005/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./TestTracing.idr

2TestTracing: Check

1TestTracing: Check

3Prelude.Bool: Check

2Prelude.Bool: Check

test/idrisdoc005/test_tracing.ipkg+2

@@ -1,4 +1,6 @@

1package test_tracing

2

3+opts = "--quiet"

4+

3modules = TestTracing

5modules = TestTracing

4

6

test/idrisdoc006/expected−2

@@ -1,6 +1,4 @@

1−Type checking ./A/fully/Qualified/NAME.idr

2IdrisDoc file written

1IdrisDoc file written

3−Type checking ./B.idr

4A.fully.Qualified.NAME.html

2A.fully.Qualified.NAME.html

5B.html

3B.html

6A.fully.Qualified.NAME is in the index

4A.fully.Qualified.NAME is in the index

test/idrisdoc006/package_a.ipkg+2

@@ -1,4 +1,6 @@

1package test_merge

2

3+opts = "--quiet"

4+

3modules = A.fully.Qualified.NAME

5modules = A.fully.Qualified.NAME

4

6

test/idrisdoc006/package_b.ipkg+2

@@ -1,4 +1,6 @@

1package test_merge

2

3+opts = "--quiet"

4+

3modules = B

5modules = B

4

6

test/idrisdoc007/package.ipkg+2

@@ -1,4 +1,6 @@

1package do_not_delete

2

3+opts = "--quiet"

4+

3modules = A

5modules = A

4

6

test/idrisdoc008/expected−2

@@ -1,4 +1,2 @@

1−Type checking ./Abstract.idr

2−Type checking ./Visible.idr

3Abstract members are documented

1Abstract members are documented

4Public members are documented

2Public members are documented

test/idrisdoc008/visibility.ipkg+2

@@ -1,4 +1,6 @@

1package visibility

2

3+opts = "--quiet"

4+

3modules = Abstract, Visible

5modules = Abstract, Visible

4

6

test/idrisdoc009/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./Test.idr

2Data type Test : Type

1Data type Test : Type

3 Docs for datatype Test.

2 Docs for datatype Test.

4

3

test/interactive001/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./test032.idr

2isElem x [] = ?isElem_rhs_1

1isElem x [] = ?isElem_rhs_1

3isElem x (y :: xs) = ?isElem_rhs_3

2isElem x (y :: xs) = ?isElem_rhs_3

4

3

test/interactive002/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive002.idr

2Nat

1Nat

3Nat

2Nat

4Nat

3Nat

test/interactive003/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive003.idr

2ys

1ys

3x :: app xs ys

2x :: app xs ys

4[]

3[]

test/interactive004/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./interactive004.idr

2plus ?foo_rhs2 ?foo_rhs3

1plus ?foo_rhs2 ?foo_rhs3

3append k m ?append_rhs2 ?append_rhs3

2append k m ?append_rhs2 ?append_rhs3

test/interactive005/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./interactive005.idr

23 : Nat

13 : Nat

3Hello, World

2Hello, World

4main : IO ()

3main : IO ()

test/interactive006/expected−1

@@ -1,2 +1 @@

1−Type checking ./interactive006.idr

2plus ?foo_rhs2 ?foo_rhs3

1plus ?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!

133

144

15Last line

16+

16---

17---

test/io001/test004.idr+1−1

@@ -13,7 +13,7 @@ dumpFile fn = do { h <- openFile fn Read

13 x <- feof h

14 return (not x) })

15 (do { l <- fread h

16− putStr l })

16+ putStrLn l })

17 closeFile h }

18

19main : 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 @@

1DefaultArgUnknownName.idr:9:6:

2When 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:

4 No such variable sadgjhsag

test/proof007/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --check $@ DefaultArgUnknownName.idr

2+idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

3rm -f *.ibc

test/proof009/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./proof009.idr

2

1

3

2

4---------- Goal: ----------

3---------- 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 @@

1reg003a.idr:4:11:When elaborating type of Main.ECons:

2No 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 @@

1reg023.idr:7:5:When elaborating right hand side of bad:

2Can't unify

3− [94mNat[0m (Type of [91m0[0m)

3+ Nat (Type of 0)

4with

5− [92mf[0m [94mNat[0m (Expected type)

5+ f Nat (Expected type)

test/reg023/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg023.idr --check

2+idris --nocolour --consolewidth 80 $@ reg023.idr --check

3rm -f *.ibc

test/reg029/reg029.idr+1−1

@@ -3,7 +3,7 @@ module Main

3import System

4

5-- necessary to find the getenv symbol

6−%dynamic "libm"

6+%dynamic "libm","msvcrt"

7

8main : IO ()

9main = do

test/reg034/expected+2−2

@@ -1,4 +1,4 @@

1reg034.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

3reg034.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 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg034.idr

2+idris --nocolour --consolewidth 80 --check reg034.idr

3rm -f reg034 *.ibc

test/reg035/expected+1−4

@@ -1,4 +1 @@

1−reg035b.idr:8:6:Can't convert

1+reg035b.idr:8:6:No such variable __pi_arg

2− [94mAdditive[0m -> [94mNat[0m

3−with

4− [94mFin[0m [91m0[0m

test/reg035/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg035.idr

2+idris --nocolour --consolewidth 80 --check reg035.idr

3−idris --consolewidth 80 --check reg035a.lidr

3+idris --nocolour --consolewidth 80 --check reg035a.lidr

4−idris --consolewidth 80 --check reg035b.idr

4+idris --nocolour --consolewidth 80 --check reg035b.idr

5rm -f *.ibc

test/reg039/expected−1

@@ -1,2 +1 @@

1−Type checking ./reg039.idr

2[3, 2, 1]

1[3, 2, 1]

test/reg039/run+27−24

@@ -1,32 +1,35 @@

1#!/usr/bin/env bash

2

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−}

24

3

25declare -a extraargs

4declare -a extraargs

26for arg in "$@"

5for arg in "$@"

27do

6do

28 extraargs=("${extraargs[@]}" "'$arg'")

7 extraargs=("${extraargs[@]}" "'$arg'")

29done

8done

30−

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+ }

31−timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"

33+ timeout 60 "idris ${extraargs[*]} --nocolour reg039.idr --exec go"

34+ fi

32−rm -f reg039 *.ibc

35+ rm -f reg039 *.ibc

test/reg041/expected−1

@@ -1,3 +1,2 @@

1−Type checking ./ott.idr

2?prf : (x : Bool) -> (x1 : Bool) -> El (EQ two x two x1) -> El (EQ two x two x1)

1?prf : (x : Bool) -> (x1 : Bool) -> El (EQ two x two x1) -> El (EQ two x two x1)

3Z

2Z

test/reg044/expected+4−4

@@ -1,11 +1,11 @@

1reg044.idr:4:4:When elaborating right hand side of Main.pf:

2Can't unify

3− [95mb[0m [94m=[0m [95mb[0m (Type of [91mRefl[0m)

3+ b = b (Type of Refl)

4with

5− [95ma[0m [94m=[0m [95mb[0m (Expected type)

5+ a = b (Expected type)

6

7Specifically:

8 Can't unify

9− [95mb[0m

9+ b

10 with

11− [95ma[0m

11+ a

test/reg044/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 reg044.idr --check

2+idris --nocolour --consolewidth 80 reg044.idr --check

3rm -f *.ibc

test/reg049/expected+2

@@ -1,2 +1,4 @@

1reg049.idr:2:9:When elaborating constructor Main.Bogus:

2Void 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 @@

1reg054.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:

3 Attempting concrete match on polymorphic argument: 0

4reg054.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:

6 No explicit types on left hand side: Char

7reg054.idr:37:9:Can't convert

8− [94mMaybe[0m a1

8+ Maybe a1

9with

10− [95ma[0m

10+ a

test/reg054/run+1−1

@@ -1,2 +1,2 @@

1#!/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 @@

1reg055.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)

3reg055.idr:8:3:When elaborating left hand side of h:

4Can't match on h x x

5reg055a.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:

7 Attempting concrete match on polymorphic argument: Nothing

8reg055a.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 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg055.idr --check

2+idris --nocolour --consolewidth 80 $@ reg055.idr --check

3−idris --consolewidth 80 $@ reg055a.idr --check

3+idris --nocolour --consolewidth 80 $@ reg055a.idr --check

4rm -f *.ibc

5

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 = ();

10

11sub sandbox_path {

12 my ($test_dir,) = @_;

13− my $sandbox = abs_path("$test_dir/../../.cabal-sandbox/bin");

13+ my $sandbox = "$test_dir/../../.cabal-sandbox/bin";

14

15 if ( -d $sandbox ) {

16− return "PATH=$sandbox:$PATH";

16+ my $sandbox_abs = abs_path($sandbox);

17+ return "PATH=\"$sandbox_abs:$PATH\"";

17 } else {

18 } else {

18 return "";

19 return "";

19 }

20 }

@@ -30,6 +31,14 @@ sub runtest {

30 my $got = `$sandbox ./run @idrOpts`;

31 my $got = `$sandbox ./run @idrOpts`;

31 my $exp = `cat expected`;

32 my $exp = `cat expected`;

32

33

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+ }

33 open my $out, '>', 'output';

42 open my $out, '>', 'output';

34 print $out $got;

43 print $out $got;

35 close $out;

44 close $out;

test/tactics001/Tactics.idr+10−10

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

1module Tactics

2

3−import Language.Reflection.Tactical

3+import Language.Reflection.Elab

4

5import Data.Vect

6

@@ -18,24 +18,24 @@ refl t x = RApp (RApp (Var (UN "Refl")) t) x

18plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n

19plusZeroRightNeutralNew Z = Refl

20plusZeroRightNeutralNew (S k) =

21− %runTactics (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))

21+ %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var "k"))

22− fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))

22+ fill $ refl `(Nat : Type) `(S ~(Var (UN "k")))

23− solve)

23+ solve)

24

25plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k)

26plusSuccRightSuccNew Z k = Refl

27plusSuccRightSuccNew (S j) k =

28− %runTactics (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var "j") ~(Var (UN "k")))

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")))))

29+ fill $ refl `(Nat : Type) `(S (S (plus ~(Var (UN "j")) ~(Var (UN "k")))))

30− solve)

30+ solve)

31

32-- Test that side effects in new tactics work

33

34mkDecl : ()

35−mkDecl = %runTactics (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])

35+mkDecl = %runElab (do declareType $ Declare (NS (UN "repUnit") ["Tactics"])

36 [Implicit (UN "z") `(Nat)]

37 `(Vect ~(Var (UN "z")) ())

38− fill `(() : ())

38+ fill `(() : ())

39− solve)

39+ solve)

40

41repUnit = pure ()

test/totality007/expected−1

@@ -1,4 +1,3 @@

1−Type checking ./Totality.idr

2Totality.idr:4:1:

1Totality.idr:4:1:

3Totality.foo is not total as there are missing cases

2Totality.foo is not total as there are missing cases

4Totality.idr:4:1:Could not build: Totality.foo is not total as there are missing cases

3Totality.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

2

3-- totality007

4-- Test that the package builder doesn't allow totality errors in a build

5−opts = "--consolewidth 80"

5+opts = "--quiet --consolewidth 80"

6sourcedir = src

7modules = Totality

test/tutorial006/expected+9−9

@@ -1,24 +1,24 @@

1tutorial006a.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.:::

3 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)

5 with

6− [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m (Expected type)

6+ Vect (plus n m) a (Expected type)

7

8 Specifically:

9 Can't unify

10− [92mplus[0m [95mn[0m [95mn[0m

10+ plus n n

11 with

12− [92mplus[0m [95mn[0m [95mm[0m

12+ plus n m

13tutorial006b.idr:10:10:

14When elaborating right hand side of with block in Main.parity:

15Can'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)

17with

18− [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))) (Expected type)

18+ Parity (S (S (plus j j))) (Expected type)

19

20Specifically:

21 Can't unify

22− [92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)

22+ plus (S j) (S j)

23 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 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ tutorial006a.idr --check

2+idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check

3−idris --consolewidth 80 $@ tutorial006b.idr --check

3+idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check

4rm -f *.ibc

test/unique001/expected+6−6

@@ -3,17 +3,17 @@

338,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END

438,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END

5unique001a.idr:33:11:Can't convert

6− [94mInt[0m -> [94mString[0m

6+ Int -> String

7with

8− UniqueType ([94mInt[0m -> [94mString[0m)

8+ UniqueType (Int -> String)

9unique001a.idr:44:12:Can't convert

10− [94mInt[0m -> [94mString[0m

10+ Int -> String

11with

12− UniqueType ([94mInt[0m -> [94mString[0m)

12+ UniqueType (Int -> String)

13unique001a.idr:55:12:Can't convert

14− UniqueType ([94mInt[0m -> [94mString[0m)

14+ UniqueType (Int -> String)

15with

16− [94mInt[0m -> [94mString[0m

16+ Int -> String

17unique001b.idr:16:7:Borrowed name xs must not be used on RHS

18unique001c.idr:46:6:Unique name f is used more than once

19unique001d.idr:3:7:Borrowed name x must not be used on RHS

test/unique001/run+6−6

@@ -1,9 +1,9 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique001.idr -o unique001

2+idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001

3./unique001

4−idris --consolewidth 80 $@ unique001a.idr --check

4+idris --nocolour --consolewidth 80 $@ unique001a.idr --check

5−idris --consolewidth 80 $@ unique001b.idr --check

5+idris --nocolour --consolewidth 80 $@ unique001b.idr --check

6−idris --consolewidth 80 $@ unique001c.idr --check

6+idris --nocolour --consolewidth 80 $@ unique001c.idr --check

7−idris --consolewidth 80 $@ unique001d.idr --check

7+idris --nocolour --consolewidth 80 $@ unique001d.idr --check

8−idris --consolewidth 80 $@ unique001e.idr --check

8+idris --nocolour --consolewidth 80 $@ unique001e.idr --check

9rm -f unique001 *.ibc

test/unique001/unique001c.idr+3−3

@@ -25,7 +25,7 @@ share : UTree -> Tree

25share ULeaf = Leaf

26share (UNode x y z) = Node (share x) y (share z)

27

28−class UFunctor (f : Type -> Type*) where

28+class UFunctor (f : Type -> AnyType) where

29 fmap : (a -> b) -> f a -> f b

30

31instance UFunctor List where

@@ -36,10 +36,10 @@ instance UFunctor UList where

36 fmap f UNil = UNil

37 fmap f (UCons x xs) = UCons (f x) (fmap f xs)

38

39−uconst : {a : Type*} -> a -> b -> a

39+uconst : {a : AnyType} -> a -> b -> a

40uconst x y = x

41

42−data MPair : Type* -> Type* -> Type* where

42+data MPair : AnyType -> AnyType -> AnyType where

43 MkMPair : {a, b : Type*} -> a -> b -> MPair a b

44

45ndup : {a : UniqueType} -> a -> UPair a a

test/unique002/expected+2−2

@@ -1,5 +1,5 @@

1unique002.idr:15:5:Unique name xs is used more than once

2unique002a.idr:15:5:Can't convert

3− [94mInt[0m -> [94mString[0m

3+ Int -> String

4with

5− UniqueType ([94mInt[0m -> [94mString[0m)

5+ UniqueType (Int -> String)

test/unique002/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique002.idr --check

2+idris --nocolour --consolewidth 80 $@ unique002.idr --check

3−idris --consolewidth 80 $@ unique002a.idr --check

3+idris --nocolour --consolewidth 80 $@ unique002a.idr --check

4rm -f *.ibc

test/unique003/expected+2−2

@@ -1,4 +1,4 @@

1unique003.idr:18:5:Can't convert

2− [94mInt[0m -> [94mString[0m

2+ Int -> String

3with

4− UniqueType ([94mInt[0m -> [94mString[0m)

4+ UniqueType (Int -> String)

test/unique003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ unique003.idr --check

2+idris --nocolour --consolewidth 80 $@ unique003.idr --check

3rm -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