2c80895 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Bring my changes in line with the latest upstream

2c80895Alyssa Carter13 years ago

CHANGELOG+6−1

compare with master

unifiedsplit

@@ -1,5 +1,5 @@

1New in 0.9.11:

2−-------------

2+--------------

4* Agda-style equational reasoning (in Syntax.PreorderReasoning)

5* 'case' construct now abstracts over the scrutinee in its type

@@ -8,6 +8,11 @@ New in 0.9.11:

8 valid identifier. Two labels are definitionally equal if they have the

9 same name.

11+Internal changes

12+

13+* Faster elaboration

14+* Smaller .ibc files

15+

11New in 0.9.10:

16New in 0.9.10:

12--------------

17--------------

examples/Makefile+2−2

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

1−check: .PHONY

1+check:

2 rm -f *.ibc

3 for x in *.idr ; do \

4 echo "Checking $$x"; \

5 idris --check $$x; \

6 done

8−.PHONY:

8+.PHONY: check

idris.cabal+24−3

@@ -14,7 +14,7 @@ Description: Idris is a general purpose language with full dependent types.

14 Dependent types allow types to be predicated on values,

15 meaning that some aspects of a program's behaviour can be

16 specified precisely in the type. The language is closely

17− related to Epigram and Agda. There is a tutorial at

17+ related to Epigram and Agda. There is a tutorial at

18 <http://www.idris-lang.org/documentation>.

19 Features include:

20 .

@@ -95,6 +95,11 @@ Extra-source-files:

95 libs/effects/Effect/*.idr

96 libs/effects/*.idr

98+ libs/neweffects/Makefile

99+ libs/neweffects/neweffects.ipkg

100+ libs/neweffects/Effect/*.idr

101+ libs/neweffects/*.idr

102+

98 libs/javascript/*.idr

103 libs/javascript/*.idr

99 libs/javascript/JavaScript/*.idr

104 libs/javascript/JavaScript/*.idr

100 libs/javascript/Makefile

105 libs/javascript/Makefile

@@ -192,6 +197,12 @@ Extra-source-files:

192 test/reg029/run

197 test/reg029/run

193 test/reg029/*.idr

198 test/reg029/*.idr

194 test/reg029/expected

199 test/reg029/expected

200+ test/reg030/run

201+ test/reg030/*.idr

202+ test/reg030/expected

203+ test/reg031/run

204+ test/reg031/*.idr

205+ test/reg031/expected

195 test/test001/run

206 test/test001/run

196 test/test001/*.idr

207 test/test001/*.idr

197 test/test001/expected

208 test/test001/expected

@@ -303,6 +314,12 @@ Extra-source-files:

303 test/test035/run

314 test/test035/run

304 test/test035/expected

315 test/test035/expected

305 test/test035/*.idr

316 test/test035/*.idr

317+ test/test036/run

318+ test/test036/expected

319+ test/test036/*.idr

320+ test/test037/run

321+ test/test037/expected

322+ test/test037/*.idr

306

323

307source-repository head

324source-repository head

308 type: git

325 type: git

@@ -335,10 +352,12 @@ Library

335 Exposed-modules:

352 Exposed-modules:

336 Idris.Core.CaseTree

353 Idris.Core.CaseTree

337 , Idris.Core.Constraints

354 , Idris.Core.Constraints

355+ , Idris.Core.DeepSeq

338 , Idris.Core.Elaborate

356 , Idris.Core.Elaborate

339 , Idris.Core.Evaluate

357 , Idris.Core.Evaluate

340 , Idris.Core.Execute

358 , Idris.Core.Execute

341 , Idris.Core.ProofState

359 , Idris.Core.ProofState

360+ , Idris.Core.TC

342 , Idris.Core.TT

361 , Idris.Core.TT

343 , Idris.Core.Typecheck

362 , Idris.Core.Typecheck

344 , Idris.Core.Unify

363 , Idris.Core.Unify

@@ -404,6 +423,7 @@ Library

404 Util.Pretty

423 Util.Pretty

405 , Util.System

424 , Util.System

406 , Util.Net

425 , Util.Net

426+ , Util.Zlib

407

427

408 , Pkg.PParser

428 , Pkg.PParser

409

429

@@ -439,6 +459,7 @@ Library

439 , network

459 , network

440 , xml

460 , xml

441 , deepseq

461 , deepseq

462+ , zlib

442 Extensions: MultiParamTypeClasses

463 Extensions: MultiParamTypeClasses

443 , FunctionalDependencies

464 , FunctionalDependencies

444 , FlexibleInstances

465 , FlexibleInstances

@@ -453,7 +474,7 @@ Library

453 if os(freebsd)

474 if os(freebsd)

454 cpp-options: -DFREEBSD

475 cpp-options: -DFREEBSD

455 build-depends: unix

476 build-depends: unix

456− if os(dragonfly)

477+ if os(dragonfly)

457 cpp-options: -DDRAGONFLY

478 cpp-options: -DDRAGONFLY

458 build-depends: unix

479 build-depends: unix

459 if os(darwin)

480 if os(darwin)

@@ -487,6 +508,6 @@ Executable idris

487 , transformers

508 , transformers

488

509

489 ghc-prof-options: -auto-all -caf-all

510 ghc-prof-options: -auto-all -caf-all

490− ghc-options: -threaded -rtsopts

511+ ghc-options: -threaded -rtsopts -funbox-strict-fields

491

512

492

513

libs/Makefile+7−4

@@ -1,20 +1,23 @@

1−build: .PHONY

1+build:

2 $(MAKE) -C prelude build

3 $(MAKE) -C base build

4 $(MAKE) -C effects build

5+ $(MAKE) -C neweffects build

5 $(MAKE) -C javascript build

6 $(MAKE) -C javascript build

8−install: .PHONY

9+install:

9 $(MAKE) -C prelude install

10 $(MAKE) -C prelude install

10 $(MAKE) -C base install

11 $(MAKE) -C base install

11 $(MAKE) -C effects install

12 $(MAKE) -C effects install

13+ $(MAKE) -C neweffects install

12 $(MAKE) -C javascript install

14 $(MAKE) -C javascript install

14−clean: .PHONY

16+clean:

15 $(MAKE) -C prelude clean

17 $(MAKE) -C prelude clean

16 $(MAKE) -C base clean

18 $(MAKE) -C base clean

17 $(MAKE) -C effects clean

19 $(MAKE) -C effects clean

20+ $(MAKE) -C neweffects clean

18 $(MAKE) -C javascript clean

21 $(MAKE) -C javascript clean

20−.PHONY:

23+.PHONY: build install clean

libs/base/Data/Fun.idrnew file+8

@@ -0,0 +1,8 @@

1+module Data.Fun

3+--------------------------------------------------------------------------------

4+-- Build an n-ary function type from a Vect of Types and a result type

5+--------------------------------------------------------------------------------

6+Fun : Vect n Type -> Type -> Type

7+Fun [] r = r

8+Fun (t::ts) r = t -> Fun ts r

libs/base/Data/Rel.idrnew file+13

@@ -0,0 +1,13 @@

1+module Data.Rel

3+import Data.Fun

5+--------------------------------------------------------------------------------

6+-- Build an n-ary relation type from a Vect of Types

7+--------------------------------------------------------------------------------

8+Rel : Vect n Type -> Type

9+Rel ts = Fun ts Type

10+

11+liftRel : (ts : Vect n Type) -> (p : Rel ts) -> (Type -> Type) -> Type

12+liftRel [] p f = f p

13+liftRel (t :: ts) p f = (x : t) -> liftRel ts (p x) f

libs/base/Decidable/Decidable.idr+9−11

@@ -1,24 +1,22 @@

1module Decidable.Decidable

3+import Data.Rel

3%access public

5%access public

5--------------------------------------------------------------------------------

7--------------------------------------------------------------------------------

6-- Typeclass for decidable n-ary Relations

8-- Typeclass for decidable n-ary Relations

7--------------------------------------------------------------------------------

9--------------------------------------------------------------------------------

9−{-

11+-- Note: Instance resolution for Decidable is likely to not work in the REPL

10−This can't work yet! The class parameters must appear in the method type

12+-- at the moment.

11−signatures otherwise when defining the instances class resolution doesn't

13+class Decidable (ts : Vect k Type) (p : Rel ts) where

12−have any clues...

13−

14−using (t : Type)

15− class Rel (p : t) where

16− total liftRel : (Type -> Type) -> Type

14+ total decide : liftRel ts p Dec

18− class (Rel p) => Decidable (p : t) where

16+-- 'No such variable {k506}'

19− total decide : liftRel Dec

17+--decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec

18+--decision ts p = decide {ts} {p}

21using (P : Type, p : P)

20using (P : Type, p : P)

22 data Given : Dec P -> Type where

21 data Given : Dec P -> Type where

23 always : Given (Yes p)

22 always : Given (Yes p)

24−-}

libs/base/Decidable/Order.idr+4−13

@@ -1,13 +1,10 @@

1module Decidable.Order

3−%access public

4−

5−{-

6−Doesn't work yet, see note in Decidable.idr

7−

8import Decidable.Decidable

3import Decidable.Decidable

9import Decidable.Equality

4import Decidable.Equality

6+%access public

11--------------------------------------------------------------------------------

8--------------------------------------------------------------------------------

12-- Utility Lemmas

9-- Utility Lemmas

13--------------------------------------------------------------------------------

10--------------------------------------------------------------------------------

@@ -74,14 +71,8 @@ decideNatLTE x (S y) with (decEq x (S y))

74 | Yes nLTEm = Yes (nLTESm nLTEm)

71 | Yes nLTEm = Yes (nLTESm nLTEm)

75 | No nGTm = No (nGTSm nGTm)

72 | No nGTm = No (nGTSm nGTm)

77−instance Rel NatLTE where

78− liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m)

79−

80−instance Decidable NatLTE where

74+instance Decidable [Nat,Nat] NatLTE where

81 decide = decideNatLTE

75 decide = decideNatLTE

83lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n)

77lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n)

84−lte m n = decide {p = NatLTE} m n

78+lte m n = decide {ts = [Nat,Nat]} {p = NatLTE} m n

85−

86−-}

87−

libs/base/Language/Reflection.idr+11−2

@@ -10,6 +10,7 @@ data TTName = UN String

10 -- ^ Machine chosen names

11 | NErased

12 -- ^ Name of somethng which is never used in scope

13+%name TTName n, n'

14implicit

15implicit

15userSuppliedName : String -> TTName

16userSuppliedName : String -> TTName

@@ -19,6 +20,7 @@ data TTUExp = UVar Int

19 -- ^ universe variable

20 -- ^ universe variable

20 | UVal Int

21 | UVal Int

21 -- ^ explicit universe variable

22 -- ^ explicit universe variable

23+%name TTUExp uexp

23-- | Primitive constants

25-- | Primitive constants

24data Const = I Int | BI Nat | Fl Float | Ch Char | Str String

26data Const = I Int | BI Nat | Fl Float | Ch Char | Str String

@@ -27,6 +29,8 @@ data Const = I Int | BI Nat | Fl Float | Ch Char | Str String

27 | B8Type | B16Type | B32Type | B64Type

29 | B8Type | B16Type | B32Type | B64Type

28 | PtrType | VoidType | Forgot

30 | PtrType | VoidType | Forgot

32+%name Const c, c'

33+

30abstract class ReflConst (a : Type) where

34abstract class ReflConst (a : Type) where

31 toConst : a -> Const

35 toConst : a -> Const

@@ -71,6 +75,7 @@ data NameType = Bound

71 -- ^ constructor with tag and number

75 -- ^ constructor with tag and number

72 | TCon Int Int

76 | TCon Int Int

73 -- ^ type constructor with tag and number

77 -- ^ type constructor with tag and number

78+%name NameType nt, nt'

75-- | Types annotations for bound variables in different

80-- | Types annotations for bound variables in different

76-- binding contexts

81-- binding contexts

@@ -83,7 +88,7 @@ data Binder a = Lam a

83 | Guess a a

88 | Guess a a

84 | PVar a

89 | PVar a

85 | PVTy a

90 | PVTy a

86−

91+%name Binder b, b'

88instance Functor Binder where

93instance Functor Binder where

89 map f (Lam x) = Lam (f x)

94 map f (Lam x) = Lam (f x)

@@ -139,6 +144,8 @@ data TT = P NameType TTName TT

139 | TType TTUExp

144 | TType TTUExp

140 -- ^ types

145 -- ^ types

141

146

147+%name TT tm, tm'

148+

142-- | Raw terms without types

149-- | Raw terms without types

143data Raw = Var TTName

150data Raw = Var TTName

144 | RBind TTName (Binder Raw) Raw

151 | RBind TTName (Binder Raw) Raw

@@ -147,6 +154,8 @@ data Raw = Var TTName

147 | RForce Raw

154 | RForce Raw

148 | RConstant Const

155 | RConstant Const

149

156

157+%name Raw tm, tm'

158+

150data Tactic = Try Tactic Tactic

159data Tactic = Try Tactic Tactic

151 -- ^ try the first tactic and resort to the second one on failure

160 -- ^ try the first tactic and resort to the second one on failure

152 | GoalType String Tactic

161 | GoalType String Tactic

@@ -185,4 +194,4 @@ data Tactic = Try Tactic Tactic

185 -- ^ name a reflected term and type it

194 -- ^ name a reflected term and type it

186 | Compute

195 | Compute

187 -- ^ normalise the context

196 -- ^ normalise the context

188−

197+%name Tactic tac, tac'

libs/base/Language/Reflection/Errors.idr+18−6

@@ -2,7 +2,10 @@ module Language.Reflection.Errors

3import Language.Reflection

5−data SourceLocation = FileLoc String Int

5+record SourceLocation : Type where

6+ FileLoc : (filename : String) -> (line : Int) -> (col : Int) -> SourceLocation

8+%name SourceLocation loc

7data Err = Msg String

10data Err = Msg String

8 | InternalMsg String

11 | InternalMsg String

@@ -12,16 +15,19 @@ data Err = Msg String

12 -- unification succeed

15 -- unification succeed

13 | InfiniteUnify TTName TT (List (TTName, TT))

16 | InfiniteUnify TTName TT (List (TTName, TT))

14 | CantConvert TT TT (List (TTName, TT))

17 | CantConvert TT TT (List (TTName, TT))

18+ | CantSolveGoal TT (List (TTName, TT))

15 | UnifyScope TTName TTName TT (List (TTName, TT))

19 | UnifyScope TTName TTName TT (List (TTName, TT))

16 | CantInferType String

20 | CantInferType String

17 | NonFunctionType TT TT

21 | NonFunctionType TT TT

22+ | NotEquality TT TT

23+ | TooManyArguments TTName

18 | CantIntroduce TT

24 | CantIntroduce TT

19 | NoSuchVariable TTName

25 | NoSuchVariable TTName

20 | NoTypeDecl TTName

26 | NoTypeDecl TTName

21 | NotInjective TT TT TT

27 | NotInjective TT TT TT

22 | CantResolve TT

28 | CantResolve TT

23 | CantResolveAlts (List String)

29 | CantResolveAlts (List String)

24− | IncompleteTT TT

30+ | IncompleteTerm TT

25 | UniverseError

31 | UniverseError

26 | ProgramLineComment

32 | ProgramLineComment

27 | Inaccessible TTName

33 | Inaccessible TTName

@@ -32,11 +38,17 @@ data Err = Msg String

32 | At SourceLocation Err

38 | At SourceLocation Err

33 | Elaborating String TTName Err

39 | Elaborating String TTName Err

34 | ProviderError String

40 | ProviderError String

41+ | LoadingFailed String Err

36−-- | Error reports are a list of report parts

43+%name Err err, e

37−data ErrorReport = Message String

38− | Name TTName

39− | Term TT

45+-- | Error reports are a list of report parts

46+data ErrorReportPart = TextPart String

47+ | NamePart TTName

48+ | TermPart TT

49+ | SubReport (List ErrorReportPart)

50+%name ErrorReportPart part, p

42-- Error reports become functions in List (String, TT) -> Err -> ErrorReport

52-- Error reports become functions in List (String, TT) -> Err -> ErrorReport

53+ErrorHandler : Type

54+ErrorHandler = Err -> Maybe (List ErrorReportPart)

libs/base/Language/Reflection/Utils.idr+71

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

1module Language.Reflection.Utils

3import Language.Reflection

4+import Language.Reflection.Errors

5--------------------------------------------------------

6--------------------------------------------------------

6-- Tactic construction conveniences

7-- Tactic construction conveniences

@@ -185,3 +186,73 @@ instance Eq TT where

185 equalp Impossible Impossible = True

186 equalp Impossible Impossible = True

186 equalp (TType u) (TType u') = u == u'

187 equalp (TType u) (TType u') = u == u'

187 equalp x y = False

188 equalp x y = False

189+

190+total

191+forget : TT -> Maybe Raw

192+forget tm = fe [] tm

193+ where

194+ atIndex : List a -> Int -> Maybe a

195+ atIndex [] _ = Nothing

196+ atIndex (x::xs) n =

197+ case compare n 0 of

198+ EQ => Just x

199+ LT => Nothing

200+ GT => atIndex xs (n-1)

201+

202+ %assert_total

203+ fe : List TTName -> TT -> Maybe Raw

204+ fe env (P _ n _) = Just $ Var n

205+ fe env (V i) = map Var (atIndex env i)

206+ fe env (Bind n b sc) = [| RBind (pure n) (traverse (fe env) b) (fe (n::env) sc) |]

207+ fe env (App f a) = [| RApp (fe env f) (fe env a) |]

208+ fe env (TConst c) = Just $ RConstant c

209+ fe env (Proj tm i) = Nothing -- runtime only, not useful for metaprogramming

210+ fe env (TType i) = Just RType

211+ fe env Erased = Just $ RConstant Forgot

212+ fe env Impossible = Nothing

213+

214+instance Show Raw where

215+ show r = my_show r

216+ where %assert_total my_show : Raw -> String

217+ my_show (Var n) = "Var " ++ show n

218+ my_show (RBind n b tm) = "RBind " ++ show n ++ " " ++ show b ++ " (" ++ my_show tm ++ ")"

219+ my_show (RApp tm tm') = "RApp " ++ my_show tm ++ " " ++ my_show tm'

220+ my_show RType = "RType"

221+ my_show (RForce tm) = "RForce " ++ my_show tm

222+ my_show (RConstant c) = "RConstant " ++ show c

223+

224+instance Show SourceLocation where

225+ show (FileLoc filename line col) = "FileLoc \"" ++ filename ++ "\" " ++ show line ++ " " ++ show col

226+

227+instance Show Err where

228+ show (Msg x) = "Msg \"" ++ x ++ "\""

229+ show (InternalMsg x) = "InternalMsg \"" ++ x ++ "\""

230+ show (CantUnify x tm tm' err xs y) = "CantUnify " ++ show x ++

231+ " ( " ++ show tm ++ ") (" ++ show tm' ++ ") (" ++ show err ++ ") " ++

232+ show xs ++ " " ++ show y

233+ show (InfiniteUnify n tm xs) = "InfiniteUnify " ++ show n ++ show tm ++ show xs

234+ show (CantConvert tm tm' xs) = "CantConvert " ++ show tm ++ show tm' ++ show xs

235+ show (UnifyScope n n' tm xs) = "UnifyScope " ++ show n ++ " " ++ show n' ++ " " ++ show tm ++ " " ++ show xs

236+ show (CantInferType x) = "CantInferType " ++ show x

237+ show (NonFunctionType tm tm') = "NonFunctionType " ++ show tm ++ show tm'

238+ show (NotEquality tm tm') = "NotEquality " ++ show tm ++ " " ++ show tm'

239+ show (TooManyArguments n) = "TooManyArguments " ++ show n

240+ show (CantIntroduce tm) = "CantIntroduce " ++ show tm

241+ show (NoSuchVariable n) = "NoSuchVariable " ++ show n

242+ show (NoTypeDecl n) = "NoTypeDecl " ++ show n

243+ show (NotInjective tm tm' x) = "NotInjective " ++ show tm ++ " " ++ show tm'

244+ show (CantResolve tm) = "CantResolve " ++ show tm

245+ show (CantResolveAlts xs) = "CantResolveAlts " ++ show xs

246+ show (IncompleteTerm tm) = "IncompleteTerm " ++ show tm

247+ show UniverseError = "UniverseError"

248+ show ProgramLineComment = "ProgramLineComment"

249+ show (Inaccessible n) = "Inaccessible " ++ show n

250+ show (NonCollapsiblePostulate n) = "NonCollapsiblePostulate " ++ show n

251+ show (AlreadyDefined n) = "AlreadyDefined " ++ show n

252+ show (ProofSearchFail err) = "ProofSearchFail " ++ show err

253+ show (NoRewriting tm) = "NoRewriting " ++ show tm

254+ show (At loc err) = "At " ++ show loc ++ " " ++ show err

255+ show (Elaborating x n err) = "Elaborating " ++ show x ++ " " ++ show x ++ " " ++ show n ++ " (" ++ show err ++ ")"

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

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

258+

libs/base/Makefile+4−4

@@ -1,17 +1,17 @@

1IDRIS := idris

3−build: .PHONY

3+build:

4 $(IDRIS) --build base.ipkg

6install:

7 $(IDRIS) --install base.ipkg

9−clean: .PHONY

9+clean:

10 $(IDRIS) --clean base.ipkg

12rebuild: clean build

14−linecount: .PHONY

14+linecount:

15 find . -name '*.idr' | xargs wc -l

17−.PHONY:

17+.PHONY: build install clean rebuild linecount

libs/base/base.ipkg+2−1

@@ -23,7 +23,8 @@ modules = System,

23 Data.ZZ, Data.Sign,

24 Data.SortedMap, Data.SortedSet, Data.BoundedList,

25 Data.Vect, Data.HVect, Data.Vect.Quantifiers,

26− Data.Floats, Data.Complex, Data.Heap,

26+ Data.Floats, Data.Complex, Data.Heap, Data.Fun,

27+ Data.Rel,

28 Control.Isomorphism,

29 Control.Isomorphism,

29 Control.Monad.Identity,

30 Control.Monad.Identity,

libs/effects/Makefile+3−3

@@ -1,9 +1,9 @@

1IDRIS := idris

3−build: .PHONY

3+build:

4 $(IDRIS) --build effects.ipkg

6−clean: .PHONY

6+clean:

7 $(IDRIS) --clean effects.ipkg

9install:

@@ -11,4 +11,4 @@ install:

12rebuild: clean build

14−.PHONY:

14+.PHONY: build clean install rebuild

libs/javascript/Makefile+3−3

@@ -1,14 +1,14 @@

1IDRIS := idris

3−build: .PHONY

3+build:

4 $(IDRIS) --build javascript.ipkg

6install:

7 $(IDRIS) --install javascript.ipkg

9−clean: .PHONY

9+clean:

10 $(IDRIS) --clean javascript.ipkg

12rebuild: clean build

14−.PHONY:

14+.PHONY: build install clean rebuild

libs/neweffects/Effect/Default.idrnew file+44

@@ -0,0 +1,44 @@

1+module Default

3+class Default a where

4+ default : a

6+instance Default Int where

7+ default = 0

9+instance Default Integer where

10+ default = 0

11+

12+instance Default Float where

13+ default = 0

14+

15+instance Default Nat where

16+ default = 0

17+

18+instance Default Char where

19+ default = '\0'

20+

21+instance Default String where

22+ default = ""

23+

24+instance Default Bool where

25+ default = False

26+

27+instance Default () where

28+ default = ()

29+

30+instance (Default a, Default b) => Default (a, b) where

31+ default = (default, default)

32+

33+instance Default (Maybe a) where

34+ default = Nothing

35+

36+instance Default (List a) where

37+ default = []

38+

39+instance Default a => Default (Vect n a) where

40+ default = mkDef _ where

41+ mkDef : (n : Nat) -> Vect n a

42+ mkDef Z = []

43+ mkDef (S k) = default :: mkDef k

44+

libs/neweffects/Effect/Exception.idrnew file+39

@@ -0,0 +1,39 @@

1+module Effect.Exception

3+import Effects

4+import System

5+import Control.IOExcept

7+data Exception : Type -> Effect where

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

10+instance Handler (Exception a) Maybe where

11+ handle _ (Raise e) k = Nothing

12+

13+instance Show a => Handler (Exception a) IO where

14+ handle _ (Raise e) k = do print e

15+ believe_me (exit 1)

16+

17+instance Handler (Exception a) (IOExcept a) where

18+ handle _ (Raise e) k = ioM (return (Left e))

19+

20+instance Handler (Exception a) (Either a) where

21+ handle _ (Raise e) k = Left e

22+

23+EXCEPTION : Type -> EFFECT

24+EXCEPTION t = MkEff () (Exception t)

25+

26+raise : a -> { [EXCEPTION a ] } Eff m b

27+raise err = Raise err

28+

29+

30+

31+

32+

33+

34+-- TODO: Catching exceptions mid program?

35+-- probably need to invoke a new interpreter

36+

37+-- possibly add a 'handle' to the Eff language so that an alternative

38+-- handler can be introduced mid interpretation?

39+

libs/neweffects/Effect/File.idrnew file+62

@@ -0,0 +1,62 @@

1+module Effect.File

3+import Effects

4+import Control.IOExcept

6+data OpenFile : Mode -> Type where

7+ FH : File -> OpenFile m

9+openOK : Mode -> Bool -> Type

10+openOK m True = OpenFile m

11+openOK m False = ()

12+

13+data FileIO : Effect where

14+ Open : String -> (m : Mode) ->

15+ {() ==> if result then OpenFile m else ()} FileIO Bool

16+ Close : {OpenFile m ==> ()} FileIO ()

17+

18+ ReadLine : {OpenFile Read} FileIO String

19+ WriteLine : String -> {OpenFile Write} FileIO ()

20+ EOF : {OpenFile Read} FileIO Bool

21+

22+instance Handler FileIO IO where

23+ handle () (Open fname m) k = do h <- openFile fname m

24+ valid <- validFile h

25+ if valid then k True (FH h)

26+ else k False ()

27+ handle (FH h) Close k = do closeFile h

28+ k () ()

29+ handle (FH h) ReadLine k = do str <- fread h

30+ k str (FH h)

31+ handle (FH h) (WriteLine str) k = do fwrite h str

32+ k () (FH h)

33+ handle (FH h) EOF k = do e <- feof h

34+ k e (FH h)

35+

36+FILE_IO : Type -> EFFECT

37+FILE_IO t = MkEff t FileIO

38+

39+open : Handler FileIO e =>

40+ String -> (m : Mode) ->

41+ { [FILE_IO ()] ==> [FILE_IO (if result then OpenFile m else ())] } Eff e Bool

42+open f m = Open f m

43+

44+close : Handler FileIO e =>

45+ { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()

46+close = Close

47+

48+readLine : Handler FileIO e =>

49+ { [FILE_IO (OpenFile Read)] } Eff e String

50+readLine = ReadLine

51+

52+writeLine : Handler FileIO e =>

53+ String -> { [FILE_IO (OpenFile Write)] } Eff e ()

54+writeLine str = WriteLine str

55+

56+eof : Handler FileIO e =>

57+ { [FILE_IO (OpenFile Read)] } Eff e Bool

58+eof = EOF

59+

60+

61+

62+

libs/neweffects/Effect/Memory.idrnew file+175

@@ -0,0 +1,175 @@

1+module Effect.Memory

3+import Effects

4+import Control.IOExcept

6+%access public

8+abstract

9+data MemoryChunk : Nat -> Nat -> Type where

10+ CH : Ptr -> MemoryChunk size initialized

11+

12+abstract

13+data RawMemory : Effect where

14+ Allocate : (n : Nat) ->

15+ RawMemory () () (\v => MemoryChunk n 0)

16+ Free : RawMemory () (MemoryChunk n i) (\v => ())

17+ Initialize : Bits8 ->

18+ (size : Nat) ->

19+ so (i + size <= n) ->

20+ RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))

21+ Peek : (offset : Nat) ->

22+ (size : Nat) ->

23+ so (offset + size <= i) ->

24+ RawMemory (Vect size Bits8)

25+ (MemoryChunk n i) (\v => MemoryChunk n i)

26+ Poke : (offset : Nat) ->

27+ (Vect size Bits8) ->

28+ so (offset <= i && offset + size <= n) ->

29+ RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))

30+ Move : (src : MemoryChunk src_size src_init) ->

31+ (dst_offset : Nat) ->

32+ (src_offset : Nat) ->

33+ (size : Nat) ->

34+ so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

35+ so (src_offset + size <= src_init) ->

36+ RawMemory () (MemoryChunk dst_size dst_init)

37+ (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))

38+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

39+

40+private

41+do_malloc : Nat -> IOExcept String Ptr

42+do_malloc size with (fromInteger (cast size) == size)

43+ | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)

44+ fail <- ioe_lift $ nullPtr ptr

45+ if fail then ioe_fail "Cannot allocate memory"

46+ else return ptr

47+ | False = ioe_fail "The target architecture does not support adressing enough memory"

48+

49+private

50+do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()

51+do_memset ptr offset c size

52+ = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)

53+ ptr (fromInteger $ cast offset) c (fromInteger $ cast size)

54+

55+private

56+do_free : Ptr -> IO ()

57+do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr

58+

59+private

60+do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()

61+do_memmove dest src dest_offset src_offset size

62+ = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)

63+ dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)

64+

65+private

66+do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)

67+do_peek _ _ Z = return (Prelude.Vect.Nil)

68+do_peek ptr offset (S n)

69+ = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)

70+ bs <- do_peek ptr (S offset) n

71+ Prelude.Monad.return (Prelude.Vect.(::) b bs)

72+

73+private

74+do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()

75+do_poke _ _ [] = return ()

76+do_poke ptr offset (b::bs)

77+ = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b

78+ do_poke ptr (S offset) bs

79+

80+instance Handler RawMemory (IOExcept String) where

81+ handle () (Allocate n) k

82+ = do ptr <- do_malloc n

83+ k () (CH ptr)

84+ handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k

85+ = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)

86+ handle (CH ptr) (Free) k

87+ = ioe_lift (do_free ptr) $> k () ()

88+ handle (CH ptr) (Peek offset size _) k

89+ = do res <- ioe_lift (do_peek ptr offset size)

90+ k res (CH ptr)

91+ handle (CH ptr) (Poke offset content _) k

92+ = do ioe_lift (do_poke ptr offset content)

93+ k () (CH ptr)

94+ handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

95+ = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

96+ k () (CH dest_ptr)

97+ handle chunk (GetRawPtr) k

98+ = k chunk chunk

99+

100+RAW_MEMORY : Type -> EFFECT

101+RAW_MEMORY t = MkEff t RawMemory

102+

103+allocate : (n : Nat) ->

104+ Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

105+allocate size = Allocate size

106+

107+initialize : {i : Nat} ->

108+ {n : Nat} ->

109+ Bits8 ->

110+ (size : Nat) ->

111+ so (i + size <= n) ->

112+ Eff m () [RAW_MEMORY (MemoryChunk n i)]

113+ (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

114+initialize c size prf = Initialize c size prf

115+

116+free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

117+free = Free

118+

119+peek : {i : Nat} ->

120+ (offset : Nat) ->

121+ (size : Nat) ->

122+ so (offset + size <= i) ->

123+ { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)

124+peek offset size prf = Peek offset size prf

125+

126+poke : {n : Nat} ->

127+ {i : Nat} ->

128+ (offset : Nat) ->

129+ Vect size Bits8 ->

130+ so (offset <= i && offset + size <= n) ->

131+ Eff m () [RAW_MEMORY (MemoryChunk n i)]

132+ (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])

133+poke offset content prf = Poke offset content prf

134+

135+private

136+getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)

137+getRawPtr = GetRawPtr

138+

139+private

140+move' : {dst_size : Nat} ->

141+ {dst_init : Nat} ->

142+ {src_init : Nat} ->

143+ (src_ptr : MemoryChunk src_size src_init) ->

144+ (dst_offset : Nat) ->

145+ (src_offset : Nat) ->

146+ (size : Nat) ->

147+ so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

148+ so (src_offset + size <= src_init) ->

149+ Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]

150+ (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])

151+move' src_ptr dst_offset src_offset size dst_bounds src_bounds

152+ = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

153+

154+data MoveDescriptor = Dst | Src

155+

156+move : {dst_size : Nat} ->

157+ {dst_init : Nat} ->

158+ {src_size : Nat} ->

159+ {src_init : Nat} ->

160+ (dst_offset : Nat) ->

161+ (src_offset : Nat) ->

162+ (size : Nat) ->

163+ so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

164+ so (src_offset + size <= src_init) ->

165+ Eff m ()

166+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

167+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

168+ (\v =>

169+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

170+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])

171+move dst_offset src_offset size dst_bounds src_bounds

172+ = do src_ptr <- Src :- getRawPtr

173+ Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

174+ return ()

175+

libs/neweffects/Effect/Monad.idrnew file+21

@@ -0,0 +1,21 @@

1+module Effect.Monad

3+import Effects

5+-- Eff is a monad too, so we can happily use it in a monad transformer.

7+using (xs : List EFFECT, m : Type -> Type)

8+ instance Functor (\a => EffM m a xs (\v => xs)) where

9+ map f prog = do t <- prog

10+ value (f t)

11+

12+ instance Applicative (\a => EffM m a xs (\v => xs)) where

13+ pure = value

14+ (<$>) f a = do f' <- f

15+ a' <- a

16+ value (f' a')

17+

18+ instance Monad (\a => Eff m a xs (\v => xs)) where

19+ (>>=) = Effects.(>>=)

20+

21+

libs/neweffects/Effect/Random.idrnew file+25

@@ -0,0 +1,25 @@

1+module Effect.Random

3+import Effects

5+data Random : Effect where

6+ getRandom : { Integer } Random Integer

7+ setSeed : Integer -> { Integer } Random ()

9+using (m : Type -> Type)

10+ instance Handler Random m where

11+ handle seed getRandom k

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

13+ k seed' seed'

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

15+

16+RND : EFFECT

17+RND = MkEff Integer Random

18+

19+rndInt : Integer -> Integer -> { [RND] } Eff m Integer

20+rndInt lower upper = do v <- getRandom

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

22+

23+srand : Integer -> { [RND] } Eff m ()

24+srand n = setSeed n

25+

libs/neweffects/Effect/Select.idrnew file+23

@@ -0,0 +1,23 @@

1+module Effect.Select

3+import Effects

5+data Selection : Effect where

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

8+instance Handler Selection Maybe where

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

10+ tryAll [] = Nothing

11+ tryAll (x :: xs) = case k x () of

12+ Nothing => tryAll xs

13+ Just v => Just v

14+

15+instance Handler Selection List where

16+ handle r (Select xs) k = concatMap (\x => k x r) xs

17+

18+SELECT : EFFECT

19+SELECT = MkEff () Selection

20+

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

22+select xs = Select xs

23+

libs/neweffects/Effect/State.idrnew file+40

@@ -0,0 +1,40 @@

1+module Effect.State

3+import Effects

5+%access public

7+data State : Effect where

8+ Get : { a } State a

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

10+

11+using (m : Type -> Type)

12+ instance Handler State m where

13+ handle st Get k = k st st

14+ handle st (Put n) k = k () n

15+

16+STATE : Type -> EFFECT

17+STATE t = MkEff t State

18+

19+get : { [STATE x] } Eff m x

20+get = Get

21+

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

23+put val = Put val

24+

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

26+putM val = Put val

27+

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

29+update f = put (f !get)

30+

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

32+updateM f = putM (f !get)

33+

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

35+locally newst prog = do st <- get

36+ putM newst

37+ val <- prog

38+ putM st

39+ return val

40+

libs/neweffects/Effect/StdIO.idrnew file+63

@@ -0,0 +1,63 @@

1+module Effect.StdIO

3+import Effects

4+import Control.IOExcept

6+data StdIO : Effect where

7+ PutStr : String -> { () } StdIO ()

8+ GetStr : { () } StdIO String

10+instance Handler StdIO IO where

11+ handle () (PutStr s) k = do putStr s; k () ()

12+ handle () GetStr k = do x <- getLine; k x ()

13+

14+{-

15+instance Handler StdIO (IOExcept a) where

16+ handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

17+ handle () GetStr k = do x <- ioe_lift getLine; k () x

18+

19+-- Handle effects in a pure way, for simulating IO for unit testing/proof

20+

21+data IOStream a = MkStream (List String -> (a, List String))

22+

23+instance Handler StdIO IOStream where

24+ handle () (PutStr s) k

25+ = MkStream (\x => case k () () of

26+ MkStream f => let (res, str) = f x in

27+ (res, s :: str))

28+ handle {a} () GetStr k

29+ = MkStream (\x => case x of

30+ [] => cont "" []

31+ (t :: ts) => cont t ts)

32+ where

33+ cont : String -> List String -> (a, List String)

34+ cont t ts = case k () t of

35+ MkStream f => f ts

36+

37+-}

38+

39+--- The Effect and associated functions

40+

41+STDIO : EFFECT

42+STDIO = MkEff () StdIO

43+

44+putStr : Handler StdIO e => String -> { [STDIO] } Eff e ()

45+putStr s = PutStr s

46+

47+putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e ()

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

49+

50+getStr : Handler StdIO e => { [STDIO] } Eff e String

51+getStr = GetStr

52+

53+-- mkStrFn : Env IOStream xs ->

54+-- Eff IOStream xs a ->

55+-- List String -> (a, List String)

56+-- mkStrFn {a} env p input = case mkStrFn' of

57+-- MkStream f => f input

58+-- where injStream : a -> IOStream a

59+-- injStream v = MkStream (\x => (v, []))

60+-- mkStrFn' : IOStream a

61+-- mkStrFn' = runWith injStream env p

62+--

63+--

libs/neweffects/Effects.idrnew file+268

@@ -0,0 +1,268 @@

1+module Effects

3+import Language.Reflection

4+import Control.Catchable

5+import Effect.Default

7+%access public

9+---- Effects

10+

11+Effect : Type

12+Effect = (x : Type) -> Type -> (x -> Type) -> Type

13+

14+data EFFECT : Type where

15+ MkEff : Type -> Effect -> EFFECT

16+

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

18+ handle : res -> (eff : e t res resk) ->

19+ ((x : t) -> resk x -> m a) -> m a

20+

21+-- A bit of syntactic sugar ('syntax' is not very flexible so we only go

22+-- up to a small number of parameters...)

23+

24+syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

25+syntax "{" [inst] "}" [eff] = eff inst (\result => inst)

26+

27+---- Properties and proof construction

28+

29+using (xs : List a, ys : List a)

30+ data SubList : List a -> List a -> Type where

31+ SubNil : SubList {a} [] []

32+ Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

33+ Drop : SubList xs ys -> SubList xs (x :: ys)

34+

35+ subListId : SubList xs xs

36+ subListId {xs = Nil} = SubNil

37+ subListId {xs = x :: xs} = Keep subListId

38+

39+namespace Env

40+ data Env : (m : Type -> Type) -> List EFFECT -> Type where

41+ Nil : Env m Nil

42+ (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

43+

44+data EffElem : Effect -> Type ->

45+ List EFFECT -> Type where

46+ Here : EffElem x a (MkEff a x :: xs)

47+ There : EffElem x a xs -> EffElem x a (y :: xs)

48+

49+-- make an environment corresponding to a sub-list

50+dropEnv : Env m ys -> SubList xs ys -> Env m xs

51+dropEnv [] SubNil = []

52+dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

53+dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

54+

55+updateWith : (ys' : List a) -> (xs : List a) ->

56+ SubList ys xs -> List a

57+updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

58+updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

59+updateWith [] [] SubNil = []

60+updateWith (y :: ys) [] SubNil = y :: ys

61+updateWith [] (x :: xs) (Keep rest) = []

62+

63+-- put things back, replacing old with new in the sub-environment

64+rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

65+ Env m xs -> Env m (updateWith ys' xs prf)

66+rebuildEnv [] SubNil env = env

67+rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

68+rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

69+rebuildEnv (x :: xs) SubNil [] = x :: xs

70+

71+---- The Effect EDSL itself ----

72+

73+-- some proof automation

74+

75+%reflection

76+reflectListEffElem : List a -> Tactic

77+reflectListEffElem [] = Refine "Here" `Seq` Solve

78+reflectListEffElem (x :: xs)

79+ = Try (Refine "Here" `Seq` Solve)

80+ (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

81+-- TMP HACK! FIXME!

82+-- The evaluator needs a 'function case' to know its a reflection function

83+-- until we propagate that information! Without this, the _ case won't get

84+-- matched.

85+reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

86+reflectListEffElem _ = Refine "Here" `Seq` Solve

87+

88+%reflection

89+reflectSubList : List a -> Tactic

90+reflectSubList [] = Refine "subListId" `Seq` Solve

91+reflectSubList (x :: xs)

92+ = Try (Refine "subListId" `Seq` Solve)

93+ (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

94+ (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

95+reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

96+reflectSubList _ = Refine "subListId" `Seq` Solve

97+

98+%reflection

99+reflectEff : (P : Type) -> Tactic

100+reflectEff (EffElem m a xs)

101+ = reflectListEffElem xs `Seq` Solve

102+reflectEff (SubList xs ys)

103+ = reflectSubList ys `Seq` Solve

104+

105+updateResTy : (val : t) ->

106+ (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

107+ List EFFECT

108+updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs

109+updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

110+

111+-- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

112+-- List EFFECT

113+-- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

114+-- updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

115+

116+infix 5 :::, :-, :=

117+

118+data LRes : lbl -> Type -> Type where

119+ (:=) : (x : lbl) -> res -> LRes x res

120+

121+(:::) : lbl -> EFFECT -> EFFECT

122+(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

123+

124+using (lbl : Type)

125+ instance Default a => Default (LRes lbl a) where

126+ default = lbl := default

127+

128+private

129+unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

130+unlabel {m} {x = MkEff a eff} [l := v] = [v]

131+

132+private

133+relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)

134+relabel {xs = []} l [] = []

135+relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

136+

137+-- the language of Effects

138+

139+data Eff : (m : Type -> Type) ->

140+ (x : Type) ->

141+ List EFFECT -> (x -> List EFFECT) -> Type where

142+ value : a -> Eff m a xs (\v => xs)

143+ ebind : Eff m a xs xs' ->

144+ ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

145+ effect : (prf : EffElem e a xs) ->

146+ (eff : e t a b) ->

147+ Eff m t xs (\v => updateResTy v xs prf eff)

148+

149+ lift : (prf : SubList ys xs) ->

150+ Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)

151+ new : Handler e m =>

152+ res ->

153+ Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

154+ Eff m a xs (\v => xs')

155+ catch : Catchable m err =>

156+ Eff m a xs xs' -> (err -> Eff m a xs xs') ->

157+ Eff m a xs xs'

158+

159+ (:-) : (l : ty) ->

160+ Eff m t [x] xs' -> -- [x] (\v => xs) ->

161+ Eff m t [l ::: x] (\v => map (l :::) (xs' v))

162+

163+(>>=) : Eff m a xs xs' ->

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

165+(>>=) = ebind

166+

167+implicit

168+lift' : Eff m t ys ys' ->

169+ {default tactics { byReflection reflectEff; }

170+ prf : SubList ys xs} ->

171+ Eff m t xs (\v => updateWith (ys' v) xs prf)

172+lift' e {prf} = lift prf e

173+

174+implicit

175+effect' : {a, b: _} -> {e : Effect} ->

176+ (eff : e t a b) ->

177+ {default tactics { byReflection reflectEff; }

178+ prf : EffElem e a xs} ->

179+ Eff m t xs (\v => updateResTy v xs prf eff)

180+effect' e {prf} = effect prf e

181+

182+return : a -> Eff m a xs (\v => xs)

183+return x = value x

184+

185+-- for idiom brackets

186+

187+infixl 2 <$>

188+

189+pure : a -> Eff m a xs (\v => xs)

190+pure = value

191+

192+(<$>) : Eff m (a -> b) xs (\v => xs) ->

193+ Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)

194+(<$>) prog v = do fn <- prog

195+ arg <- v

196+ return (fn arg)

197+

198+-- an interpreter

199+

200+private

201+execEff : Env m xs -> (p : EffElem e res xs) ->

202+ (eff : e a res resk) ->

203+ ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t

204+execEff (val :: env) Here eff' k

205+ = handle val eff' (\v, res => k v (res :: env))

206+execEff (val :: env) (There p) eff k

207+ = execEff env p eff (\v, env' => k v (val :: env'))

208+

209+-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

210+-- updates can be propagated even through failing computations?

211+

212+eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

213+eff env (value x) k = k x env

214+eff env (prog `ebind` c) k

215+ = eff env prog (\p', env' => eff env' (c p') k)

216+eff env (effect prf effP) k = execEff env prf effP k

217+eff env (lift prf effP) k

218+ = let env' = dropEnv env prf in

219+ eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

220+eff env (new r prog) k

221+ = let env' = r :: env in

222+ eff env' prog (\p' => \ (v :: envk) => k p' envk)

223+eff env (catch prog handler) k

224+ = catch (eff env prog k)

225+ (\e => eff env (handler e) k)

226+-- FIXME:

227+-- xs is needed explicitly because otherwise the pattern binding for

228+-- 'l' appears too late. Solution seems to be to reorder patterns at the

229+-- end so that everything is in scope when it needs to be.

230+eff {xs = [l ::: x]} env (l :- prog) k

231+ = let env' = unlabel env in

232+ eff env' prog (\p', envk => k p' (relabel l envk))

233+

234+run : Applicative m => Env m xs -> Eff m a xs xs' -> m a

235+run env prog = eff env prog (\r, env => pure r)

236+

237+-- yuck :)

238+syntax MkDefaultEnv = (| [], [default], [default, default],

239+ [default, default, default],

240+ [default, default, default, default],

241+ [default, default, default, default, default],

242+ [default, default, default, default, default, default],

243+ [default, default, default, default, default, default, default],

244+ [default, default, default, default, default, default, default, default] |)

245+

246+run' : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a

247+run' {env} prog = eff env prog (\r, env => pure r)

248+

249+runEnv : Applicative m => Env m xs -> Eff m a xs xs' ->

250+ m (x : a ** Env m (xs' x))

251+runEnv env prog = eff env prog (\r, env => pure (r ** env))

252+

253+runPure : Env id xs -> Eff id a xs xs' -> a

254+runPure env prog = eff env prog (\r, env => r)

255+

256+runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a

257+runWith inj env prog = eff env prog (\r, env => inj r)

258+

259+-- some higher order things

260+

261+mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

262+mapE f [] = pure []

263+mapE f (x :: xs) = [| f x :: mapE f xs |]

264+

265+when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()

266+when True e = e

267+when False e = pure ()

268+

libs/neweffects/Makefilenew file+14

@@ -0,0 +1,14 @@

1+IDRIS := idris

3+build:

4+ $(IDRIS) --build neweffects.ipkg

6+clean:

7+ $(IDRIS) --clean neweffects.ipkg

9+install:

10+ $(IDRIS) --install neweffects.ipkg

11+

12+rebuild: clean build

13+

14+.PHONY: build clean install rebuild

libs/neweffects/neweffects.ipkgnew file+9

@@ -0,0 +1,9 @@

1+package neweffects

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

4+modules = Effects, Effect.Default,

6+ Effect.Exception, Effect.File, Effect.State,

7+ Effect.Random, Effect.StdIO, Effect.Select,

8+ Effect.Memory

libs/prelude/Builtins.idr+2

@@ -1,3 +1,5 @@

1+%unqualified

1%access public

3%access public

2%default total

4%default total

libs/prelude/IO.idr+2

@@ -1,3 +1,5 @@

1+%unqualified

1import Prelude.List

3import Prelude.List

3%access public

5%access public

libs/prelude/Makefile+4−4

@@ -1,17 +1,17 @@

1IDRIS := idris

3−build: .PHONY

3+build:

4 $(IDRIS) --build prelude.ipkg

6install:

7 $(IDRIS) --install prelude.ipkg

9−clean: .PHONY

9+clean:

10 $(IDRIS) --clean prelude.ipkg

12rebuild: clean build

14−linecount: .PHONY

14+linecount:

15 find . -name '*.idr' | xargs wc -l

17−.PHONY:

17+.PHONY: build install clean rebuild linecount

libs/prelude/Prelude.idr+11−7

@@ -275,11 +275,11 @@ instance Applicative List where

275instance Applicative (Vect k) where

276 pure = replicate _

277

278− fs <$> vs = zipWith ($) fs vs

278+ fs <$> vs = zipWith apply fs vs

279

280instance Applicative Stream where

281 pure = repeat

282− (<$>) = zipWith ($)

282+ (<$>) = zipWith apply

283

284---- Alternative instances

285

@@ -334,7 +334,7 @@ instance Traversable (Vect n) where

334 traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]

335

336---- some mathematical operations

337−---- XXX this should probably go some place else,

337+---- XXX this should probably go some place else,

338pow : (Num a) => a -> Nat -> a

339pow x Z = 1

340pow x (S n) = x * (pow x n)

@@ -376,7 +376,7 @@ instance Enum Integer where

376 enumFromThen n inc = n :: enumFromThen (inc + n) inc

377 enumFromTo n m = if n <= m

378 then go (natRange (S (cast {to = Nat} (m - n))))

379− else []

379+ else []

380 where go : List Nat -> List Integer

381 go [] = []

382 go (x :: xs) = n + cast x :: go xs

@@ -392,7 +392,7 @@ instance Enum Int where

392 toNat n = cast n

393 fromNat n = cast n

394 enumFromThen n inc = n :: enumFromThen (inc + n) inc

395− enumFromTo n m = if n <= m

395+ enumFromTo n m = if n <= m

396 then go (natRange (S (cast {to = Nat} (m - n))))

397 else []

398 where go : List Nat -> List Int

@@ -532,12 +532,16 @@ ferror (FHandle h) = do err <- do_ferror h

532partial

533nullPtr : Ptr -> IO Bool

534nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

535− return (ok /= 0);

535+ return (ok /= 0)

536

537partial

538nullStr : String -> IO Bool

539nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

540− return (ok /= 0);

540+ return (ok /= 0)

541+

542+eqPtr : Ptr -> Ptr -> IO Bool

543+eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

544+ return (eq /= 0)

541

545

542partial

546partial

543validFile : File -> IO Bool

547validFile : File -> IO Bool

libs/prelude/Prelude/Basics.idr+2−4

@@ -33,11 +33,9 @@ infixl 9 .

33flip : (a -> b -> c) -> b -> a -> c

34flip f x y = f y x

36−infixr 1 $

37−

38-- | Function application.

36-- | Function application.

39−($) : (a -> b) -> a -> b

37+apply : (a -> b) -> a -> b

40−f $ a = f a

38+apply f a = f a

42cong : {f : t -> u} -> (a = b) -> f a = f b

40cong : {f : t -> u} -> (a = b) -> f a = f b

43cong refl = refl

41cong refl = refl

llvm/Makefile+3−3

@@ -14,11 +14,11 @@ $(LIB): $(OBJECTS)

14.c.o:

15 $(CC) -c $(CFLAGS) $< -o $@

17−install: $(LIB) .PHONY

17+install: $(LIB)

18 mkdir -p $(TARGET)

19 install $(LIB) $(TARGET)

21−clean: .PHONY

21+clean:

22 rm -f $(OBJECTS) $(LIB)

24−.PHONY:

24+.PHONY: build install clean

main/Main.hs+57−30

@@ -53,6 +53,10 @@ runIdris opts = do

53 when (ShowIncs `elem` opts) $ runIO showIncs

54 when (ShowLibs `elem` opts) $ runIO showLibs

55 when (ShowLibdir `elem` opts) $ runIO showLibdir

56+ case opt getPkgCheck opts of

57+ [] -> return ()

58+ fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts)) fs

59+ runIO $ exitWith ExitSuccess

56 case opt getPkgClean opts of

60 case opt getPkgClean opts of

57 [] -> return ()

61 [] -> return ()

58 fs -> do runIO $ mapM_ cleanPkg fs

62 fs -> do runIO $ mapM_ cleanPkg fs

@@ -79,34 +83,57 @@ showIncs = do incFlags <- getIncFlags

79 putStrLn incFlags

83 putStrLn incFlags

80 exitWith ExitSuccess

84 exitWith ExitSuccess

86+usagemsghdr = "Idris version " ++ ver ++ ", (C) The Idris Community 2014"

87+

82−usagemsg = "Idris version " ++ ver ++ "\n" ++

88+usagemsg = usagemsghdr ++ "\n" ++

83− "--------------" ++ map (\x -> '-') ver ++ "\n" ++

89+ map (\x -> '-') usagemsghdr ++ "\n" ++

84− "Usage: idris [input file] [options]\n" ++

90+ "idris [OPTIONS] [FILE]\n\n" ++

85− "Options:\n" ++

91+ "Common flags:\n" ++

86− "\t--quiet Quiet mode (for editors)\n" ++

92+ "\t --install=IPKG Install Package\n" ++

87− "\t--[no]colour Control REPL colour highlighting\n" ++

93+ "\t --clean=IPKG Clean Package\n" ++

88− "\t--check Type check only\n" ++

94+ "\t --build=IPKG Build Package\n" ++

95+ "\t --exec=EXPR Execute as Idris\n" ++

96+ "\t --libdir Display library directory\n" ++

97+ "\t --link Display link directory\n" ++

98+ "\t --include Display the includes directory\n" ++

99+ "\t --nobanner Suppress the banner\n" ++

100+ "\t --color Force colored output\n" ++

101+ "\t --colour Force coloured output\n" ++

102+ "\t --nocolor Disable colored output\n" ++

103+ "\t --nocolour Disable coloured output\n" ++

104+ "\t --errorcontent Undocumented\n" ++

105+ "\t --nocoverage Undocumented\n" ++

89− "\t-o [file] Specify output filename\n" ++

106+ "\t -o --output=FILE Specify output file\n" ++

107+ "\t --check Undocumented\n" ++

108+ "\t --total Require functions to be total by default\n" ++

109+ "\t --partial Undocumented\n" ++

110+ "\t --warnpartial Warn about undeclared partial functions.\n" ++

111+ "\t --warn Undocumented\n" ++

112+ "\t --typecase Undocumented\n" ++

113+ "\t --typeintype Undocumented\n" ++

114+ "\t --nobasepkgs Undocumented\n" ++

115+ "\t --noprelude Undocumented\n" ++

116+ "\t --nobuiltins Undocumented\n" ++

117+ "\t -O --level=LEVEL Undocumented\n" ++

90− "\t-i [dir] Add directory to the list of import paths\n" ++

118+ "\t -i --idrispath=DIR Add directory to the list of import paths\n" ++

119+ "\t --package=ITEM Undocumented\n" ++

91− "\t--ibcsubdir [dir] Write IBC files into sub directory\n" ++

120+ "\t --ibcsubdir=FILE Write IBC files into sub directory\n" ++

92− "\t--noprelude Don't import the prelude\n" ++

121+ "\t --codegen=TARGET Select code generator: C, Java, bytecode," ++

93− "\t--total Require functions to be total by default\n" ++

122+ "\t javascript, node, or llvm\n" ++

94− "\t--warnpartial Warn about undeclared partial functions\n" ++

123+ "\t --mvn Create a maven project (for Java codegen)\n" ++

95− "\t--typeintype Disable universe checking\n" ++

124+ "\t --cpu=CPU Select tartget CPU e.g. corei& or cortex-m3" ++

96− "\t--log [level] Type debugging log level\n" ++

125+ "\t (for LLVM codegen)\n" ++

126+ "\t --target=TRIPLE Select target triple (for llvm codegen)\n" ++

97− "\t-S Do no further compilation of code generator output\n" ++

127+ "\t -S --codegenonly Do no further compilation of code generator output\n" ++

98− "\t-c Compile to object files rather than an executable\n" ++

128+ "\t -c --compileonly Compile to object fules rather than an executable\n" ++

99− "\t--mvn Create a maven project (for Java codegen)\n" ++

129+ "\t -X --extension=ITEM undocumented\n" ++

100− "\t--exec [expr] Execute the expression expr in the interpreter,\n" ++

130+ "\t --dumpdefuns Undocumented\n" ++

101− "\t defaulting to Main.main if none provided, and exit.\n" ++

131+ "\t --dumpcases Undocumented\n" ++

102− "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in \n" ++

132+ "\t --log=LEVEL --loglevel Type Debugging log level\n" ++

103− "\t s-expressions)\n" ++

133+ "\t --ideslave Undocumented\n" ++

104− "\t--libdir Show library install directory and exit\n" ++

134+ "\t --client Undocumented\n" ++

105− "\t--link Show C library directories and exit (for C linking)\n" ++

135+ "\t -h --help Display help message\n" ++

106− "\t--include Show C include directories and exit (for C linking)\n" ++

136+ "\t -v --version Print version information\n" ++

107− "\t--codegen [cg] Select code generator: C, Java, bytecode, javascript,\n" ++

137+ "\t -V --Verbose Loud verbosity\n" ++

108− "\t node or llvm\n" ++

138+ "\t -q --quiet Quiet verbosity\n"

109− "\t--target [triple] Select target triple (for LLVM codegen)\n" ++

110− "\t--cpu [cpu] Select target CPU (e.g. corei7 or cortex-m3) (for LLVM codegen)\n"

111−

112

139

papers/impl-paper/Makefile+5−5

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

1PAPER = impldtp

3−all: ${PAPER}.pdf .PHONY

3+all: ${PAPER}.pdf

5TEXFILES = ${PAPER}.tex intro.tex conclusions.tex hll.tex\

6 typechecking.tex elaboration.tex delab.tex \

@@ -28,16 +28,16 @@ ${PAPER}.dvi: $(SOURCES)

28 -latex ${PAPER}

29 -latex ${PAPER}

31−progress: .PHONY

31+progress:

32 wc -w ${TEXFILES}

34%.png : %.diag

35 $(DITAA) -o -E $<

37−todropbox: .PHONY

37+todropbox:

38 cp ${SOURCES} ~/Dropbox/TeX/ImplDTP/

40−fromdropbox: .PHONY

40+fromdropbox:

41 cp ~/Dropbox/TeX/ImplDTP/* .

43−.PHONY:

43+.PHONY: all progress todropbox fromdropbox

rts/Makefile+3−3

@@ -15,13 +15,13 @@ $(LIBTARGET) : $(OBJS)

15 ar r $(LIBTARGET) $(OBJS)

16 ranlib $(LIBTARGET)

18−install : .PHONY

18+install :

19 mkdir -p $(TARGET)

20 install $(LIBTARGET) $(HDRS) $(TARGET)

22−clean : .PHONY

22+clean :

23 rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET)

25idris_rts.o: idris_rts.h

27−.PHONY:

27+.PHONY: build install clean

rts/idris_stdfgn.c+4

@@ -36,6 +36,10 @@ int isNull(void* ptr) {

36 return ptr==NULL;

37}

39+int idris_eqPtr(void* x, void* y) {

40+ return x==y;

41+}

42+

39void* idris_stdin() {

43void* idris_stdin() {

40 return (void*)stdin;

44 return (void*)stdin;

41}

45}

rts/idris_stdfgn.h+1

@@ -12,6 +12,7 @@ int fileEOF(void* h);

12int fileError(void* h);

13void fputStr(void*h, char* str);

15+int idris_eqPtr(void* x, void* y);

15int isNull(void* ptr);

16int isNull(void* ptr);

16void* idris_stdin();

17void* idris_stdin();

src/IRTS/CodegenC.hs+19−2

@@ -10,6 +10,7 @@ import Idris.Core.TT

10import Paths_idris

11import Util.System

13+import Numeric

13import Data.Char

14import Data.Char

14import Data.List (intercalate)

15import Data.List (intercalate)

15import System.Process

16import System.Process

@@ -104,6 +105,22 @@ toC f code

104 indent 1 ++ "INITFRAME;\n" ++

105 indent 1 ++ "INITFRAME;\n" ++

105 concatMap (bcc 1) code ++ "}\n\n"

106 concatMap (bcc 1) code ++ "}\n\n"

106

107

108+showCStr :: String -> String

109+showCStr s = '"' : foldr ((++) . showChar) "\"" s

110+ where

111+ showChar :: Char -> String

112+ showChar '"' = "\\\""

113+ showChar '\\' = "\\\\"

114+ showChar c

115+ -- Note: we need the double quotes around the codes because otherwise

116+ -- "\n3" would get encoded as "\x0a3", which is incorrect.

117+ -- Instead, we opt for "\x0a""3" and let the C compiler deal with it.

118+ | ord c < 0x10 = "\"\"\\x0" ++ showHex (ord c) "\"\""

119+ | ord c < 0x20 = "\"\"\\x" ++ showHex (ord c) "\"\""

120+ | ord c < 0x7f = [c] -- 0x7f = \DEL

121+ | ord c < 0x100 = "\"\"\\x" ++ showHex (ord c) "\"\""

122+ | otherwise = error $ "non-8-bit character in string literal: " ++ show c

123+

107bcc :: Int -> BC -> String

124bcc :: Int -> BC -> String

108bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

125bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

109bcc i (ASSIGNCONST l c)

126bcc i (ASSIGNCONST l c)

@@ -114,7 +131,7 @@ bcc i (ASSIGNCONST l c)

114 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"

131 | otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"

115 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

132 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

116 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

133 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

117− mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

134+ mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

118 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

135 mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

119 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

136 mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

120 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

137 mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

@@ -444,7 +461,7 @@ doOp v LStdIn [] = v ++ "MKPTR(vm, stdin)"

444doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"

461doOp v LStdOut [] = v ++ "MKPTR(vm, stdout)"

445doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

462doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

446

463

447−doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

464+doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ", " ++ creg x ++ "))"

448doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

465doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

449doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

466doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

450doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

467doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

src/IRTS/CodegenJava.hs+5−5

@@ -369,13 +369,13 @@ addMainMethod decls

369 | otherwise = decls

370 where

371 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)

372− | name == mangle' (UN "Main") = findMainMethod body

372+ | name == mangle' (sUN "Main") = findMainMethod body

373 findMain (_:decls) = findMain decls

374 findMain [] = False

375

376− innerMainMethod = (either error id $ mangle (UN "main"))

376+ innerMainMethod = (either error id $ mangle (sUN "main"))

377 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)

378− | name == mangle' (UN "main") = True

378+ | name == mangle' (sUN "main") = True

379 findMainMethod (_:decls) = findMainMethod decls

380 findMainMethod [] = False

381

@@ -390,7 +390,7 @@ mkMainMethod =

390 $ call "idris_initArgs" [ (threadType ~> "currentThread") []

391 , jConst "args"

392 ]

393− , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) []

393+ , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []

394 ]

395

396-----------------------------------------------------------------------

@@ -749,6 +749,6 @@ mkPrimitiveFunction op args =

749

750mkThread :: LVar -> CodeGeneration Exp

751mkThread arg =

752− (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]

752+ (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]

753

754

src/IRTS/CodegenJavaScript.hs+192−32

@@ -64,6 +64,7 @@ data JS = JSRaw String

64 | JSArray [JS]

65 | JSObject [(String, JS)]

66 | JSString String

67+ | JSChar String

67 | JSNum JSNum

68 | JSNum JSNum

68 | JSAssign JS JS

69 | JSAssign JS JS

69 | JSAlloc String (Maybe JS)

70 | JSAlloc String (Maybe JS)

@@ -153,6 +154,9 @@ compileJS (JSObject fields) =

153compileJS (JSString str) =

154compileJS (JSString str) =

154 show str

155 show str

155

156

157+compileJS (JSChar chr) =

158+ chr

159+

156compileJS (JSNum num)

160compileJS (JSNum num)

157 | JSInt i <- num = show i

161 | JSInt i <- num = show i

158 | JSFloat f <- num = show f

162 | JSFloat f <- num = show f

@@ -170,8 +174,16 @@ compileJS (JSIndex lhs rhs) =

170 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"

174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"

171

175

172compileJS (JSCond branches) =

176compileJS (JSCond branches) =

173− intercalate " else " $ map createIfBlock branches

177+ intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)

174 where

178 where

179+ eliminateDeadBranches (e@(JSTrue, _):_) = [e]

180+ eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

181+ eliminateDeadBranches [] = []

182+

183+ createIfBlock (JSTrue, e) =

184+ "{\n"

185+ ++ "return " ++ compileJS e

186+ ++ ";\n}"

175 createIfBlock (cond, e) =

187 createIfBlock (cond, e) =

176 "if (" ++ compileJS cond ++") {\n"

188 "if (" ++ compileJS cond ++") {\n"

177 ++ "return " ++ compileJS e

189 ++ "return " ++ compileJS e

@@ -233,6 +245,7 @@ jsLet name value body =

233 )

245 )

234 ) [value]

246 ) [value]

235

247

248+

236jsSubst :: String -> JS -> JS -> JS

249jsSubst :: String -> JS -> JS -> JS

237jsSubst var new (JSVar old)

250jsSubst var new (JSVar old)

238 | var == translateVariableName old = new

251 | var == translateVariableName old = new

@@ -260,6 +273,16 @@ jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

260 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)

273 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)

261 )]

274 )]

262

275

276+jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)

277+ | var `notElem` args =

278+ JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (

279+ map (jsSubst var new) vals

280+ )

281+ | otherwise =

282+ JSApp (JSProj (JSFunction args body) "apply") (

283+ map (jsSubst var new) vals

284+ )

285+

263jsSubst var new (JSApp (JSProj obj field) args) =

286jsSubst var new (JSApp (JSProj obj field) args) =

264 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args

287 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args

265

288

@@ -291,11 +314,50 @@ jsSubst var new (JSIndex obj field) =

291jsSubst var new (JSCond conds) =

314jsSubst var new (JSCond conds) =

292 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)

315 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)

293

316

317+jsSubst var new (JSAssign lhs rhs) =

318+ JSAssign (jsSubst var new lhs) (jsSubst var new rhs)

319+

294jsSubst _ _ js = js

320jsSubst _ _ js = js

295

321

322+

323+isJSConstant :: JS -> Bool

324+isJSConstant js

325+ | JSString _ <- js = True

326+ | JSChar _ <- js = True

327+ | JSNum _ <- js = True

328+ | JSType _ <- js = True

329+

330+ | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True

331+ | otherwise = False

332+

296inlineJS :: JS -> JS

333inlineJS :: JS -> JS

297−inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =

334+inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =

298− JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []

335+ inlineJS $ jsSubst "cse" val body

336+

337+inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =

338+ JSSeq [ JSAlloc arg (Just (inlineJS val))

339+ , inlineJS cond

340+ ]

341+

342+inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [

343+ JSThis,JSProj var "vars"

344+ ])

345+ | var /= JSIdent "cse" =

346+ inlineApply args body 0

347+ where

348+ inlineApply [] body _ = inlineJS body

349+ inlineApply (a:as) body n =

350+ inlineApply as (

351+ jsSubst a (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body

352+ ) (n + 1)

353+

354+inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])

355+ | isJSConstant val = val

356+

357+inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [

358+ JSFunction [] (JSReturn val)

359+ ])

360+ | isJSConstant val = val

299

361

300inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])

362inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])

301 | JSNew con [tag, vals] <- ret

363 | JSNew con [tag, vals] <- ret

@@ -365,6 +427,9 @@ inlineJS (JSCond cases) =

365inlineJS (JSObject fields) =

427inlineJS (JSObject fields) =

366 JSObject (map (second inlineJS) fields)

428 JSObject (map (second inlineJS) fields)

367

429

430+inlineJS (JSOp op lhs rhs) =

431+ JSOp op (inlineJS lhs) (inlineJS rhs)

432+

368inlineJS js = js

433inlineJS js = js

369

434

370reduceJS :: [JS] -> [JS]

435reduceJS :: [JS] -> [JS]

@@ -373,6 +438,96 @@ reduceJS js = reduceLoop [] ([], js)

373funName :: JS -> String

438funName :: JS -> String

374funName (JSAlloc fun _) = fun

439funName (JSAlloc fun _) = fun

375

440

441+initConstructors :: [JS] -> [JS]

442+initConstructors js =

443+ let tags = nub $ sort $ concat (map getTags js) in

444+ map createConstant tags ++ replaceConstructors tags js

445+ where

446+ getTags :: JS -> [Int]

447+ getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]

448+

449+ getTags (JSNew _ args) = concatMap getTags args

450+

451+ getTags (JSFunction _ body) = getTags body

452+

453+ getTags (JSReturn ret) = getTags ret

454+

455+ getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs

456+

457+ getTags (JSSeq seq) = concatMap getTags seq

458+

459+ getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs

460+

461+ getTags (JSProj obj _) = getTags obj

462+

463+ getTags (JSArray vals) = concatMap getTags vals

464+

465+ getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs

466+

467+ getTags (JSAlloc _ (Just val)) = getTags val

468+

469+ getTags (JSCond conds) =

470+ concatMap (uncurry (++)) $ map (getTags *** getTags) conds

471+

472+ getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f

473+

474+ getTags js = []

475+

476+ replaceConstructors :: [Int] -> [JS] -> [JS]

477+ replaceConstructors tags js = map (replaceHelper tags) js

478+ where

479+ replaceHelper :: [Int] -> JS -> JS

480+ replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])

481+ | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)

482+

483+ replaceHelper tags (JSNew con args) =

484+ JSNew con $ map (replaceHelper tags) args

485+

486+ replaceHelper tags (JSFunction fun body) =

487+ JSFunction fun (replaceHelper tags body)

488+

489+ replaceHelper tags (JSReturn ret) =

490+ JSReturn (replaceHelper tags ret)

491+

492+ replaceHelper tags (JSApp lhs rhs) =

493+ JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)

494+

495+ replaceHelper tags (JSSeq seq) =

496+ JSSeq $ map (replaceHelper tags) seq

497+

498+ replaceHelper tags (JSOp op lhs rhs) =

499+ JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)

500+

501+ replaceHelper tags (JSProj obj field) =

502+ JSProj (replaceHelper tags obj) field

503+

504+ replaceHelper tags (JSArray vals) =

505+ JSArray $ map (replaceHelper tags) vals

506+

507+ replaceHelper tags (JSAssign lhs rhs) =

508+ JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)

509+

510+ replaceHelper tags (JSAlloc var (Just val)) =

511+ JSAlloc var $ Just (replaceHelper tags val)

512+

513+ replaceHelper tags (JSCond conds) =

514+ JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)

515+

516+ replaceHelper tags (JSTernary c t f) =

517+ JSTernary (replaceHelper tags c) (

518+ replaceHelper tags t

519+ ) (

520+ replaceHelper tags f

521+ )

522+

523+ replaceHelper tags js = js

524+

525+ createConstant :: Int -> JS

526+ createConstant tag =

527+ JSAlloc ("__IDRCTR__" ++ show tag) (Just (

528+ JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]

529+ ))

530+

376removeIDs :: [JS] -> [JS]

531removeIDs :: [JS] -> [JS]

377removeIDs js =

532removeIDs js =

378 case partition isID js of

533 case partition isID js of

@@ -536,6 +691,12 @@ reduceLoop reduced (cons, program) =

536 reduceCall funs (JSProj obj field) =

691 reduceCall funs (JSProj obj field) =

537 JSProj (reduceCall funs obj) field

692 JSProj (reduceCall funs obj) field

538

693

694+ reduceCall funs (JSIndex obj idx) =

695+ JSIndex (reduceCall funs obj) (reduceCall funs idx)

696+

697+ reduceCall funs (JSOp op rhs lhs) =

698+ JSOp op (reduceCall funs rhs) (reduceCall funs lhs)

699+

539 reduceCall funs (JSCond conds) =

700 reduceCall funs (JSCond conds) =

540 JSCond $ map (reduceCall funs *** reduceCall funs) conds

701 JSCond $ map (reduceCall funs *** reduceCall funs) conds

541

702

@@ -588,7 +749,7 @@ codegenJavaScript target definitions filename outputType = do

588

749

589 functions :: [String]

750 functions :: [String]

590 functions =

751 functions =

591− map (compileJS . reduceConstants) ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def)

752+ map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))

592

753

593 mainLoop :: String

754 mainLoop :: String

594 mainLoop = compileJS $

755 mainLoop = compileJS $

@@ -606,7 +767,7 @@ codegenJavaScript target definitions filename outputType = do

606 mainFun = jsTailcall $ jsCall runMain []

767 mainFun = jsTailcall $ jsCall runMain []

607

768

608 runMain :: String

769 runMain :: String

609− runMain = idrNamespace ++ translateName (MN 0 "runMain")

770+ runMain = idrNamespace ++ translateName (sMN 0 "runMain")

610

771

611 invokeLoop :: String

772 invokeLoop :: String

612 invokeLoop = compileJS $ jsCall "main" []

773 invokeLoop = compileJS $ jsCall "main" []

@@ -671,15 +832,15 @@ translateIdentifier =

671

832

672translateNamespace :: Name -> String

833translateNamespace :: Name -> String

673translateNamespace (UN _) = idrNamespace

834translateNamespace (UN _) = idrNamespace

674−translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns

835+translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns

675translateNamespace (MN _ _) = idrNamespace

836translateNamespace (MN _ _) = idrNamespace

676translateNamespace (SN name) = idrNamespace ++ translateSpecialName name

837translateNamespace (SN name) = idrNamespace ++ translateSpecialName name

677translateNamespace NErased = idrNamespace

838translateNamespace NErased = idrNamespace

678

839

679translateName :: Name -> String

840translateName :: Name -> String

680−translateName (UN name) = 'u' : translateIdentifier name

841+translateName (UN name) = 'u' : translateIdentifier (str name)

681translateName (NS name _) = 'n' : translateName name

842translateName (NS name _) = 'n' : translateName name

682−translateName (MN i name) = 'm' : translateIdentifier name ++ show i

843+translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i

683translateName (SN name) = 's' : translateSpecialName name

844translateName (SN name) = 's' : translateSpecialName name

684translateName NErased = "e"

845translateName NErased = "e"

685

846

@@ -688,9 +849,9 @@ translateSpecialName name

688 | WhereN i m n <- name =

849 | WhereN i m n <- name =

689 'w' : translateName m ++ translateName n ++ show i

850 'w' : translateName m ++ translateName n ++ show i

690 | InstanceN n s <- name =

851 | InstanceN n s <- name =

691− 'i' : translateName n ++ concatMap translateIdentifier s

852+ 'i' : translateName n ++ concatMap (translateIdentifier . str) s

692 | ParentN n s <- name =

853 | ParentN n s <- name =

693− 'p' : translateName n ++ translateIdentifier s

854+ 'p' : translateName n ++ translateIdentifier (str s)

694 | MethodN n <- name =

855 | MethodN n <- name =

695 'm' : translateName n

856 'm' : translateName n

696 | CaseN n <- name =

857 | CaseN n <- name =

@@ -699,6 +860,9 @@ translateSpecialName name

699translateConstant :: Const -> JS

860translateConstant :: Const -> JS

700translateConstant (I i) = JSNum (JSInt i)

861translateConstant (I i) = JSNum (JSInt i)

701translateConstant (Fl f) = JSNum (JSFloat f)

862translateConstant (Fl f) = JSNum (JSFloat f)

863+translateConstant (Ch '\DEL') = JSChar "'\\u007F'"

864+translateConstant (Ch '\a') = JSChar "'\\u0007'"

865+translateConstant (Ch '\SO') = JSChar "'\\u000E'"

702translateConstant (Ch c) = JSString [c]

866translateConstant (Ch c) = JSString [c]

703translateConstant (Str s) = JSString s

867translateConstant (Str s) = JSString s

704translateConstant (AType (ATInt ITNative)) = JSType JSIntTy

868translateConstant (AType (ATInt ITNative)) = JSType JSIntTy

@@ -714,29 +878,32 @@ translateConstant c =

714

878

715translateDeclaration :: (String, SDecl) -> JS

879translateDeclaration :: (String, SDecl) -> JS

716translateDeclaration (path, SFun name params stackSize body)

880translateDeclaration (path, SFun name params stackSize body)

717− | (MN _ "APPLY") <- name

881+ | (MN _ ap) <- name

718 , (SLet var val next) <- body

882 , (SLet var val next) <- body

719− , (SChkCase cvar cases) <- next =

883+ , (SChkCase cvar cases) <- next

884+ , ap == txt "APPLY" =

720 let lvar = translateVariableName var

885 let lvar = translateVariableName var

721 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in

886 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in

722 JSSeq [ lookupTable [(var, "chk")] var cases

887 JSSeq [ lookupTable [(var, "chk")] var cases

723 , jsDecl $ JSFunction ["fn0", "arg0"] (

888 , jsDecl $ JSFunction ["fn0", "arg0"] (

724 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")

889 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")

725− , JSReturn $ jsLet (translateVariableName var) (

890+ , JSAlloc (translateVariableName var) (

726− translateExpression val

891+ Just $ translateExpression val

892+ )

727− ) (JSTernary (

893+ , JSReturn $ (JSTernary (

728− (JSVar var `jsInstanceOf` jsCon) `jsAnd`

894+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`

729− (hasProp lookupTableName (translateVariableName var))

895+ (hasProp lookupTableName (translateVariableName var))

730− ) (JSIdent $

896+ ) (JSIdent $

731− lookupTableName ++ lookup

897+ lookupTableName ++ lookup

732− ) JSNull

898+ ) JSNull

733− )

899+ )

734 ]

900 ]

735 )

901 )

736 ]

902 ]

737

903

738− | (MN _ "EVAL") <- name

904+ | (MN _ ev) <- name

739− , (SChkCase var cases) <- body =

905+ , (SChkCase var cases) <- body

906+ , ev == txt "EVAL" =

740 JSSeq [ lookupTable [] var cases

907 JSSeq [ lookupTable [] var cases

741 , jsDecl $ JSFunction ["arg0"] (JSReturn $

908 , jsDecl $ JSFunction ["arg0"] (JSReturn $

742 JSTernary (

909 JSTernary (

@@ -798,23 +965,16 @@ translateDeclaration (path, SFun name params stackSize body)

798 JSFunction (p ++ map snd aux) (

965 JSFunction (p ++ map snd aux) (

799 JSSeq $

966 JSSeq $

800 zipWith assignVar [0..] p ++

967 zipWith assignVar [0..] p ++

801− map allocVar [numP .. (numP + stackSize - 1)] ++

802 map assignAux aux ++

968 map assignAux aux ++

803 [JSReturn body]

969 [JSReturn body]

804 )

970 )

805 where

971 where

806− numP :: Int

807− numP = length params

808−

809− allocVar :: Int -> JS

810− allocVar n = JSAlloc (jsVar n) Nothing

811−

812 assignVar :: Int -> String -> JS

972 assignVar :: Int -> String -> JS

813 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)

973 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)

814

974

815 assignAux :: (LVar, String) -> JS

975 assignAux :: (LVar, String) -> JS

816− assignAux (var, val) =

976+ assignAux (Loc var, val) =

817− JSAssign (JSIdent $ translateVariableName var) (JSIdent val)

977+ JSAlloc (jsVar var) (Just $ JSIdent val)

818

978

819 p :: [String]

979 p :: [String]

820 p = map translateName params

980 p = map translateName params

src/IRTS/Compiler.hs+34−31

@@ -40,7 +40,7 @@ compile codegen f tm

40 = do checkMVs

41 let tmnames = namesUsed (STerm tm)

42 usedIn <- mapM (allNames []) tmnames

43− let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn

43+ let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn

44 defsIn <- mkDecls tm (concat used)

45 findUnusedArgs (concat used)

46 maindef <- irMain tm

@@ -49,7 +49,7 @@ compile codegen f tm

49 flags <- getFlags codegen

50 hdrs <- getHdrs codegen

51 impdirs <- allImportDirs

52− let defs = defsIn ++ [(MN 0 "runMain", maindef)]

52+ let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

53 -- iputStrLn $ showSep "\n" (map show defs)

54 let (nexttag, tagged) = addTags 65536 (liftAll defs)

55 let ctxtIn = addAlist tagged emptyContext

@@ -108,7 +108,7 @@ compile codegen f tm

108

109irMain :: TT Name -> Idris LDecl

110irMain tm = do i <- ir tm

111− return $ LFun [] (MN 0 "runMain") [] (LForce i)

111+ return $ LFun [] (sMN 0 "runMain") [] (LForce i)

112

113mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

114mkDecls t used

@@ -137,7 +137,7 @@ build (n, d)

137 = do i <- getIState

138 case lookup n (idris_scprims i) of

139 Just (ar, op) ->

140− let args = map (\x -> MN x "op") [0..] in

140+ let args = map (\x -> sMN x "op") [0..] in

141 return (n, (LFun [] n (take ar args)

142 (LOp op (map (LV . Glob) (take ar args)))))

143 _ -> do def <- mkLDecl n d

@@ -168,40 +168,38 @@ mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)

168instance ToIR (TT Name) where

169 ir tm = ir' [] tm where

170 ir' env tm@(App f a)

171− | (P _ (UN "mkForeignPrim") _, args) <- unApply tm

171+ | (P _ (UN m) _, args) <- unApply tm,

172+ m == txt "mkForeignPrim"

172 = doForeign env args

173 = doForeign env args

173− | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm

174+ | (P _ (UN u) _, [_, arg]) <- unApply tm,

175+ u == txt "unsafePerformPrimIO"

174 = ir' env arg

176 = ir' env arg

175 -- TMP HACK - until we get inlining.

177 -- TMP HACK - until we get inlining.

176− | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm

178+ | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,

179+ r == txt "replace"

177 = ir' env arg

180 = ir' env arg

178− | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

181+ | (P _ (UN l) _, [_, arg]) <- unApply tm,

182+ l == txt "lazy"

179 = do arg' <- ir' env arg

183 = do arg' <- ir' env arg

180 return $ LLazyExp arg'

184 return $ LLazyExp arg'

181− | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm

185+ | (P _ (UN a) _, [_, _, _, arg]) <- unApply tm,

186+ a == txt "assert_smaller"

182 = ir' env arg

187 = ir' env arg

183− | (P _ (UN "par") _, [_, arg]) <- unApply tm

188+ | (P _ (UN p) _, [_, arg]) <- unApply tm,

189+ p == txt "par"

184 = do arg' <- ir' env arg

190 = do arg' <- ir' env arg

185 return $ LOp LPar [LLazyExp arg']

191 return $ LOp LPar [LLazyExp arg']

186− | (P _ (UN "prim_fork") _, [arg]) <- unApply tm

192+ | (P _ (UN pf) _, [arg]) <- unApply tm,

193+ pf == txt "prim_fork"

187 = do arg' <- ir' env arg

194 = do arg' <- ir' env arg

188 return $ LOp LFork [LLazyExp arg']

195 return $ LOp LFork [LLazyExp arg']

189−-- | (P _ (UN "prim__IO") _, [v]) <- unApply tm

190−-- = do v' <- ir' env v

191−-- return v'

192−-- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm

193−-- = do v' <- ir' env v

194−-- sc' <- ir' (n:env) sc

195−-- return (LLet n (LForce v') sc')

196−-- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm

197−-- = do v' <- ir' env v

198−-- k' <- ir' env k

199−-- return (LApp False k' [LForce v'])

200− | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm

196+ | (P _ (UN m) _, [_,size,t]) <- unApply tm,

197+ m == txt "malloc"

201 = do size' <- ir' env size

198 = do size' <- ir' env size

202 t' <- ir' env t

199 t' <- ir' env t

203 return t' -- TODO $ malloc_ size' t'

200 return t' -- TODO $ malloc_ size' t'

204− | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm

201+ | (P _ (UN tm) _, [_,t]) <- unApply tm,

202+ tm == txt "trace_malloc"

205 = do t' <- ir' env t

203 = do t' <- ir' env t

206 return t' -- TODO

204 return t' -- TODO

207-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm

205-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm

@@ -272,7 +270,7 @@ instance ToIR (TT Name) where

272 (args ++ map (\n -> P Bound n undefined) extra)

270 (args ++ map (\n -> P Bound n undefined) extra)

273 return $ LLam extra sc'

271 return $ LLam extra sc'

274

272

275− satArgs n = map (\i -> MN i "sat") [1..n]

273+ satArgs n = map (\i -> sMN i "sat") [1..n]

276

274

277 buildApp env e [] = return e

275 buildApp env e [] = return e

278 buildApp env e xs = do xs' <- mapM (ir' env) xs

276 buildApp env e xs = do xs' <- mapM (ir' env) xs

@@ -300,10 +298,15 @@ getFTypes tm = case unApply tm of

300 fmap (mkIty' ty :) (getFTypes xs)

298 fmap (mkIty' ty :) (getFTypes xs)

301 _ -> Nothing

299 _ -> Nothing

302

300

303−mkIty' (P _ (UN ty) _) = mkIty ty

301+mkIty' (P _ (UN ty) _) = mkIty (str ty)

302+mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

304−mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy

303+ | fi == txt "FIntT" = mkIntIty (str intTy)

305−mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO

304+mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

305+ | ff == txt "FFunction" && fa == txt "FAny" &&

306+ io == txt "IO"

307+ = FFunctionIO

306−mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction

308+mkIty' (App (App (P _ (UN ff) _) _) _)

309+ | ff == txt "FFunction" = FFunction

307mkIty' _ = FAny

310mkIty' _ = FAny

308

311

309-- would be better if these FInt types were evaluated at compile time

312-- would be better if these FInt types were evaluated at compile time

@@ -337,8 +340,8 @@ mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

337mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

340mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

338mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

341mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

339

342

340−zname = NS (UN "Z") ["Nat","Prelude"]

343+zname = sNS (sUN "Z") ["Nat","Prelude"]

341−sname = NS (UN "S") ["Nat","Prelude"]

344+sname = sNS (sUN "S") ["Nat","Prelude"]

342

345

343instance ToIR ([Name], SC) where

346instance ToIR ([Name], SC) where

344 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

347 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

src/IRTS/Defunctionalise.hs+14−14

@@ -143,7 +143,7 @@ addApps defs (n, LFun _ _ args e)

143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

144

145 chainAPPLY f [] = f

146− chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as

146+ chainAPPLY f (a : as) = chainAPPLY (DApp False (sMN 0 "APPLY") [f, a]) as

147

148 -- if anything in the DExp is projected from, we'll need to evaluate it,

149 -- but we only want to do it once, rather than every time we project.

@@ -171,7 +171,7 @@ addApps defs (n, LFun _ _ args e)

171 needsEval x (DProj (DV (Glob x')) _) = x == x'

172 needsEval x _ = False

173

174−eEVAL x = DApp False (MN 0 "EVAL") [x]

174+eEVAL x = DApp False (sMN 0 "EVAL") [x]

175

176data EvalApply a = EvalCase (Name -> a)

177 | ApplyCase a

@@ -198,26 +198,26 @@ mkApplyCase fname n ar

198 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

199 (DApp False (mkUnderCon fname (ar - (n + 1)))

200 (map (DV . Glob) (take n (genArgs 0) ++

201− [MN 0 "arg"])))))

201+ [sMN 0 "arg"])))))

202 : mkApplyCase fname (n + 1) ar

203

204mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

205−mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]

205+mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]

206− (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))

206+ (mkBigCase (sMN 0 "EVAL") 256 (DV (Glob (sMN 0 "arg")))

207 (mapMaybe evalCase xs ++

208− [DDefaultCase (DV (Glob (MN 0 "arg")))])))

208+ [DDefaultCase (DV (Glob (sMN 0 "arg")))])))

209 where

210− evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

210+ evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg"))

211 evalCase _ = Nothing

212

213mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

214−mkApply xs = (MN 0 "APPLY", DFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]

214+mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]

215 (case mapMaybe applyCase xs of

216 [] -> DNothing

217 cases ->

218− mkBigCase (MN 0 "APPLY") 256

218+ mkBigCase (sMN 0 "APPLY") 256

219− (DApp False (MN 0 "EVAL")

219+ (DApp False (sMN 0 "EVAL")

220− [DV (Glob (MN 0 "fn"))])

220+ [DV (Glob (sMN 0 "fn"))])

221 (cases ++

222 [DDefaultCase DNothing])))

223 where

@@ -231,11 +231,11 @@ declare t xs = dec' t xs [] where

231 dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, DConstructor n t ar) : acc)

232

233

234−genArgs i = MN i "P_c" : genArgs (i + 1)

234+genArgs i = sMN i "P_c" : genArgs (i + 1)

235

236−mkFnCon n = MN 0 ("P_" ++ show n)

236+mkFnCon n = sMN 0 ("P_" ++ show n)

237mkUnderCon n 0 = n

238−mkUnderCon n missing = MN missing ("U_" ++ show n)

238+mkUnderCon n missing = sMN missing ("U_" ++ show n)

239

240instance Show DExp where

241 show e = show' [] e where

src/IRTS/Java/Mangling.hs+3−3

@@ -26,7 +26,7 @@ prefixCallNamespaces name (SFun fname args i e) =

26 where

27 prefixCallNamespacesExp :: Ident -> SExp -> SExp

28 prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =

29− SApp tail (NS n (name:ns)) args

29+ SApp tail (NS n (txt name:ns)) args

30 prefixCallNamespacesExp name (SLet var e1 e2) =

31 SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)

32 prefixCallNamespacesExp name (SUpdate var e) =

@@ -63,7 +63,7 @@ mangleWithPrefix prefix (UN name) =

63 . parser ident

64 . (prefix ++)

65 . cleanNonLetter

66− $ cleanWs False name

66+ $ cleanWs False (str name)

67 where

68 cleanNonLetter (x:xs)

69 | x == '#' = "_Hash" ++ cleanNonLetter xs

@@ -96,7 +96,7 @@ mangleWithPrefix prefix (UN name) =

96 | capitalize = (toUpper x) : (cleanWs False xs)

97 | otherwise = x : (cleanWs False xs)

98 cleanWs _ [] = []

99−mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (UN (showCG s))

99+mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (sUN (showCG s))

100

101mangle :: (Applicative m, MonadError String m) => Name -> m Ident

102mangle = mangleWithPrefix "__IDRCG__"

src/IRTS/Lang.hs+1−1

@@ -102,7 +102,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

102

103lname (NS n x) i = NS (lname n i) x

104lname (UN n) i = MN i n

105−lname x i = MN i (show x)

105+lname x i = sMN i (show x)

106

107liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

108liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

src/IRTS/Simplified.hs+2−1

@@ -2,6 +2,7 @@ module IRTS.Simplified where

3import IRTS.Defunctionalise

4import Idris.Core.TT

5+import Idris.Core.Typecheck

5import Data.Maybe

6import Data.Maybe

6import Control.Monad.State

7import Control.Monad.State

@@ -94,7 +95,7 @@ sVar (DV (Glob x))

94sVar (DV x) = return (x, Nothing)

95sVar (DV x) = return (x, Nothing)

95sVar e = do e' <- simplify False e

96sVar e = do e' <- simplify False e

96 i <- hvar

97 i <- hvar

97− return (Glob (MN i "R"), Just e')

98+ return (Glob (sMN i "R"), Just e')

99mkapp f args = mkapp' f args [] where

100mkapp f args = mkapp' f args [] where

100 mkapp' f [] args = return $ f (reverse args)

101 mkapp' f [] args = return $ f (reverse args)

src/Idris/AbsSyntax.hs+270−122

@@ -19,9 +19,11 @@ import System.Console.Haskeline

19import System.IO

21import Control.Monad.State

22+import Control.Monad.Error(throwError)

23import Data.List

24import Data.List

24import Data.Char

25import Data.Char

26+import qualified Data.Text as T

25import Data.Either

27import Data.Either

26import Data.Maybe

28import Data.Maybe

27import Data.Word (Word)

29import Data.Word (Word)

@@ -180,7 +182,7 @@ addNameHint ty n

180 putIState $ i { idris_namehints = addDef ty' ns' (idris_namehints i) }

182 putIState $ i { idris_namehints = addDef ty' ns' (idris_namehints i) }

181

183

182getNameHints :: IState -> Name -> [Name]

184getNameHints :: IState -> Name -> [Name]

183−getNameHints i (UN "->") = [UN "f",UN "g"]

185+getNameHints i (UN arr) | arr == txt "->" = [sUN "f",sUN "g"]

184getNameHints i n =

186getNameHints i n =

185 case lookupCtxt n (idris_namehints i) of

187 case lookupCtxt n (idris_namehints i) of

186 [ns] -> ns

188 [ns] -> ns

@@ -200,7 +202,7 @@ addInstance int n i

200 [CI a b c d e ins] ->

202 [CI a b c d e ins] ->

201 do let cs = addDef n (CI a b c d e (addI i ins)) (idris_classes ist)

203 do let cs = addDef n (CI a b c d e (addI i ins)) (idris_classes ist)

202 putIState $ ist { idris_classes = cs }

204 putIState $ ist { idris_classes = cs }

203− _ -> do let cs = addDef n (CI (MN 0 "none") [] [] [] [] [i]) (idris_classes ist)

205+ _ -> do let cs = addDef n (CI (sMN 0 "none") [] [] [] [] [i]) (idris_classes ist)

204 putIState $ ist { idris_classes = cs }

206 putIState $ ist { idris_classes = cs }

205 where addI i ins | int = i : ins

207 where addI i ins | int = i : ins

206 | chaser n = ins ++ [i]

208 | chaser n = ins ++ [i]

@@ -209,7 +211,8 @@ addInstance int n i

209 insI i (n : ns) | chaser n = i : n : ns

211 insI i (n : ns) | chaser n = i : n : ns

210 | otherwise = n : insI i ns

212 | otherwise = n : insI i ns

211

213

212− chaser (UN ('@':'@':_)) = True

214+ chaser (UN nm)

215+ | ('@':'@':_) <- str nm = True

213 chaser (NS n _) = chaser n

216 chaser (NS n _) = chaser n

214 chaser _ = False

217 chaser _ = False

215

218

@@ -234,6 +237,24 @@ addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

234clearIBC :: Idris ()

237clearIBC :: Idris ()

235clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

238clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

236

239

240+resetNameIdx :: Idris ()

241+resetNameIdx = do i <- getIState

242+ put (i { idris_nameIdx = (0, emptyContext) })

243+

244+-- Used to preserve sharing of names

245+addNameIdx :: Name -> Idris (Int, Name)

246+addNameIdx n = do i <- getIState

247+ let (i', x) = addNameIdx' i n

248+ return x

249+

250+addNameIdx' :: IState -> Name -> (IState, (Int, Name))

251+addNameIdx' i n

252+ = let idxs = snd (idris_nameIdx i) in

253+ case lookupCtxt n idxs of

254+ [x] -> (i, x)

255+ _ -> let i' = fst (idris_nameIdx i) + 1 in

256+ (i { idris_nameIdx = (i', addDef n (i', n) idxs) }, (i', n))

257+

237getHdrs :: Codegen -> Idris [String]

258getHdrs :: Codegen -> Idris [String]

238getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

259getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

239

260

@@ -284,12 +305,33 @@ getInternalApp fp l = do i <- getIState

284 Nothing -> return Placeholder

305 Nothing -> return Placeholder

285 -- TODO: What if it's not there?

306 -- TODO: What if it's not there?

286

307

308+-- Pattern definitions are only used for coverage checking, so erase them

309+-- when we're done

310+clearOrigPats :: Idris ()

311+clearOrigPats = do i <- get

312+ let ps = idris_patdefs i

313+ let ps' = mapCtxt (\ (_,miss) -> ([], miss)) ps

314+ put (i { idris_patdefs = ps' })

315+

316+-- Erase types from Ps in the context (basically ending up with what's in

317+-- the .ibc, which is all we need after all the analysis is done)

318+clearPTypes :: Idris ()

319+clearPTypes = do i <- get

320+ let ctxt = tt_ctxt i

321+ put (i { tt_ctxt = mapDefCtxt pErase ctxt })

322+ where pErase (CaseOp c t tys orig tot cds)

323+ = CaseOp c t tys orig [] (pErase' cds)

324+ pErase x = x

325+ pErase' (CaseDefs _ (cs, c) _ rs)

326+ = let c' = (cs, fmap pEraseType c) in

327+ CaseDefs c' c' c' rs

328+

287checkUndefined :: FC -> Name -> Idris ()

329checkUndefined :: FC -> Name -> Idris ()

288checkUndefined fc n

330checkUndefined fc n

289 = do i <- getContext

331 = do i <- getContext

290 case lookupTy n i of

332 case lookupTy n i of

291− (_:_) -> fail $ show fc ++ ":" ++

333+ (_:_) -> throwError . Msg $ show fc ++ ":" ++

292− show n ++ " already defined"

334+ show n ++ " already defined"

293 _ -> return ()

335 _ -> return ()

294

336

295isUndefined :: FC -> Name -> Idris Bool

337isUndefined :: FC -> Name -> Idris Bool

@@ -650,16 +692,16 @@ setTypeCase t = do i <- getIState

650

692

651bi = fileFC "builtin"

693bi = fileFC "builtin"

652

694

653−inferTy = MN 0 "__Infer"

695+inferTy = sMN 0 "__Infer"

654−inferCon = MN 0 "__infer"

696+inferCon = sMN 0 "__infer"

655inferDecl = PDatadecl inferTy

697inferDecl = PDatadecl inferTy

656 PType

698 PType

657− [("", inferCon, PPi impl (MN 0 "iType") PType (

699+ [("", inferCon, PPi impl (sMN 0 "iType") PType (

658− PPi expl (MN 0 "ival") (PRef bi (MN 0 "iType"))

700+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

659− (PRef bi inferTy)), bi)]

701+ (PRef bi inferTy)), bi, [])]

660inferOpts = []

702inferOpts = []

661

703

662−infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "iType") Placeholder True, pexp t]

704+infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

663infP = P (TCon 6 0) inferTy (TType (UVal 0))

705infP = P (TCon 6 0) inferTy (TType (UVal 0))

664

706

665getInferTerm, getInferType :: Term -> Term

707getInferTerm, getInferType :: Term -> Term

@@ -676,52 +718,52 @@ primNames = [unitTy, unitCon,

676 falseTy, pairTy, pairCon,

718 falseTy, pairTy, pairCon,

677 eqTy, eqCon, inferTy, inferCon]

719 eqTy, eqCon, inferTy, inferCon]

678

720

679−unitTy = MN 0 "__Unit"

721+unitTy = sMN 0 "__Unit"

680−unitCon = MN 0 "__II"

722+unitCon = sMN 0 "__II"

681unitDecl = PDatadecl unitTy PType

723unitDecl = PDatadecl unitTy PType

682− [("", unitCon, PRef bi unitTy, bi)]

724+ [("", unitCon, PRef bi unitTy, bi, [])]

683unitOpts = [DefaultEliminator]

725unitOpts = [DefaultEliminator]

684

726

685−falseTy = MN 0 "__False"

727+falseTy = sMN 0 "__False"

686falseDecl = PDatadecl falseTy PType []

728falseDecl = PDatadecl falseTy PType []

687falseOpts = []

729falseOpts = []

688

730

689−pairTy = MN 0 "__Pair"

731+pairTy = sMN 0 "__Pair"

690−pairCon = MN 0 "__MkPair"

732+pairCon = sMN 0 "__MkPair"

691pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

733pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

692 [("", pairCon, PPi impl (n "A") PType (

734 [("", pairCon, PPi impl (n "A") PType (

693 PPi impl (n "B") PType (

735 PPi impl (n "B") PType (

694 PPi expl (n "a") (PRef bi (n "A")) (

736 PPi expl (n "a") (PRef bi (n "A")) (

695 PPi expl (n "b") (PRef bi (n "B"))

737 PPi expl (n "b") (PRef bi (n "B"))

696 (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

738 (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

697− pexp (PRef bi (n "B"))])))), bi)]

739+ pexp (PRef bi (n "B"))])))), bi, [])]

698− where n a = MN 0 a

740+ where n a = sMN 0 a

699pairOpts = []

741pairOpts = []

700

742

701−eqTy = UN "="

743+eqTy = sUN "="

702−eqCon = UN "refl"

744+eqCon = sUN "refl"

703−eqDecl = PDatadecl eqTy (piBind [(n "a", PType), (n "b", PType),

745+eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

704− (n "x", PRef bi (n "a")), (n "y", PRef bi (n "b"))]

746+ (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

705 PType)

747 PType)

706− [("", eqCon, PPi impl (n "a") PType (

748+ [("", eqCon, PPi impl (n "A") PType (

707− PPi impl (n "x") (PRef bi (n "a"))

749+ PPi impl (n "x") (PRef bi (n "A"))

708− (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder False,

750+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

709− pimp (n "b") Placeholder False,

751+ pimp (n "B") Placeholder False,

710 pexp (PRef bi (n "x")),

752 pexp (PRef bi (n "x")),

711− pexp (PRef bi (n "x"))])), bi)]

753+ pexp (PRef bi (n "x"))])), bi, [])]

712− where n a = MN 0 a

754+ where n a = sMN 0 a

713eqOpts = []

755eqOpts = []

714

756

715−elimName = UN "__Elim"

757+elimName = sUN "__Elim"

716−elimMethElimTy = UN "__elimTy"

758+elimMethElimTy = sUN "__elimTy"

717−elimMethElim = UN "elim"

759+elimMethElim = sUN "elim"

718−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(UN "scrutineeType", PType)]

760+elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

719 [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,

761 [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,

720 PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

762 PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

721

763

722-- Defined in builtins.idr

764-- Defined in builtins.idr

723−sigmaTy = UN "Exists"

765+sigmaTy = sUN "Exists"

724−existsCon = UN "Ex_intro"

766+existsCon = sUN "Ex_intro"

725

767

726piBind :: [(Name, PTerm)] -> PTerm -> PTerm

768piBind :: [(Name, PTerm)] -> PTerm -> PTerm

727piBind = piBindp expl

769piBind = piBindp expl

@@ -859,7 +901,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

859 updateps yn nm [] = []

901 updateps yn nm [] = []

860 updateps yn nm (((a, t), i):as)

902 updateps yn nm (((a, t), i):as)

861 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

903 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

862− | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as

904+ | otherwise = (sMN i (show n ++ "_u"), t) : updateps yn nm as

863

905

864 removeBound lhs ns = ns \\ nub (bnames lhs)

906 removeBound lhs ns = ns \\ nub (bnames lhs)

865

907

@@ -879,8 +921,8 @@ expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

879 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

921 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

880 (map econ cons)

922 (map econ cons)

881 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

923 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

882− econ (doc, n, t, fc)

924+ econ (doc, n, t, fc, fs)

883− = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc)

925+ = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

884expandParamsD rhs ist dec ps ns (PParams f params pds)

926expandParamsD rhs ist dec ps ns (PParams f params pds)

885 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

927 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

886 (map (expandParamsD True ist dec ps ns) pds)

928 (map (expandParamsD True ist dec ps ns) pds)

@@ -998,7 +1040,7 @@ addUsingConstraints syn fc t

998 -- if all of args in ns, then add it

1040 -- if all of args in ns, then add it

999 doAdd (UConstraint c args : cs) ns t

1041 doAdd (UConstraint c args : cs) ns t

1000 | all (\n -> elem n ns) args

1042 | all (\n -> elem n ns) args

1001− = PPi (Constraint False Dynamic "") (MN 0 "cu")

1043+ = PPi (Constraint False Dynamic "") (sMN 0 "cu")

1002 (mkConst c args) (doAdd cs ns t)

1044 (mkConst c args) (doAdd cs ns t)

1003 | otherwise = doAdd cs ns t

1045 | otherwise = doAdd cs ns t

1004

1046

@@ -1068,7 +1110,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1068 imps top env (PPi (Imp l _ doc _) n ty sc)

1110 imps top env (PPi (Imp l _ doc _) n ty sc)

1069 = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

1111 = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

1070 (decls , ns) <- get

1112 (decls , ns) <- get

1071− put (PImp (getPriority ist ty) True l n ty doc : decls,

1113+ put (PImp (getPriority ist ty) True l n Placeholder doc : decls,

1072 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1114 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1073 imps True (n:env) sc

1115 imps True (n:env) sc

1074 imps top env (PPi (Exp l _ doc _) n ty sc)

1116 imps top env (PPi (Exp l _ doc _) n ty sc)

@@ -1076,7 +1118,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1076 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1118 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1077 _ -> [])

1119 _ -> [])

1078 (decls, ns) <- get -- ignore decls in HO types

1120 (decls, ns) <- get -- ignore decls in HO types

1079− put (PExp (getPriority ist ty) l ty doc : decls,

1121+ put (PExp (getPriority ist ty) l Placeholder doc : decls,

1080 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1122 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1081 imps True (n:env) sc

1123 imps True (n:env) sc

1082 imps top env (PPi (Constraint l _ doc) n ty sc)

1124 imps top env (PPi (Constraint l _ doc) n ty sc)

@@ -1084,7 +1126,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1084 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1126 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1085 _ -> [])

1127 _ -> [])

1086 (decls, ns) <- get -- ignore decls in HO types

1128 (decls, ns) <- get -- ignore decls in HO types

1087− put (PConstraint 10 l ty doc : decls,

1129+ put (PConstraint 10 l Placeholder doc : decls,

1088 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1130 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1089 imps True (n:env) sc

1131 imps True (n:env) sc

1090 imps top env (PPi (TacImp l _ scr doc) n ty sc)

1132 imps top env (PPi (TacImp l _ scr doc) n ty sc)

@@ -1092,7 +1134,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1092 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1134 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1093 _ -> [])

1135 _ -> [])

1094 (decls, ns) <- get -- ignore decls in HO types

1136 (decls, ns) <- get -- ignore decls in HO types

1095− put (PTacImplicit 10 l n scr ty doc : decls,

1137+ put (PTacImplicit 10 l n scr Placeholder doc : decls,

1096 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1138 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1097 imps True (n:env) sc

1139 imps True (n:env) sc

1098 imps top env (PEq _ l r)

1140 imps top env (PEq _ l r)

@@ -1154,71 +1196,84 @@ addImpl = addImpl' False [] []

1154-- and *not* inside a PHidden

1196-- and *not* inside a PHidden

1155

1197

1156addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

1198addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

1157−addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

1199+addImpl' inpat env infns ist ptm

1200+ = mkUniqueNames env (ai (zip env (repeat Nothing)) [] ptm)

1158 where

1201 where

1159− ai env (PRef fc f)

1202+ ai env ds (PRef fc f)

1160 | f `elem` infns = PInferRef fc f

1203 | f `elem` infns = PInferRef fc f

1161− | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f []

1204+ | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f ds []

1162− ai env (PHidden (PRef fc f))

1205+ ai env ds (PHidden (PRef fc f))

1163− | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f []

1206+ | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f ds []

1164− ai env (PEq fc l r) = let l' = ai env l

1207+ ai env ds (PEq fc l r)

1208+ = let l' = ai env ds l

1165− r' = ai env r in

1209+ r' = ai env ds r in

1166− PEq fc l' r'

1210+ PEq fc l' r'

1167− ai env (PRewrite fc l r g) = let l' = ai env l

1211+ ai env ds (PRewrite fc l r g)

1212+ = let l' = ai env ds l

1168− r' = ai env r

1213+ r' = ai env ds r

1169− g' = fmap (ai env) g in

1214+ g' = fmap (ai env ds) g in

1170− PRewrite fc l' r' g'

1215+ PRewrite fc l' r' g'

1171− ai env (PTyped l r) = let l' = ai env l

1216+ ai env ds (PTyped l r)

1217+ = let l' = ai env ds l

1172− r' = ai env r in

1218+ r' = ai env ds r in

1173− PTyped l' r'

1219+ PTyped l' r'

1174− ai env (PPair fc l r) = let l' = ai env l

1220+ ai env ds (PPair fc l r)

1221+ = let l' = ai env ds l

1175− r' = ai env r in

1222+ r' = ai env ds r in

1176− PPair fc l' r'

1223+ PPair fc l' r'

1177− ai env (PDPair fc l t r) = let l' = ai env l

1224+ ai env ds (PDPair fc l t r)

1225+ = let l' = ai env ds l

1178− t' = ai env t

1226+ t' = ai env ds t

1179− r' = ai env r in

1227+ r' = ai env ds r in

1180− PDPair fc l' t' r'

1228+ PDPair fc l' t' r'

1181− ai env (PAlternative a as) = let as' = map (ai env) as in

1229+ ai env ds (PAlternative a as)

1230+ = let as' = map (ai env ds) as in

1182− PAlternative a as'

1231+ PAlternative a as'

1232+ ai env _ (PDisamb ds' as) = ai env ds' as

1183− ai env (PApp fc (PInferRef _ f) as)

1233+ ai env ds (PApp fc (PInferRef _ f) as)

1184− = let as' = map (fmap (ai env)) as in

1234+ = let as' = map (fmap (ai env ds)) as in

1185 PApp fc (PInferRef fc f) as'

1235 PApp fc (PInferRef fc f) as'

1186− ai env (PApp fc ftm@(PRef _ f) as)

1236+ ai env ds (PApp fc ftm@(PRef _ f) as)

1187− | f `elem` infns = ai env (PApp fc (PInferRef fc f) as)

1237+ | f `elem` infns = ai env ds (PApp fc (PInferRef fc f) as)

1188 | not (f `elem` map fst env)

1238 | not (f `elem` map fst env)

1189− = let as' = map (fmap (ai env)) as in

1239+ = let as' = map (fmap (ai env ds)) as in

1190− handleErr $ aiFn inpat False ist fc f as'

1240+ handleErr $ aiFn inpat False ist fc f ds as'

1191− | Just (Just ty) <- lookup f env

1241+ | Just (Just ty) <- lookup f env =

1192− = let as' = map (fmap (ai env)) as

1242+ let as' = map (fmap (ai env ds)) as

1193− arity = getPArity ty in

1243+ arity = getPArity ty in

1194− mkPApp fc arity ftm as'

1244+ mkPApp fc arity ftm as'

1195− ai env (PApp fc f as) = let f' = ai env f

1245+ ai env ds (PApp fc f as)

1246+ = let f' = ai env ds f

1196− as' = map (fmap (ai env)) as in

1247+ as' = map (fmap (ai env ds)) as in

1197− mkPApp fc 1 f' as'

1248+ mkPApp fc 1 f' as'

1198− ai env (PCase fc c os) = let c' = ai env c

1249+ ai env ds (PCase fc c os)

1250+ = let c' = ai env ds c

1199− os' = map (pmap (ai env)) os in

1251+ os' = map (pmap (ai env ds)) os in

1200− PCase fc c' os'

1252+ PCase fc c' os'

1201− ai env (PLam n ty sc) = let ty' = ai env ty

1253+ ai env ds (PLam n ty sc)

1254+ = let ty' = ai env ds ty

1202− sc' = ai ((n, Just ty):env) sc in

1255+ sc' = ai ((n, Just ty):env) ds sc in

1203− PLam n ty' sc'

1256+ PLam n ty' sc'

1204− ai env (PLet n ty val sc)

1257+ ai env ds (PLet n ty val sc)

1205− = let ty' = ai env ty

1258+ = let ty' = ai env ds ty

1206− val' = ai env val

1259+ val' = ai env ds val

1207− sc' = ai ((n, Just ty):env) sc in

1260+ sc' = ai ((n, Just ty):env) ds sc in

1208− PLet n ty' val' sc'

1261+ PLet n ty' val' sc'

1209− ai env (PPi p n ty sc) = let ty' = ai env ty

1262+ ai env ds (PPi p n ty sc)

1263+ = let ty' = ai env ds ty

1210− sc' = ai ((n, Just ty):env) sc in

1264+ sc' = ai ((n, Just ty):env) ds sc in

1211− PPi p n ty' sc'

1265+ PPi p n ty' sc'

1212− ai env (PGoal fc r n sc) = let r' = ai env r

1266+ ai env ds (PGoal fc r n sc)

1267+ = let r' = ai env ds r

1213− sc' = ai ((n, Nothing):env) sc in

1268+ sc' = ai ((n, Nothing):env) ds sc in

1214− PGoal fc r' n sc'

1269+ PGoal fc r' n sc'

1215− ai env (PHidden tm) = PHidden (ai env tm)

1270+ ai env ds (PHidden tm) = PHidden (ai env ds tm)

1216− ai env (PProof ts) = PProof (map (fmap (ai env)) ts)

1271+ ai env ds (PProof ts) = PProof (map (fmap (ai env ds)) ts)

1217− ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts)

1272+ ai env ds (PTactics ts) = PTactics (map (fmap (ai env ds)) ts)

1218− ai env (PRefl fc tm) = PRefl fc (ai env tm)

1273+ ai env ds (PRefl fc tm) = PRefl fc (ai env ds tm)

1219− ai env (PUnifyLog tm) = PUnifyLog (ai env tm)

1274+ ai env ds (PUnifyLog tm) = PUnifyLog (ai env ds tm)

1220− ai env (PNoImplicits tm) = PNoImplicits (ai env tm)

1275+ ai env ds (PNoImplicits tm) = PNoImplicits (ai env ds tm)

1221− ai env tm = tm

1276+ ai env ds tm = tm

1222

1277

1223 handleErr (Left err) = PElabError err

1278 handleErr (Left err) = PElabError err

1224 handleErr (Right x) = x

1279 handleErr (Right x) = x

@@ -1226,8 +1281,8 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

1226-- if in a pattern, and there are no arguments, and there's no possible

1281-- if in a pattern, and there are no arguments, and there's no possible

1227-- names with zero explicit arguments, don't add implicits.

1282-- names with zero explicit arguments, don't add implicits.

1228

1283

1229−aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm

1284+aiFn :: Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm

1230−aiFn inpat True ist fc f []

1285+aiFn inpat True ist fc f ds []

1231 = case lookupDef f (tt_ctxt ist) of

1286 = case lookupDef f (tt_ctxt ist) of

1232 [] -> Right $ PPatvar fc f

1287 [] -> Right $ PPatvar fc f

1233 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1288 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

@@ -1235,7 +1290,7 @@ aiFn inpat True ist fc f []

1235 if (not (vname f) || tcname f

1290 if (not (vname f) || tcname f

1236 || any (conCaf (tt_ctxt ist)) ialts)

1291 || any (conCaf (tt_ctxt ist)) ialts)

1237-- any constructor alts || any allImp ialts))

1292-- any constructor alts || any allImp ialts))

1238− then aiFn inpat False ist fc f [] -- use it as a constructor

1293+ then aiFn inpat False ist fc f ds [] -- use it as a constructor

1239 else Right $ PPatvar fc f

1294 else Right $ PPatvar fc f

1240 where imp (PExp _ _ _ _) = False

1295 where imp (PExp _ _ _ _) = False

1241 imp _ = True

1296 imp _ = True

@@ -1249,22 +1304,32 @@ aiFn inpat True ist fc f []

1249 vname (UN n) = True -- non qualified

1304 vname (UN n) = True -- non qualified

1250 vname _ = False

1305 vname _ = False

1251

1306

1252−aiFn inpat expat ist fc f as

1307+aiFn inpat expat ist fc f ds as

1253 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

1308 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

1254−aiFn inpat expat ist fc f as

1309+aiFn inpat expat ist fc f ds as

1255 -- This is where namespaces get resolved by adding PAlternative

1310 -- This is where namespaces get resolved by adding PAlternative

1256 = do let ns = lookupCtxtName f (idris_implicits ist)

1311 = do let ns = lookupCtxtName f (idris_implicits ist)

1257− let ns' = filter (\(n, _) -> notHidden n) ns

1312+ let nh = filter (\(n, _) -> notHidden n) ns

1313+ let ns' = case trimAlts ds nh of

1314+ [] -> nh

1315+ x -> x

1258 case ns' of

1316 case ns' of

1259 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

1317 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

1260 [] -> if f `elem` (map fst (idris_metavars ist))

1318 [] -> if f `elem` (map fst (idris_metavars ist))

1261 then Right $ PApp fc (PRef fc f) as

1319 then Right $ PApp fc (PRef fc f) as

1262 else Right $ mkPApp fc (length as) (PRef fc f) as

1320 else Right $ mkPApp fc (length as) (PRef fc f) as

1263 alts -> Right $

1321 alts -> Right $

1264− PAlternative True $

1322+ PAlternative True $

1265− map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1323+ map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1266− (insertImpl ns as)) alts

1324+ (insertImpl ns as)) alts

1267 where

1325 where

1326+ trimAlts [] alts = alts

1327+ trimAlts ns alts

1328+ = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts

1329+

1330+ nspace (NS _ s) = s

1331+ nspace _ = []

1332+

1268 notHidden n = case getAccessibility n of

1333 notHidden n = case getAccessibility n of

1269 Hidden -> False

1334 Hidden -> False

1270 _ -> True

1335 _ -> True

@@ -1286,7 +1351,8 @@ aiFn inpat expat ist fc f as

1286 case find n given [] of

1351 case find n given [] of

1287 Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'

1352 Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'

1288 Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1353 Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1289− insertImpl (PTacImplicit p l n sc ty d : ps) given =

1354+ insertImpl (PTacImplicit p l n sc' ty d : ps) given =

1355+ let sc = addImpl ist sc' in

1290 case find n given [] of

1356 case find n given [] of

1291 Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

1357 Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

1292 Nothing -> if inpat

1358 Nothing -> if inpat

@@ -1422,12 +1488,14 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1422 fullApp x = x

1488 fullApp x = x

1423

1489

1424 match' x y = match (fullApp x) (fullApp y)

1490 match' x y = match (fullApp x) (fullApp y)

1425− match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x'

1491+ match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x'

1492+ | fi == txt "fromInteger" && b == txt "builtins",

1426− | PConstant (I _) <- getTm x = match (getTm x) x'

1493+ PConstant (I _) <- getTm x = match (getTm x) x'

1427− match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x])

1494+ match x' (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x])

1495+ | fi == txt "fromInteger" && b == txt "builtins",

1428− | PConstant (I _) <- getTm x = match (getTm x) x'

1496+ PConstant (I _) <- getTm x = match (getTm x) x'

1429− match (PApp _ (PRef _ (UN "lazy")) [_,x]) x' = match (getTm x) x'

1497+ match (PApp _ (PRef _ (UN l)) [_,x]) x' | l == txt "lazy" = match (getTm x) x'

1430− match x (PApp _ (PRef _ (UN "lazy")) [_,x']) = match x (getTm x')

1498+ match x (PApp _ (PRef _ (UN l)) [_,x']) | l == txt "lazy" = match x (getTm x')

1431 match (PApp _ f args) (PApp _ f' args')

1499 match (PApp _ f args) (PApp _ f' args')

1432 | length args == length args'

1500 | length args == length args'

1433 = do mf <- match' f f'

1501 = do mf <- match' f f'

@@ -1558,9 +1626,11 @@ substMatchShadow n shs tm t = sm shs t where

1558shadow :: Name -> Name -> PTerm -> PTerm

1626shadow :: Name -> Name -> PTerm -> PTerm

1559shadow n n' t = sm t where

1627shadow n n' t = sm t where

1560 sm (PRef fc x) | n == x = PRef fc n'

1628 sm (PRef fc x) | n == x = PRef fc n'

1561− sm (PLam x t sc) = PLam x (sm t) (sm sc)

1629+ sm (PLam x t sc) | n /= x = PLam x (sm t) (sm sc)

1562− sm (PPi p x t sc) = PPi p x (sm t) (sm sc)

1630+ sm (PPi p x t sc) | n /=x = PPi p x (sm t) (sm sc)

1631+ sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc)

1563 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1632 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1633+ sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

1564 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

1634 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

1565 sm (PEq f x y) = PEq f (sm x) (sm y)

1635 sm (PEq f x y) = PEq f (sm x) (sm y)

1566 sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)

1636 sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)

@@ -1568,9 +1638,87 @@ shadow n n' t = sm t where

1568 sm (PPair f x y) = PPair f (sm x) (sm y)

1638 sm (PPair f x y) = PPair f (sm x) (sm y)

1569 sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)

1639 sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)

1570 sm (PAlternative a as) = PAlternative a (map sm as)

1640 sm (PAlternative a as) = PAlternative a (map sm as)

1641+ sm (PTactics ts) = PTactics (map (fmap sm) ts)

1642+ sm (PProof ts) = PProof (map (fmap sm) ts)

1571 sm (PHidden x) = PHidden (sm x)

1643 sm (PHidden x) = PHidden (sm x)

1572 sm (PUnifyLog x) = PUnifyLog (sm x)

1644 sm (PUnifyLog x) = PUnifyLog (sm x)

1573 sm (PNoImplicits x) = PNoImplicits (sm x)

1645 sm (PNoImplicits x) = PNoImplicits (sm x)

1574 sm x = x

1646 sm x = x

1575

1647

1648+-- Rename any binders which are repeated (so that we don't have to mess

1649+-- about with shadowing anywhere else).

1650+

1651+mkUniqueNames :: [Name] -> PTerm -> PTerm

1652+mkUniqueNames env tm = evalState (mkUniq tm) env where

1653+ inScope = boundNamesIn tm

1654+

1655+ mkUniqA arg = do t' <- mkUniq (getTm arg)

1656+ return (arg { getTm = t' })

1657+

1658+ -- FIXME: Probably ought to do this for completeness! It's fine as

1659+ -- long as there are no bindings inside tactics though.

1660+ mkUniqT tac = return tac

1661+

1662+ mkUniq :: PTerm -> State [Name] PTerm

1663+ mkUniq (PLam n ty sc)

1664+ = do env <- get

1665+ (n', sc') <-

1666+ if n `elem` env

1667+ then do let n' = uniqueName n (env ++ inScope)

1668+ return (n', shadow n n' sc)

1669+ else return (n, sc)

1670+ put (n' : env)

1671+ ty' <- mkUniq ty

1672+ sc'' <- mkUniq sc'

1673+ return $! PLam n' ty' sc''

1674+ mkUniq (PPi p n ty sc)

1675+ = do env <- get

1676+ (n', sc') <-

1677+ if n `elem` env

1678+ then do let n' = uniqueName n (env ++ inScope)

1679+ return (n', shadow n n' sc)

1680+ else return (n, sc)

1681+ put (n' : env)

1682+ ty' <- mkUniq ty

1683+ sc'' <- mkUniq sc'

1684+ return $! PPi p n' ty' sc''

1685+ mkUniq (PLet n ty val sc)

1686+ = do env <- get

1687+ (n', sc') <-

1688+ if n `elem` env

1689+ then do let n' = uniqueName n (env ++ inScope)

1690+ return (n', shadow n n' sc)

1691+ else return (n, sc)

1692+ put (n' : env)

1693+ ty' <- mkUniq ty; val' <- mkUniq val

1694+ sc'' <- mkUniq sc'

1695+ return $! PLet n' ty' val' sc''

1696+ mkUniq (PApp fc t args)

1697+ = do t' <- mkUniq t

1698+ args' <- mapM mkUniqA args

1699+ return $! PApp fc t' args'

1700+ mkUniq (PAppBind fc t args)

1701+ = do t' <- mkUniq t

1702+ args' <- mapM mkUniqA args

1703+ return $! PAppBind fc t' args'

1704+ mkUniq (PCase fc t alts)

1705+ = do t' <- mkUniq t

1706+ alts' <- mapM (\(x,y)-> do x' <- mkUniq x; y' <- mkUniq y

1707+ return (x', y')) alts

1708+ return $! PCase fc t' alts'

1709+ mkUniq (PPair fc l r)

1710+ = do l' <- mkUniq l; r' <- mkUniq r

1711+ return $! PPair fc l' r'

1712+ mkUniq (PDPair fc l t r)

1713+ = do l' <- mkUniq l; t' <- mkUniq t; r' <- mkUniq r

1714+ return $! PDPair fc l' t' r'

1715+ mkUniq (PAlternative b as)

1716+ = liftM (PAlternative b) (mapM mkUniq as)

1717+ mkUniq (PHidden t) = liftM PHidden (mkUniq t)

1718+ mkUniq (PUnifyLog t) = liftM PUnifyLog (mkUniq t)

1719+ mkUniq (PDisamb n t) = liftM (PDisamb n) (mkUniq t)

1720+ mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

1721+ mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

1722+ mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

1723+ mkUniq t = return t

1576

1724

src/Idris/AbsSyntaxTree.hs+67−27

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Error

25import Data.List

26import Data.Char

27+import qualified Data.Text as T

27import Data.Either

28import Data.Either

28import Data.Word (Word)

29import Data.Word (Word)

@@ -131,7 +132,9 @@ data IState = IState {

131 idris_outputmode :: OutputMode,

132 idris_outputmode :: OutputMode,

132 idris_colourRepl :: Bool,

133 idris_colourRepl :: Bool,

133 idris_colourTheme :: ColourTheme,

134 idris_colourTheme :: ColourTheme,

134− idris_outh :: Handle

135+ idris_outh :: Handle,

136+ idris_errorhandlers :: [Name],

137+ idris_nameIdx :: (Int, Ctxt (Int, Name))

135 }

138 }

136

139

137data SizeChange = Smaller | Same | Bigger | Unknown

140data SizeChange = Smaller | Same | Bigger | Unknown

@@ -154,10 +157,10 @@ deriving instance Binary CGInfo

154deriving instance NFData CGInfo

157deriving instance NFData CGInfo

155!-}

158!-}

156

159

157−primDefs = [UN "unsafePerformPrimIO",

160+primDefs = [sUN "unsafePerformPrimIO",

158− UN "mkLazyForeignPrim",

161+ sUN "mkLazyForeignPrim",

159− UN "mkForeignPrim",

162+ sUN "mkForeignPrim",

160− UN "FalseElim"]

163+ sUN "FalseElim"]

161

164

162-- information that needs writing for the current module's .ibc file

165-- information that needs writing for the current module's .ibc file

163data IBCWrite = IBCFix FixDecl

166data IBCWrite = IBCFix FixDecl

@@ -189,13 +192,15 @@ data IBCWrite = IBCFix FixDecl

189 | IBCLineApp FilePath Int PTerm

192 | IBCLineApp FilePath Int PTerm

190 deriving Show

193 deriving Show

191

194

195+-- | The initial state for the compiler

196+idrisInit :: IState

192idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

197idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

193 emptyContext emptyContext emptyContext emptyContext

198 emptyContext emptyContext emptyContext emptyContext

194 emptyContext emptyContext emptyContext emptyContext

199 emptyContext emptyContext emptyContext emptyContext

195 emptyContext

200 emptyContext

196 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

201 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

197 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

202 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

198− True defaultTheme stdout

203+ True defaultTheme stdout [] (0, emptyContext)

199

204

200-- | The monad for the main REPL - reading and processing files and updating

205-- | The monad for the main REPL - reading and processing files and updating

201-- global state (hence the IO inner monad).

206-- global state (hence the IO inner monad).

@@ -258,6 +263,7 @@ data Command = Quit

258 | SetColour ColourType IdrisColour

263 | SetColour ColourType IdrisColour

259 | ColourOn

264 | ColourOn

260 | ColourOff

265 | ColourOff

266+ | ListErrorHandlers

261

267

262data Opt = Filename String

268data Opt = Filename String

263 | Ver

269 | Ver

@@ -289,6 +295,7 @@ data Opt = Filename String

289 | PkgBuild String

295 | PkgBuild String

290 | PkgInstall String

296 | PkgInstall String

291 | PkgClean String

297 | PkgClean String

298+ | PkgCheck String

292 | WarnOnly

299 | WarnOnly

293 | Pkg String

300 | Pkg String

294 | BCAsm String

301 | BCAsm String

@@ -380,6 +387,7 @@ data FnOpt = Inlinable -- always evaluate when simplifying

380 -- a function argument, and further evaluation resutls

387 -- a function argument, and further evaluation resutls

381 | Implicit -- implicit coercion

388 | Implicit -- implicit coercion

382 | CExport String -- export, with a C name

389 | CExport String -- export, with a C name

390+ | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension

383 | Reflection -- a reflecting function, compile-time only

391 | Reflection -- a reflecting function, compile-time only

384 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

392 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

385 deriving (Show, Eq)

393 deriving (Show, Eq)

@@ -470,7 +478,7 @@ deriving instance NFData PClause'

470-- | Data declaration

478-- | Data declaration

471data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

479data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

472 d_tcon :: t, -- ^ Type constructor

480 d_tcon :: t, -- ^ Type constructor

473− d_cons :: [(String, Name, t, FC)] -- ^ Constructors

481+ d_cons :: [(String, Name, t, FC, [Name])] -- ^ Constructors

474 }

482 }

475 -- ^ Data declaration

483 -- ^ Data declaration

476 | PLaterdecl { d_name :: Name, d_tcon :: t }

484 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -497,7 +505,7 @@ declared (PPostulate _ _ _ _ n t) = [n]

497declared (PClauses _ _ n _) = [] -- not a declaration

505declared (PClauses _ _ n _) = [] -- not a declaration

498declared (PCAF _ n _) = [n]

506declared (PCAF _ n _) = [n]

499declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

507declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

500− where fstt (_, a, _, _) = a

508+ where fstt (_, a, _, _, _) = a

501declared (PData _ _ _ _ (PLaterdecl n _)) = [n]

509declared (PData _ _ _ _ (PLaterdecl n _)) = [n]

502declared (PParams _ _ ds) = concatMap declared ds

510declared (PParams _ _ ds) = concatMap declared ds

503declared (PNamespace _ ds) = concatMap declared ds

511declared (PNamespace _ ds) = concatMap declared ds

@@ -517,7 +525,7 @@ tldeclared (PPostulate _ _ _ _ n t) = [n]

517tldeclared (PClauses _ _ n _) = [] -- not a declaration

525tldeclared (PClauses _ _ n _) = [] -- not a declaration

518tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

526tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

519tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

527tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

520− where fstt (_, a, _, _) = a

528+ where fstt (_, a, _, _, _) = a

521tldeclared (PParams _ _ ds) = []

529tldeclared (PParams _ _ ds) = []

522tldeclared (PMutual _ ds) = concatMap tldeclared ds

530tldeclared (PMutual _ ds) = concatMap tldeclared ds

523tldeclared (PNamespace _ ds) = concatMap tldeclared ds

531tldeclared (PNamespace _ ds) = concatMap tldeclared ds

@@ -532,7 +540,7 @@ defined (PPostulate _ _ _ _ n t) = []

532defined (PClauses _ _ n _) = [n] -- not a declaration

540defined (PClauses _ _ n _) = [n] -- not a declaration

533defined (PCAF _ n _) = [n]

541defined (PCAF _ n _) = [n]

534defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

542defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

535− where fstt (_, a, _, _) = a

543+ where fstt (_, a, _, _, _) = a

536defined (PData _ _ _ _ (PLaterdecl n _)) = []

544defined (PData _ _ _ _ (PLaterdecl n _)) = []

537defined (PParams _ _ ds) = concatMap defined ds

545defined (PParams _ _ ds) = concatMap defined ds

538defined (PNamespace _ ds) = concatMap defined ds

546defined (PNamespace _ ds) = concatMap defined ds

@@ -602,6 +610,7 @@ data PTerm = PQuote Raw

602 | PElabError Err -- ^ Error to report on elaboration

610 | PElabError Err -- ^ Error to report on elaboration

603 | PImpossible -- ^ Special case for declaring when an LHS can't typecheck

611 | PImpossible -- ^ Special case for declaring when an LHS can't typecheck

604 | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice

612 | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice

613+ | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces

605 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

614 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

606 | PNoImplicits PTerm -- ^ never run implicit converions on the term

615 | PNoImplicits PTerm -- ^ never run implicit converions on the term

607 deriving Eq

616 deriving Eq

@@ -632,6 +641,7 @@ mapPT f t = f (mpt t) where

632 mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

641 mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

633 mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

642 mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

634 mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

643 mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

644+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

635 mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

645 mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

636 mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

646 mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

637 mpt x = x

647 mpt x = x

@@ -838,10 +848,10 @@ deriving instance Binary SSymbol

838deriving instance NFData SSymbol

848deriving instance NFData SSymbol

839!-}

849!-}

840

850

841−initDSL = DSL (PRef f (UN ">>="))

851+initDSL = DSL (PRef f (sUN ">>="))

842− (PRef f (UN "return"))

852+ (PRef f (sUN "return"))

843− (PRef f (UN "<$>"))

853+ (PRef f (sUN "<$>"))

844− (PRef f (UN "pure"))

854+ (PRef f (sUN "pure"))

845 Nothing

855 Nothing

846 Nothing

856 Nothing

847 Nothing

857 Nothing

@@ -877,7 +887,7 @@ expandNS :: SyntaxInfo -> Name -> Name

877expandNS syn n@(NS _ _) = n

887expandNS syn n@(NS _ _) = n

878expandNS syn n = case syn_namespace syn of

888expandNS syn n = case syn_namespace syn of

879 [] -> n

889 [] -> n

880− xs -> NS n xs

890+ xs -> sNS n xs

881

891

882

892

883--- Pretty printing declarations and terms

893--- Pretty printing declarations and terms

@@ -935,7 +945,7 @@ showDImp :: Bool -> PData -> String

935showDImp impl (PDatadecl n ty cons)

945showDImp impl (PDatadecl n ty cons)

936 = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t"

946 = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t"

937 ++ showSep "\n\t| "

947 ++ showSep "\n\t| "

938− (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

948+ (map (\ (_, n, t, _, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

939

949

940getImps :: [PArg] -> [(Name, PTerm)]

950getImps :: [PArg] -> [(Name, PTerm)]

941getImps [] = []

951getImps [] = []

@@ -974,8 +984,8 @@ prettyImp impl = prettySe 10

974 prettyBasic n

984 prettyBasic n

975 where

985 where

976 prettyBasic n@(UN _) = pretty n

986 prettyBasic n@(UN _) = pretty n

977− prettyBasic (MN _ s) = text s

987+ prettyBasic (MN _ s) = text (str s)

978− prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map text $ reverse s))) <> prettyBasic n

988+ prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map (text.str) $ reverse s))) <> prettyBasic n

979 prettyBasic (SN sn) = text (show sn)

989 prettyBasic (SN sn) = text (show sn)

980 prettySe p (PLam n ty sc) =

990 prettySe p (PLam n ty sc) =

981 bracket p 2 $

991 bracket p 2 $

@@ -1046,8 +1056,9 @@ prettyImp impl = prettySe 10

1046 | not impl = pretty f

1056 | not impl = pretty f

1047 prettySe p (PAppBind _ (PRef _ f) [])

1057 prettySe p (PAppBind _ (PRef _ f) [])

1048 | not impl = text "!" <+> pretty f

1058 | not impl = text "!" <+> pretty f

1049− prettySe p (PApp _ (PRef _ op@(UN (f:_))) args)

1059+ prettySe p (PApp _ (PRef _ op@(UN nm)) args)

1060+ | not (tnull nm) &&

1050− | length (getExps args) == 2 && (not impl) && (not $ isAlpha f) =

1061+ length (getExps args) == 2 && (not impl) && (not $ isAlpha (thead nm)) =

1051 let [l, r] = getExps args in

1062 let [l, r] = getExps args in

1052 bracket p 1 $

1063 bracket p 1 $

1053 if size r > breakingSize then

1064 if size r > breakingSize then

@@ -1160,8 +1171,8 @@ showName ist bnd impl colour n = case ist of

1160 Nothing -> showbasic n

1171 Nothing -> showbasic n

1161 where name = if impl then show n else showbasic n

1172 where name = if impl then show n else showbasic n

1162 showbasic n@(UN _) = showCG n

1173 showbasic n@(UN _) = showCG n

1163− showbasic (MN _ s) = s

1174+ showbasic (MN _ s) = str s

1164− showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

1175+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

1165 showbasic (SN s) = show s

1176 showbasic (SN s) = show s

1166 fst3 (x, _, _) = x

1177 fst3 (x, _, _) = x

1167 colourise n t = let ctxt' = fmap tt_ctxt ist in

1178 colourise n t = let ctxt' = fmap tt_ctxt ist in

@@ -1235,8 +1246,9 @@ showImp ist impl colour tm = se 10 [] tm where

1235 | not impl = se p bnd hd

1246 | not impl = se p bnd hd

1236 se p bnd (PAppBind _ hd@(PRef _ f) [])

1247 se p bnd (PAppBind _ hd@(PRef _ f) [])

1237 | not impl = "!" ++ se p bnd hd

1248 | not impl = "!" ++ se p bnd hd

1238− se p bnd (PApp _ op@(PRef _ (UN (f:_))) args)

1249+ se p bnd (PApp _ op@(PRef _ (UN nm)) args)

1250+ | not (tnull nm) &&

1239− | length (getExps args) == 2 && not impl && not (isAlpha f)

1251+ length (getExps args) == 2 && not impl && not (isAlpha (thead nm))

1240 = let [l, r] = getExps args in

1252 = let [l, r] = getExps args in

1241 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

1253 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

1242 se p bnd (PApp _ f as)

1254 se p bnd (PApp _ f as)

@@ -1280,13 +1292,14 @@ showImp ist impl colour tm = se 10 [] tm where

1280 se p bnd (PElabError s) = show s

1292 se p bnd (PElabError s) = show s

1281 se p bnd (PCoerced t) = se p bnd t

1293 se p bnd (PCoerced t) = se p bnd t

1282 se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t

1294 se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t

1295+ se p bnd (PDisamb ns t) = "%disamb " ++ show ns ++ se p bnd t

1283 se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t

1296 se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t

1284-- se p bnd x = "Not implemented"

1297-- se p bnd x = "Not implemented"

1285

1298

1286 slist' p bnd (PApp _ (PRef _ nil) _)

1299 slist' p bnd (PApp _ (PRef _ nil) _)

1287− | not impl && nsroot nil == UN "Nil" = Just []

1300+ | not impl && nsroot nil == sUN "Nil" = Just []

1288 slist' p bnd (PApp _ (PRef _ cons) args)

1301 slist' p bnd (PApp _ (PRef _ cons) args)

1289− | nsroot cons == UN "::",

1302+ | nsroot cons == sUN "::",

1290 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1303 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1291 all isImp imps,

1304 all isImp imps,

1292 Just tl' <- slist' p bnd tl

1305 Just tl' <- slist' p bnd tl

@@ -1360,6 +1373,7 @@ instance Sized PTerm where

1360 size (PAlternative a alts) = 1 + size alts

1373 size (PAlternative a alts) = 1 + size alts

1361 size (PHidden hidden) = size hidden

1374 size (PHidden hidden) = size hidden

1362 size (PUnifyLog tm) = size tm

1375 size (PUnifyLog tm) = size tm

1376+ size (PDisamb _ tm) = size tm

1363 size (PNoImplicits tm) = size tm

1377 size (PNoImplicits tm) = size tm

1364 size PType = 1

1378 size PType = 1

1365 size (PConstant const) = 1 + size const

1379 size (PConstant const) = 1 + size const

@@ -1383,6 +1397,7 @@ allNamesIn tm = nub $ ni [] tm

1383 where

1397 where

1384 ni env (PRef _ n)

1398 ni env (PRef _ n)

1385 | not (n `elem` env) = [n]

1399 | not (n `elem` env) = [n]

1400+ ni env (PPatvar _ n) = [n]

1386 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1401 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1387 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1402 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1388 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1403 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

@@ -1397,11 +1412,34 @@ allNamesIn tm = nub $ ni [] tm

1397 ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r

1412 ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r

1398 ni env (PAlternative a ls) = concatMap (ni env) ls

1413 ni env (PAlternative a ls) = concatMap (ni env) ls

1399 ni env (PUnifyLog tm) = ni env tm

1414 ni env (PUnifyLog tm) = ni env tm

1415+ ni env (PDisamb _ tm) = ni env tm

1400 ni env (PNoImplicits tm) = ni env tm

1416 ni env (PNoImplicits tm) = ni env tm

1401 ni env _ = []

1417 ni env _ = []

1402

1418

1403−-- Return names which are free in the given term.

1419+-- Return all names defined in binders in the given term

1420+boundNamesIn :: PTerm -> [Name]

1421+boundNamesIn tm = nub $ ni tm

1422+ where

1423+ ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1424+ ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1425+ ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1426+ ni (PLam n ty sc) = n : (ni ty ++ ni sc)

1427+ ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1428+ ni (PPi _ n ty sc) = n : (ni ty ++ ni sc)

1429+ ni (PEq _ l r) = ni l ++ ni r

1430+ ni (PRewrite _ l r _) = ni l ++ ni r

1431+ ni (PTyped l r) = ni l ++ ni r

1432+ ni (PPair _ l r) = ni l ++ ni r

1433+ ni (PDPair _ (PRef _ n) t r) = ni t ++ ni r

1434+ ni (PDPair _ l t r) = ni l ++ ni t ++ ni r

1435+ ni (PAlternative a as) = concatMap (ni) as

1436+ ni (PHidden tm) = ni tm

1437+ ni (PUnifyLog tm) = ni tm

1438+ ni (PDisamb _ tm) = ni tm

1439+ ni (PNoImplicits tm) = ni tm

1440+ ni _ = []

1404

1441

1442+-- Return names which are free in the given term.

1405namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1443namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1406namesIn uvars ist tm = nub $ ni [] tm

1444namesIn uvars ist tm = nub $ ni [] tm

1407 where

1445 where

@@ -1424,6 +1462,7 @@ namesIn uvars ist tm = nub $ ni [] tm

1424 ni env (PAlternative a as) = concatMap (ni env) as

1462 ni env (PAlternative a as) = concatMap (ni env) as

1425 ni env (PHidden tm) = ni env tm

1463 ni env (PHidden tm) = ni env tm

1426 ni env (PUnifyLog tm) = ni env tm

1464 ni env (PUnifyLog tm) = ni env tm

1465+ ni env (PDisamb _ tm) = ni env tm

1427 ni env (PNoImplicits tm) = ni env tm

1466 ni env (PNoImplicits tm) = ni env tm

1428 ni env _ = []

1467 ni env _ = []

1429

1468

@@ -1451,6 +1490,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

1451 ni env (PAlternative a as) = concatMap (ni env) as

1490 ni env (PAlternative a as) = concatMap (ni env) as

1452 ni env (PHidden tm) = ni env tm

1491 ni env (PHidden tm) = ni env tm

1453 ni env (PUnifyLog tm) = ni env tm

1492 ni env (PUnifyLog tm) = ni env tm

1493+ ni env (PDisamb _ tm) = ni env tm

1454 ni env (PNoImplicits tm) = ni env tm

1494 ni env (PNoImplicits tm) = ni env tm

1455 ni env _ = []

1495 ni env _ = []

1456

1496

src/Idris/CaseSplit.hs+13−12

@@ -91,7 +91,8 @@ inventName ist ty n =

91 Nothing -> []

92 Just t -> getNameHints ist t

93 let nsupp = case n of

94+ MN i n | not (tnull n) && thead n == '_'

94− MN i ('_':_) -> mkSupply (supp ++ varlist)

95+ -> mkSupply (supp ++ varlist)

95 MN i n -> mkSupply (UN n : supp ++ varlist)

96 MN i n -> mkSupply (UN n : supp ++ varlist)

96 x -> mkSupply (x : supp)

97 x -> mkSupply (x : supp)

97 let badnames = map snd (namemap ms) ++ map snd (invented ms) ++

98 let badnames = map snd (namemap ms) ++ map snd (invented ms) ++

@@ -106,7 +107,7 @@ inventName ist ty n =

106mkSupply ns = mkSupply' ns (map nextName ns)

107mkSupply ns = mkSupply' ns (map nextName ns)

107 where mkSupply' xs ns' = xs ++ mkSupply ns'

108 where mkSupply' xs ns' = xs ++ mkSupply ns'

108

109

109−varlist = map (UN . (:[])) "xyzwstuv" -- EB's personal preference :)

110+varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

110

111

111stripNS tm = mapPT dens tm where

112stripNS tm = mapPT dens tm where

112 dens (PRef fc n) = PRef fc (nsroot n)

113 dens (PRef fc n) = PRef fc (nsroot n)

@@ -164,7 +165,7 @@ argTys ist (PRef fc n)

164 = case lookupTy n (tt_ctxt ist) of

165 = case lookupTy n (tt_ctxt ist) of

165 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166 _ -> repeat Nothing

167 _ -> repeat Nothing

167− where tyName (Bind _ (Pi _) _) = Just (UN "->")

168+ where tyName (Bind _ (Pi _) _) = Just (sUN "->")

168 tyName t | (P _ n _, _) <- unApply t = Just n

169 tyName t | (P _ n _, _) <- unApply t = Just n

169 | otherwise = Nothing

170 | otherwise = Nothing

170argTys _ _ = repeat Nothing

171argTys _ _ = repeat Nothing

@@ -264,8 +265,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

264

265

265 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266 -- this isn't supported in a pattern, so special case here

267 -- this isn't supported in a pattern, so special case here

267− nshow (PRef _ (UN "Z")) = "Z"

268+ nshow (PRef _ (UN z)) | z == txt "Z" = "Z"

268− nshow (PApp _ (PRef _ (UN "S")) [x]) =

269+ nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" =

269 "S " ++ addBrackets (nshow (getTm x))

270 "S " ++ addBrackets (nshow (getTm x))

270 nshow t = show t

271 nshow t = show t

271

272

@@ -296,7 +297,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

296getUniq nm i

297getUniq nm i

297 = do ist <- getIState

298 = do ist <- getIState

298 let n = nameRoot [] nm ++ "_" ++ show i

299 let n = nameRoot [] nm ++ "_" ++ show i

299− case lookupTy (UN n) (tt_ctxt ist) of

300+ case lookupTy (sUN n) (tt_ctxt ist) of

300 [] -> return (n, i+1)

301 [] -> return (n, i+1)

301 _ -> getUniq nm (i+1)

302 _ -> getUniq nm (i+1)

302

303

@@ -324,14 +325,14 @@ getClause l fn fp = do ty <- getInternalApp fp l

324 mkApp i _ _ = ""

325 mkApp i _ _ = ""

325

326

326 getNameFrom i used (PPi _ _ _ _)

327 getNameFrom i used (PPi _ _ _ _)

327− = uniqueNameFrom (mkSupply [UN "f", UN "g"]) used

328+ = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

328 getNameFrom i used (PApp fc f as) = getNameFrom i used f

329 getNameFrom i used (PApp fc f as) = getNameFrom i used f

329− getNameFrom i used (PEq _ _ _) = uniqueNameFrom [UN "prf"] used

330+ getNameFrom i used (PEq _ _ _) = uniqueNameFrom [sUN "prf"] used

330 getNameFrom i used (PRef fc f)

331 getNameFrom i used (PRef fc f)

331 = case getNameHints i f of

332 = case getNameHints i f of

332− [] -> uniqueName (UN "x") used

333+ [] -> uniqueName (sUN "x") used

333 ns -> uniqueNameFrom (mkSupply ns) used

334 ns -> uniqueNameFrom (mkSupply ns) used

334− getNameFrom i used _ = uniqueName (UN "x") used

335+ getNameFrom i used _ = uniqueName (sUN "x") used

335

336

336getProofClause :: Int -- ^ line number that the type is declared

337getProofClause :: Int -- ^ line number that the type is declared

337 -> Name -- ^ Function name

338 -> Name -- ^ Function name

@@ -363,11 +364,11 @@ mkWith str n = let str' = replaceRHS str "with (_)"

363nameMissing :: [PTerm] -> Idris [PTerm]

364nameMissing :: [PTerm] -> Idris [PTerm]

364nameMissing ps = do ist <- get

365nameMissing ps = do ist <- get

365 newPats <- mapM nm ps

366 newPats <- mapM nm ps

366− let newPats' = mergeAllPats ist (UN "_") (base (head ps))

367+ let newPats' = mergeAllPats ist (sUN "_") (base (head ps))

367 newPats

368 newPats

368 return (map fst newPats')

369 return (map fst newPats')

369 where

370 where

370− base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (UN "_")))) args)

371+ base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (sUN "_")))) args)

371 base t = t

372 base t = t

372

373

373 nm ptm = do mptm <- elabNewPat ptm

374 nm ptm = do mptm <- elabNewPat ptm

src/Idris/Completion.hs+3−3

@@ -54,9 +54,9 @@ tactics = map fst tacticArgs

54-- | Convert a name into a string usable for completion. Filters out names

55-- that users probably don't want to see.

56nameString :: Name -> Maybe String

57−nameString (UN ('@':_)) = Nothing

57+nameString (UN nm)

58−nameString (UN ('#':_)) = Nothing

58+ | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing

59−nameString (UN n) = Just n

59+nameString (UN n) = Just (str n)

60nameString (NS n _) = nameString n

61nameString _ = Nothing

src/Idris/Core/CaseTree.hs+10−7

@@ -21,7 +21,8 @@ data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

21 | ImpossibleCase -- ^ already checked to be impossible

22 deriving (Eq, Ord, Functor)

23{-!

24−deriving instance Binary SC

24+deriving instance Binary SC'

25+deriving instance NFData SC'

25!-}

26!-}

27type SC = SC' Term

28type SC = SC' Term

@@ -33,7 +34,8 @@ data CaseAlt' t = ConCase Name Int [Name] !(SC' t)

33 | DefaultCase !(SC' t)

34 | DefaultCase !(SC' t)

34 deriving (Show, Eq, Ord, Functor)

35 deriving (Show, Eq, Ord, Functor)

35{-!

36{-!

36−deriving instance Binary CaseAlt

37+deriving instance Binary CaseAlt'

38+deriving instance NFData CaseAlt'

37!-}

39!-}

39type CaseAlt = CaseAlt' Term

41type CaseAlt = CaseAlt' Term

@@ -155,6 +157,7 @@ directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

155directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

157directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

156directUse fn@(App f a)

158directUse fn@(App f a)

157 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

159 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

160+ | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime

158 | otherwise = nub $ directUse f ++ directUse a

161 | otherwise = nub $ directUse f ++ directUse a

159directUse (Proj x i) = nub $ directUse x

162directUse (Proj x i) = nub $ directUse x

160directUse _ = []

163directUse _ = []

@@ -214,7 +217,7 @@ simpleCase tc cover reflect phase fc argtys cs

214 then return t

217 then return t

215 else Error (At fc (Msg "Typecase is not allowed"))

218 else Error (At fc (Msg "Typecase is not allowed"))

216 Error err -> Error (At fc err)

219 Error err -> Error (At fc err)

217− where args = map (\i -> MN i "e") [0..]

220+ where args = map (\i -> sMN i "e") [0..]

218 defaultCase True = STerm Erased

221 defaultCase True = STerm Erased

219 defaultCase False = UnmatchedCase "Error"

222 defaultCase False = UnmatchedCase "Error"

220 fstT (x, _, _) = x

223 fstT (x, _, _) = x

@@ -298,8 +301,8 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

298 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

301 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

299 return $ PCon n t args'

302 return $ PCon n t args'

300 -- n + 1

303 -- n + 1

301− toPat' (P _ (UN "prim__addBigInt") _)

304+ toPat' (P _ (UN pabi) _)

302− [p, Constant (BI 1)]

305+ [p, Constant (BI 1)] | pabi == txt "prim__addBigInt"

303 = do p' <- toPat' p []

306 = do p' <- toPat' p []

304 return $ PSuc p'

307 return $ PSuc p'

305 -- Typecase

308 -- Typecase

@@ -331,7 +334,7 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

331 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

334 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

332 = do t' <- toPat' t []

335 = do t' <- toPat' t []

333 sc' <- toPat' sc []

336 sc' <- toPat' sc []

334− return $ PReflected (UN "->") (t':sc':[])

337+ return $ PReflected (sUN "->") (t':sc':[])

335 toPat' (P _ n _) args | reflect

338 toPat' (P _ n _) args | reflect

336 = do args' <- mapM (\x -> toPat' x []) args

339 = do args' <- mapM (\x -> toPat' x []) args

337 return $ PReflected n args'

340 return $ PReflected n args'

@@ -488,7 +491,7 @@ argsToAlt rs@((r, m) : rest)

488 uniq i n = n

491 uniq i n = n

489

492

490getVar :: String -> State CS Name

493getVar :: String -> State CS Name

491−getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (MN v b)

494+getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (sMN v b)

492

495

493groupCons :: [Clause] -> State CS [Group]

496groupCons :: [Clause] -> State CS [Group]

494groupCons cs = gc [] cs

497groupCons cs = gc [] cs

src/Idris/Core/Constraints.hs+1

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

2module Idris.Core.Constraints(ucheck) where

4import Idris.Core.TT

5+import Idris.Core.Typecheck

6import Control.Applicative

7import Control.Applicative

7import Control.Arrow

8import Control.Arrow

src/Idris/Core/DeepSeq.hsnew file+114

@@ -0,0 +1,114 @@

1+module Idris.Core.DeepSeq where

3+import Idris.Core.TT

4+import Idris.Core.CaseTree

6+import Control.DeepSeq

8+instance NFData Name where

9+ rnf (UN x1) = rnf x1 `seq` ()

10+ rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

11+ rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

12+ rnf NErased = ()

13+ rnf (SN x1) = rnf x1 `seq` ()

14+

15+instance NFData SpecialName where

16+ rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

17+ rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

18+ rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19+ rnf (MethodN x1) = rnf x1 `seq` ()

20+ rnf (CaseN x1) = rnf x1 `seq` ()

21+ rnf (ElimN x1) = rnf x1 `seq` ()

22+

23+instance NFData Raw where

24+ rnf (Var x1) = rnf x1 `seq` ()

25+ rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

26+ rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

27+ rnf RType = ()

28+ rnf (RForce x1) = rnf x1 `seq` ()

29+ rnf (RConstant x1) = x1 `seq` ()

30+

31+instance NFData FC where

32+ rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

33+

34+instance NFData Err where

35+ rnf (Msg x1) = rnf x1 `seq` ()

36+ rnf (InternalMsg x1) = rnf x1 `seq` ()

37+ rnf (CantUnify x1 x2 x3 x4 x5 x6)

38+ = rnf x1 `seq`

39+ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

40+ rnf (InfiniteUnify x1 x2 x3)

41+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

42+ rnf (CantConvert x1 x2 x3)

43+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

44+ rnf (UnifyScope x1 x2 x3 x4)

45+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

46+ rnf (CantInferType x1) = rnf x1 `seq` ()

47+ rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

48+ rnf (CantIntroduce x1) = rnf x1 `seq` ()

49+ rnf (NoSuchVariable x1) = rnf x1 `seq` ()

50+ rnf (NoTypeDecl x1) = rnf x1 `seq` ()

51+ rnf (NotInjective x1 x2 x3)

52+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

53+ rnf (CantResolve x1) = rnf x1 `seq` ()

54+ rnf (CantResolveAlts x1) = rnf x1 `seq` ()

55+ rnf (IncompleteTerm x1) = rnf x1 `seq` ()

56+ rnf UniverseError = ()

57+ rnf ProgramLineComment = ()

58+ rnf (Inaccessible x1) = rnf x1 `seq` ()

59+ rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

60+ rnf (AlreadyDefined x1) = rnf x1 `seq` ()

61+ rnf (ProofSearchFail x1) = rnf x1 `seq` ()

62+ rnf (NoRewriting x1) = rnf x1 `seq` ()

63+ rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

64+ rnf (Elaborating x1 x2 x3)

65+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

66+ rnf (ProviderError x1) = rnf x1 `seq` ()

67+ rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

68+

69+instance (NFData b) => NFData (Binder b) where

70+ rnf (Lam x1) = rnf x1 `seq` ()

71+ rnf (Pi x1) = rnf x1 `seq` ()

72+ rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

73+ rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74+ rnf (Hole x1) = rnf x1 `seq` ()

75+ rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

76+ rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

77+ rnf (PVar x1) = rnf x1 `seq` ()

78+ rnf (PVTy x1) = rnf x1 `seq` ()

79+

80+instance NFData UExp where

81+ rnf (UVar x1) = rnf x1 `seq` ()

82+ rnf (UVal x1) = rnf x1 `seq` ()

83+

84+instance NFData NameType where

85+ rnf Bound = ()

86+ rnf Ref = ()

87+ rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

88+ rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

89+

90+instance (NFData n) => NFData (TT n) where

91+ rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92+ rnf (V x1) = rnf x1 `seq` ()

93+ rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

94+ rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

95+ rnf (Constant x1) = x1 `seq` ()

96+ rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

97+ rnf Erased = ()

98+ rnf Impossible = ()

99+ rnf (TType x1) = rnf x1 `seq` ()

100+

101+instance (NFData t) => NFData (SC' t) where

102+ rnf (Case x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103+ rnf (ProjCase x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

104+ rnf (STerm x1) = rnf x1 `seq` ()

105+ rnf (UnmatchedCase x1) = rnf x1 `seq` ()

106+ rnf ImpossibleCase = ()

107+

108+instance (NFData t) => NFData (CaseAlt' t) where

109+ rnf (ConCase x1 x2 x3 x4)

110+ = x1 `seq` x2 `seq` x3 `seq` rnf x4 `seq` ()

111+ rnf (FnCase x1 x2 x3) = x1 `seq` x2 `seq` rnf x3 `seq` ()

112+ rnf (ConstCase x1 x2) = x1 `seq` rnf x2 `seq` ()

113+ rnf (SucCase x1 x2) = x1 `seq` rnf x2 `seq` ()

114+ rnf (DefaultCase x1) = rnf x1 `seq` ()

src/Idris/Core/Elaborate.hs+116−74

@@ -16,8 +16,10 @@ import Idris.Core.TT

16import Idris.Core.Evaluate

17import Idris.Core.Typecheck

18import Idris.Core.Unify

19+import Idris.Core.DeepSeq

20−import Control.Monad.State

21+import Control.DeepSeq

22+import Control.Monad.State.Strict

21import Data.Char

23import Data.Char

22import Data.List

24import Data.List

23import Debug.Trace

25import Debug.Trace

@@ -46,7 +48,7 @@ proofFail :: Elab' aux a -> Elab' aux a

46proofFail e = do s <- get

48proofFail e = do s <- get

47 case runStateT e s of

49 case runStateT e s of

48 OK (a, s') -> do put s'

50 OK (a, s') -> do put s'

49− return a

51+ return $! a

50 Error err -> lift $ Error (ProofSearchFail err)

52 Error err -> lift $ Error (ProofSearchFail err)

52explicit :: Name -> Elab' aux ()

54explicit :: Name -> Elab' aux ()

@@ -64,11 +66,39 @@ loadState = do (ES p s e) <- get

64 Just st -> put st

66 Just st -> put st

65 _ -> fail "Nothing to undo"

67 _ -> fail "Nothing to undo"

69+getNameFrom :: Name -> Elab' aux Name

70+getNameFrom n = do (ES (p, a) s e) <- get

71+ let next = nextname p

72+ let p' = p { nextname = next + 1 }

73+ put (ES (p', a) s e)

74+ let n' = case n of

75+ UN x -> MN (next+100) x

76+ MN i x -> if i == 99999

77+ then MN (next+500) x

78+ else MN (next+100) x

79+ NS (UN x) s -> MN (next+100) x

80+ return $! n'

81+

82+setNextName :: Elab' aux ()

83+setNextName = do env <- get_env

84+ ES (p, a) s e <- get

85+ let pargs = map fst (getArgTys (ptype p))

86+ initNextNameFrom (pargs ++ map fst env)

87+

88+initNextNameFrom :: [Name] -> Elab' aux ()

89+initNextNameFrom ns = do ES (p, a) s e <- get

90+ let n' = maxName (nextname p) ns

91+ put (ES (p { nextname = n' }, a) s e)

92+ where

93+ maxName m ((MN i _) : xs) = maxName (max m i) xs

94+ maxName m (_ : xs) = maxName m xs

95+ maxName m [] = m + 1

96+

67errAt :: String -> Name -> Elab' aux a -> Elab' aux a

97errAt :: String -> Name -> Elab' aux a -> Elab' aux a

68errAt thing n elab = do s <- get

98errAt thing n elab = do s <- get

69 case runStateT elab s of

99 case runStateT elab s of

70 OK (a, s') -> do put s'

100 OK (a, s') -> do put s'

71− return a

101+ return $! a

72 Error (At f e) ->

102 Error (At f e) ->

73 lift $ Error (At f (Elaborating thing n e))

103 lift $ Error (At f (Elaborating thing n e))

74 Error e -> lift $ Error (Elaborating thing n e)

104 Error e -> lift $ Error (Elaborating thing n e)

@@ -77,7 +107,7 @@ erun :: FC -> Elab' aux a -> Elab' aux a

77erun f elab = do s <- get

107erun f elab = do s <- get

78 case runStateT elab s of

108 case runStateT elab s of

79 OK (a, s') -> do put s'

109 OK (a, s') -> do put s'

80− return a

110+ return $! a

81 Error (ProofSearchFail (At f e))

111 Error (ProofSearchFail (At f e))

82 -> lift $ Error (ProofSearchFail (At f e))

112 -> lift $ Error (ProofSearchFail (At f e))

83 Error (At f e) -> lift $ Error (At f e)

113 Error (At f e) -> lift $ Error (At f e)

@@ -95,7 +125,11 @@ initElaborator = newProof

95elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

125elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

96elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

126elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

97 (a, ES ps' str _) <- runElab d elab ps

127 (a, ES ps' str _) <- runElab d elab ps

98− return (a, str)

128+ return $! (a, str)

129+

130+force_term :: Elab' aux ()

131+force_term = do ES (ps, a) l p <- get

132+ put (ES (ps { pterm = force (pterm ps) }, a) l p)

133

100updateAux :: (aux -> aux) -> Elab' aux ()

134updateAux :: (aux -> aux) -> Elab' aux ()

101updateAux f = do ES (ps, a) l p <- get

135updateAux f = do ES (ps, a) l p <- get

@@ -103,23 +137,27 @@ updateAux f = do ES (ps, a) l p <- get

103

137

104getAux :: Elab' aux aux

138getAux :: Elab' aux aux

105getAux = do ES (ps, a) _ _ <- get

139getAux = do ES (ps, a) _ _ <- get

106− return a

140+ return $! a

107

141

108unifyLog :: Bool -> Elab' aux ()

142unifyLog :: Bool -> Elab' aux ()

109unifyLog log = do ES (ps, a) l p <- get

143unifyLog log = do ES (ps, a) l p <- get

110 put (ES (ps { unifylog = log }, a) l p)

144 put (ES (ps { unifylog = log }, a) l p)

111

145

146+getUnifyLog :: Elab' aux Bool

147+getUnifyLog = do ES (ps, a) l p <- get

148+ return (unifylog ps)

149+

112processTactic' t = do ES (p, a) logs prev <- get

150processTactic' t = do ES (p, a) logs prev <- get

113 (p', log) <- lift $ processTactic t p

151 (p', log) <- lift $ processTactic t p

114 put (ES (p', a) (logs ++ log) prev)

152 put (ES (p', a) (logs ++ log) prev)

115− return ()

153+ return $! ()

116

154

117-- Some handy gadgets for pulling out bits of state

155-- Some handy gadgets for pulling out bits of state

118

156

119-- get the global context

157-- get the global context

120get_context :: Elab' aux Context

158get_context :: Elab' aux Context

121get_context = do ES p _ _ <- get

159get_context = do ES p _ _ <- get

122− return (context (fst p))

160+ return $! (context (fst p))

123

161

124-- update the context

162-- update the context

125-- (should only be used for adding temporary definitions or all sorts of

163-- (should only be used for adding temporary definitions or all sorts of

@@ -131,7 +169,7 @@ set_context ctxt = do ES (p, a) logs prev <- get

131-- get the proof term

169-- get the proof term

132get_term :: Elab' aux Term

170get_term :: Elab' aux Term

133get_term = do ES p _ _ <- get

171get_term = do ES p _ _ <- get

134− return (pterm (fst p))

172+ return $! (pterm (fst p))

135

173

136-- get the proof term

174-- get the proof term

137update_term :: (Term -> Term) -> Elab' aux ()

175update_term :: (Term -> Term) -> Elab' aux ()

@@ -146,24 +184,24 @@ get_env = do ES p _ _ <- get

146

184

147get_holes :: Elab' aux [Name]

185get_holes :: Elab' aux [Name]

148get_holes = do ES p _ _ <- get

186get_holes = do ES p _ _ <- get

149− return (holes (fst p))

187+ return $! (holes (fst p))

150

188

151get_probs :: Elab' aux Fails

189get_probs :: Elab' aux Fails

152get_probs = do ES p _ _ <- get

190get_probs = do ES p _ _ <- get

153− return (problems (fst p))

191+ return $! (problems (fst p))

154

192

155-- get the current goal type

193-- get the current goal type

156goal :: Elab' aux Type

194goal :: Elab' aux Type

157goal = do ES p _ _ <- get

195goal = do ES p _ _ <- get

158 b <- lift $ goalAtFocus (fst p)

196 b <- lift $ goalAtFocus (fst p)

159− return (binderTy b)

197+ return $! (binderTy b)

160

198

161-- Get the guess at the current hole, if there is one

199-- Get the guess at the current hole, if there is one

162get_guess :: Elab' aux Type

200get_guess :: Elab' aux Type

163get_guess = do ES p _ _ <- get

201get_guess = do ES p _ _ <- get

164 b <- lift $ goalAtFocus (fst p)

202 b <- lift $ goalAtFocus (fst p)

165 case b of

203 case b of

166− Guess t v -> return v

204+ Guess t v -> return $! v

167 _ -> fail "Not a guess"

205 _ -> fail "Not a guess"

168

206

169-- typecheck locally

207-- typecheck locally

@@ -171,22 +209,22 @@ get_type :: Raw -> Elab' aux Type

171get_type tm = do ctxt <- get_context

209get_type tm = do ctxt <- get_context

172 env <- get_env

210 env <- get_env

173 (val, ty) <- lift $ check ctxt env tm

211 (val, ty) <- lift $ check ctxt env tm

174− return (finalise ty)

212+ return $! (finalise ty)

175

213

176get_type_val :: Raw -> Elab' aux (Term, Type)

214get_type_val :: Raw -> Elab' aux (Term, Type)

177get_type_val tm = do ctxt <- get_context

215get_type_val tm = do ctxt <- get_context

178 env <- get_env

216 env <- get_env

179 (val, ty) <- lift $ check ctxt env tm

217 (val, ty) <- lift $ check ctxt env tm

180− return (finalise val, finalise ty)

218+ return $! (finalise val, finalise ty)

181

219

182-- get holes we've deferred for later definition

220-- get holes we've deferred for later definition

183get_deferred :: Elab' aux [Name]

221get_deferred :: Elab' aux [Name]

184get_deferred = do ES p _ _ <- get

222get_deferred = do ES p _ _ <- get

185− return (deferred (fst p))

223+ return $! (deferred (fst p))

186

224

187checkInjective :: (Term, Term, Term) -> Elab' aux ()

225checkInjective :: (Term, Term, Term) -> Elab' aux ()

188checkInjective (tm, l, r) = do ctxt <- get_context

226checkInjective (tm, l, r) = do ctxt <- get_context

189− if isInj ctxt tm then return ()

227+ if isInj ctxt tm then return $! ()

190 else lift $ tfail (NotInjective tm l r)

228 else lift $ tfail (NotInjective tm l r)

191 where isInj ctxt (P _ n _)

229 where isInj ctxt (P _ n _)

192 | isConName n ctxt = True

230 | isConName n ctxt = True

@@ -199,7 +237,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

199-- get instance argument names

237-- get instance argument names

200get_instances :: Elab' aux [Name]

238get_instances :: Elab' aux [Name]

201get_instances = do ES p _ _ <- get

239get_instances = do ES p _ _ <- get

202− return (instances (fst p))

240+ return $! (instances (fst p))

203

241

204-- given a desired hole name, return a unique hole name

242-- given a desired hole name, return a unique hole name

205unique_hole = unique_hole' False

243unique_hole = unique_hole' False

@@ -209,13 +247,14 @@ unique_hole' reusable n

209 = do ES p _ _ <- get

247 = do ES p _ _ <- get

210 let bs = bound_in (pterm (fst p)) ++

248 let bs = bound_in (pterm (fst p)) ++

211 bound_in (ptype (fst p))

249 bound_in (ptype (fst p))

250+ let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p)

212− n' <- return $ uniqueNameCtxt (context (fst p)) n (holes (fst p)

251+ n' <- return $! uniqueNameCtxt (context (fst p)) n nouse

213− ++ bs ++ dontunify (fst p) ++ usedns (fst p))

214 ES (p, a) s u <- get

252 ES (p, a) s u <- get

215− -- Hmm: Do we need this level of uniqueness?

253+ case n' of

216− let p' = p -- if reusable then p else p { usedns = n' : usedns p }

254+ MN i _ -> when (i >= nextname p) $

217− put (ES (p', a) s u)

255+ put (ES (p { nextname = i + 1 }, a) s u)

256+ _ -> return $! ()

218− return n'

257+ return $! n'

219 where

258 where

220 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

259 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

221 where

260 where

@@ -231,7 +270,7 @@ elog str = do ES p logs prev <- get

231

270

232getLog :: Elab' aux String

271getLog :: Elab' aux String

233getLog = do ES p logs _ <- get

272getLog = do ES p logs _ <- get

234− return logs

273+ return $! logs

235

274

236-- The primitives, from ProofState

275-- The primitives, from ProofState

237

276

@@ -312,11 +351,12 @@ equiv tm = processTactic' (Equiv tm)

312

351

313patvar :: Name -> Elab' aux ()

352patvar :: Name -> Elab' aux ()

314patvar n = do env <- get_env

353patvar n = do env <- get_env

354+ hs <- get_holes

315 if (n `elem` map fst env) then do apply (Var n) []; solve

355 if (n `elem` map fst env) then do apply (Var n) []; solve

316 else do n' <- case n of

356 else do n' <- case n of

317− UN _ -> return n

357+ UN _ -> return $! n

318 MN _ _ -> unique_hole n

358 MN _ _ -> unique_hole n

319− NS _ _ -> return n

359+ NS _ _ -> return $! n

320 processTactic' (PatVar n')

360 processTactic' (PatVar n')

321

361

322patbind :: Name -> Elab' aux ()

362patbind :: Name -> Elab' aux ()

@@ -356,13 +396,13 @@ reorder_claims n = processTactic' (Reorder n)

356qed :: Elab' aux Term

396qed :: Elab' aux Term

357qed = do processTactic' QED

397qed = do processTactic' QED

358 ES p _ _ <- get

398 ES p _ _ <- get

359− return (pterm (fst p))

399+ return $! (pterm (fst p))

360

400

361undo :: Elab' aux ()

401undo :: Elab' aux ()

362undo = processTactic' Undo

402undo = processTactic' Undo

363

403

364prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

404prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

365−prepare_apply fn imps =

405+prepare_apply fn imps =

366 do ty <- get_type fn

406 do ty <- get_type fn

367 ctxt <- get_context

407 ctxt <- get_context

368 env <- get_env

408 env <- get_env

@@ -377,18 +417,18 @@ prepare_apply fn imps =

377-- case claims of

417-- case claims of

378-- [] -> return ()

418-- [] -> return ()

379-- (h : _) -> reorder_claims h

419-- (h : _) -> reorder_claims h

380− return claims

420+ return $! claims

381 where

421 where

382 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

422 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

383 do let t = rebind hs t_in

423 do let t = rebind hs t_in

384− n <- unique_hole (mkMN n')

424+ n <- getNameFrom (mkMN n')

385-- when (null claims) (start_unify n)

425-- when (null claims) (start_unify n)

386 let sc' = instantiate (P Bound n t) sc

426 let sc' = instantiate (P Bound n t) sc

387−-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show hs) $

427+-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $

388 claim n (forget t)

428 claim n (forget t)

389 when i (movelast n)

429 when i (movelast n)

390 mkClaims sc' is (n : claims) hs

430 mkClaims sc' is (n : claims) hs

391− mkClaims t [] claims _ = return (reverse claims)

431+ mkClaims t [] claims _ = return $! (reverse claims)

392 mkClaims _ _ _ _

432 mkClaims _ _ _ _

393 | Var n <- fn

433 | Var n <- fn

394 = do ctxt <- get_context

434 = do ctxt <- get_context

@@ -400,9 +440,9 @@ prepare_apply fn imps =

400 doClaim ((i, _), n, t) = do claim n t

440 doClaim ((i, _), n, t) = do claim n t

401 when i (movelast n)

441 when i (movelast n)

402

442

403− mkMN n@(MN _ _) = n

443+ mkMN n@(MN i _) = n

404− mkMN n@(UN x) = MN 1000 x

444+ mkMN n@(UN x) = MN 99999 x

405− mkMN n@(SN s) = MN 1000 (show s)

445+ mkMN n@(SN s) = sMN 99999 (show s)

406 mkMN (NS n xs) = NS (mkMN n) xs

446 mkMN (NS n xs) = NS (mkMN n) xs

407

447

408 rebind hs (Bind n t sc)

448 rebind hs (Bind n t sc)

@@ -419,16 +459,13 @@ match_apply = apply' match_fill

419apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

459apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

420apply' fillt fn imps =

460apply' fillt fn imps =

421 do args <- prepare_apply fn (map fst imps)

461 do args <- prepare_apply fn (map fst imps)

422− env <- get_env

423− g <- goal

424 -- _Don't_ solve the arguments we're specifying by hand.

462 -- _Don't_ solve the arguments we're specifying by hand.

425 -- (remove from unified list before calling end_unify)

463 -- (remove from unified list before calling end_unify)

426 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

464 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

427 -- so do nothing

465 -- so do nothing

428− ptm <- get_term

429 hs <- get_holes

466 hs <- get_holes

430 ES (p, a) s prev <- get

467 ES (p, a) s prev <- get

431− let dont = nub $ head hs : dontunify p ++

468+ let dont = head hs : dontunify p ++

432 if null imps then [] -- do all we can

469 if null imps then [] -- do all we can

433 else

470 else

434 map fst (filter (not.snd) (zip args (map fst imps)))

471 map fst (filter (not.snd) (zip args (map fst imps)))

@@ -441,13 +478,10 @@ apply' fillt fn imps =

441 put (ES (p { dontunify = dont, unified = (n, unify),

478 put (ES (p { dontunify = dont, unified = (n, unify),

442 notunified = notunify ++ notunified p }, a) s prev)

479 notunified = notunify ++ notunified p }, a) s prev)

443 fillt (raw_apply fn (map Var args))

480 fillt (raw_apply fn (map Var args))

444− ptm <- get_term

445− g <- goal

446-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

481-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

447 end_unify

482 end_unify

448− ptm <- get_term

449− return (map (updateUnify unify) args)

483+ return $! (map (updateUnify unify) args)

450− where updateUnify hs n = case lookup n hs of

484+ where updateUnify us n = case lookup n us of

451 Just (P _ t _) -> t

485 Just (P _ t _) -> t

452 _ -> n

486 _ -> n

453

487

@@ -460,7 +494,7 @@ apply2 fn elabs =

460 let (n, hs) = unified p

494 let (n, hs) = unified p

461 end_unify

495 end_unify

462 solve

496 solve

463− where elabArgs [] [] = return ()

497+ where elabArgs [] [] = return $! ()

464 elabArgs (n:ns) (Just e:es) = do focus n; e

498 elabArgs (n:ns) (Just e:es) = do focus n; e

465 elabArgs ns es

499 elabArgs ns es

466 elabArgs (n:ns) (_:es) = elabArgs ns es

500 elabArgs (n:ns) (_:es) = elabArgs ns es

@@ -491,18 +525,18 @@ apply_elab n args =

491 let sc' = instantiate (P Bound n t) sc

525 let sc' = instantiate (P Bound n t) sc

492 claim n (forget t)

526 claim n (forget t)

493 case i of

527 case i of

494− Nothing -> return ()

528+ Nothing -> return $! ()

495 Just _ -> -- don't solve by unification as there is an explicit value

529 Just _ -> -- don't solve by unification as there is an explicit value

496 do ES (p, a) s prev <- get

530 do ES (p, a) s prev <- get

497 put (ES (p { dontunify = n : dontunify p }, a) s prev)

531 put (ES (p { dontunify = n : dontunify p }, a) s prev)

498 doClaims sc' is ((n, i) : claims)

532 doClaims sc' is ((n, i) : claims)

499− doClaims t [] claims = return (reverse claims)

533+ doClaims t [] claims = return $! (reverse claims)

500 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

534 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

501

535

502 elabClaims failed r []

536 elabClaims failed r []

503− | null failed = return ()

537+ | null failed = return $! ()

504 | otherwise = if r then elabClaims [] False failed

538 | otherwise = if r then elabClaims [] False failed

505− else return ()

539+ else return $! ()

506 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

540 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

507 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

541 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

508 | r = try (do ES p _ _ <- get

542 | r = try (do ES p _ _ <- get

@@ -512,7 +546,7 @@ apply_elab n args =

512 focus n; elaboration; elabClaims failed r xs

546 focus n; elaboration; elabClaims failed r xs

513

547

514 mkMN n@(MN _ _) = n

548 mkMN n@(MN _ _) = n

515− mkMN n@(UN x) = MN 1000 x

549+ mkMN n@(UN x) = MN 0 x

516 mkMN (NS n ns) = NS (mkMN n) ns

550 mkMN (NS n ns) = NS (mkMN n) ns

517

551

518-- If the goal is not a Pi-type, invent some names and make it a pi type

552-- If the goal is not a Pi-type, invent some names and make it a pi type

@@ -521,9 +555,9 @@ checkPiGoal n

521 = do g <- goal

555 = do g <- goal

522 case g of

556 case g of

523 Bind _ (Pi _) _ -> return ()

557 Bind _ (Pi _) _ -> return ()

524− _ -> do a <- unique_hole (MN 0 "pargTy")

558+ _ -> do a <- getNameFrom (sMN 0 "pargTy")

525− b <- unique_hole (MN 0 "pretTy")

559+ b <- getNameFrom (sMN 0 "pretTy")

526− f <- unique_hole (MN 0 "pf")

560+ f <- getNameFrom (sMN 0 "pf")

527 claim a RType

561 claim a RType

528 claim b RType

562 claim b RType

529 claim f (RBind n (Pi (Var a)) (Var b))

563 claim f (RBind n (Pi (Var a)) (Var b))

@@ -535,13 +569,13 @@ checkPiGoal n

535

569

536simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

570simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

537simple_app fun arg appstr =

571simple_app fun arg appstr =

538− do a <- unique_hole (MN 0 "argTy")

572+ do a <- getNameFrom (sMN 0 "argTy")

539− b <- unique_hole (MN 0 "retTy")

573+ b <- getNameFrom (sMN 0 "retTy")

540− f <- unique_hole (MN 0 "f")

574+ f <- getNameFrom (sMN 0 "f")

541− s <- unique_hole (MN 0 "s")

575+ s <- getNameFrom (sMN 0 "s")

542 claim a RType

576 claim a RType

543 claim b RType

577 claim b RType

544− claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b))

578+ claim f (RBind (sMN 0 "aX") (Pi (Var a)) (Var b))

545 tm <- get_term

579 tm <- get_term

546 start_unify s

580 start_unify s

547 claim s (Var a)

581 claim s (Var a)

@@ -570,17 +604,24 @@ arg n tyhole = do ty <- unique_hole tyhole

570 forall n (Var ty)

604 forall n (Var ty)

571

605

572-- try a tactic, if it adds any unification problem, return an error

606-- try a tactic, if it adds any unification problem, return an error

573−no_errors :: Elab' aux () -> Elab' aux ()

607+no_errors :: Elab' aux () -> Maybe Err -> Elab' aux ()

574−no_errors tac

608+no_errors tac err

575− = do ps <- get_probs

609+ = do ps <- get_probs

576− tac

610+ s <- get

611+ case err of

612+ Nothing -> tac

613+ Just e -> -- update the error, if there is one.

614+ case runStateT tac s of

615+ Error _ -> lift $ Error e

616+ OK (a, s') -> do put s'

617+ return a

577− ps' <- get_probs

618+ ps' <- get_probs

578− if (length ps' > length ps) then

619+ if (length ps' > length ps) then

579− case reverse ps' of

620+ case reverse ps' of

580− ((x,y,env,err) : _) ->

621+ ((x,y,env,err) : _) ->

581− let env' = map (\(x, b) -> (x, binderTy b)) env in

622+ let env' = map (\(x, b) -> (x, binderTy b)) env in

582− lift $ tfail $ CantUnify False x y err env' 0

623+ lift $ tfail $ CantUnify False x y err env' 0

583− else return ()

624+ else return $! ()

584

625

585-- Try a tactic, if it fails, try another

626-- Try a tactic, if it fails, try another

586try :: Elab' aux a -> Elab' aux a -> Elab' aux a

627try :: Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -592,10 +633,10 @@ try' t1 t2 proofSearch

592 ps <- get_probs

633 ps <- get_probs

593 case prunStateT 999999 False ps t1 s of

634 case prunStateT 999999 False ps t1 s of

594 OK ((v, _), s') -> do put s'

635 OK ((v, _), s') -> do put s'

595− return v

636+ return $! v

596 Error e1 -> if recoverableErr e1 then

637 Error e1 -> if recoverableErr e1 then

597 do case runStateT t2 s of

638 do case runStateT t2 s of

598− OK (v, s') -> do put s'; return v

639+ OK (v, s') -> do put s'; return $! v

599 Error e2 -> if score e1 >= score e2

640 Error e2 -> if score e1 >= score e2

600 then lift (tfail e1)

641 then lift (tfail e1)

601 else lift (tfail e2)

642 else lift (tfail e2)

@@ -603,6 +644,7 @@ try' t1 t2 proofSearch

603 where recoverableErr err@(CantUnify r x y _ _ _)

644 where recoverableErr err@(CantUnify r x y _ _ _)

604 = -- traceWhen r (show err) $

645 = -- traceWhen r (show err) $

605 r || proofSearch

646 r || proofSearch

647+ recoverableErr (CantSolveGoal _ _) = False

606 recoverableErr (ProofSearchFail _) = False

648 recoverableErr (ProofSearchFail _) = False

607 recoverableErr _ = True

649 recoverableErr _ = True

608

650

@@ -632,8 +674,8 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

632 case prunStateT pmax True ps x s of

674 case prunStateT pmax True ps x s of

633 OK ((v, newps), s') ->

675 OK ((v, newps), s') ->

634 do let cs' = if (newps < pmax)

676 do let cs' = if (newps < pmax)

635− then [do put s'; return v]

677+ then [do put s'; return $! v]

636− else (do put s'; return v) : cs

678+ else (do put s'; return $! v) : cs

637 tryAll' cs' newps f xs

679 tryAll' cs' newps f xs

638 Error err -> do put s

680 Error err -> do put s

639 if (score err) < 100

681 if (score err) < 100

src/Idris/Core/Evaluate.hs+31−25

@@ -9,11 +9,12 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

9 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

10 addDatatype, addCasedef, simplifyCasedef, addOperator,

11 lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

12+ mapDefCtxt,

12 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

13 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

13 Value(..), Quote(..), initEval, uniqueNameCtxt) where

14 Value(..), Quote(..), initEval, uniqueNameCtxt) where

15import Debug.Trace

16import Debug.Trace

16−import Control.Monad.State

17+import Control.Monad.State -- not Strict!

17import qualified Data.Binary as B

18import qualified Data.Binary as B

18import Data.Binary hiding (get, put)

19import Data.Binary hiding (get, put)

@@ -98,11 +99,11 @@ specialise ctxt env limits t

99simplify :: Context -> Env -> TT Name -> TT Name

100simplify :: Context -> Env -> TT Name -> TT Name

100simplify ctxt env t

101simplify ctxt env t

101− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

102+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

102− (UN "assert_smaller", 0),

103+ (sUN "assert_smaller", 0),

103− (UN "par", 0),

104+ (sUN "par", 0),

104− (UN "prim__syntactic_eq", 0),

105+ (sUN "prim__syntactic_eq", 0),

105− (UN "fork", 0)]

106+ (sUN "fork", 0)]

106 (map finalEntry env) (finalise t)

107 (map finalEntry env) (finalise t)

107 [Simplify]

108 [Simplify]

108 quote 0 val) initEval

109 quote 0 val) initEval

@@ -110,11 +111,11 @@ simplify ctxt env t

110-- | Simplify for run-time (i.e. basic inlining)

111-- | Simplify for run-time (i.e. basic inlining)

111rt_simplify :: Context -> Env -> TT Name -> TT Name

112rt_simplify :: Context -> Env -> TT Name -> TT Name

112rt_simplify ctxt env t

113rt_simplify ctxt env t

113− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

114+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

114− (UN "assert_smaller", 0),

115+ (sUN "assert_smaller", 0),

115− (UN "par", 0),

116+ (sUN "par", 0),

116− (UN "prim__syntactic_eq", 0),

117+ (sUN "prim__syntactic_eq", 0),

117− (UN "prim_fork", 0)]

118+ (sUN "prim_fork", 0)]

118 (map finalEntry env) (finalise t)

119 (map finalEntry env) (finalise t)

119 [RunTT]

120 [RunTT]

120 quote 0 val) initEval

121 quote 0 val) initEval

@@ -189,7 +190,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

189 = not (inl || dict) || elem n stk

190 = not (inl || dict) || elem n stk

190 | Simplify `elem` opts

191 | Simplify `elem` opts

191 = (not (inl || dict) || elem n stk)

192 = (not (inl || dict) || elem n stk)

192− || (n == UN "prim__syntactic_eq")

193+ || (n == sUN "prim__syntactic_eq")

193 | otherwise = False

194 | otherwise = False

194

195

195 getCases cd | simpl = cases_totcheck cd

196 getCases cd | simpl = cases_totcheck cd

@@ -227,11 +228,11 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

227 ev ntimes stk top env (P nt n ty)

228 ev ntimes stk top env (P nt n ty)

228 = liftM (VP nt n) (ev ntimes stk top env ty)

229 = liftM (VP nt n) (ev ntimes stk top env ty)

229 ev ntimes stk top env (V i)

230 ev ntimes stk top env (V i)

230− | i < length env && i >= 0 = return $ env !! i

231+ | i < length env && i >= 0 = return $ snd (env !! i)

231 | otherwise = return $ VV i

232 | otherwise = return $ VV i

232 ev ntimes stk top env (Bind n (Let t v) sc)

233 ev ntimes stk top env (Bind n (Let t v) sc)

233 = do v' <- ev ntimes stk top env v --(finalise v)

234 = do v' <- ev ntimes stk top env v --(finalise v)

234− sc' <- ev ntimes stk top (v' : env) sc

235+ sc' <- ev ntimes stk top ((n, v') : env) sc

235 wknV (-1) sc'

236 wknV (-1) sc'

236-- | otherwise

237-- | otherwise

237-- = do t' <- ev ntimes stk top env t

238-- = do t' <- ev ntimes stk top env t

@@ -246,12 +247,13 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

246 ev ntimes stk top env (Bind n (NLet t v) sc)

247 ev ntimes stk top env (Bind n (NLet t v) sc)

247 = do t' <- ev ntimes stk top env (finalise t)

248 = do t' <- ev ntimes stk top env (finalise t)

248 v' <- ev ntimes stk top env (finalise v)

249 v' <- ev ntimes stk top env (finalise v)

249− sc' <- ev ntimes stk top (v' : env) sc

250+ sc' <- ev ntimes stk top ((n, v') : env) sc

250 return $ VBind True n (Let t' v') (\x -> return sc')

251 return $ VBind True n (Let t' v') (\x -> return sc')

251 ev ntimes stk top env (Bind n b sc)

252 ev ntimes stk top env (Bind n b sc)

252 = do b' <- vbind env b

253 = do b' <- vbind env b

254+ let n' = uniqueName n (map fst env)

253 return $ VBind True -- (vinstances 0 sc < 2)

255 return $ VBind True -- (vinstances 0 sc < 2)

254− n b' (\x -> ev ntimes stk False (x:env) sc)

256+ n' b' (\x -> ev ntimes stk False ((n, x):env) sc)

255 where vbind env t

257 where vbind env t

256-- | simpl

258-- | simpl

257-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

259-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

@@ -344,7 +346,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

344-- _ -> return $ unload env f args

346-- _ -> return $ unload env f args

345-- specApply stk env f args = return $ unload env f args

347-- specApply stk env f args = return $ unload env f args

346

348

347− unload :: [Value] -> Value -> [Value] -> Value

349+ unload :: [(Name, Value)] -> Value -> [Value] -> Value

348 unload env f [] = f

350 unload env f [] = f

349 unload env f (a:as) = unload env (VApp f a) as

351 unload env f (a:as) = unload env (VApp f a) as

350

352

@@ -359,12 +361,12 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

359 | otherwise = return (Nothing, args)

361 | otherwise = return (Nothing, args)

360

362

361 evTree :: [(Name, Int)] -> [Name] -> Bool ->

363 evTree :: [(Name, Int)] -> [Name] -> Bool ->

362− [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

364+ [(Name, Value)] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

363 evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing

365 evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing

364 evTree ntimes stk top env amap (STerm tm)

366 evTree ntimes stk top env amap (STerm tm)

365 = do let etm = pToVs (map fst amap) tm

367 = do let etm = pToVs (map fst amap) tm

366 etm' <- ev ntimes stk (not (conHeaded tm))

368 etm' <- ev ntimes stk (not (conHeaded tm))

367− (map snd amap ++ env) etm

369+ (amap ++ env) etm

368 return $ Just etm'

370 return $ Just etm'

369 evTree ntimes stk top env amap (ProjCase t alts)

371 evTree ntimes stk top env amap (ProjCase t alts)

370 = do t' <- ev ntimes stk top env t

372 = do t' <- ev ntimes stk top env t

@@ -393,7 +395,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

393 chooseAlt env f' (getValArgs f')

395 chooseAlt env f' (getValArgs f')

394 alts amap

396 alts amap

395

397

396− chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

398+ chooseAlt :: [(Name, Value)] -> Value -> (Value, [Value]) -> [CaseAlt] ->

397 [(Name, Value)] ->

399 [(Name, Value)] ->

398 Eval (Maybe ([(Name, Value)], SC))

400 Eval (Maybe ([(Name, Value)], SC))

399 chooseAlt env _ (VP (DCon i a) _ _, args) alts amap

401 chooseAlt env _ (VP (DCon i a) _ _, args) alts amap

@@ -411,7 +413,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

411 chooseAlt env _ (VP _ n _, args) alts amap

413 chooseAlt env _ (VP _ n _, args) alts amap

412 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

414 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

413 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

415 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

414− | Just (ns, sc) <- findFn (UN "->") alts

416+ | Just (ns, sc) <- findFn (sUN "->") alts

415 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

417 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

416 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

418 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

417 chooseAlt _ _ _ alts amap

419 chooseAlt _ _ _ alts amap

@@ -491,7 +493,7 @@ instance Quote Value where

491 = do sc' <- quote i sc

493 = do sc' <- quote i sc

492 t' <- quote i t

494 t' <- quote i t

493 v' <- quote i v

495 v' <- quote i v

494− let sc'' = pToV (MN vd "vlet") (addBinder sc')

496+ let sc'' = pToV (sMN vd "vlet") (addBinder sc')

495 return (Bind n (Let t' v') sc'')

497 return (Bind n (Let t' v') sc'')

496 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

498 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

497 quote i (VType u) = return $ TType u

499 quote i (VType u) = return $ TType u

@@ -512,9 +514,9 @@ wknV i t = return t

512

514

513convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

515convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

514

516

515−convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

517+convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

516convEq ctxt = ceq [] where

518convEq ctxt = ceq [] where

517− ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool

519+ ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

518 ceq ps (P xt x _) (P yt y _)

520 ceq ps (P xt x _) (P yt y _)

519 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

521 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

520 | otherwise = sameDefs ps x y

522 | otherwise = sameDefs ps x y

@@ -696,6 +698,10 @@ data Context = MkContext {

696-- | The initial empty context

698-- | The initial empty context

697initContext = MkContext [] 0 emptyContext

699initContext = MkContext [] 0 emptyContext

698

700

701+mapDefCtxt :: (Def -> Def) -> Context -> Context

702+mapDefCtxt f (MkContext c t defs) = MkContext c t (mapCtxt f' defs)

703+ where f' (d, a, t, m) = f' (f d, a, t, m)

704+

699-- | Get the definitions from a context

705-- | Get the definitions from a context

700ctxtAlist :: Context -> [(Name, Def)]

706ctxtAlist :: Context -> [(Name, Def)]

701ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

707ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

@@ -886,7 +892,7 @@ lookupDefAcc :: Name -> Bool -> Context ->

886lookupDefAcc n mkpublic ctxt

892lookupDefAcc n mkpublic ctxt

887 = map mkp $ lookupCtxt n (definitions ctxt)

893 = map mkp $ lookupCtxt n (definitions ctxt)

888 -- io_bind a special case for REPL prettiness

894 -- io_bind a special case for REPL prettiness

889− where mkp (d, a, _, _) = if mkpublic && (not (n == UN "io_bind" || n == UN "io_return"))

895+ where mkp (d, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_return"))

890 then (d, Public) else (d, a)

896 then (d, Public) else (d, a)

891

897

892lookupTotal :: Name -> Context -> [Totality]

898lookupTotal :: Name -> Context -> [Totality]

src/Idris/Core/Execute.hs+65−49

@@ -96,7 +96,7 @@ toTT (EApp e1 e2) = do e1' <- toTT e1

96toTT (EType u) = return $ TType u

97toTT EErased = return Erased

98toTT (EConstant c) = return (Constant c)

99−toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT

99+toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT

100toTT (EHandle _) = return Erased

101

102unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -173,7 +173,7 @@ execute tm = do est <- initState

173 Right tm' -> return tm'

174

175ioWrap :: ExecVal -> ExecVal

176−ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]

176+ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]

177

178ioUnit :: ExecVal

179ioUnit = ioWrap (EP Ref unitCon EErased)

@@ -219,8 +219,9 @@ execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

219execApp env ctxt (f, args) = do newF <- doExec env ctxt f

220 laziness <- (++ repeat False) <$> (getLaziness newF)

221 newArgs <- mapM argExec (zip args laziness)

222− execApp' env ctxt newF newArgs

222+ res <- execApp' env ctxt newF newArgs

223+ return res

223− where getLaziness (EP _ (UN "lazy") _) = return [False, True]

224+ where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

224 getLaziness (EP _ n _) = do est <- getExecState

225 getLaziness (EP _ n _) = do est <- getExecState

225 let argInfo = exec_implicits est

226 let argInfo = exec_implicits est

226 case lookupCtxtName n argInfo of

227 case lookupCtxtName n argInfo of

@@ -235,28 +236,36 @@ execApp env ctxt (f, args) = do newF <- doExec env ctxt f

235

236

236execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

238execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

238−execApp' env ctxt (EP _ (UN "unsafePerformPrimIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =

239+execApp' env ctxt (EP _ fp _) (ty:action:rest)

240+ | fp == upio,

241+ (prim__IO, [_, v]) <- unApplyV action

239− execApp' env ctxt v rest

242+ = execApp' env ctxt v rest

240−

243+

241−execApp' env ctxt (EP _ (UN "prim_io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =

244+execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

245+ | fp == piobind,

246+ (prim__IO, [_, v']) <- unApplyV v =

242 do v'' <- tryForce v'

247 do v'' <- tryForce v'

243 res <- execApp' env ctxt k [v''] >>= tryForce

248 res <- execApp' env ctxt k [v''] >>= tryForce

244 execApp' env ctxt res rest

249 execApp' env ctxt res rest

245−execApp' env ctxt con@(EP _ (UN "prim_io_return") _) args@(tp:v:rest) =

250+execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

251+ | fp == pioret =

246 do v' <- tryForce v

252 do v' <- tryForce v

247 execApp' env ctxt (mkEApp con [tp, v']) rest

253 execApp' env ctxt (mkEApp con [tp, v']) rest

248

254

249-- Special cases arising from not having access to the C RTS in the interpreter

255-- Special cases arising from not having access to the C RTS in the interpreter

250−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest)

256+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

257+ | fp == mkfprim,

251− | Just (FFun "putStr" _ _) <- foreignFromTT fn

258+ Just (FFun "putStr" _ _) <- foreignFromTT fn

252 = do execIO (putStr arg)

259 = do execIO (putStr arg)

253 execApp' env ctxt ioUnit rest

260 execApp' env ctxt ioUnit rest

254−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

261+execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

262+ | fp == mkfprim,

255− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

263+ Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

256 = do contents <- execIO $ hGetLine h

264 = do contents <- execIO $ hGetLine h

257 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

265 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

258−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

266+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

267+ | fp == mkfprim,

259− | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

268+ Just (FFun "fileOpen" _ _) <- foreignFromTT fn

260 = do m <- case mode of

269 = do m <- case mode of

261 "r" -> return ReadMode

270 "r" -> return ReadMode

262 "w" -> return WriteMode

271 "w" -> return WriteMode

@@ -268,42 +277,46 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268 h <- execIO $ openFile f m

277 h <- execIO $ openFile f m

269 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

278 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

270

279

271−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

280+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

281+ | fp == mkfprim,

272− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

282+ Just (FFun "fileEOF" _ _) <- foreignFromTT fn

273 = do eofp <- execIO $ hIsEOF h

283 = do eofp <- execIO $ hIsEOF h

274 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

284 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

275 execApp' env ctxt res (tail rest)

285 execApp' env ctxt res (tail rest)

276

286

277−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

287+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

288+ | fp == mkfprim,

278− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

289+ Just (FFun "fileClose" _ _) <- foreignFromTT fn

279 = do execIO $ hClose h

290 = do execIO $ hClose h

280 execApp' env ctxt ioUnit (tail rest)

291 execApp' env ctxt ioUnit (tail rest)

281

292

282−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

293+execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

294+ | fp == mkfprim,

283− | Just (FFun "isNull" _ _) <- foreignFromTT fn

295+ Just (FFun "isNull" _ _) <- foreignFromTT fn

284 = let res = ioWrap . EConstant . I $

296 = let res = ioWrap . EConstant . I $

285 if p == nullPtr then 1 else 0

297 if p == nullPtr then 1 else 0

286 in execApp' env ctxt res (tail rest)

298 in execApp' env ctxt res (tail rest)

287

299

288-- A foreign-returned char* has to be tested for NULL sometimes

300-- A foreign-returned char* has to be tested for NULL sometimes

289−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str s):rest)

301+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

302+ | fp == mkfprim,

290− | Just (FFun "isNull" _ _) <- foreignFromTT fn

303+ Just (FFun "isNull" _ _) <- foreignFromTT fn

291 = let res = ioWrap . EConstant . I $ 0

304 = let res = ioWrap . EConstant . I $ 0

292 in execApp' env ctxt res (tail rest)

305 in execApp' env ctxt res (tail rest)

293

306

294-- Throw away the 'World' argument to the foreign function

307-- Throw away the 'World' argument to the foreign function

295

308

296−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

309+execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

297− | Just (FFun f argTs retT) <- foreignFromTT fn

310+ = case foreignFromTT fn of

298− , length xs >= length argTs =

311+ Just (FFun f argTs retT) | length xs >= length argTs ->

299− do let (args', xs') = (take (length argTs) xs, -- foreign args

312+ do let (args', xs') = (take (length argTs) xs, -- foreign args

300− drop (length argTs + 1) xs) -- rest

313+ drop (length argTs + 1) xs) -- rest

301− res <- stepForeign (ty:fn:args')

314+ res <- stepForeign (ty:fn:args')

302− case res of

315+ case res of

303− Nothing -> fail $ "Could not call foreign function \"" ++ f ++

316+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++

304− "\" with args " ++ show args

317+ "\" with args " ++ show args

305− Just r -> return (mkEApp r xs')

318+ Just r -> return (mkEApp r xs')

306− | otherwise = return (mkEApp f args)

319+ Nothing -> return (mkEApp f args)

307

320

308execApp' env ctxt c@(EP (DCon _ arity) n _) args =

321execApp' env ctxt c@(EP (DCon _ arity) n _) args =

309 do args' <- mapM tryForce (take arity args)

322 do args' <- mapM tryForce (take arity args)

@@ -343,13 +356,23 @@ execApp' env ctxt (EThunk i) args = do f <- force i

343execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

356execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

344execApp' env ctxt f args = return (mkEApp f args)

357execApp' env ctxt f args = return (mkEApp f args)

345

358

359+prs = sUN "prim__readString"

360+pbm = sUN "prim__believe_me"

361+pstd = sUN "prim__stdin"

362+mkfprim = sUN "mkForeignPrim"

363+pioret = sUN "prim_io_return"

364+piobind = sUN "prim_io_bind"

365+upio = sUN "unsafePerformPrimIO"

366+

346-- | Look up primitive operations in the global table and transform them into ExecVal functions

367-- | Look up primitive operations in the global table and transform them into ExecVal functions

347getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

368getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

348−getOp (UN "prim__believe_me") [_, _, x] = Just (return x)

369+getOp fn [_, _, x] | fn == pbm = Just (return x)

349−getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =

370+getOp fn [EP _ fn' _]

371+ | fn == prs && fn' == pstd =

350 Just $ do line <- execIO getLine

372 Just $ do line <- execIO getLine

351 return (EConstant (Str line))

373 return (EConstant (Str line))

352−getOp (UN "prim__readString") [EHandle h] =

374+getOp fn [EHandle h]

375+ | fn == prs =

353 Just $ do contents <- execIO $ hGetLine h

376 Just $ do contents <- execIO $ hGetLine h

354 return (EConstant (Str (contents ++ "\n")))

377 return (EConstant (Str (contents ++ "\n")))

355getOp n args = getPrim n primitives >>= flip applyPrim args

378getOp n args = getPrim n primitives >>= flip applyPrim args

@@ -478,11 +501,12 @@ foreignFromTT t = case (unApplyV t) of

478 argFTy <- sequence $ map getFTy argTy

501 argFTy <- sequence $ map getFTy argTy

479 retFTy <- getFTy ret

502 retFTy <- getFTy ret

480 return $ FFun name argFTy retFTy

503 return $ FFun name argFTy retFTy

481− _ -> trace "failed to construct ffun" Nothing

504+ _ -> trace ("failed to construct ffun") Nothing

482

505

483getFTy :: ExecVal -> Maybe FType

506getFTy :: ExecVal -> Maybe FType

484−getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

507+getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))

508+ | fi == txt "FIntT" =

485− case intTy of

509+ case str intTy of

486 "ITNative" -> Just (FArith (ATInt ITNative))

510 "ITNative" -> Just (FArith (ATInt ITNative))

487 "ITChar" -> Just (FArith (ATInt ITChar))

511 "ITChar" -> Just (FArith (ATInt ITChar))

488 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

512 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

@@ -491,7 +515,7 @@ getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

491 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

515 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

492 _ -> Nothing

516 _ -> Nothing

493getFTy (EP _ (UN t) _) =

517getFTy (EP _ (UN t) _) =

494− case t of

518+ case str t of

495 "FFloat" -> Just (FArith ATFloat)

519 "FFloat" -> Just (FArith ATFloat)

496 "FString" -> Just FString

520 "FString" -> Just FString

497 "FPtr" -> Just FPtr

521 "FPtr" -> Just FPtr

@@ -499,14 +523,6 @@ getFTy (EP _ (UN t) _) =

499 _ -> Nothing

523 _ -> Nothing

500getFTy _ = Nothing

524getFTy _ = Nothing

501

525

502−unList :: Term -> Maybe [Term]

503−unList tm = case unApply tm of

504− (nil, [_]) -> Just []

505− (cons, ([_, x, xs])) ->

506− do rest <- unList xs

507− return $ x:rest

508− (f, args) -> Nothing

509−

510unEList :: ExecVal -> Maybe [ExecVal]

526unEList :: ExecVal -> Maybe [ExecVal]

511unEList tm = case unApplyV tm of

527unEList tm = case unApplyV tm of

512 (nil, [_]) -> Just []

528 (nil, [_]) -> Just []

src/Idris/Core/ProofState.hs+33−31

@@ -13,7 +13,7 @@ import Idris.Core.Evaluate

13import Idris.Core.TT

14import Idris.Core.Unify

16−import Control.Monad.State

16+import Control.Monad.State.Strict

17import Control.Applicative hiding (empty)

18import Data.List

19import Debug.Trace

@@ -159,7 +159,7 @@ hole (Hole _) = True

159hole (Guess _ _) = True

160hole _ = False

161

162−holeName i = MN i "hole"

162+holeName i = sMN i "hole"

163

164qshow :: Fails -> String

165qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

@@ -209,7 +209,7 @@ getName :: Monad m => String -> StateT TState m Name

209getName tag = do ps <- get

210 let n = nextname ps

211 put (ps { nextname = n+1 })

212− return $ MN n tag

212+ return $ sMN n tag

213

214action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

215action a = do ps <- get

@@ -476,18 +476,12 @@ solve ctxt env (Bind x (Guess ty val) sc)

476 | True = do ps <- get

477 let (uh, uns) = unified ps

478 case lookup x (notunified ps) of

479− Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

480− -- return []

481− unify' ctxt env tm val

479+ Just tm -> unify' ctxt env tm val

482 _ -> return []

480 _ -> return []

483 action (\ps -> ps { holes = holes ps \\ [x],

481 action (\ps -> ps { holes = holes ps \\ [x],

484 solved = Just (x, val),

482 solved = Just (x, val),

485−-- problems = solveInProblems

486−-- x val (problems ps),

487− -- dontunify = dontunify ps \\ [x],

488− -- unified = (uh, uns ++ [(x, val)]),

489 instances = instances ps \\ [x] })

483 instances = instances ps \\ [x] })

490− let tm' = instantiate val (pToV x sc) in

484+ let tm' = subst x val sc in

491 return tm'

485 return tm'

492 | otherwise = lift $ tfail $ IncompleteTerm val

486 | otherwise = lift $ tfail $ IncompleteTerm val

493solve _ _ h@(Bind x t sc)

487solve _ _ h@(Bind x t sc)

@@ -513,7 +507,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

513 (tyv, tyt) <- lift $ check ctxt env ty

507 (tyv, tyt) <- lift $ check ctxt env ty

514-- ns <- lift $ unify ctxt env tyv t'

508-- ns <- lift $ unify ctxt env tyv t'

515 case t' of

509 case t' of

516− Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

510+ Bind y (Pi s) t -> let t' = subst y (P Bound n s) t in

517 do ns <- unify' ctxt env s tyv

511 do ns <- unify' ctxt env s tyv

518 ps <- get

512 ps <- get

519 let (uh, uns) = unified ps

513 let (uh, uns) = unified ps

@@ -532,7 +526,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

532 _ -> hnf ctxt env t

526 _ -> hnf ctxt env t

533 case t' of

527 case t' of

534 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

528 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

535− let t' = instantiate (P Bound n s) (pToV y t) in

529+ let t' = subst y (P Bound n s) t in

536 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

530 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

537 _ -> lift $ tfail $ CantIntroduce t'

531 _ -> lift $ tfail $ CantIntroduce t'

538intro n ctxt env _ = fail "Can't introduce here."

532intro n ctxt env _ = fail "Can't introduce here."

@@ -548,7 +542,7 @@ forall n ty ctxt env _ = fail "Can't pi bind here"

548patvar :: Name -> RunTactic

542patvar :: Name -> RunTactic

549patvar n ctxt env (Bind x (Hole t) sc) =

543patvar n ctxt env (Bind x (Hole t) sc) =

550 do action (\ps -> ps { holes = holes ps \\ [x] })

544 do action (\ps -> ps { holes = holes ps \\ [x] })

551− return $ Bind n (PVar t) (instantiate (P Bound n t) (pToV x sc))

545+ return $ Bind n (PVar t) (subst x (P Bound n t) sc)

552patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

546patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

553

547

554letbind :: Name -> Raw -> Raw -> RunTactic

548letbind :: Name -> Raw -> Raw -> RunTactic

@@ -568,16 +562,16 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

568 do (tmv, tmt) <- lift $ check ctxt env tm

562 do (tmv, tmt) <- lift $ check ctxt env tm

569 let tmt' = normalise ctxt env tmt

563 let tmt' = normalise ctxt env tmt

570 case unApply tmt' of

564 case unApply tmt' of

571− (P _ (UN "=") _, [lt,rt,l,r]) ->

565+ (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->

572 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

566 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

573 let newt = mkP l r l t

567 let newt = mkP l r l t

574 let sc = forget $ (Bind x (Hole newt)

568 let sc = forget $ (Bind x (Hole newt)

575− (mkApp (P Ref (UN "replace") (TType (UVal 0)))

569+ (mkApp (P Ref (sUN "replace") (TType (UVal 0)))

576 [lt, l, r, p, tmv, xp]))

570 [lt, l, r, p, tmv, xp]))

577 (scv, sct) <- lift $ check ctxt env sc

571 (scv, sct) <- lift $ check ctxt env sc

578 return scv

572 return scv

579 _ -> lift $ tfail (NotEquality tmv tmt')

573 _ -> lift $ tfail (NotEquality tmv tmt')

580− where rname = MN 0 "replaced"

574+ where rname = sMN 0 "replaced"

581rewrite _ _ _ _ = fail "Can't rewrite here"

575rewrite _ _ _ _ = fail "Can't rewrite here"

582

576

583-- To make the P for rewrite, replace syntactic occurrences of l in ty with

577-- To make the P for rewrite, replace syntactic occurrences of l in ty with

@@ -633,7 +627,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

633 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

627 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

634 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

628 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

635 _ -> fail "Unkown type for induction"

629 _ -> fail "Unkown type for induction"

636− where scname = MN 0 "scarg"

630+ where scname = sMN 0 "scarg"

637 makeConsArg (nm, ty) = P Bound nm ty

631 makeConsArg (nm, ty) = P Bound nm ty

638 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

632 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

639 bindConsArgs [] v = v

633 bindConsArgs [] v = v

@@ -642,7 +636,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

642 splitTyArgs param_pos tyargs =

636 splitTyArgs param_pos tyargs =

643 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

637 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

644 in (map snd params, map snd indicies)

638 in (map snd params, map snd indicies)

645− makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (MN 0 "idx") nms):nms) []

639+ makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []

646 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

640 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

647 let var = P Bound idnm idxt

641 let var = P Bound idnm idxt

648 return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs

642 return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs

@@ -662,7 +656,7 @@ patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

662 x@(Bind y (PVTy s) t) -> x

656 x@(Bind y (PVTy s) t) -> x

663 _ -> hnf ctxt env t

657 _ -> hnf ctxt env t

664 case t' of

658 case t' of

665− Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

659+ Bind y (PVTy s) t -> let t' = subst y (P Bound n s) t in

666 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

660 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

667 _ -> fail "Nothing to pattern bind"

661 _ -> fail "Nothing to pattern bind"

668patbind n ctxt env _ = fail "Can't pattern bind here"

662patbind n ctxt env _ = fail "Can't pattern bind here"

@@ -739,34 +733,42 @@ keepGiven du (u@(n, _) : us) hs

739 | n `elem` du = u : keepGiven du us hs

733 | n `elem` du = u : keepGiven du us hs

740keepGiven du (u : us) hs = keepGiven du us hs

734keepGiven du (u : us) hs = keepGiven du us hs

741

735

742−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

736+updateSolved xs x = updateSolved' xs x

743− updateSolved' xs x

737+updateSolved' [] x = x

744updateSolved' xs (Bind n (Hole ty) t)

738updateSolved' xs (Bind n (Hole ty) t)

745− | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t))

739+ | Just v <- lookup n xs

740+ = case xs of

741+ [_] -> psubst n v t

742+ _ -> psubst n v (updateSolved' xs t)

746updateSolved' xs (Bind n b t)

743updateSolved' xs (Bind n b t)

747 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

744 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

745+updateSolved' xs (App f a)

748−updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

746+ = App (updateSolved' xs f) (updateSolved' xs a)

749−updateSolved' xs (P _ n _)

747+updateSolved' xs (P _ n@(MN _ _) _)

750 | Just v <- lookup n xs = v

748 | Just v <- lookup n xs = v

751updateSolved' xs t = t

749updateSolved' xs t = t

752

750

751+updateEnv [] e = e

753updateEnv ns [] = []

752updateEnv ns [] = []

754updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

753updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

755

754

755+updateError [] err = err

756updateError ns (CantUnify b l r e xs sc)

757 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

758updateError ns e = e

759

760solveInProblems x val [] = []

761solveInProblems x val ((l, r, env, err) : ps)

762− = ((instantiate val (pToV x l), instantiate val (pToV x r),

762+ = ((psubst x val l, psubst x val r,

763 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

764

765+updateNotunified [] nu = nu

765updateNotunified ns nu = up nu where

766updateNotunified ns nu = up nu where

766 up [] = []

767 up [] = []

767− up ((n, t) : ns) = let t' = updateSolved ns t in

768+ up ((n, t) : nus) = let t' = updateSolved ns t in

768− ((n, t') : up ns)

769+ ((n, t') : up nus)

769

770

771+updateProblems ctxt [] ps inj holes = ([], ps)

770updateProblems ctxt ns ps inj holes = up ns ps where

772updateProblems ctxt ns ps inj holes = up ns ps where

771 up ns [] = (ns, [])

773 up ns [] = (ns, [])

772 up ns ((x, y, env, err) : ps) =

774 up ns ((x, y, env, err) : ps) =

@@ -811,12 +813,11 @@ processTactic EndUnify ps

811 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

813 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

812 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

814 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

813 (injective ps) (holes ps)

815 (injective ps) (holes ps)

814− tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

815− updateSolved ns'' (pterm ps) in

816+ tm' = updateSolved ns'' (pterm ps) in

816 return (ps { pterm = tm',

817 return (ps { pterm = tm',

817 unified = (h, []),

818 unified = (h, []),

818 problems = probs',

819 problems = probs',

819− notunified = updateNotunified ns (notunified ps),

820+ notunified = updateNotunified ns'' (notunified ps),

820 holes = holes ps \\ map fst ns'' }, "")

821 holes = holes ps \\ map fst ns'' }, "")

821processTactic (Reorder n) ps

822processTactic (Reorder n) ps

822 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

823 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

@@ -841,6 +842,7 @@ processTactic MatchProblems ps

841 pterm' = updateSolved ns' (pterm ps) in

842 pterm' = updateSolved ns' (pterm ps) in

842 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843 previous = Just ps, plog = "",

844 previous = Just ps, plog = "",

845+ notunified = updateNotunified ns' (notunified ps),

844 holes = holes ps \\ (map fst ns') }, plog ps)

846 holes = holes ps \\ (map fst ns') }, plog ps)

845processTactic t ps

847processTactic t ps

846 = case holes ps of

848 = case holes ps of

src/Idris/Core/TC.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE DeriveFunctor #-}

3+module Idris.Core.TC(TC'(..)) where

5+import Control.Monad

6+import Control.Monad.Trans.Error(Error(..))

8+data TC' e a = OK !a

9+ | Error e

10+ deriving (Eq, Functor)

11+

12+bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b

13+bindTC x k = case x of

14+ OK v -> k v

15+ Error e -> Error e

16+{-# INLINE bindTC #-}

17+

18+instance Error e => Monad (TC' e) where

19+ return x = OK x

20+ x >>= k = bindTC x k

21+ fail e = Error (strMsg e)

22+

23+instance Error e => MonadPlus (TC' e) where

24+ mzero = fail "Unknown error"

25+ (OK x) `mplus` _ = OK x

26+ _ `mplus` (OK y) = OK y

27+ err `mplus` _ = err

28+

src/Idris/Core/TT.hs+171−102

@@ -18,13 +18,16 @@

18 programs with implicit syntax into fully explicit terms.

19-}

21−module Idris.Core.TT where

21+module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where

23+import Idris.Core.TC

24+

23−import Control.Monad.State

25+import Control.Monad.State.Strict

24import Control.Monad.Trans.Error (Error(..))

26import Control.Monad.Trans.Error (Error(..))

25import Debug.Trace

27import Debug.Trace

26−import qualified Data.Map as Map

28+import qualified Data.Map.Strict as Map

27import Data.Char

29import Data.Char

30+import qualified Data.Text as T

28import Data.List

31import Data.List

29import Data.Vector.Unboxed (Vector)

32import Data.Vector.Unboxed (Vector)

30import qualified Data.Vector.Unboxed as V

33import qualified Data.Vector.Unboxed as V

@@ -74,37 +77,53 @@ instance Sized FC where

74instance Show FC where

77instance Show FC where

75 show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c

78 show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c

80+-- | Used for error reflection

81+data ErrorReportPart = TextPart String

82+ | NamePart Name

83+ | TermPart Term

84+ | SubReport [ErrorReportPart]

85+ deriving (Show, Eq)

86+

87+

88+-- Please remember to keep Err synchronised with

89+-- Language.Reflection.Errors.Err in the stdlib!

90+

91+-- | Idris errors. Used as exceptions in the compiler, but reported to users

92+-- if they reach the top level.

77data Err = Msg String

93data Err = Msg String

78− | InternalMsg String

94+ | InternalMsg String

79− | CantUnify Bool Term Term Err [(Name, Type)] Int

95+ | CantUnify Bool Term Term Err [(Name, Type)] Int

80− -- Int is 'score' - how much we did unify

96+ -- Int is 'score' - how much we did unify

81− -- Bool indicates recoverability, True indicates more info may make

97+ -- Bool indicates recoverability, True indicates more info may make

82− -- unification succeed

98+ -- unification succeed

83− | InfiniteUnify Name Term [(Name, Type)]

99+ | InfiniteUnify Name Term [(Name, Type)]

84− | CantConvert Term Term [(Name, Type)]

100+ | CantConvert Term Term [(Name, Type)]

101+ | CantSolveGoal Term [(Name, Type)]

85− | UnifyScope Name Name Term [(Name, Type)]

102+ | UnifyScope Name Name Term [(Name, Type)]

86− | CantInferType String

103+ | CantInferType String

87− | NonFunctionType Term Term

104+ | NonFunctionType Term Term

88− | NotEquality Term Term

105+ | NotEquality Term Term

89− | TooManyArguments Name

106+ | TooManyArguments Name

90− | CantIntroduce Term

107+ | CantIntroduce Term

91− | NoSuchVariable Name

108+ | NoSuchVariable Name

92− | NoTypeDecl Name

109+ | NoTypeDecl Name

93− | NotInjective Term Term Term

110+ | NotInjective Term Term Term

94− | CantResolve Term

111+ | CantResolve Term

95− | CantResolveAlts [String]

112+ | CantResolveAlts [String]

96− | IncompleteTerm Term

113+ | IncompleteTerm Term

97− | UniverseError

114+ | UniverseError

98− | ProgramLineComment

115+ | ProgramLineComment

99− | Inaccessible Name

116+ | Inaccessible Name

100− | NonCollapsiblePostulate Name

117+ | NonCollapsiblePostulate Name

101− | AlreadyDefined Name

118+ | AlreadyDefined Name

102− | ProofSearchFail Err

119+ | ProofSearchFail Err

103− | NoRewriting Term

120+ | NoRewriting Term

104− | At FC Err

121+ | At FC Err

105− | Elaborating String Name Err

122+ | Elaborating String Name Err

106− | ProviderError String

123+ | ProviderError String

107− | LoadingFailed String Err

124+ | LoadingFailed String Err

125+ | ReflectionError [[ErrorReportPart]] Err

126+ | ReflectionFailed String Err

108 deriving Eq

127 deriving Eq

109{-!

128{-!

110deriving instance NFData Err

129deriving instance NFData Err

@@ -137,6 +156,7 @@ score (CantUnify _ _ _ m _ s) = s + score m

137score (CantResolve _) = 20

156score (CantResolve _) = 20

138score (NoSuchVariable _) = 1000

157score (NoSuchVariable _) = 1000

139score (ProofSearchFail _) = 10000

158score (ProofSearchFail _) = 10000

159+score (CantSolveGoal _ _) = 10000

140score (InternalMsg _) = -1

160score (InternalMsg _) = -1

141score _ = 0

161score _ = 0

142

162

@@ -145,9 +165,10 @@ instance Show Err where

145 show (InternalMsg s) = "Internal error: " ++ show s

165 show (InternalMsg s) = "Internal error: " ++ show s

146 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

166 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

147 ++ show e ++ " in " ++ show sc ++ " " ++ show i

167 ++ show e ++ " in " ++ show sc ++ " " ++ show i

168+ show (CantSolveGoal g _) = "CantSolve " ++ show g

148 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

169 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

149 show (ProviderError msg) = "Type provider error: " ++ msg

170 show (ProviderError msg) = "Type provider error: " ++ msg

150− show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ show e

171+ show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

151 show ProgramLineComment = "Program line next to comment"

172 show ProgramLineComment = "Program line next to comment"

152 show (At f e) = show f ++ ":" ++ show e

173 show (At f e) = show f ++ ":" ++ show e

153 show _ = "Error"

174 show _ = "Error"

@@ -167,13 +188,11 @@ instance Pretty Err where

167 pretty _ = text "Error"

188 pretty _ = text "Error"

168

189

169instance Error Err where

190instance Error Err where

170− strMsg = Msg

191+ strMsg = InternalMsg

171

192

172−data TC a = OK a

193+type TC = TC' Err

173− | Error Err

174− deriving (Eq, Functor)

175

194

176−instance Pretty a => Pretty (TC a) where

195+instance (Pretty a) => Pretty (TC a) where

177 pretty (OK ok) = pretty ok

196 pretty (OK ok) = pretty ok

178 pretty (Error err) =

197 pretty (Error err) =

179 if size err > breakingSize then

198 if size err > breakingSize then

@@ -185,29 +204,16 @@ instance Show a => Show (TC a) where

185 show (OK x) = show x

204 show (OK x) = show x

186 show (Error str) = "Error: " ++ show str

205 show (Error str) = "Error: " ++ show str

187

206

188−-- at some point, this instance should also carry type checking options

189−-- (e.g. Type:Type)

190−

191−instance Monad TC where

192− return = OK

193− x >>= k = case x of

194− OK v -> k v

195− Error e -> Error e

196− fail e = Error (InternalMsg e)

197−

198tfail :: Err -> TC a

207tfail :: Err -> TC a

199tfail e = Error e

208tfail e = Error e

200

209

210+failMsg :: String -> TC a

211+failMsg str = Error (Msg str)

212+

201trun :: FC -> TC a -> TC a

213trun :: FC -> TC a -> TC a

202trun fc (OK a) = OK a

214trun fc (OK a) = OK a

203trun fc (Error e) = Error (At fc e)

215trun fc (Error e) = Error (At fc e)

204

216

205−instance MonadPlus TC where

206− mzero = fail "Unknown error"

207− (OK x) `mplus` _ = OK x

208− _ `mplus` (OK y) = OK y

209− err `mplus` _ = err

210−

211discard :: Monad m => m a -> m ()

217discard :: Monad m => m a -> m ()

212discard f = f >> return ()

218discard f = f >> return ()

213

219

@@ -225,20 +231,44 @@ traceWhen False _ a = a

225

231

226-- | Names are hierarchies of strings, describing scope (so no danger of

232-- | Names are hierarchies of strings, describing scope (so no danger of

227-- duplicate names, but need to be careful on lookup).

233-- duplicate names, but need to be careful on lookup).

228−data Name = UN String -- ^ User-provided name

234+data Name = UN T.Text -- ^ User-provided name

229− | NS Name [String] -- ^ Root, namespaces

235+ | NS Name [T.Text] -- ^ Root, namespaces

230− | MN Int String -- ^ Machine chosen names

236+ | MN Int T.Text -- ^ Machine chosen names

231 | NErased -- ^ Name of somethng which is never used in scope

237 | NErased -- ^ Name of somethng which is never used in scope

232 | SN SpecialName -- ^ Decorated function names

238 | SN SpecialName -- ^ Decorated function names

239+ | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

233 deriving (Eq, Ord)

240 deriving (Eq, Ord)

241+

242+txt :: String -> T.Text

243+txt = T.pack

244+

245+str :: T.Text -> String

246+str = T.unpack

247+

248+tnull :: T.Text -> Bool

249+tnull = T.null

250+

251+thead :: T.Text -> Char

252+thead = T.head

253+

254+-- Smart constructors for names, using old String style

255+sUN :: String -> Name

256+sUN s = UN (txt s)

257+

258+sNS :: Name -> [String] -> Name

259+sNS n ss = NS n (map txt ss)

260+

261+sMN :: Int -> String -> Name

262+sMN i s = MN i (txt s)

263+

234{-!

264{-!

235deriving instance Binary Name

265deriving instance Binary Name

236deriving instance NFData Name

266deriving instance NFData Name

237!-}

267!-}

238

268

239data SpecialName = WhereN Int Name Name

269data SpecialName = WhereN Int Name Name

240− | InstanceN Name [String]

270+ | InstanceN Name [T.Text]

241− | ParentN Name String

271+ | ParentN Name T.Text

242 | MethodN Name

272 | MethodN Name

243 | CaseN Name

273 | CaseN Name

244 | ElimN Name

274 | ElimN Name

@@ -248,6 +278,12 @@ deriving instance Binary SpecialName

248deriving instance NFData SpecialName

278deriving instance NFData SpecialName

249!-}

279!-}

250

280

281+sInstanceN :: Name -> [String] -> SpecialName

282+sInstanceN n ss = InstanceN n (map T.pack ss)

283+

284+sParentN :: Name -> String -> SpecialName

285+sParentN n s = ParentN n (T.pack s)

286+

251instance Sized Name where

287instance Sized Name where

252 size (UN n) = 1

288 size (UN n) = 1

253 size (NS n els) = 1 + length els

289 size (NS n els) = 1 + length els

@@ -255,36 +291,36 @@ instance Sized Name where

255 size _ = 1

291 size _ = 1

256

292

257instance Pretty Name where

293instance Pretty Name where

258− pretty (UN n) = text n

294+ pretty (UN n) = text (T.unpack n)

259 pretty (NS n s) = pretty n

295 pretty (NS n s) = pretty n

260− pretty (MN i s) = lbrace <+> text s <+> (text . show $ i) <+> rbrace

296+ pretty (MN i s) = lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

261 pretty (SN s) = text (show s)

297 pretty (SN s) = text (show s)

262

298

263instance Show Name where

299instance Show Name where

264− show (UN n) = n

300+ show (UN n) = str n

265− show (NS n s) = showSep "." (reverse s) ++ "." ++ show n

301+ show (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ show n

266− show (MN _ "underscore") = "_"

302+ show (MN _ u) | u == txt "underscore" = "_"

267− show (MN i s) = "{" ++ s ++ show i ++ "}"

303+ show (MN i s) = "{" ++ str s ++ show i ++ "}"

268 show (SN s) = show s

304 show (SN s) = show s

269 show NErased = "_"

305 show NErased = "_"

270

306

271instance Show SpecialName where

307instance Show SpecialName where

272 show (WhereN i p c) = show p ++ ", " ++ show c

308 show (WhereN i p c) = show p ++ ", " ++ show c

273− show (InstanceN cl inst) = showSep ", " inst ++ " instance of " ++ show cl

309+ show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl

274 show (MethodN m) = "method " ++ show m

310 show (MethodN m) = "method " ++ show m

275− show (ParentN p c) = show p ++ "#" ++ c

311+ show (ParentN p c) = show p ++ "#" ++ T.unpack c

276 show (CaseN n) = "case block in " ++ show n

312 show (CaseN n) = "case block in " ++ show n

277 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

313 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

278

314

279-- Show a name in a way decorated for code generation, not human reading

315-- Show a name in a way decorated for code generation, not human reading

280showCG :: Name -> String

316showCG :: Name -> String

281−showCG (UN n) = n

317+showCG (UN n) = T.unpack n

282−showCG (NS n s) = showSep "." (reverse s) ++ "." ++ showCG n

318+showCG (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCG n

283−showCG (MN _ "underscore") = "_"

319+showCG (MN _ u) | u == txt "underscore" = "_"

284−showCG (MN i s) = "{" ++ s ++ show i ++ "}"

320+showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}"

285showCG (SN s) = showCG' s

321showCG (SN s) = showCG' s

286 where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i

322 where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i

287− showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" inst

323+ showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst)

288 showCG' (MethodN m) = '!':showCG m

324 showCG' (MethodN m) = '!':showCG m

289 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

325 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

290 showCG' (CaseN c) = showCG c ++ "_case"

326 showCG' (CaseN c) = showCG c ++ "_case"

@@ -297,9 +333,13 @@ showCG NErased = "_"

297type Ctxt a = Map.Map Name (Map.Map Name a)

333type Ctxt a = Map.Map Name (Map.Map Name a)

298emptyContext = Map.empty

334emptyContext = Map.empty

299

335

336+mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b

337+mapCtxt = fmap . fmap

338+

300-- |Return True if the argument 'Name' should be interpreted as the name of a

339-- |Return True if the argument 'Name' should be interpreted as the name of a

301-- typeclass.

340-- typeclass.

302−tcname (UN ('@':_)) = True

341+tcname (UN xs) | T.null xs = False

342+ | otherwise = T.head xs == '@'

303tcname (NS n _) = tcname n

343tcname (NS n _) = tcname n

304tcname (SN (InstanceN _ _)) = True

344tcname (SN (InstanceN _ _)) = True

305tcname (SN (MethodN _)) = True

345tcname (SN (MethodN _)) = True

@@ -307,7 +347,8 @@ tcname (SN (ParentN _ _)) = True

307tcname _ = False

347tcname _ = False

308

348

309implicitable (NS n _) = implicitable n

349implicitable (NS n _) = implicitable n

310−implicitable (UN (x:xs)) = isLower x

350+implicitable (UN xs) | T.null xs = False

351+ | otherwise = isLower (T.head xs)

311implicitable (MN _ _) = True

352implicitable (MN _ _) = True

312implicitable _ = False

353implicitable _ = False

313

354

@@ -472,22 +513,22 @@ deriving instance NFData Raw

472-- | All binding forms are represented in a uniform fashion. This type only represents

513-- | All binding forms are represented in a uniform fashion. This type only represents

473-- the types of bindings (and their values, if any); the attached identifiers are part

514-- the types of bindings (and their values, if any); the attached identifiers are part

474-- of the 'Bind' constructor for the 'TT' type.

515-- of the 'Bind' constructor for the 'TT' type.

475−data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

516+data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

476− | Pi { binderTy :: b }

517+ | Pi { binderTy :: !b }

477 {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -}

518 {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -}

478− | Let { binderTy :: b,

519+ | Let { binderTy :: !b,

479 binderVal :: b {-^ value for bound variable-}}

520 binderVal :: b {-^ value for bound variable-}}

480 -- ^ A binding that occurs in a @let@ expression

521 -- ^ A binding that occurs in a @let@ expression

481− | NLet { binderTy :: b,

522+ | NLet { binderTy :: !b,

482 binderVal :: b }

523 binderVal :: b }

483− | Hole { binderTy :: b}

524+ | Hole { binderTy :: !b}

484 | GHole { envlen :: Int,

525 | GHole { envlen :: Int,

485− binderTy :: b}

526+ binderTy :: !b}

486− | Guess { binderTy :: b,

527+ | Guess { binderTy :: !b,

487 binderVal :: b }

528 binderVal :: b }

488− | PVar { binderTy :: b }

529+ | PVar { binderTy :: !b }

489 -- ^ A pattern variable

530 -- ^ A pattern variable

490− | PVTy { binderTy :: b }

531+ | PVTy { binderTy :: !b }

491 deriving (Show, Eq, Ord, Functor)

532 deriving (Show, Eq, Ord, Functor)

492{-!

533{-!

493deriving instance Binary Binder

534deriving instance Binary Binder

@@ -592,12 +633,12 @@ instance Eq NameType where

592data TT n = P NameType n (TT n) -- ^ named references with type

633data TT n = P NameType n (TT n) -- ^ named references with type

593 -- (P for "Parameter", motivated by McKinna and Pollack's

634 -- (P for "Parameter", motivated by McKinna and Pollack's

594 -- Pure Type Systems Formalized)

635 -- Pure Type Systems Formalized)

595− | V Int -- ^ a resolved de Bruijn-indexed variable

636+ | V !Int -- ^ a resolved de Bruijn-indexed variable

596− | Bind n (Binder (TT n)) (TT n) -- ^ a binding

637+ | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

597− | App (TT n) (TT n) -- ^ function, function type, arg

638+ | App !(TT n) (TT n) -- ^ function, function type, arg

598 | Constant Const -- ^ constant

639 | Constant Const -- ^ constant

599− | Proj (TT n) Int -- ^ argument projection; runtime only

640+ | Proj (TT n) !Int -- ^ argument projection; runtime only

600− -- (-1) is a special case for 'subtract one from BI'

641+ -- (-1) is a special case for 'subtract one from BI'

601 | Erased -- ^ an erased term

642 | Erased -- ^ an erased term

602 | Impossible -- ^ special case for totality checking

643 | Impossible -- ^ special case for totality checking

603 | TType UExp -- ^ the type of types at some level

644 | TType UExp -- ^ the type of types at some level

@@ -624,10 +665,10 @@ instance TermSize (TT Name) where

624 -- variable is the same as the name we're using

665 -- variable is the same as the name we're using

625 -- So generate a different name in that case.

666 -- So generate a different name in that case.

626 termsize n (Bind n' (Let t v) sc)

667 termsize n (Bind n' (Let t v) sc)

627− = let rn = if n == n' then MN 0 "noname" else n in

668+ = let rn = if n == n' then sMN 0 "noname" else n in

628 termsize rn v + termsize rn sc

669 termsize rn v + termsize rn sc

629 termsize n (Bind n' b sc)

670 termsize n (Bind n' b sc)

630− = let rn = if n == n' then MN 0 "noname" else n in

671+ = let rn = if n == n' then sMN 0 "noname" else n in

631 termsize rn sc

672 termsize rn sc

632 termsize n (App f a) = termsize n f + termsize n a

673 termsize n (App f a) = termsize n f + termsize n a

633 termsize n (Proj t i) = termsize n t

674 termsize n (Proj t i) = termsize n t

@@ -656,8 +697,8 @@ data Datatype n = Data { d_typename :: n,

656instance Eq n => Eq (TT n) where

697instance Eq n => Eq (TT n) where

657 (==) (P xt x _) (P yt y _) = x == y

698 (==) (P xt x _) (P yt y _) = x == y

658 (==) (V x) (V y) = x == y

699 (==) (V x) (V y) = x == y

659− (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys

700+ (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

660− (==) (App fx ax) (App fy ay) = fx == fy && ax == ay

701+ (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

661 (==) (TType _) (TType _) = True -- deal with constraints later

702 (==) (TType _) (TType _) = True -- deal with constraints later

662 (==) (Constant x) (Constant y) = x == y

703 (==) (Constant x) (Constant y) = x == y

663 (==) (Proj x i) (Proj y j) = x == y && i == j

704 (==) (Proj x i) (Proj y j) = x == y && i == j

@@ -770,6 +811,15 @@ finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc))

770finalise (App f a) = App (finalise f) (finalise a)

811finalise (App f a) = App (finalise f) (finalise a)

771finalise t = t

812finalise t = t

772

813

814+-- Once we've finished checking everything about a term we no longer need

815+-- the type on the 'P' so erase it so save memory

816+

817+pEraseType :: TT n -> TT n

818+pEraseType (P nt t _) = P nt t Erased

819+pEraseType (App f a) = App (pEraseType f) (pEraseType a)

820+pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc)

821+pEraseType t = t

822+

773-- | As 'instantiate', but in addition to replacing @'V' 0@,

823-- | As 'instantiate', but in addition to replacing @'V' 0@,

774-- replace references to the given 'Name'-like id.

824-- replace references to the given 'Name'-like id.

775subst :: Eq n => n {-^ The id to replace -} ->

825subst :: Eq n => n {-^ The id to replace -} ->

@@ -778,6 +828,16 @@ subst :: Eq n => n {-^ The id to replace -} ->

778 TT n

828 TT n

779subst n v tm = instantiate v (pToV n tm)

829subst n v tm = instantiate v (pToV n tm)

780

830

831+-- If there are no Vs in the term (i.e. in proof state)

832+psubst :: Eq n => n -> TT n -> TT n -> TT n

833+psubst n v tm = s' tm where

834+ s' (P _ x _) | n == x = v

835+ s' (Bind x b sc) | n == x = Bind x (fmap s' b) sc

836+ | otherwise = Bind x (fmap s' b) (s' sc)

837+ s' (App f a) = App (s' f) (s' a)

838+ s' (Proj t idx) = Proj (s' t) idx

839+ s' t = t

840+

781-- | As 'subst', but takes a list of (name, substitution) pairs instead

841-- | As 'subst', but takes a list of (name, substitution) pairs instead

782-- of a single name and substitution

842-- of a single name and substitution

783substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

843substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

@@ -837,6 +897,14 @@ mkApp :: TT n -> [TT n] -> TT n

837mkApp f [] = f

897mkApp f [] = f

838mkApp f (a:as) = mkApp (App f a) as

898mkApp f (a:as) = mkApp (App f a) as

839

899

900+unList :: Term -> Maybe [Term]

901+unList tm = case unApply tm of

902+ (nil, [_]) -> Just []

903+ (cons, ([_, x, xs])) ->

904+ do rest <- unList xs

905+ return $ x:rest

906+ (f, args) -> Nothing

907+

840-- | Cast a 'TT' term to a 'Raw' value, discarding universe information and

908-- | Cast a 'TT' term to a 'Raw' value, discarding universe information and

841-- the types of named references and replacing all de Bruijn indices

909-- the types of named references and replacing all de Bruijn indices

842-- with the corresponding name. It is an error if there are free de

910-- with the corresponding name. It is an error if there are free de

@@ -846,8 +914,9 @@ forget tm = fe [] tm

846 where

914 where

847 fe env (P _ n _) = Var n

915 fe env (P _ n _) = Var n

848 fe env (V i) = Var (env !! i)

916 fe env (V i) = Var (env !! i)

917+ fe env (Bind n b sc) = let n' = uniqueName n env in

849− fe env (Bind n b sc) = RBind n (fmap (fe env) b)

918+ RBind n' (fmap (fe env) b)

850− (fe (n:env) sc)

919+ (fe (n':env) sc)

851 fe env (App f a) = RApp (fe env f) (fe env a)

920 fe env (App f a) = RApp (fe env f) (fe env a)

852 fe env (Constant c)

921 fe env (Constant c)

853 = RConstant c

922 = RConstant c

@@ -898,13 +967,13 @@ uniqueBinders ns t = t

898

967

899nextName (NS x s) = NS (nextName x) s

968nextName (NS x s) = NS (nextName x) s

900nextName (MN i n) = MN (i+1) n

969nextName (MN i n) = MN (i+1) n

901−nextName (UN x) = let (num', nm') = span isDigit (reverse x)

970+nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

902− nm = reverse nm'

971+ nm = T.reverse nm'

903− num = readN (reverse num') in

972+ num = readN (T.reverse num') in

904− UN (nm ++ show (num+1))

973+ UN (nm `T.append` txt (show (num+1)))

905 where

974 where

906− readN "" = 0

975+ readN x | not (T.null x) = read (T.unpack x)

907− readN x = read x

976+ readN x = 0

908nextName (SN x) = SN (nextName' x)

977nextName (SN x) = SN (nextName' x)

909 where

978 where

910 nextName' (WhereN i f x) = WhereN i f (nextName x)

979 nextName' (WhereN i f x) = WhereN i f (nextName x)

@@ -1056,7 +1125,7 @@ pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

1056 pureBinder (Let t v) = pureTerm t && pureTerm v

1125 pureBinder (Let t v) = pureTerm t && pureTerm v

1057 pureBinder t = pureTerm (binderTy t)

1126 pureBinder t = pureTerm (binderTy t)

1058

1127

1059− notClassName (MN _ "class") = False

1128+ notClassName (MN _ c) | c == txt "class" = False

1060 notClassName _ = True

1129 notClassName _ = True

1061

1130

1062pureTerm _ = True

1131pureTerm _ = True

src/Idris/Core/Typecheck.hs+1−1

@@ -88,7 +88,7 @@ check' holes ctxt env top = chk env top where

88 -- make sure bound names in function types are locally unique, machine

89 -- generated names, we'll be fine.

90 -- NOTE: now replaced with 'uniqueBinders' above

91− where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s)

91+ where renameBinders i (Bind x (Pi s) t) = Bind (sMN i "binder") (Pi s)

92 (renameBinders (i+1) t)

93 renameBinders i sc = sc

94 chk env RType

src/Idris/Core/Unify.hs+27−7

@@ -6,7 +6,7 @@ import Idris.Core.TT

6import Idris.Core.Evaluate

8import Control.Monad

9−import Control.Monad.State

9+import Control.Monad.State.Strict

10import Data.List

11import Debug.Trace

@@ -35,22 +35,24 @@ match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

35 TC [(Name, TT Name)]

36match_unify ctxt env topx topy dont holes =

37 case runStateT (un [] topx topy) (UI 0 []) of

38− OK (v, UI _ []) -> return (trimSolutions v)

38+ OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

39 res ->

40 let topxn = normalise ctxt env topx

41 topyn = normalise ctxt env topy in

42 case runStateT (un [] topxn topyn)

43 (UI 0 []) of

44 OK (v, UI _ fails) ->

45− return (trimSolutions v)

45+ return (map (renameBinders env) (trimSolutions v))

46 Error e ->

47 -- just normalise the term we're matching against

48 case runStateT (un [] topxn topy)

49 (UI 0 []) of

50 OK (v, UI _ fails) ->

51− return (trimSolutions v)

51+ return (map (renameBinders env) (trimSolutions v))

52 _ -> tfail e

53 where

54+

55+

54 un names (P _ x _) tm

56 un names (P _ x _) tm

55 | holeIn env x || x `elem` holes

57 | holeIn env x || x `elem` holes

56 = do sc 1; checkCycle names (x, tm)

58 = do sc 1; checkCycle names (x, tm)

@@ -127,6 +129,23 @@ match_unify ctxt env topx topy dont holes =

127 (inst ns tm) (errEnv env))

129 (inst ns tm) (errEnv env))

128 where inst [] tm = tm

130 where inst [] tm = tm

129 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

131 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

132+

133+renameBinders :: Env -> (Name, TT Name) -> (Name, TT Name)

134+renameBinders env (x, tm) = (x, uniqueBinders tm)

135+ where

136+ uniqueBinders (Bind n b sc)

137+ | n `elem` map fst env

138+ = let n' = uniqueName n (map fst env) in

139+ Bind n' (fmap uniqueBinders b)

140+ (uniqueBinders (rename n n' sc))

141+ | otherwise = Bind n (fmap uniqueBinders b) (uniqueBinders sc)

142+ uniqueBinders (App f a) = App (uniqueBinders f) (uniqueBinders a)

143+ uniqueBinders t = t

144+

145+ rename n n' (P nt x ty) | n == x = P nt n' ty

146+ rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)

147+ rename n n' (App f a) = App (rename n n' f) (rename n n' a)

148+ rename n n' t = t

130

149

131trimSolutions ns = dropPairs ns

150trimSolutions ns = dropPairs ns

132 where dropPairs [] = []

151 where dropPairs [] = []

@@ -154,7 +173,7 @@ unify ctxt env topx topy dont holes =

154-- trace ("Unifying " ++ show (topx, topy)) $

173-- trace ("Unifying " ++ show (topx, topy)) $

155 -- don't bother if topx and topy are different at the head

174 -- don't bother if topx and topy are different at the head

156 case runStateT (un False [] topx topy) (UI 0 []) of

175 case runStateT (un False [] topx topy) (UI 0 []) of

157− OK (v, UI _ []) -> return (trimSolutions v,

176+ OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),

158 [])

177 [])

159 res ->

178 res ->

160 let topxn = normalise ctxt env topx

179 let topxn = normalise ctxt env topx

@@ -163,7 +182,8 @@ unify ctxt env topx topy dont holes =

163 case runStateT (un False [] topxn topyn)

182 case runStateT (un False [] topxn topyn)

164 (UI 0 []) of

183 (UI 0 []) of

165 OK (v, UI _ fails) ->

184 OK (v, UI _ fails) ->

166− return (trimSolutions v, reverse fails)

185+ return (map (renameBinders env) (trimSolutions v),

186+ reverse fails)

167-- Error e@(CantUnify False _ _ _ _ _) -> tfail e

187-- Error e@(CantUnify False _ _ _ _ _) -> tfail e

168 Error e -> tfail e

188 Error e -> tfail e

169 where

189 where

@@ -277,7 +297,7 @@ unify ctxt env topx topy dont holes =

277

297

278 un' fn bnames (App f x) (Bind n (Pi t) y)

298 un' fn bnames (App f x) (Bind n (Pi t) y)

279 | noOccurrence n y && x == y

299 | noOccurrence n y && x == y

280− = un' False bnames f (Bind (MN 0 "uv") (Lam (TType (UVar 0)))

300+ = un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

281 (Bind n (Pi t) (V 1)))

301 (Bind n (Pi t) (V 1)))

282

302

283 un' fn bnames (Bind x bx sx) (Bind y by sy)

303 un' fn bnames (Bind x bx sx) (Bind y by sy)

src/Idris/Coverage.hs+13−10

@@ -15,7 +15,7 @@ import Data.Either

15import Data.Maybe

16import Debug.Trace

18−import Control.Monad.State

18+import Control.Monad.State.Strict

20mkPatTm :: PTerm -> Idris Term

21mkPatTm t = do i <- getIState

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

31 return $ mkApp t' args'

32 toTT _ = do v <- get

33 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (sMN v "imp") Erased)

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -166,13 +166,13 @@ genAll i args

166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167 otherPats o@(PPair fc l r)

168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

169+ ([pimp (sUN "A") Placeholder True,

170− pimp (UN "B") Placeholder True] ++

170+ pimp (sUN "B") Placeholder True] ++

171 [pexp l, pexp r]) o

172 otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

173+ = ops fc (sUN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

174+ ([pimp (sUN "a") Placeholder True,

175− pimp (UN "P") Placeholder True] ++

175+ pimp (sUN "P") Placeholder True] ++

176 [pexp t,pexp v]) o

177 otherPats o@(PConstant c) = return o

178 otherPats arg = return Placeholder

@@ -191,7 +191,8 @@ genAll i args

191 getExpTm t = getTm t

192

193 -- put it back to its original form

194− resugar (PApp _ (PRef fc (UN "Ex_intro")) [_,_,t,v])

194+ resugar (PApp _ (PRef fc (UN ei)) [_,_,t,v])

195+ | ei == txt "Ex_intro"

195 = PDPair fc (getTm t) Placeholder (getTm v)

196 = PDPair fc (getTm t) Placeholder (getTm v)

196 resugar (PApp _ (PRef fc n) [_,_,l,r])

197 resugar (PApp _ (PRef fc n) [_,_,l,r])

197 | n == pairCon

198 | n == pairCon

@@ -258,7 +259,8 @@ calcProd i fc topn pats

258

259

259 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260 prod n done ok ap@(App _ _)

261 prod n done ok ap@(App _ _)

261− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg

262+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

263+ l == txt "lazy" = prod n done ok arg

262 | (P nt f _, args) <- unApply ap

264 | (P nt f _, args) <- unApply ap

263 = do recOK <- checkProdRec (n:done) f

265 = do recOK <- checkProdRec (n:done) f

264 let ctxt = tt_ctxt i

266 let ctxt = tt_ctxt i

@@ -405,7 +407,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

405 findCalls (dePat rhs) (patvars lhs) pargs

407 findCalls (dePat rhs) (patvars lhs) pargs

406

408

407 findCalls ap@(App f a) pvs pargs

409 findCalls ap@(App f a) pvs pargs

408− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

410+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

411+ l == txt "lazy"

409 = findCalls arg pvs pargs

412 = findCalls arg pvs pargs

410 | (P _ n _, args) <- unApply ap

413 | (P _ n _, args) <- unApply ap

411 = mkChange n args pargs ++

414 = mkChange n args pargs ++

src/Idris/DSL.hs+6−5

@@ -8,7 +8,7 @@ import Paths_idris

8import Idris.Core.TT

9import Idris.Core.Evaluate

11−import Control.Monad.State

11+import Control.Monad.State.Strict

12import Debug.Trace

14debindApp :: SyntaxInfo -> PTerm -> PTerm

@@ -44,6 +44,7 @@ expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

44expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

45expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)

46expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t)

47+expandDo dsl (PDisamb ns t) = PDisamb ns (expandDo dsl t)

47expandDo dsl (PReturn fc) = dsl_return dsl

48expandDo dsl (PReturn fc) = dsl_return dsl

48expandDo dsl (PRewrite fc r t ty)

49expandDo dsl (PRewrite fc r t ty)

49 = PRewrite fc r (expandDo dsl t) ty

50 = PRewrite fc r (expandDo dsl t) ty

@@ -57,8 +58,8 @@ expandDo dsl (PDoBlock ds)

57 block b (DoBind fc n tm : rest)

58 block b (DoBind fc n tm : rest)

58 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

59 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

59 block b (DoBindP fc p tm : rest)

60 block b (DoBindP fc p tm : rest)

60− = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

61+ = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

61− (PCase fc (PRef fc (MN 0 "bpat"))

62+ (PCase fc (PRef fc (sMN 0 "bpat"))

62 [(p, block b rest)]))]

63 [(p, block b rest)]))]

63 block b (DoLet fc n ty tm : rest)

64 block b (DoLet fc n ty tm : rest)

64 = PLet n ty tm (block b rest)

65 = PLet n ty tm (block b rest)

@@ -67,7 +68,7 @@ expandDo dsl (PDoBlock ds)

67 block b (DoExp fc tm : rest)

68 block b (DoExp fc tm : rest)

68 = PApp fc b

69 = PApp fc b

69 [pexp tm,

70 [pexp tm,

70− pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

71+ pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))]

71 block b _ = PElabError (Msg "Invalid statement in do block")

72 block b _ = PElabError (Msg "Invalid statement in do block")

73expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

74expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

@@ -131,7 +132,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

131 db' (PAppBind fc t args)

132 db' (PAppBind fc t args)

132 = do args' <- dbs args

133 = do args' <- dbs args

133 (bs, n) <- get

134 (bs, n) <- get

134− let nm = MN n ("bindApp" ++ show n)

135+ let nm = sUN ("_bindApp" ++ show n)

135 put ((nm, fc, PApp fc t args') : bs, n+1)

136 put ((nm, fc, PApp fc t args') : bs, n+1)

136 return (PRef fc nm)

137 return (PRef fc nm)

137 db' (PApp fc t args)

138 db' (PApp fc t args)

src/Idris/DataOpts.hs+40−20

@@ -18,14 +18,16 @@ type ForceMap = M.IntMap Forceability

19-- Calculate the forceable arguments to a constructor

20-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> Type -> Idris ()

21+forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22−forceArgs typeName n t = do

22+forceArgs typeName n expforce t = do

23 ist <- getIState

24 let fargs = getForcedArgs ist typeName t

25 copt = case lookupCtxt n (idris_optimisation ist) of

26 [] -> Optimise False False [] []

27 op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs }) (idris_optimisation ist)

28+ opts = addDef n (copt { forceable = M.toList fargs ++

29+ zip expforce (repeat Unconditional) })

30+ (idris_optimisation ist)

29 putIState (ist { idris_optimisation = opts })

31 putIState (ist { idris_optimisation = opts })

30 addIBC (IBCOpt n)

32 addIBC (IBCOpt n)

31 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

33 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

@@ -37,7 +39,7 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

38 -- Label all occurrences of the variable bound in Pi in the rest of

40 -- Label all occurrences of the variable bound in Pi in the rest of

39 -- the term with the number i so that we can recognize them anytime later.

41 -- the term with the number i so that we can recognize them anytime later.

40− label i = instantiate $ P Bound (MN i "ctor_arg") Erased

42+ label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

42 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

44 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

43 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

45 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

@@ -73,7 +75,8 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

73 guardedArgs t = bareArg t

75 guardedArgs t = bareArg t

75 bareArg :: Term -> ForceMap

77 bareArg :: Term -> ForceMap

76− bareArg (P _ (MN i "ctor_arg") _) = M.singleton i Unconditional

78+ bareArg (P _ (MN i ctor_arg) _)

79+ | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

77 bareArg _ = M.empty

80 bareArg _ = M.empty

79 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

82 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

@@ -196,8 +199,14 @@ instance Optimisable Raw where

196

199

197 stripCollapsed t = return t

200 stripCollapsed t = return t

198

201

202+-- Erase types (makes ibc smaller, and we don't need them)

199−instance Optimisable t => Optimisable (Binder t) where

203+instance Optimisable (Binder (TT Name)) where

200− applyOpts (Let t v) = Let <$> applyOpts t <*> applyOpts v

204+ applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

205+ applyOpts b = return (b { binderTy = Erased })

206+ stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207+ stripCollapsed b = return (b { binderTy = Erased })

208+

209+instance Optimisable (Binder Raw) where

201 applyOpts b = do t' <- applyOpts (binderTy b)

210 applyOpts b = do t' <- applyOpts (binderTy b)

202 return (b { binderTy = t' })

211 return (b { binderTy = t' })

203 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

212 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

@@ -221,17 +230,24 @@ applyDataOpt oi n args

221

230

222-- Run-time: do everything

231-- Run-time: do everything

223

232

233+prel = [txt "Nat", txt "Prelude"]

234+

224instance Optimisable (TT Name) where

235instance Optimisable (TT Name) where

225− applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _)

236+ applyOpts (P _ (NS (UN fn) mod) _)

237+ | fn == txt "plus" && mod == prel

226− = return (P Ref (UN "prim__addBigInt") Erased)

238+ = return (P Ref (sUN "prim__addBigInt") Erased)

227− applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _)

239+ applyOpts (P _ (NS (UN fn) mod) _)

240+ | fn == txt "mult" && mod == prel

228− = return (P Ref (UN "prim__mulBigInt") Erased)

241+ = return (P Ref (sUN "prim__mulBigInt") Erased)

229− applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x)

242+ applyOpts (App (P _ (NS (UN fn) mod) _) x)

243+ | fn == txt "fromIntegerNat" && mod == prel

230 = applyOpts x

244 = applyOpts x

231− applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _)

245+ applyOpts (P _ (NS (UN fn) mod) _)

246+ | fn == txt "fromIntegerNat" && mod == prel

232− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

247+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

233− applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _)

248+ applyOpts (P _ (NS (UN fn) mod) _)

249+ | fn == txt "toIntegerNat" && mod == prel

234− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

250+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

235 applyOpts c@(P (DCon t arity) n _)

251 applyOpts c@(P (DCon t arity) n _)

236 = do i <- getIState

252 = do i <- getIState

237 case lookupCtxt n (idris_optimisation i) of

253 case lookupCtxt n (idris_optimisation i) of

@@ -282,16 +298,19 @@ applyDataOptRT oi n tag arity args

282 (collapsible oi) (M.fromList $ forceable oi) in

298 (collapsible oi) (M.fromList $ forceable oi) in

283 bind extra tm

299 bind extra tm

284 where

300 where

285− satArgs n = map (\i -> MN i "sat") [1..n]

301+ satArgs n = map (\i -> sMN i "sat") [1..n]

286

302

287 bind [] tm = tm

303 bind [] tm = tm

288 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

304 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

289

305

290 -- Nat special cases

306 -- Nat special cases

291 -- TODO: Would be nice if this was configurable in idris source!

307 -- TODO: Would be nice if this was configurable in idris source!

308+ doOpts (NS (UN z) [nat, prelude]) [] _ _

309+ | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

292− doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

310+ = Constant (BI 0)

293− doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

311+ doOpts (NS (UN s) [nat, prelude]) [k] _ _

312+ | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

294− = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

313+ = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

295

314

296 doOpts n args True _ = Erased

315 doOpts n args True _ = Erased

297 doOpts n args _ forceMap

316 doOpts n args _ forceMap

@@ -302,3 +321,4 @@ applyDataOptRT oi n tag arity args

302 where

321 where

303 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

322 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

304 args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

323 args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324+

src/Idris/DeepSeq.hs+2−97

@@ -1,7 +1,7 @@

1−module Idris.DeepSeq where

1+module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where

3+import Idris.Core.DeepSeq

3import Idris.Core.TT

4import Idris.Core.TT

4−import Idris.AbsSyntax

5import Idris.AbsSyntaxTree

7import Control.DeepSeq

@@ -12,32 +12,6 @@ instance NFData Forceability where

12 rnf Conditional = ()

13 rnf Unconditional = ()

15−instance NFData Raw where

16− rnf (Var x1) = rnf x1 `seq` ()

17− rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

18− rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19− rnf RType = ()

20− rnf (RForce x1) = rnf x1 `seq` ()

21− rnf (RConstant x1) = x1 `seq` ()

22−

23−instance NFData FC where

24− rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

25−

26−instance NFData Name where

27− rnf (UN x1) = rnf x1 `seq` ()

28− rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

29− rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

30− rnf NErased = ()

31− rnf (SN x1) = rnf x1 `seq` ()

32−

33−instance NFData SpecialName where

34− rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

35− rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

36− rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

37− rnf (MethodN x1) = rnf x1 `seq` ()

38− rnf (CaseN x1) = rnf x1 `seq` ()

39− rnf (ElimN x1) = rnf x1 `seq` ()

40−

41instance NFData IntTy where

15instance NFData IntTy where

42 rnf (ITFixed x1) = rnf x1 `seq` ()

16 rnf (ITFixed x1) = rnf x1 `seq` ()

43 rnf ITNative = ()

17 rnf ITNative = ()

@@ -45,85 +19,16 @@ instance NFData IntTy where

45 rnf ITChar = ()

19 rnf ITChar = ()

46 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

20 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

48−

49instance NFData NativeTy where

22instance NFData NativeTy where

50 rnf IT8 = ()

23 rnf IT8 = ()

51 rnf IT16 = ()

24 rnf IT16 = ()

52 rnf IT32 = ()

25 rnf IT32 = ()

53 rnf IT64 = ()

26 rnf IT64 = ()

54−

56instance NFData ArithTy where

28instance NFData ArithTy where

57 rnf (ATInt x1) = rnf x1 `seq` ()

29 rnf (ATInt x1) = rnf x1 `seq` ()

58 rnf ATFloat = ()

30 rnf ATFloat = ()

60−instance NFData Err where

61− rnf (Msg x1) = rnf x1 `seq` ()

62− rnf (InternalMsg x1) = rnf x1 `seq` ()

63− rnf (CantUnify x1 x2 x3 x4 x5 x6)

64− = rnf x1 `seq`

65− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

66− rnf (InfiniteUnify x1 x2 x3)

67− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

68− rnf (CantConvert x1 x2 x3)

69− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

70− rnf (UnifyScope x1 x2 x3 x4)

71− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

72− rnf (CantInferType x1) = rnf x1 `seq` ()

73− rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74− rnf (CantIntroduce x1) = rnf x1 `seq` ()

75− rnf (NoSuchVariable x1) = rnf x1 `seq` ()

76− rnf (NoTypeDecl x1) = rnf x1 `seq` ()

77− rnf (NotInjective x1 x2 x3)

78− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

79− rnf (CantResolve x1) = rnf x1 `seq` ()

80− rnf (CantResolveAlts x1) = rnf x1 `seq` ()

81− rnf (IncompleteTerm x1) = rnf x1 `seq` ()

82− rnf UniverseError = ()

83− rnf ProgramLineComment = ()

84− rnf (Inaccessible x1) = rnf x1 `seq` ()

85− rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

86− rnf (AlreadyDefined x1) = rnf x1 `seq` ()

87− rnf (ProofSearchFail x1) = rnf x1 `seq` ()

88− rnf (NoRewriting x1) = rnf x1 `seq` ()

89− rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

90− rnf (Elaborating x1 x2 x3)

91− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92− rnf (ProviderError x1) = rnf x1 `seq` ()

93− rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

94−

95−instance (NFData b) => NFData (Binder b) where

96− rnf (Lam x1) = rnf x1 `seq` ()

97− rnf (Pi x1) = rnf x1 `seq` ()

98− rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

99− rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

100− rnf (Hole x1) = rnf x1 `seq` ()

101− rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

102− rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103− rnf (PVar x1) = rnf x1 `seq` ()

104− rnf (PVTy x1) = rnf x1 `seq` ()

105−

106−instance NFData UExp where

107− rnf (UVar x1) = rnf x1 `seq` ()

108− rnf (UVal x1) = rnf x1 `seq` ()

109−

110−instance NFData NameType where

111− rnf Bound = ()

112− rnf Ref = ()

113− rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

114− rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

115−

116−instance (NFData n) => NFData (TT n) where

117− rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

118− rnf (V x1) = rnf x1 `seq` ()

119− rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

120− rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

121− rnf (Constant x1) = x1 `seq` ()

122− rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

123− rnf Erased = ()

124− rnf Impossible = ()

125− rnf (TType x1) = rnf x1 `seq` ()

126−

127instance NFData SizeChange where

32instance NFData SizeChange where

128 rnf Smaller = ()

33 rnf Smaller = ()

129 rnf Same = ()

34 rnf Same = ()

src/Idris/Delaborate.hs+30−9

@@ -9,6 +9,8 @@ import Idris.AbsSyntax

9import Idris.Core.TT

10import Idris.Core.Evaluate

12+import Data.List (intersperse)

13+

12import Debug.Trace

14import Debug.Trace

14bugaddr = "https://github.com/idris-lang/Idris-dev/issues"

16bugaddr = "https://github.com/idris-lang/Idris-dev/issues"

@@ -40,7 +42,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

41 de env _ (App f a) = deFn env f [a]

43 de env _ (App f a) = deFn env f [a]

42 de env _ (V i) | i < length env = PRef un (snd (env!!i))

44 de env _ (V i) | i < length env = PRef un (snd (env!!i))

43− | otherwise = PRef un (UN ("v" ++ show i ++ ""))

45+ | otherwise = PRef un (sUN ("v" ++ show i ++ ""))

44 de env _ (P _ n _) | n == unitTy = PTrue un

46 de env _ (P _ n _) | n == unitTy = PTrue un

45 | n == unitCon = PTrue un

47 | n == unitCon = PTrue un

46 | n == falseTy = PFalse un

48 | n == falseTy = PFalse un

@@ -61,8 +63,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

61 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

63 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

62 de env _ (Bind n (Let ty val) sc)

64 de env _ (Bind n (Let ty val) sc)

63 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

65 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

64− de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc

66+ de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

65− de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

67+ de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

66 de env _ (Bind n _ sc) = de ((n,n):env) [] sc

68 de env _ (Bind n _ sc) = de ((n,n):env) [] sc

67 de env _ (Constant i) = PConstant i

69 de env _ (Constant i) = PConstant i

68 de env _ Erased = Placeholder

70 de env _ Erased = Placeholder

@@ -80,16 +82,16 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

80 deFn env (P _ n _) [l,r]

82 deFn env (P _ n _) [l,r]

81 | n == pairTy = PPair un (de env [] l) (de env [] r)

83 | n == pairTy = PPair un (de env [] l) (de env [] r)

82 | n == eqCon = PRefl un (de env [] r)

84 | n == eqCon = PRefl un (de env [] r)

83− | n == UN "lazy" = de env [] r

85+ | n == sUN "lazy" = de env [] r

84 deFn env (P _ n _) [ty, Bind x (Lam _) r]

86 deFn env (P _ n _) [ty, Bind x (Lam _) r]

85− | n == UN "Exists"

87+ | n == sUN "Exists"

86 = PDPair un (PRef un x) (de env [] ty)

88 = PDPair un (PRef un x) (de env [] ty)

87 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

89 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

88 deFn env (P _ n _) [_,_,l,r]

90 deFn env (P _ n _) [_,_,l,r]

89 | n == pairCon = PPair un (de env [] l) (de env [] r)

91 | n == pairCon = PPair un (de env [] l) (de env [] r)

90 | n == eqTy = PEq un (de env [] l) (de env [] r)

92 | n == eqTy = PEq un (de env [] l) (de env [] r)

91− | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

93+ | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder

92− (de env [] r)

94+ (de env [] r)

93 deFn env (P _ n _) args | not mvs

95 deFn env (P _ n _) args | not mvs

94 = case lookup n (idris_metavars ist) of

96 = case lookup n (idris_metavars ist) of

95 Just (Just _, mi, _) ->

97 Just (Just _, mi, _) ->

@@ -140,6 +142,11 @@ pshow i (CantConvert x y env)

140 "Can't convert" ++ indented (showImp (Just i) imps colour (delab i x)) ++ "with"

142 "Can't convert" ++ indented (showImp (Just i) imps colour (delab i x)) ++ "with"

141 ++ indented (showImp (Just i) imps colour (delab i y)) ++

143 ++ indented (showImp (Just i) imps colour (delab i y)) ++

142 if (opt_errContext (idris_options i)) then showSc i env else ""

144 if (opt_errContext (idris_options i)) then showSc i env else ""

145+pshow i (CantSolveGoal x env)

146+ = let imps = opt_showimp (idris_options i) in

147+ let colour = idris_colourRepl i in

148+ "Can't solve goal " ++ indented (showImp (Just i) imps colour (delab i x)) ++

149+ if (opt_errContext (idris_options i)) then showSc i env else ""

143pshow i (UnifyScope n out tm env)

150pshow i (UnifyScope n out tm env)

144 = let imps = opt_showimp (idris_options i) in

151 = let imps = opt_showimp (idris_options i) in

145 let colour = idris_colourRepl i in

152 let colour = idris_colourRepl i in

@@ -190,6 +197,20 @@ pshow i (Elaborating s n e) = "When elaborating " ++ s ++

190 showqual i n ++ ":\n" ++ pshow i e

197 showqual i n ++ ":\n" ++ pshow i e

191pshow i (ProviderError msg) = "Type provider error: " ++ msg

198pshow i (ProviderError msg) = "Type provider error: " ++ msg

192pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e

199pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e

200+pshow i (ReflectionError parts orig) = let parts' = map (concat . intersperse " " . map showPart) parts in

201+ concat (intersperse "\n" parts') ++

202+ "\nOriginal error:\n" ++ indented (pshow i orig)

203+ where showPart :: ErrorReportPart -> String

204+ showPart (TextPart str) = str

205+ showPart (NamePart n) = let colour = idris_colourRepl i in

206+ showName (Just i) [] False colour n

207+ showPart (TermPart tm) = let colour = idris_colourRepl i

208+ in showImp (Just i) False colour (delab i tm)

209+ showPart (SubReport rs) = indented . concat . intersperse " " . map showPart $ rs

210+pshow i (ReflectionFailed msg err) = "When attempting to perform error reflection, the following internal error occurred:\n" ++

211+ indented (pshow i err) ++

212+ "\nThis is probably a bug. Please consider reporting it at " ++ bugaddr

213+

193

214

194showSc i [] = ""

215showSc i [] = ""

195showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))

216showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))

@@ -204,8 +225,8 @@ showqual i n = showName (Just i) [] False False (dens n)

204 dens n = n

225 dens n = n

205

226

206showbasic n@(UN _) = show n

227showbasic n@(UN _) = show n

207−showbasic (MN _ s) = s

228+showbasic (MN _ s) = str s

208−showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

229+showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

209showbasic (SN s) = show s

230showbasic (SN s) = show s

210

231

211

232

src/Idris/Docs.hs+1−1

@@ -107,7 +107,7 @@ docFun n

107

108 return (Doc n docstr args (delab i ty) f)

109 where funName :: Name -> String

110− funName (UN n) = n

110+ funName (UN n) = str n

111 funName (NS n _) = funName n

112

113

src/Idris/ElabDecls.hs+161−109

@@ -28,12 +28,13 @@ import Idris.Core.CaseTree

29import Control.DeepSeq

30import Control.Monad

31−import Control.Monad.State

31+import Control.Monad.State.Strict as State

32import Data.List

33import Data.Maybe

34import Debug.Trace

36import qualified Data.Map as Map

37+import qualified Data.Text as T

37import Data.Char(isLetter, toLower)

38import Data.Char(isLetter, toLower)

38import Data.List.Split (splitOn)

39import Data.List.Split (splitOn)

@@ -91,8 +92,10 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

91 let nty' = normalise ctxt [] nty

92 let nty' = normalise ctxt [] nty

93 -- Add normalised type to internals

94 -- Add normalised type to internals

95+ rep <- useREPL

96+ when rep $ do

94− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

97+ addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

95− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

98+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

97 let (t, _) = unApply (getRetTy nty')

100 let (t, _) = unApply (getRetTy nty')

98 let corec = case t of

101 let corec = case t of

@@ -112,6 +115,19 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

112 addIBC (IBCFlags n opts')

115 addIBC (IBCFlags n opts')

113 when (Implicit `elem` opts) $ do addCoercion n

116 when (Implicit `elem` opts) $ do addCoercion n

114 addIBC (IBCCoercion n)

117 addIBC (IBCCoercion n)

118+ -- If the function is declared as an error handler and the language

119+ -- extension is enabled, then add it to the list of error handlers.

120+ errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

121+ when (ErrorHandler `elem` opts) $ do

122+ if errorReflection

123+ then

124+ -- TODO: Check that the declared type is the correct type for an error handler:

125+ -- handler : List (TTName, TT) -> Err -> ErrorReport - for now no ctxt

126+ if tyIsHandler nty'

127+ then do i <- getIState

128+ putIState $ i { idris_errorhandlers = idris_errorhandlers i ++ [n] }

129+ else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

130+ else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

115 when corec $ do setAccessibility n Frozen

131 when corec $ do setAccessibility n Frozen

116 addIBC (IBCAccess n Frozen)

132 addIBC (IBCAccess n Frozen)

117 return usety

133 return usety

@@ -124,6 +140,22 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

124 | otherwise = mergeTy sc sc'

140 | otherwise = mergeTy sc sc'

125 mergeTy _ sc = sc

141 mergeTy _ sc = sc

126

142

143+ err = txt "Err"

144+ maybe = txt "Maybe"

145+ lst = txt "List"

146+ errrep = txt "ErrorReportPart"

147+

148+ tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _))

149+ (App (P _ (NS (UN m) ns2) _)

150+ (App (P _ (NS (UN l) ns3) _)

151+ (P _ (NS (UN r) ns4) _))))

152+ | e == err && m == maybe && l == lst && r == errrep

153+ , ns1 == map txt ["Errors","Reflection","Language"]

154+ , ns2 == map txt ["Maybe", "Prelude"]

155+ , ns3 == map txt ["List", "Prelude"]

156+ , ns4 == map txt ["Errors","Reflection","Language"] = True

157+ tyIsHandler _ = False

158+

127

159

128elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

160elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

129 FC -> FnOpts -> Name -> PTerm -> Idris ()

161 FC -> FnOpts -> Name -> PTerm -> Idris ()

@@ -272,7 +304,8 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

272type EliminatorState = StateT (Map.Map String Int) Idris

304type EliminatorState = StateT (Map.Map String Int) Idris

273

305

274-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

306-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

275−elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC)] -> ElabInfo -> EliminatorState ()

307+elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] ->

308+ ElabInfo -> EliminatorState ()

276elabEliminator paramPos n ty cons info = do

309elabEliminator paramPos n ty cons info = do

277 elimLog $ "Elaborating eliminator"

310 elimLog $ "Elaborating eliminator"

278 let (cnstrs, _) = splitPi ty

311 let (cnstrs, _) = splitPi ty

@@ -280,7 +313,7 @@ elabEliminator paramPos n ty cons info = do

280 generalParams <- namePis False pms

313 generalParams <- namePis False pms

281 motiveIdxs <- namePis False idxs

314 motiveIdxs <- namePis False idxs

282 let motive = mkMotive n paramPos generalParams motiveIdxs

315 let motive = mkMotive n paramPos generalParams motiveIdxs

283− consTerms <- mapM (\(c@(_,cnm,_,_)) -> do

316+ consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

284 name <- freshName $ "elim_" ++ simpleName cnm

317 name <- freshName $ "elim_" ++ simpleName cnm

285 consTerm <- extractConsTerm c generalParams

318 consTerm <- extractConsTerm c generalParams

286 return (name, expl, consTerm)) cons

319 return (name, expl, consTerm)) cons

@@ -296,13 +329,13 @@ elabEliminator paramPos n ty cons info = do

296 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

329 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

297 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

330 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

298 elimLog $ "-- eliminator definition: " ++ showDeclImp True eliminatorDef

331 elimLog $ "-- eliminator definition: " ++ showDeclImp True eliminatorDef

299− Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

332+ State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

300 -- Do not elaborate clauses if there aren't any

333 -- Do not elaborate clauses if there aren't any

301 case eliminatorClauses of

334 case eliminatorClauses of

302 [] -> return ()

335 [] -> return ()

303− _ -> Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

336+ _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

304 where elimLog :: String -> EliminatorState ()

337 where elimLog :: String -> EliminatorState ()

305− elimLog s = Control.Monad.State.lift (logLvl 2 s)

338+ elimLog s = State.lift (logLvl 2 s)

306

339

307 elimFC :: FC

340 elimFC :: FC

308 elimFC = fileFC "(eliminator)"

341 elimFC = fileFC "(eliminator)"

@@ -312,7 +345,7 @@ elabEliminator paramPos n ty cons info = do

312

345

313 applyNS :: Name -> [String] -> Name

346 applyNS :: Name -> [String] -> Name

314 applyNS n [] = n

347 applyNS n [] = n

315− applyNS n ns = NS n ns

348+ applyNS n ns = sNS n ns

316

349

317 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

350 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

318 splitPi = splitPi' []

351 splitPi = splitPi' []

@@ -351,11 +384,11 @@ elabEliminator paramPos n ty cons info = do

351

384

352 simpleName :: Name -> String

385 simpleName :: Name -> String

353 simpleName (NS n _) = simpleName n

386 simpleName (NS n _) = simpleName n

354− simpleName (MN i n) = n ++ show i

387+ simpleName (MN i n) = str n ++ show i

355 simpleName n = show n

388 simpleName n = show n

356

389

357 nameSpaces :: Name -> [String]

390 nameSpaces :: Name -> [String]

358− nameSpaces (NS _ ns) = ns

391+ nameSpaces (NS _ ns) = map str ns

359 nameSpaces _ = []

392 nameSpaces _ = []

360

393

361 freshName :: String -> EliminatorState Name

394 freshName :: String -> EliminatorState Name

@@ -364,16 +397,16 @@ elabEliminator paramPos n ty cons info = do

364 let i = fromMaybe 0 (Map.lookup key nameMap)

397 let i = fromMaybe 0 (Map.lookup key nameMap)

365 let name = key ++ show i

398 let name = key ++ show i

366 put $ Map.insert key (i+1) nameMap

399 put $ Map.insert key (i+1) nameMap

367− return (UN name)

400+ return (sUN name)

368

401

369 scrutineeName :: Name

402 scrutineeName :: Name

370− scrutineeName = UN "scrutinee"

403+ scrutineeName = sUN "scrutinee"

371

404

372 scrutineeArgName :: Name

405 scrutineeArgName :: Name

373− scrutineeArgName = UN "scrutineeArg"

406+ scrutineeArgName = sUN "scrutineeArg"

374

407

375 motiveName :: Name

408 motiveName :: Name

376− motiveName = UN "prop"

409+ motiveName = sUN "prop"

377

410

378 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

411 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

379 mkMotive n paramPos params indicies =

412 mkMotive n paramPos params indicies =

@@ -437,9 +470,9 @@ elabEliminator paramPos n ty cons info = do

437 splitArgPms _ = ([],[])

470 splitArgPms _ = ([],[])

438

471

439

472

440− implicitIndexes :: (String, Name, PTerm, FC) -> EliminatorState [(Name, Plicity, PTerm)]

473+ implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

441− implicitIndexes (cns@(doc, cnm, ty, fc)) = do

474+ implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

442− i <- Control.Monad.State.lift getIState

475+ i <- State.lift getIState

443 implargs' <- case lookupCtxt cnm (idris_implicits i) of

476 implargs' <- case lookupCtxt cnm (idris_implicits i) of

444 [] -> do fail $ "Error while showing implicits for " ++ show cnm

477 [] -> do fail $ "Error while showing implicits for " ++ show cnm

445 [args] -> do return args

478 [args] -> do return args

@@ -452,18 +485,18 @@ elabEliminator paramPos n ty cons info = do

452 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

485 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

453 _ -> return implargs

486 _ -> return implargs

454

487

455− extractConsTerm :: (String, Name, PTerm, FC) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

488+ extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

456− extractConsTerm (doc, cnm, ty, fc) generalParameters = do

489+ extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

457 let cons' = replaceParams paramPos generalParameters ty

490 let cons' = replaceParams paramPos generalParameters ty

458 let (args, resTy) = splitPi cons'

491 let (args, resTy) = splitPi cons'

459− implidxs <- implicitIndexes (doc, cnm, ty, fc)

492+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

460 consArgs <- namePis True args

493 consArgs <- namePis True args

461 let recArgs = findRecArgs consArgs

494 let recArgs = findRecArgs consArgs

462 let recMotives = map applyRecMotive recArgs

495 let recMotives = map applyRecMotive recArgs

463 let (_, consIdxs) = splitArgPms resTy

496 let (_, consIdxs) = splitArgPms resTy

464 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

497 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

465 where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)

498 where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)

466− applyRecMotive (n,_,ty) = (UN $ "ih" ++ simpleName n, expl, applyMotive idxs (PRef elimFC n))

499+ applyRecMotive (n,_,ty) = (sUN $ "ih" ++ simpleName n, expl, applyMotive idxs (PRef elimFC n))

467 where (_, idxs) = splitArgPms ty

500 where (_, idxs) = splitArgPms ty

468

501

469 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

502 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

@@ -488,12 +521,12 @@ elabEliminator paramPos n ty cons info = do

488 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

521 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

489 convertImplPi _ = Nothing

522 convertImplPi _ = Nothing

490

523

491− generateEliminatorClauses :: (String, Name, PTerm, FC) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

524+ generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

492− generateEliminatorClauses (doc, cnm, ty, fc) cnsElim generalArgs generalParameters = do

525+ generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

493 let cons' = replaceParams paramPos generalParameters ty

526 let cons' = replaceParams paramPos generalParameters ty

494 let (args, resTy) = splitPi cons'

527 let (args, resTy) = splitPi cons'

495− i <- Control.Monad.State.lift getIState

528+ i <- State.lift getIState

496− implidxs <- implicitIndexes (doc, cnm, ty, fc)

529+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

497 let (_, generalIdxs') = splitArgPms resTy

530 let (_, generalIdxs') = splitArgPms resTy

498 let generalIdxs = map pexp generalIdxs'

531 let generalIdxs = map pexp generalIdxs'

499 consArgs <- namePis True args

532 consArgs <- namePis True args

@@ -514,7 +547,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

514 (zip

547 (zip

515 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

548 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

516 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

549 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

517− addNameHint eqTy (UN "prf")

550+ addNameHint eqTy (sUN "prf")

518 elabDecl EAll toplevel elimDecl

551 elabDecl EAll toplevel elimDecl

519 mapM_ elabPrim primitives

552 mapM_ elabPrim primitives

520 -- Special case prim__believe_me because it doesn't work on just constants

553 -- Special case prim__believe_me because it doesn't work on just constants

@@ -537,11 +570,11 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

537

570

538 p_believeMe [_,_,x] = Just x

571 p_believeMe [_,_,x] = Just x

539 p_believeMe _ = Nothing

572 p_believeMe _ = Nothing

540− believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

573+ believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))))

541− (Bind (UN "b") (Pi (TType (UVar (-2))))

574+ (Bind (sUN "b") (Pi (TType (UVar (-2))))

542− (Bind (UN "x") (Pi (V 1)) (V 1)))

575+ (Bind (sUN "x") (Pi (V 1)) (V 1)))

543 elabBelieveMe

576 elabBelieveMe

544− = do let prim__believe_me = (UN "prim__believe_me")

577+ = do let prim__believe_me = sUN "prim__believe_me"

545 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

578 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

546 setTotality prim__believe_me (Partial NotCovering)

579 setTotality prim__believe_me (Partial NotCovering)

547 i <- getIState

580 i <- getIState

@@ -555,19 +588,19 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

555 | otherwise = Just (VApp vnNothing VErased)

588 | otherwise = Just (VApp vnNothing VErased)

556 p_synEq args = Nothing

589 p_synEq args = Nothing

557

590

558− nMaybe = P (TCon 0 2) (NS (UN "Maybe") ["Maybe", "Prelude"]) Erased

591+ nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased

559− vnJust = VP (DCon 1 2) (NS (UN "Just") ["Maybe", "Prelude"]) VErased

592+ vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased

560− vnNothing = VP (DCon 0 1) (NS (UN "Nothing") ["Maybe", "Prelude"]) VErased

593+ vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased

561 vnRefl = VP (DCon 0 2) eqCon VErased

594 vnRefl = VP (DCon 0 2) eqCon VErased

562

595

563− synEqTy = Bind (UN "a") (Pi (TType (UVar (-3))))

596+ synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))))

564− (Bind (UN "b") (Pi (TType (UVar (-3))))

597+ (Bind (sUN "b") (Pi (TType (UVar (-3))))

565− (Bind (UN "x") (Pi (V 1))

598+ (Bind (sUN "x") (Pi (V 1))

566− (Bind (UN "y") (Pi (V 1))

599+ (Bind (sUN "y") (Pi (V 1))

567 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

600 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

568 [V 3, V 2, V 1, V 0]]))))

601 [V 3, V 2, V 1, V 0]]))))

569 elabSynEq

602 elabSynEq

570− = do let synEq = UN "prim__syntactic_eq"

603+ = do let synEq = sUN "prim__syntactic_eq"

571

604

572 updateContext (addOperator synEq synEqTy 4 p_synEq)

605 updateContext (addOperator synEq synEqTy 4 p_synEq)

573 setTotality synEq (Total [])

606 setTotality synEq (Total [])

@@ -605,7 +638,7 @@ elabProvider info syn fc n ty tm

605 -- Execute the type provider and normalise the result

638 -- Execute the type provider and normalise the result

606 -- use 'run__provider' to convert to a primitive IO action

639 -- use 'run__provider' to convert to a primitive IO action

607

640

608− rhs <- execute (mkApp (P Ref (UN "run__provider") Erased)

641+ rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

609 [Erased, e])

642 [Erased, e])

610 let rhs' = normalise ctxt [] rhs

643 let rhs' = normalise ctxt [] rhs

611 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

644 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

@@ -623,9 +656,10 @@ elabProvider info syn fc n ty tm

623

656

624 isProviderOf :: TT Name -> TT Name -> Bool

657 isProviderOf :: TT Name -> TT Name -> Bool

625 isProviderOf tp prov

658 isProviderOf tp prov

626− | (P _ (UN "IO") _, [prov']) <- unApply prov

659+ | (P _ (UN io) _, [prov']) <- unApply prov

660+ , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'

661+ , tp == tp', io == txt "IO"

627− , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'

662+ , prov == txt "Provider" && provs == txt "Providers" = True

628− , tp == tp' = True

629 isProviderOf _ _ = False

663 isProviderOf _ _ = False

630

664

631-- | Elaborate a type provider

665-- | Elaborate a type provider

@@ -635,8 +669,8 @@ elabTransform info fc safe lhs_in rhs_in

635 i <- getIState

669 i <- getIState

636 let lhs = addImplPat i lhs_in

670 let lhs = addImplPat i lhs_in

637 ((lhs', dlhs, []), _) <-

671 ((lhs', dlhs, []), _) <-

638− tclift $ elaborate ctxt (MN 0 "transLHS") infP []

672+ tclift $ elaborate ctxt (sMN 0 "transLHS") infP []

639− (erun fc (buildTC i info True [] (UN "transform")

673+ (erun fc (buildTC i info True [] (sUN "transform")

640 (infTerm lhs)))

674 (infTerm lhs)))

641 let lhs_tm = orderPats (getInferTerm lhs')

675 let lhs_tm = orderPats (getInferTerm lhs')

642 let lhs_ty = getInferType lhs'

676 let lhs_ty = getInferType lhs'

@@ -646,13 +680,13 @@ elabTransform info fc safe lhs_in rhs_in

646 logLvl 3 ("Transform LHS " ++ show clhs_tm)

680 logLvl 3 ("Transform LHS " ++ show clhs_tm)

647 let rhs = addImplBound i (map fst newargs) rhs_in

681 let rhs = addImplBound i (map fst newargs) rhs_in

648 ((rhs', defer), _) <-

682 ((rhs', defer), _) <-

649− tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty []

683+ tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []

650 (do pbinds lhs_tm

684 (do pbinds lhs_tm

685+ setNextName

651− erun fc (build i info False [] (UN "transform") rhs)

686+ erun fc (build i info False [] (sUN "transform") rhs)

652 erun fc $ psolve lhs_tm

687 erun fc $ psolve lhs_tm

653 tt <- get_term

688 tt <- get_term

654− let (tm, ds) = runState (collectDeferred Nothing tt) []

689+ return (runState (collectDeferred Nothing tt) []))

655− return (tm, ds))

656 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

690 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

657 logLvl 3 ("Transform RHS " ++ show crhs_tm)

691 logLvl 3 ("Transform RHS " ++ show crhs_tm)

658 when safe $ case converts ctxt [] clhs_tm crhs_tm of

692 when safe $ case converts ctxt [] clhs_tm crhs_tm of

@@ -665,7 +699,7 @@ elabTransform info fc safe lhs_in rhs_in

665elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

699elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

666 PTerm -> String -> Name -> PTerm -> Idris ()

700 PTerm -> String -> Name -> PTerm -> Idris ()

667elabRecord info syn doc fc tyn ty cdoc cn cty

701elabRecord info syn doc fc tyn ty cdoc cn cty

668− = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

702+ = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc, [])])

669 cty' <- implicit syn cn cty

703 cty' <- implicit syn cn cty

670 i <- getIState

704 i <- getIState

671 cty <- case lookupTy cn (tt_ctxt i) of

705 cty <- case lookupTy cn (tt_ctxt i) of

@@ -719,18 +753,18 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

719 getRecTy (PPi _ n ty s) = getRecTy s

753 getRecTy (PPi _ n ty s) = getRecTy s

720 getRecTy t = t

754 getRecTy t = t

721

755

722− rec = MN 0 "rec"

756+ rec = sMN 0 "rec"

723

757

724− mkp (UN n) = MN 0 ("p_" ++ n)

758+ mkp (UN n) = sMN 0 ("p_" ++ str n)

725− mkp (MN i n) = MN i ("p_" ++ n)

759+ mkp (MN i n) = sMN i ("p_" ++ str n)

726 mkp (NS n s) = NS (mkp n) s

760 mkp (NS n s) = NS (mkp n) s

727

761

728− mkImp (UN n) = UN ("implicit_" ++ n)

762+ mkImp (UN n) = sUN ("implicit_" ++ str n)

729− mkImp (MN i n) = MN i ("implicit_" ++ n)

763+ mkImp (MN i n) = sMN i ("implicit_" ++ str n)

730 mkImp (NS n s) = NS (mkImp n) s

764 mkImp (NS n s) = NS (mkImp n) s

731

765

732− mkType (UN n) = UN ("set_" ++ n)

766+ mkType (UN n) = sUN ("set_" ++ str n)

733− mkType (MN i n) = MN i ("set_" ++ n)

767+ mkType (MN i n) = sMN i ("set_" ++ str n)

734 mkType (NS n s) = NS (mkType n) s

768 mkType (NS n s) = NS (mkType n) s

735

769

736 mkProj recty substs cimp ((pn_in, pty), pos)

770 mkProj recty substs cimp ((pn_in, pty), pos)

@@ -753,11 +787,11 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

753

787

754 mkUpdate recty k num ((pn, pty), pos)

788 mkUpdate recty k num ((pn, pty), pos)

755 = do let setname = expandNS syn $ mkType pn

789 = do let setname = expandNS syn $ mkType pn

756− let valname = MN 0 "updateval"

790+ let valname = sMN 0 "updateval"

757 let pt = k (PPi expl pn pty

791 let pt = k (PPi expl pn pty

758 (PPi expl rec recty recty))

792 (PPi expl rec recty recty))

759 let pfnTy = PTy "" defaultSyntax fc [] setname pt

793 let pfnTy = PTy "" defaultSyntax fc [] setname pt

760− let pls = map (\x -> PRef fc (MN x "field")) [0..num-1]

794+ let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]

761 let lhsArgs = pls

795 let lhsArgs = pls

762 let rhsArgs = take pos pls ++ (PRef fc valname) :

796 let rhsArgs = take pos pls ++ (PRef fc valname) :

763 drop (pos + 1) pls

797 drop (pos + 1) pls

@@ -772,8 +806,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

772 return (pn, pfnTy, PClauses fc [] setname [pclause])

806 return (pn, pfnTy, PClauses fc [] setname [pclause])

773

807

774elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

808elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

775− (String, Name, PTerm, FC) -> Idris (Name, Type)

809+ (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

776−elabCon info syn tn codata (doc, n, t_in, fc)

810+elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

777 = do checkUndefined fc n

811 = do checkUndefined fc n

778 ctxt <- getContext

812 ctxt <- getContext

779 i <- getIState

813 i <- getIState

@@ -796,7 +830,10 @@ elabCon info syn tn codata (doc, n, t_in, fc)

796 addIBC (IBCDef n)

830 addIBC (IBCDef n)

797 addDocStr n doc

831 addDocStr n doc

798 addIBC (IBCDoc n)

832 addIBC (IBCDoc n)

833+ let fs = map (getNamePos 0 t) forcenames

834+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

835+ -- erasing non-forceable things

799− forceArgs tn n cty'

836+ forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

800 return (n, cty')

837 return (n, cty')

801 where

838 where

802 tyIs (Bind n b sc) = tyIs sc

839 tyIs (Bind n b sc) = tyIs sc

@@ -808,6 +845,11 @@ elabCon info syn tn codata (doc, n, t_in, fc)

808 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

845 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

809 mkLazy t = t

846 mkLazy t = t

810

847

848+ getNamePos :: Int -> PTerm -> Name -> Maybe Int

849+ getNamePos i (PPi _ n _ sc) x | n == x = Just i

850+ | otherwise = getNamePos (i + 1) sc x

851+ getNamePos _ _ _ = Nothing

852+

811-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

853-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

812-- top-level definition.

854-- top-level definition.

813elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

855elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

@@ -1120,7 +1162,7 @@ elabPE info fc caller r =

1120 _ -> error "Can't happen (getSpecTy)"

1162 _ -> error "Can't happen (getSpecTy)"

1121

1163

1122 getSpecClause ist (n, args)

1164 getSpecClause ist (n, args)

1123− = let newnm = UN ("__"++show (nsroot n) ++ "_" ++

1165+ = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++

1124 showSep "_" (map showArg args)) in

1166 showSep "_" (map showArg args)) in

1125 -- UN (show n ++ show (map snd args)) in

1167 -- UN (show n ++ show (map snd args)) in

1126 (n, newnm, mkPE_TermDecl ist newnm n args)

1168 (n, newnm, mkPE_TermDecl ist newnm n args)

@@ -1145,8 +1187,8 @@ elabValBind info aspat tm_in

1145 ((tm', defer, is), _) <-

1187 ((tm', defer, is), _) <-

1146-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

1188-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

1147-- (build i info aspat (MN 0 "val") tm))

1189-- (build i info aspat (MN 0 "val") tm))

1148− tclift (elaborate ctxt (MN 0 "val") infP []

1190+ tclift (elaborate ctxt (sMN 0 "val") infP []

1149− (build i info aspat [Reflection] (MN 0 "val") (infTerm tm)))

1191+ (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

1150 let vtm = orderPats (getInferTerm tm')

1192 let vtm = orderPats (getInferTerm tm')

1151

1193

1152 def' <- checkDef (fileFC "(input)") defer

1194 def' <- checkDef (fileFC "(input)") defer

@@ -1176,7 +1218,7 @@ checkPossible info fc tcgen fname lhs_in

1176 i <- getIState

1218 i <- getIState

1177 let lhs = addImpl i lhs_in

1219 let lhs = addImpl i lhs_in

1178 -- if the LHS type checks, it is possible

1220 -- if the LHS type checks, it is possible

1179− case elaborate ctxt (MN 0 "patLHS") infP []

1221+ case elaborate ctxt (sMN 0 "patLHS") infP []

1180 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

1222 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

1181 OK ((lhs', _, _), _) ->

1223 OK ((lhs', _, _), _) ->

1182 do let lhs_tm = orderPats (getInferTerm lhs')

1224 do let lhs_tm = orderPats (getInferTerm lhs')

@@ -1231,7 +1273,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1231 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

1273 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

1232

1274

1233 ((lhs', dlhs, []), _) <-

1275 ((lhs', dlhs, []), _) <-

1234− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1276+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1235 (errAt "left hand side of " fname

1277 (errAt "left hand side of " fname

1236 (erun fc (buildTC i info True opts fname (infTerm lhs))))

1278 (erun fc (buildTC i info True opts fname (infTerm lhs))))

1237 let lhs_tm = orderPats (getInferTerm lhs')

1279 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1244,8 +1286,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1244

1286

1245 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

1287 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

1246

1288

1289+ rep <- useREPL

1290+ when rep $ do

1247− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1291+ addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1248− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1292+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1249

1293

1250 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1294 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1251 -- Elaborate where block

1295 -- Elaborate where block

@@ -1273,10 +1317,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1273 ctxt <- getContext -- new context with where block added

1317 ctxt <- getContext -- new context with where block added

1274 logLvl 5 "STARTING CHECK"

1318 logLvl 5 "STARTING CHECK"

1275 ((rhs', defer, is), _) <-

1319 ((rhs', defer, is), _) <-

1276− tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

1320+ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []

1277 (do pbinds lhs_tm

1321 (do pbinds lhs_tm

1322+ setNextName

1278 (_, _, is) <- errAt "right hand side of " fname

1323 (_, _, is) <- errAt "right hand side of " fname

1279− (erun fc (build i info False opts fname rhs))

1324+ (erun fc (build i info False opts fname rhs))

1280 errAt "right hand side of " fname

1325 errAt "right hand side of " fname

1281 (erun fc $ psolve lhs_tm)

1326 (erun fc $ psolve lhs_tm)

1282 hs <- get_holes

1327 hs <- get_holes

@@ -1287,7 +1332,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1287 return (tm, ds, is))

1332 return (tm, ds, is))

1288 logLvl 5 "DONE CHECK"

1333 logLvl 5 "DONE CHECK"

1289 logLvl 2 $ "---> " ++ show rhs'

1334 logLvl 2 $ "---> " ++ show rhs'

1290− when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer

1335+ when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer)

1291 def' <- checkDef fc defer

1336 def' <- checkDef fc defer

1292 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1337 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1293 addDeferred def''

1338 addDeferred def''

@@ -1303,6 +1348,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1303

1348

1304 ctxt <- getContext

1349 ctxt <- getContext

1305 logLvl 5 $ "Rechecking"

1350 logLvl 5 $ "Rechecking"

1351+ logLvl 6 $ " ==> " ++ show (forget rhs')

1306 (crhs, crhsty) <- recheckC fc [] rhs'

1352 (crhs, crhsty) <- recheckC fc [] rhs'

1307 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

1353 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

1308 case converts ctxt [] clhsty crhsty of

1354 case converts ctxt [] clhsty crhsty of

@@ -1408,7 +1454,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1408 let lhs = addImplPat i (stripLinear i lhs_in)

1454 let lhs = addImplPat i (stripLinear i lhs_in)

1409 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

1455 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

1410 ((lhs', dlhs, []), _) <-

1456 ((lhs', dlhs, []), _) <-

1411− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1457+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1412 (errAt "left hand side of with in " fname

1458 (errAt "left hand side of with in " fname

1413 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

1459 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

1414 let lhs_tm = orderPats (getInferTerm lhs')

1460 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1422,9 +1468,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1422 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

1468 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

1423 -- Elaborate wval in this context

1469 -- Elaborate wval in this context

1424 ((wval', defer, is), _) <-

1470 ((wval', defer, is), _) <-

1425− tclift $ elaborate ctxt (MN 0 "withRHS")

1471+ tclift $ elaborate ctxt (sMN 0 "withRHS")

1426 (bindTyArgs PVTy bargs infP) []

1472 (bindTyArgs PVTy bargs infP) []

1427 (do pbinds lhs_tm

1473 (do pbinds lhs_tm

1474+ setNextName

1428 -- TODO: may want where here - see winfo abpve

1475 -- TODO: may want where here - see winfo abpve

1429 (_', d, is) <- errAt "with value in " fname

1476 (_', d, is) <- errAt "with value in " fname

1430 (erun fc (build i info False opts fname (infTerm wval)))

1477 (erun fc (build i info False opts fname (infTerm wval)))

@@ -1454,11 +1501,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1454 let wargtype = getRetTy cwvaltyN

1501 let wargtype = getRetTy cwvaltyN

1455 logLvl 5 ("Abstract over " ++ show wargval)

1502 logLvl 5 ("Abstract over " ++ show wargval)

1456 let wtype = bindTyArgs Pi (bargs_pre ++

1503 let wtype = bindTyArgs Pi (bargs_pre ++

1457− (MN 0 "warg", wargtype) :

1504+ (sMN 0 "warg", wargtype) :

1458− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1505+ map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)

1459− (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

1506+ (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)

1460 logLvl 3 ("New function type " ++ show wtype)

1507 logLvl 3 ("New function type " ++ show wtype)

1461− let wname = MN windex (show fname)

1508+ let wname = sMN windex (show fname)

1462

1509

1463 let imps = getImps wtype -- add to implicits context

1510 let imps = getImps wtype -- add to implicits context

1464 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

1511 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

@@ -1486,8 +1533,9 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1486 ctxt <- getContext -- New context with block added

1533 ctxt <- getContext -- New context with block added

1487 i <- getIState

1534 i <- getIState

1488 ((rhs', defer, is), _) <-

1535 ((rhs', defer, is), _) <-

1489− tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty []

1536+ tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []

1490 (do pbinds lhs_tm

1537 (do pbinds lhs_tm

1538+ setNextName

1491 (_, d, is) <- erun fc (build i info False opts fname rhs)

1539 (_, d, is) <- erun fc (build i info False opts fname rhs)

1492 psolve lhs_tm

1540 psolve lhs_tm

1493 tt <- get_term

1541 tt <- get_term

@@ -1566,7 +1614,7 @@ elabClass :: ElabInfo -> SyntaxInfo -> String ->

1566 FC -> [PTerm] ->

1614 FC -> [PTerm] ->

1567 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1615 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1568elabClass info syn doc fc constraints tn ps ds

1616elabClass info syn doc fc constraints tn ps ds

1569− = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

1617+ = do let cn = sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

1570 let tty = pibind ps PType

1618 let tty = pibind ps PType

1571 let constraint = PApp fc (PRef fc tn)

1619 let constraint = PApp fc (PRef fc tn)

1572 (map (pexp . PRef fc) (map fst ps))

1620 (map (pexp . PRef fc) (map fst ps))

@@ -1589,7 +1637,7 @@ elabClass info syn doc fc constraints tn ps ds

1589 let cty = impbind ps $ conbind constraints

1637 let cty = impbind ps $ conbind constraints

1590 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1638 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1591 constraint

1639 constraint

1592− let cons = [("", cn, cty, fc)]

1640+ let cons = [("", cn, cty, fc, [])]

1593 let ddecl = PDatadecl tn tty cons

1641 let ddecl = PDatadecl tn tty cons

1594 logLvl 5 $ "Class data " ++ showDImp True ddecl

1642 logLvl 5 $ "Class data " ++ showDImp True ddecl

1595 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

1643 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

@@ -1627,7 +1675,7 @@ elabClass info syn doc fc constraints tn ps ds

1627

1675

1628 impbind [] x = x

1676 impbind [] x = x

1629 impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1677 impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1630− conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x)

1678+ conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

1631 conbind [] x = x

1679 conbind [] x = x

1632

1680

1633 getMName (PTy _ _ _ _ n _) = nsroot n

1681 getMName (PTy _ _ _ _ n _) = nsroot n

@@ -1651,7 +1699,7 @@ elabClass info syn doc fc constraints tn ps ds

1651 _ -> ifail $ show n ++ " is not a method"

1699 _ -> ifail $ show n ++ " is not a method"

1652 defdecl _ _ _ = ifail "Can't happen (defdecl)"

1700 defdecl _ _ _ = ifail "Can't happen (defdecl)"

1653

1701

1654− defaultdec (UN n) = UN ("default#" ++ n)

1702+ defaultdec (UN n) = sUN ("default#" ++ str n)

1655 defaultdec (NS n ns) = NS (defaultdec n) ns

1703 defaultdec (NS n ns) = NS (defaultdec n) ns

1656

1704

1657 tydecl (PTy _ _ _ _ _ _) = True

1705 tydecl (PTy _ _ _ _ _ _) = True

@@ -1663,13 +1711,13 @@ elabClass info syn doc fc constraints tn ps ds

1663

1711

1664 -- Generate a function for chasing a dictionary constraint

1712 -- Generate a function for chasing a dictionary constraint

1665 cfun cn c syn all con

1713 cfun cn c syn all con

1666− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1714+ = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con)

1667 -- SN (ParentN cn (show con))

1715 -- SN (ParentN cn (show con))

1668− let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1716+ let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

1669 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1717 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1670 let lhs = PApp fc (PRef fc cfn) [pconst capp]

1718 let lhs = PApp fc (PRef fc cfn) [pconst capp]

1671 let rhs = PResolveTC (fileFC "HACK")

1719 let rhs = PResolveTC (fileFC "HACK")

1672− let ty = PPi constraint (MN 0 "pc") c con

1720+ let ty = PPi constraint (sMN 0 "pc") c con

1673 iLOG (showImp Nothing True False ty)

1721 iLOG (showImp Nothing True False ty)

1674 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

1722 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

1675 i <- getIState

1723 i <- getIState

@@ -1689,10 +1737,10 @@ elabClass info syn doc fc constraints tn ps ds

1689 -- dictionary (this is inlinable, always)

1737 -- dictionary (this is inlinable, always)

1690 tfun cn c syn all (m, (doc, o, ty))

1738 tfun cn c syn all (m, (doc, o, ty))

1691 = do let ty' = insertConstraint c ty

1739 = do let ty' = insertConstraint c ty

1692− let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1740+ let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

1693 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1741 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1694 let margs = getMArgs ty

1742 let margs = getMArgs ty

1695− let anames = map (\x -> MN x "arg") [0..]

1743+ let anames = map (\x -> sMN x "arg") [0..]

1696 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

1744 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

1697 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

1745 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

1698 iLOG (showImp Nothing True False ty)

1746 iLOG (showImp Nothing True False ty)

@@ -1721,7 +1769,7 @@ elabClass info syn doc fc constraints tn ps ds

1721

1769

1722 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

1770 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

1723 = PPi p n ty (insertConstraint c sc)

1771 = PPi p n ty (insertConstraint c sc)

1724− insertConstraint c sc = PPi constraint (MN 0 "class") c sc

1772+ insertConstraint c sc = PPi constraint (sMN 0 "class") c sc

1725

1773

1726 -- make arguments explicit and don't bind class parameters

1774 -- make arguments explicit and don't bind class parameters

1727 toExp ns e (PPi (Imp l s _ p) n ty sc)

1775 toExp ns e (PPi (Imp l s _ p) n ty sc)

@@ -1731,19 +1779,21 @@ elabClass info syn doc fc constraints tn ps ds

1731 toExp ns e sc = sc

1779 toExp ns e sc = sc

1732

1780

1733elabInstance :: ElabInfo -> SyntaxInfo ->

1781elabInstance :: ElabInfo -> SyntaxInfo ->

1782+ ElabWhat -> -- phase

1734 FC -> [PTerm] -> -- constraints

1783 FC -> [PTerm] -> -- constraints

1735 Name -> -- the class

1784 Name -> -- the class

1736 [PTerm] -> -- class parameters (i.e. instance)

1785 [PTerm] -> -- class parameters (i.e. instance)

1737 PTerm -> -- full instance type

1786 PTerm -> -- full instance type

1738 Maybe Name -> -- explicit name

1787 Maybe Name -> -- explicit name

1739 [PDecl] -> Idris ()

1788 [PDecl] -> Idris ()

1740−elabInstance info syn fc cs n ps t expn ds

1789+elabInstance info syn what fc cs n ps t expn ds = do

1741− = do i <- getIState

1790+ i <- getIState

1742− (n, ci) <- case lookupCtxtName n (idris_classes i) of

1791+ (n, ci) <- case lookupCtxtName n (idris_classes i) of

1743− [c] -> return c

1792+ [c] -> return c

1744− _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1793+ _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1745− let constraint = PApp fc (PRef fc n) (map pexp ps)

1794+ let constraint = PApp fc (PRef fc n) (map pexp ps)

1746− let iname = mkiname n ps expn

1795+ let iname = mkiname n ps expn

1796+ when (what /= EDefns) $ do

1747 nty <- elabType' True info syn "" fc [] iname t

1797 nty <- elabType' True info syn "" fc [] iname t

1748 -- if the instance type matches any of the instances we have already,

1798 -- if the instance type matches any of the instances we have already,

1749 -- and it's not a named instance, then it's overlapping, so report an error

1799 -- and it's not a named instance, then it's overlapping, so report an error

@@ -1752,6 +1802,7 @@ elabInstance info syn fc cs n ps t expn ds

1752 (class_instances ci)

1802 (class_instances ci)

1753 addInstance intInst n iname

1803 addInstance intInst n iname

1754 Just _ -> addInstance intInst n iname

1804 Just _ -> addInstance intInst n iname

1805+ when (what /= ETypes) $ do

1755 let ips = zip (class_params ci) ps

1806 let ips = zip (class_params ci) ps

1756 let ns = case n of

1807 let ns = case n of

1757 NS n ns' -> ns'

1808 NS n ns' -> ns'

@@ -1804,7 +1855,7 @@ elabInstance info syn fc cs n ps t expn ds

1804

1855

1805 mkiname n' ps' expn' =

1856 mkiname n' ps' expn' =

1806 case expn' of

1857 case expn' of

1807− Nothing -> SN (InstanceN n' (map show ps'))

1858+ Nothing -> SN (sInstanceN n' (map show ps'))

1808 Just nm -> nm

1859 Just nm -> nm

1809

1860

1810 substInstance ips pnames (PInstance syn _ cs n ps t expn ds)

1861 substInstance ips pnames (PInstance syn _ cs n ps t expn ds)

@@ -1852,14 +1903,14 @@ elabInstance info syn fc cs n ps t expn ds

1852 mkMethApp (n, _, _, ty)

1903 mkMethApp (n, _, _, ty)

1853 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

1904 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

1854 lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1905 lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1855− = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1906+ = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

1856 lamBind i (PPi _ n ty sc) sc'

1907 lamBind i (PPi _ n ty sc) sc'

1857− = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1908+ = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

1858 lamBind i _ sc = sc

1909 lamBind i _ sc = sc

1859 methArgs i (PPi (Imp _ _ _ _) n ty sc)

1910 methArgs i (PPi (Imp _ _ _ _) n ty sc)

1860− = PImp 0 True False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc

1911+ = PImp 0 True False n (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

1861 methArgs i (PPi (Exp _ _ _ _) n ty sc)

1912 methArgs i (PPi (Exp _ _ _ _) n ty sc)

1862− = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc

1913+ = PExp 0 False (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

1863 methArgs i (PPi (Constraint _ _ _) n ty sc)

1914 methArgs i (PPi (Constraint _ _ _) n ty sc)

1864 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

1915 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

1865 methArgs i _ = []

1916 methArgs i _ = []

@@ -1882,14 +1933,14 @@ elabInstance info syn fc cs n ps t expn ds

1882

1933

1883 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

1934 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

1884

1935

1885− conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x)

1936+ conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

1886 conbind [] x = x

1937 conbind [] x = x

1887

1938

1888 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

1939 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

1889 coninsert cs sc = conbind cs sc

1940 coninsert cs sc = conbind cs sc

1890

1941

1891 insertDefaults :: IState -> Name ->

1942 insertDefaults :: IState -> Name ->

1892− [(Name, (Name, PDecl))] -> [String] ->

1943+ [(Name, (Name, PDecl))] -> [T.Text] ->

1893 [PDecl] -> [PDecl]

1944 [PDecl] -> [PDecl]

1894 insertDefaults i iname [] ns ds = ds

1945 insertDefaults i iname [] ns ds = ds

1895 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

1946 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

@@ -1980,7 +2031,7 @@ elabDecls info ds = do mapM_ (elabDecl EAll info) ds

1980

2031

1981elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()

2032elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()

1982elabDecl what info d

2033elabDecl what info d

1983− = idrisCatch (elabDecl' what info d) (setAndReport)

2034+ = idrisCatch (withErrorReflection $ elabDecl' what info d) (setAndReport)

1984

2035

1985elabDecl' _ info (PFix _ _ _)

2036elabDecl' _ info (PFix _ _ _)

1986 = return () -- nothing to elaborate

2037 = return () -- nothing to elaborate

@@ -2011,8 +2062,10 @@ elabDecl' what info d@(PClauses f o n ps)

2011 [] -> []

2062 [] -> []

2012 elabClauses info f (o ++ o') n ps

2063 elabClauses info f (o ++ o') n ps

2013elabDecl' what info (PMutual f ps)

2064elabDecl' what info (PMutual f ps)

2065+ = do case ps of

2066+ [p] -> elabDecl what info p

2014− = do mapM_ (elabDecl ETypes info) ps

2067+ _ -> do mapM_ (elabDecl ETypes info) ps

2015− mapM_ (elabDecl EDefns info) ps

2068+ mapM_ (elabDecl EDefns info) ps

2016 -- Do totality checking after entire mutual block

2069 -- Do totality checking after entire mutual block

2017 i <- get

2070 i <- get

2018 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

2071 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2048,9 +2101,8 @@ elabDecl' what info (PClass doc s f cs n ps ds)

2048 = do iLOG $ "Elaborating class " ++ show n

2101 = do iLOG $ "Elaborating class " ++ show n

2049 elabClass info (s { syn_params = [] }) doc f cs n ps ds

2102 elabClass info (s { syn_params = [] }) doc f cs n ps ds

2050elabDecl' what info (PInstance s f cs n ps t expn ds)

2103elabDecl' what info (PInstance s f cs n ps t expn ds)

2051− | what /= ETypes

2052 = do iLOG $ "Elaborating instance " ++ show n

2104 = do iLOG $ "Elaborating instance " ++ show n

2053− elabInstance info s f cs n ps t expn ds

2105+ elabInstance info s what f cs n ps t expn ds

2054elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

2106elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

2055 | what /= ETypes

2107 | what /= ETypes

2056 = do iLOG $ "Elaborating record " ++ show tyn

2108 = do iLOG $ "Elaborating record " ++ show tyn

@@ -2074,7 +2126,7 @@ elabDecl' _ _ _ = return () -- skipped this time

2074

2126

2075elabCaseBlock info opts d@(PClauses f o n ps)

2127elabCaseBlock info opts d@(PClauses f o n ps)

2076 = do addIBC (IBCDef n)

2128 = do addIBC (IBCDef n)

2077− logLvl 6 $ "CASE BLOCK: " ++ show (n, d)

2129+ logLvl 5 $ "CASE BLOCK: " ++ show (n, d)

2078 let opts' = nub (o ++ opts)

2130 let opts' = nub (o ++ opts)

2079 -- propagate totality assertion to the new definitions

2131 -- propagate totality assertion to the new definitions

2080 when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]

2132 when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]

src/Idris/ElabTerm.hs+308−183

@@ -5,15 +5,18 @@ module Idris.ElabTerm where

5import Idris.AbsSyntax

6import Idris.DSL

7import Idris.Delaborate

8+import Idris.Error

8import Idris.ProofSearch

9import Idris.ProofSearch

10import Idris.Core.Elaborate hiding (Tactic(..))

11import Idris.Core.Elaborate hiding (Tactic(..))

11import Idris.Core.TT

12import Idris.Core.TT

12import Idris.Core.Evaluate

13import Idris.Core.Evaluate

14+import Idris.Core.Typecheck (check)

14import Control.Monad

16import Control.Monad

15−import Control.Monad.State

17+import Control.Monad.State.Strict

16import Data.List

18import Data.List

19+import Data.Maybe (mapMaybe)

18import Debug.Trace

21import Debug.Trace

@@ -78,7 +81,10 @@ build ist info pattern opts fn tm

78buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->

81buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->

79 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

82 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

80buildTC ist info pattern opts fn tm

83buildTC ist info pattern opts fn tm

84+ = do -- set name supply to begin after highest index in tm

85+ let ns = allNamesIn tm

86+ initNextNameFrom ns

81− = do elab ist info pattern opts fn tm

87+ elab ist info pattern opts fn tm

82 probs <- get_probs

88 probs <- get_probs

83 tm <- get_term

89 tm <- get_term

84 case probs of

90 case probs of

@@ -104,7 +110,6 @@ elab ist info pattern opts fn tm

104 end_unify

110 end_unify

105 when pattern -- convert remaining holes to pattern vars

111 when pattern -- convert remaining holes to pattern vars

106 (do update_term orderPats

112 (do update_term orderPats

107− tm <- get_term

108 mkPat)

113 mkPat)

109 where

114 where

110 tcgen = Dictionary `elem` opts

115 tcgen = Dictionary `elem` opts

@@ -168,18 +173,18 @@ elab ist info pattern opts fn tm

168 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

173 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

169 = do g <- goal; resolveTC 5 g fn ist

174 = do g <- goal; resolveTC 5 g fn ist

170 elab' ina (PResolveTC fc)

175 elab' ina (PResolveTC fc)

171− | True = do c <- unique_hole (MN 0 "class")

176+ | True = do c <- getNameFrom (sMN 0 "class")

172 instanceArg c

177 instanceArg c

173 | otherwise = do g <- goal

178 | otherwise = do g <- goal

174 try (resolveTC 2 g fn ist)

179 try (resolveTC 2 g fn ist)

175− (do c <- unique_hole (MN 0 "class")

180+ (do c <- getNameFrom (sMN 0 "class")

176 instanceArg c)

181 instanceArg c)

177 elab' ina (PRefl fc t)

182 elab' ina (PRefl fc t)

178− = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

183+ = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,

179− pimp (MN 0 "x") t False])

184+ pimp (sMN 0 "x") t False])

180 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

185 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

181− [pimp (MN 0 "a") Placeholder True,

186+ [pimp (sMN 0 "A") Placeholder True,

182− pimp (MN 0 "b") Placeholder False,

187+ pimp (sMN 0 "B") Placeholder False,

183 pexp l, pexp r])

188 pexp l, pexp r])

184 elab' ina@(_, a, inty) (PPair fc l r)

189 elab' ina@(_, a, inty) (PPair fc l r)

185 = do hnf_compute

190 = do hnf_compute

@@ -188,8 +193,8 @@ elab ist info pattern opts fn tm

188 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

193 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

189 [pexp l,pexp r])

194 [pexp l,pexp r])

190 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

195 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

191− [pimp (MN 0 "A") Placeholder True,

196+ [pimp (sMN 0 "A") Placeholder True,

192− pimp (MN 0 "B") Placeholder True,

197+ pimp (sMN 0 "B") Placeholder True,

193 pexp l, pexp r])

198 pexp l, pexp r])

194 elab' ina (PDPair fc l@(PRef _ n) t r)

199 elab' ina (PDPair fc l@(PRef _ n) t r)

195 = case t of

200 = case t of

@@ -204,12 +209,12 @@ elab ist info pattern opts fn tm

204 [pexp t,

209 [pexp t,

205 pexp (PLam n Placeholder r)])

210 pexp (PLam n Placeholder r)])

206 asValue = elab' ina (PApp fc (PRef fc existsCon)

211 asValue = elab' ina (PApp fc (PRef fc existsCon)

207− [pimp (MN 0 "a") t False,

212+ [pimp (sMN 0 "a") t False,

208− pimp (MN 0 "P") Placeholder True,

213+ pimp (sMN 0 "P") Placeholder True,

209 pexp l, pexp r])

214 pexp l, pexp r])

210 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

215 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

211− [pimp (MN 0 "a") t False,

216+ [pimp (sMN 0 "a") t False,

212− pimp (MN 0 "P") Placeholder True,

217+ pimp (sMN 0 "P") Placeholder True,

213 pexp l, pexp r])

218 pexp l, pexp r])

214 elab' ina (PAlternative True as)

219 elab' ina (PAlternative True as)

215 = do hnf_compute

220 = do hnf_compute

@@ -256,38 +261,35 @@ elab ist info pattern opts fn tm

256 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

261 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

257 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

262 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

258 elab' ina@(_, a, inty) (PLam n Placeholder sc)

263 elab' ina@(_, a, inty) (PLam n Placeholder sc)

259− = do -- n' <- unique_hole n

264+ = do -- if n is a type constructor name, this makes no sense...

260− -- let sc' = mapPT (repN n n') sc

265+ ctxt <- get_context

261− ptm <- get_term

266+ when (isTConName n ctxt) $

262− g <- goal

267+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

263 checkPiGoal n

268 checkPiGoal n

264 attack; intro (Just n);

269 attack; intro (Just n);

265 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

270 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

266 elabE (True, a, inty) sc; solve

271 elabE (True, a, inty) sc; solve

267− where repN n n' (PRef fc x) | x == n' = PRef fc n'

268− repN _ _ t = t

269 elab' ina@(_, a, inty) (PLam n ty sc)

272 elab' ina@(_, a, inty) (PLam n ty sc)

270− = do hsin <- get_holes

273+ = do tyn <- getNameFrom (sMN 0 "lamty")

271− ptmin <- get_term

274+ -- if n is a type constructor name, this makes no sense...

272− tyn <- unique_hole (MN 0 "lamty")

275+ ctxt <- get_context

276+ when (isTConName n ctxt) $

277+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

273 checkPiGoal n

278 checkPiGoal n

274 claim tyn RType

279 claim tyn RType

275 explicit tyn

280 explicit tyn

276 attack

281 attack

277 ptm <- get_term

282 ptm <- get_term

278 hs <- get_holes

283 hs <- get_holes

279− -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

280− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

281 introTy (Var tyn) (Just n)

284 introTy (Var tyn) (Just n)

282− -- end_unify

283 focus tyn

285 focus tyn

284 elabE (True, a, True) ty

286 elabE (True, a, True) ty

285 elabE (True, a, inty) sc

287 elabE (True, a, inty) sc

286 solve

288 solve

287 elab' ina@(_, a, _) (PPi _ n Placeholder sc)

289 elab' ina@(_, a, _) (PPi _ n Placeholder sc)

288− = do attack; arg n (MN 0 "ty"); elabE (True, a, True) sc; solve

290+ = do attack; arg n (sMN 0 "ty"); elabE (True, a, True) sc; solve

289 elab' ina@(_, a, _) (PPi _ n ty sc)

291 elab' ina@(_, a, _) (PPi _ n ty sc)

290− = do attack; tyn <- unique_hole (MN 0 "ty")

292+ = do attack; tyn <- getNameFrom (sMN 0 "ty")

291 claim tyn RType

293 claim tyn RType

292 n' <- case n of

294 n' <- case n of

293 MN _ _ -> unique_hole n

295 MN _ _ -> unique_hole n

@@ -299,9 +301,9 @@ elab ist info pattern opts fn tm

299 solve

301 solve

300 elab' ina@(_, a, inty) (PLet n ty val sc)

302 elab' ina@(_, a, inty) (PLet n ty val sc)

301 = do attack;

303 = do attack;

302− tyn <- unique_hole (MN 0 "letty")

304+ tyn <- getNameFrom (sMN 0 "letty")

303 claim tyn RType

305 claim tyn RType

304− valn <- unique_hole (MN 0 "letval")

306+ valn <- getNameFrom (sMN 0 "letval")

305 claim valn (Var tyn)

307 claim valn (Var tyn)

306 explicit valn

308 explicit valn

307 letbind n (Var tyn) (Var valn)

309 letbind n (Var tyn) (Var valn)

@@ -322,9 +324,9 @@ elab ist info pattern opts fn tm

322 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

324 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

323 rty <- goal

325 rty <- goal

324 attack

326 attack

325− tyn <- unique_hole (MN 0 "letty")

327+ tyn <- getNameFrom (sMN 0 "letty")

326 claim tyn RType

328 claim tyn RType

327− valn <- unique_hole (MN 0 "letval")

329+ valn <- getNameFrom (sMN 0 "letval")

328 claim valn (Var tyn)

330 claim valn (Var tyn)

329 letbind n (Var tyn) (Var valn)

331 letbind n (Var tyn) (Var valn)

330 focus valn

332 focus valn

@@ -343,7 +345,7 @@ elab ist info pattern opts fn tm

343 -- new function name

345 -- new function name

344 env <- get_env

346 env <- get_env

345 argTys <- claimArgTys env args

347 argTys <- claimArgTys env args

346− fn <- unique_hole (MN 0 "inf_fn")

348+ fn <- getNameFrom (sMN 0 "inf_fn")

347 let fty = fnTy argTys rty

349 let fty = fnTy argTys rty

348-- trace (show (ptm, map fst argTys)) $ focus fn

350-- trace (show (ptm, map fst argTys)) $ focus fn

349 -- build and defer the function application

351 -- build and defer the function application

@@ -357,8 +359,8 @@ elab ist info pattern opts fn tm

357 ans <- claimArgTys env xs

359 ans <- claimArgTys env xs

358 return ((n, (False, forget nty)) : ans)

360 return ((n, (False, forget nty)) : ans)

359 claimArgTys env (_ : xs)

361 claimArgTys env (_ : xs)

360− = do an <- unique_hole (MN 0 "inf_argTy")

362+ = do an <- getNameFrom (sMN 0 "inf_argTy")

361− aval <- unique_hole (MN 0 "inf_arg")

363+ aval <- getNameFrom (sMN 0 "inf_arg")

362 claim an RType

364 claim an RType

363 claim aval (Var an)

365 claim aval (Var an)

364 ans <- claimArgTys env xs

366 ans <- claimArgTys env xs

@@ -378,7 +380,7 @@ elab ist info pattern opts fn tm

378 mkN n@(NS _ _) = n

380 mkN n@(NS _ _) = n

379 mkN n@(SN _) = n

381 mkN n@(SN _) = n

380 mkN n = case namespace info of

382 mkN n = case namespace info of

381− Just xs@(_:_) -> NS n xs

383+ Just xs@(_:_) -> sNS n xs

382 _ -> n

384 _ -> n

383

385

384 elab' ina (PMatchApp fc fn)

386 elab' ina (PMatchApp fc fn)

@@ -391,16 +393,12 @@ elab ist info pattern opts fn tm

391 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

393 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

392 = lift $ tfail (Msg "Typecase is not allowed")

394 = lift $ tfail (Msg "Typecase is not allowed")

393 -- if f is local, just do a simple_app

395 -- if f is local, just do a simple_app

394− elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args')

396+ elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args)

395− = do let args = {- case lookupCtxt f (inblock info) of

396− Just ps -> (map (pexp . (PRef fc)) ps ++ args')

397− _ -> -} args'

398−-- newtm <- mkSpecialised ist fc f (map getTm args') tm

399− env <- get_env

397+ = do env <- get_env

400− if (f `elem` map fst env && length args' == 1)

398+ if (f `elem` map fst env && length args == 1)

401 then -- simple app, as below

399 then -- simple app, as below

402 do simple_app (elabE (ina, g, inty) (PRef fc f))

400 do simple_app (elabE (ina, g, inty) (PRef fc f))

403− (elabE (True, g, inty) (getTm (head args')))

401+ (elabE (True, g, inty) (getTm (head args)))

404 (show tm)

402 (show tm)

405 solve

403 solve

406 else

404 else

@@ -413,24 +411,17 @@ elab ist info pattern opts fn tm

413 -- we can unify with them

411 -- we can unify with them

414 case lookupCtxt f (idris_classes ist) of

412 case lookupCtxt f (idris_classes ist) of

415 [] -> return ()

413 [] -> return ()

416− _ -> mapM_ setInjective (map getTm args')

414+ _ -> mapM_ setInjective (map getTm args)

417 ctxt <- get_context

415 ctxt <- get_context

418 let guarded = isConName f ctxt

416 let guarded = isConName f ctxt

419 ns <- apply (Var f) (map isph args)

417 ns <- apply (Var f) (map isph args)

420− ptm <- get_term

421− g <- goal

422− -- Sort so that the implicit tactics go last

418+ -- Sort so that the implicit tactics and alternatives go last

423 let (ns', eargs) = unzip $

419 let (ns', eargs) = unzip $

424− sortBy (\(_,x) (_,y) ->

425− compare (priority x) (priority y))

426− (zip ns args)

420+ sortBy cmpArg (zip ns args)

427 elabArgs (ina || not isinf, guarded, inty)

421 elabArgs (ina || not isinf, guarded, inty)

428 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

422 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

429− mkSpecialised ist fc f (map getTm args') tm

430 solve

423 solve

431− ptm <- get_term

432 ivs' <- get_instances

424 ivs' <- get_instances

433− ps' <- get_probs

434 -- Attempt to resolve any type classes which have 'complete' types,

425 -- Attempt to resolve any type classes which have 'complete' types,

435 -- i.e. no holes in them

426 -- i.e. no holes in them

436 when (not pattern || (ina && not tcgen && not guarded)) $

427 when (not pattern || (ina && not tcgen && not guarded)) $

@@ -446,6 +437,13 @@ elab ist info pattern opts fn tm

446 (ivs' \\ ivs)

437 (ivs' \\ ivs)

447 where tcArg (n, PConstraint _ _ Placeholder _) = True

438 where tcArg (n, PConstraint _ _ Placeholder _) = True

448 tcArg _ = False

439 tcArg _ = False

440+

441+ -- normal < tactic < default tactic

442+ cmpArg (_, x) (_, y)

443+ = compare (priority x + alt x) (priority y + alt y)

444+ where alt t = case getTm t of

445+ PAlternative False _ -> 5

446+ _ -> 0

449

447

450 tacTm (PTactics _) = True

448 tacTm (PTactics _) = True

451 tacTm (PProof _) = True

449 tacTm (PProof _) = True

@@ -466,7 +464,7 @@ elab ist info pattern opts fn tm

466 do attack; defer n'; solve

464 do attack; defer n'; solve

467 where mkN n@(NS _ _) = n

465 where mkN n@(NS _ _) = n

468 mkN n = case namespace info of

466 mkN n = case namespace info of

469− Just xs@(_:_) -> NS n xs

467+ Just xs@(_:_) -> sNS n xs

470 _ -> n

468 _ -> n

471 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

469 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

472 elab' ina (PTactics ts)

470 elab' ina (PTactics ts)

@@ -475,11 +473,11 @@ elab ist info pattern opts fn tm

475 elab' ina (PElabError e) = fail (pshow ist e)

473 elab' ina (PElabError e) = fail (pshow ist e)

476 elab' ina (PRewrite fc r sc newg)

474 elab' ina (PRewrite fc r sc newg)

477 = do attack

475 = do attack

478− tyn <- unique_hole (MN 0 "rty")

476+ tyn <- getNameFrom (sMN 0 "rty")

479 claim tyn RType

477 claim tyn RType

480− valn <- unique_hole (MN 0 "rval")

478+ valn <- getNameFrom (sMN 0 "rval")

481 claim valn (Var tyn)

479 claim valn (Var tyn)

482− letn <- unique_hole (MN 0 "rewrite_rule")

480+ letn <- getNameFrom (sMN 0 "rewrite_rule")

483 letbind letn (Var tyn) (Var valn)

481 letbind letn (Var tyn) (Var valn)

484 focus valn

482 focus valn

485 elab' ina r

483 elab' ina r

@@ -494,11 +492,11 @@ elab ist info pattern opts fn tm

494 solve

492 solve

495 where doEquiv t sc =

493 where doEquiv t sc =

496 do attack

494 do attack

497− tyn <- unique_hole (MN 0 "ety")

495+ tyn <- getNameFrom (sMN 0 "ety")

498 claim tyn RType

496 claim tyn RType

499− valn <- unique_hole (MN 0 "eqval")

497+ valn <- getNameFrom (sMN 0 "eqval")

500 claim valn (Var tyn)

498 claim valn (Var tyn)

501− letn <- unique_hole (MN 0 "equiv_val")

499+ letn <- getNameFrom (sMN 0 "equiv_val")

502 letbind letn (Var tyn) (Var valn)

500 letbind letn (Var tyn) (Var valn)

503 focus tyn

501 focus tyn

504 elab' ina t

502 elab' ina t

@@ -508,10 +506,10 @@ elab ist info pattern opts fn tm

508 solve

506 solve

509 elab' ina@(_, a, inty) c@(PCase fc scr opts)

507 elab' ina@(_, a, inty) c@(PCase fc scr opts)

510 = do attack

508 = do attack

511− tyn <- unique_hole (MN 0 "scty")

509+ tyn <- getNameFrom (sMN 0 "scty")

512 claim tyn RType

510 claim tyn RType

513− valn <- unique_hole (MN 0 "scval")

511+ valn <- getNameFrom (sMN 0 "scval")

514− scvn <- unique_hole (MN 0 "scvar")

512+ scvn <- getNameFrom (sMN 0 "scvar")

515 claim valn (Var tyn)

513 claim valn (Var tyn)

516 letbind scvn (Var tyn) (Var valn)

514 letbind scvn (Var tyn) (Var valn)

517 focus valn

515 focus valn

@@ -537,7 +535,7 @@ elab ist info pattern opts fn tm

537-- mkCaseName (MN i x) = MN i (x ++ "_case")

535-- mkCaseName (MN i x) = MN i (x ++ "_case")

538 mkN n@(NS _ _) = n

536 mkN n@(NS _ _) = n

539 mkN n = case namespace info of

537 mkN n = case namespace info of

540− Just xs@(_:_) -> NS n xs

538+ Just xs@(_:_) -> sNS n xs

541 _ -> n

539 _ -> n

542 elab' ina (PUnifyLog t) = do unifyLog True

540 elab' ina (PUnifyLog t) = do unifyLog True

543 elab' ina t

541 elab' ina t

@@ -617,8 +615,8 @@ elab ist info pattern opts fn tm

617 = elabArgs ina failed fc r ns args

615 = elabArgs ina failed fc r ns args

618 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

616 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

619 | lazy && not pattern

617 | lazy && not pattern

620− = do elabArg n (PApp bi (PRef bi (UN "lazy"))

618+ = do elabArg n (PApp bi (PRef bi (sUN "lazy"))

621− [pimp (UN "a") Placeholder True,

619+ [pimp (sUN "a") Placeholder True,

622 pexp t]);

620 pexp t]);

623 | otherwise = elabArg n t

621 | otherwise = elabArg n t

624 where elabArg n t

622 where elabArg n t

@@ -698,9 +696,9 @@ findInstances ist t

698 | otherwise = []

696 | otherwise = []

699

697

700trivial' ist

698trivial' ist

701− = trivial (elab ist toplevel False [] (MN 0 "tac")) ist

699+ = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

702proofSearch' ist top n hints

700proofSearch' ist top n hints

703− = proofSearch (elab ist toplevel False [] (MN 0 "tac")) top n hints ist

701+ = proofSearch (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist

704

702

705

703

706resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

704resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

@@ -710,9 +708,10 @@ resolveTC depth topg fn ist

710 = do hnf_compute

708 = do hnf_compute

711 g <- goal

709 g <- goal

712 ptm <- get_term

710 ptm <- get_term

711+ ulog <- getUnifyLog

713 hs <- get_holes

712 hs <- get_holes

714− if True -- all (\n -> not (n `elem` hs)) (freeNames g)

713+ traceWhen ulog ("Resolving class " ++ show g) $

715− then try' (trivial' ist)

714+ try' (trivial' ist)

716 (do t <- goal

715 (do t <- goal

717 let (tc, ttypes) = unApply t

716 let (tc, ttypes) = unApply t

718 scopeOnly <- needsDefault t tc ttypes

717 scopeOnly <- needsDefault t tc ttypes

@@ -720,28 +719,23 @@ resolveTC depth topg fn ist

720 let insts = if scopeOnly then filter chaser insts_in

719 let insts = if scopeOnly then filter chaser insts_in

721 else insts_in

720 else insts_in

722 tm <- get_term

721 tm <- get_term

723−-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $

724−-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))

725−-- if scopeOnly then fail "Can't resolve" else

726 let depth' = if scopeOnly then 2 else depth

722 let depth' = if scopeOnly then 2 else depth

727 blunderbuss t depth' insts) True

723 blunderbuss t depth' insts) True

728− else do try' (trivial' ist)

729− (do g <- goal

730− fail $ "Can't resolve " ++ show g) True

731−-- tm <- get_term

732−-- fail $ "Can't resolve yet in " ++ show tm

733 where

724 where

734 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

725 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

735 | otherwise = (fail "Can't resolve", show n)

726 | otherwise = (fail "Can't resolve", show n)

736

727

737 -- HACK! Rather than giving a special name, better to have some kind

728 -- HACK! Rather than giving a special name, better to have some kind

738 -- of flag in ClassInfo structure

729 -- of flag in ClassInfo structure

730+ chaser (UN nm)

739− chaser (UN ('@':'@':_)) = True -- old way

731+ | ('@':'@':_) <- str nm = True -- old way

740 chaser (SN (ParentN _ _)) = True

732 chaser (SN (ParentN _ _)) = True

741 chaser (NS n _) = chaser n

733 chaser (NS n _) = chaser n

742 chaser _ = False

734 chaser _ = False

743

735

736+ numclass = sNS (sUN "Num") ["Classes","Prelude"]

737+

744− needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _]

738+ needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass

745 = do focus a

739 = do focus a

746 fill (RConstant (AType (ATInt ITBig))) -- default Integer

740 fill (RConstant (AType (ATInt ITBig))) -- default Integer

747 solve

741 solve

@@ -774,8 +768,8 @@ resolveTC depth topg fn ist

774 [args] -> map isImp (snd args) -- won't be overloaded!

768 [args] -> map isImp (snd args) -- won't be overloaded!

775 ps <- get_probs

769 ps <- get_probs

776 tm <- get_term

770 tm <- get_term

777− args <- try' (match_apply (Var n) imps)

771+ args <- try' (apply (Var n) imps)

778− (apply (Var n) imps) True

772+ (match_apply (Var n) imps) True

779 ps' <- get_probs

773 ps' <- get_probs

780 when (length ps < length ps') $ fail "Can't apply type class"

774 when (length ps < length ps') $ fail "Can't apply type class"

781-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

775-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

@@ -787,7 +781,9 @@ resolveTC depth topg fn ist

787 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

781 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

788 -- if there's any arguments left, we've failed to resolve

782 -- if there's any arguments left, we've failed to resolve

789 hs <- get_holes

783 hs <- get_holes

784+ ulog <- getUnifyLog

790− solve

785+ solve

786+ traceWhen ulog ("Got " ++ show n) $ return ()

791 where isImp (PImp p _ _ _ _ _) = (True, p)

787 where isImp (PImp p _ _ _ _ _) = (True, p)

792 isImp arg = (False, priority arg)

788 isImp arg = (False, priority arg)

793

789

@@ -814,7 +810,9 @@ collectDeferred top t = return t

814runTac :: Bool -> IState -> PTactic -> ElabD ()

810runTac :: Bool -> IState -> PTactic -> ElabD ()

815runTac autoSolve ist tac

811runTac autoSolve ist tac

816 = do env <- get_env

812 = do env <- get_env

813+ g <- goal

817− no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

814+ no_errors (runT (fmap (addImplBound ist (map fst env)) tac))

815+ (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))

818 where

816 where

819 runT (Intro []) = do g <- goal

817 runT (Intro []) = do g <- goal

820 attack; intro (bname g)

818 attack; intro (bname g)

@@ -829,7 +827,7 @@ runTac autoSolve ist tac

829 where

827 where

830 bname (Bind n _ _) = Just n

828 bname (Bind n _ _) = Just n

831 bname _ = Nothing

829 bname _ = Nothing

832− runT (Exact tm) = do elab ist toplevel False [] (MN 0 "tac") tm

830+ runT (Exact tm) = do elab ist toplevel False [] (sMN 0 "tac") tm

833 when autoSolve solveAll

831 when autoSolve solveAll

834 runT (MatchRefine fn)

832 runT (MatchRefine fn)

835 = do fnimps <-

833 = do fnimps <-

@@ -869,27 +867,27 @@ runTac autoSolve ist tac

869 when autoSolve solveAll

867 when autoSolve solveAll

870 runT (Equiv tm) -- let bind tm, then

868 runT (Equiv tm) -- let bind tm, then

871 = do attack

869 = do attack

872− tyn <- unique_hole (MN 0 "ety")

870+ tyn <- getNameFrom (sMN 0 "ety")

873 claim tyn RType

871 claim tyn RType

874− valn <- unique_hole (MN 0 "eqval")

872+ valn <- getNameFrom (sMN 0 "eqval")

875 claim valn (Var tyn)

873 claim valn (Var tyn)

876− letn <- unique_hole (MN 0 "equiv_val")

874+ letn <- getNameFrom (sMN 0 "equiv_val")

877 letbind letn (Var tyn) (Var valn)

875 letbind letn (Var tyn) (Var valn)

878 focus tyn

876 focus tyn

879− elab ist toplevel False [] (MN 0 "tac") tm

877+ elab ist toplevel False [] (sMN 0 "tac") tm

880 focus valn

878 focus valn

881 when autoSolve solveAll

879 when autoSolve solveAll

882 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

880 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

883 = do attack; -- (h:_) <- get_holes

881 = do attack; -- (h:_) <- get_holes

884− tyn <- unique_hole (MN 0 "rty")

882+ tyn <- getNameFrom (sMN 0 "rty")

885 -- start_unify h

883 -- start_unify h

886 claim tyn RType

884 claim tyn RType

887− valn <- unique_hole (MN 0 "rval")

885+ valn <- getNameFrom (sMN 0 "rval")

888 claim valn (Var tyn)

886 claim valn (Var tyn)

889− letn <- unique_hole (MN 0 "rewrite_rule")

887+ letn <- getNameFrom (sMN 0 "rewrite_rule")

890 letbind letn (Var tyn) (Var valn)

888 letbind letn (Var tyn) (Var valn)

891 focus valn

889 focus valn

892− elab ist toplevel False [] (MN 0 "tac") tm

890+ elab ist toplevel False [] (sMN 0 "tac") tm

893 rewrite (Var letn)

891 rewrite (Var letn)

894 when autoSolve solveAll

892 when autoSolve solveAll

895 runT (Induction nm)

893 runT (Induction nm)

@@ -897,27 +895,27 @@ runTac autoSolve ist tac

897 when autoSolve solveAll

895 when autoSolve solveAll

898 runT (LetTac n tm)

896 runT (LetTac n tm)

899 = do attack

897 = do attack

900− tyn <- unique_hole (MN 0 "letty")

898+ tyn <- getNameFrom (sMN 0 "letty")

901 claim tyn RType

899 claim tyn RType

902− valn <- unique_hole (MN 0 "letval")

900+ valn <- getNameFrom (sMN 0 "letval")

903 claim valn (Var tyn)

901 claim valn (Var tyn)

904 letn <- unique_hole n

902 letn <- unique_hole n

905 letbind letn (Var tyn) (Var valn)

903 letbind letn (Var tyn) (Var valn)

906 focus valn

904 focus valn

907− elab ist toplevel False [] (MN 0 "tac") tm

905+ elab ist toplevel False [] (sMN 0 "tac") tm

908 when autoSolve solveAll

906 when autoSolve solveAll

909 runT (LetTacTy n ty tm)

907 runT (LetTacTy n ty tm)

910 = do attack

908 = do attack

911− tyn <- unique_hole (MN 0 "letty")

909+ tyn <- getNameFrom (sMN 0 "letty")

912 claim tyn RType

910 claim tyn RType

913− valn <- unique_hole (MN 0 "letval")

911+ valn <- getNameFrom (sMN 0 "letval")

914 claim valn (Var tyn)

912 claim valn (Var tyn)

915 letn <- unique_hole n

913 letn <- unique_hole n

916 letbind letn (Var tyn) (Var valn)

914 letbind letn (Var tyn) (Var valn)

917 focus tyn

915 focus tyn

918− elab ist toplevel False [] (MN 0 "tac") ty

916+ elab ist toplevel False [] (sMN 0 "tac") ty

919 focus valn

917 focus valn

920− elab ist toplevel False [] (MN 0 "tac") tm

918+ elab ist toplevel False [] (sMN 0 "tac") tm

921 when autoSolve solveAll

919 when autoSolve solveAll

922 runT Compute = compute

920 runT Compute = compute

923 runT Trivial = do trivial' ist; when autoSolve solveAll

921 runT Trivial = do trivial' ist; when autoSolve solveAll

@@ -930,16 +928,16 @@ runTac autoSolve ist tac

930 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

928 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

931 tgoal <- goal -- store the goal

929 tgoal <- goal -- store the goal

932 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

930 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

933− script <- unique_hole (MN 0 "script")

931+ script <- getNameFrom (sMN 0 "script")

934 claim script scriptTy

932 claim script scriptTy

935− scriptvar <- unique_hole (MN 0 "scriptvar" )

933+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

936 letbind scriptvar scriptTy (Var script)

934 letbind scriptvar scriptTy (Var script)

937 focus script

935 focus script

938− elab ist toplevel False [] (MN 0 "tac") tm

936+ elab ist toplevel False [] (sMN 0 "tac") tm

939 (script', _) <- get_type_val (Var scriptvar)

937 (script', _) <- get_type_val (Var scriptvar)

940 -- now that we have the script apply

938 -- now that we have the script apply

941 -- it to the reflected goal and context

939 -- it to the reflected goal and context

942− restac <- unique_hole (MN 0 "restac")

940+ restac <- getNameFrom (sMN 0 "restac")

943 claim restac tacticTy

941 claim restac tacticTy

944 focus restac

942 focus restac

945 fill (raw_apply (forget script')

943 fill (raw_apply (forget script')

@@ -953,27 +951,27 @@ runTac autoSolve ist tac

953 let tactic = normalise ctxt env restac'

951 let tactic = normalise ctxt env restac'

954 runReflected tactic

952 runReflected tactic

955 where tacticTy = Var (reflm "Tactic")

953 where tacticTy = Var (reflm "Tactic")

956− listTy = Var (NS (UN "List") ["List", "Prelude"])

954+ listTy = Var (sNS (sUN "List") ["List", "Prelude"])

957− scriptTy = (RBind (UN "__pi_arg")

955+ scriptTy = (RBind (sUN "__pi_arg")

958 (Pi (RApp listTy envTupleType))

956 (Pi (RApp listTy envTupleType))

959− (RBind (UN "__pi_arg1")

957+ (RBind (sUN "__pi_arg1")

960 (Pi (Var $ reflm "TT")) tacticTy))

958 (Pi (Var $ reflm "TT")) tacticTy))

961 runT (ByReflection tm) -- run the reflection function 'tm' on the

959 runT (ByReflection tm) -- run the reflection function 'tm' on the

962 -- goal, then apply the resulting reflected Tactic

960 -- goal, then apply the resulting reflected Tactic

963 = do tgoal <- goal

961 = do tgoal <- goal

964 attack

962 attack

965− script <- unique_hole (MN 0 "script")

963+ script <- getNameFrom (sMN 0 "script")

966 claim script scriptTy

964 claim script scriptTy

967− scriptvar <- unique_hole (MN 0 "scriptvar" )

965+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

968 letbind scriptvar scriptTy (Var script)

966 letbind scriptvar scriptTy (Var script)

969 focus script

967 focus script

970 ptm <- get_term

968 ptm <- get_term

971− elab ist toplevel False [] (MN 0 "tac")

969+ elab ist toplevel False [] (sMN 0 "tac")

972 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

970 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

973 (script', _) <- get_type_val (Var scriptvar)

971 (script', _) <- get_type_val (Var scriptvar)

974 -- now that we have the script apply

972 -- now that we have the script apply

975 -- it to the reflected goal

973 -- it to the reflected goal

976− restac <- unique_hole (MN 0 "restac")

974+ restac <- getNameFrom (sMN 0 "restac")

977 claim restac tacticTy

975 claim restac tacticTy

978 focus restac

976 focus restac

979 fill (forget script')

977 fill (forget script')

@@ -989,28 +987,28 @@ runTac autoSolve ist tac

989 scriptTy = tacticTy

987 scriptTy = tacticTy

990

988

991 runT (Reflect v) = do attack -- let x = reflect v in ...

989 runT (Reflect v) = do attack -- let x = reflect v in ...

992− tyn <- unique_hole (MN 0 "letty")

990+ tyn <- getNameFrom (sMN 0 "letty")

993 claim tyn RType

991 claim tyn RType

994− valn <- unique_hole (MN 0 "letval")

992+ valn <- getNameFrom (sMN 0 "letval")

995 claim valn (Var tyn)

993 claim valn (Var tyn)

996− letn <- unique_hole (MN 0 "letvar")

994+ letn <- getNameFrom (sMN 0 "letvar")

997 letbind letn (Var tyn) (Var valn)

995 letbind letn (Var tyn) (Var valn)

998 focus valn

996 focus valn

999− elab ist toplevel False [] (MN 0 "tac") v

997+ elab ist toplevel False [] (sMN 0 "tac") v

1000 (value, _) <- get_type_val (Var letn)

998 (value, _) <- get_type_val (Var letn)

1001 ctxt <- get_context

999 ctxt <- get_context

1002 env <- get_env

1000 env <- get_env

1003 let value' = hnf ctxt env value

1001 let value' = hnf ctxt env value

1004 runTac autoSolve ist (Exact $ PQuote (reflect value'))

1002 runTac autoSolve ist (Exact $ PQuote (reflect value'))

1005 runT (Fill v) = do attack -- let x = fill x in ...

1003 runT (Fill v) = do attack -- let x = fill x in ...

1006− tyn <- unique_hole (MN 0 "letty")

1004+ tyn <- getNameFrom (sMN 0 "letty")

1007 claim tyn RType

1005 claim tyn RType

1008− valn <- unique_hole (MN 0 "letval")

1006+ valn <- getNameFrom (sMN 0 "letval")

1009 claim valn (Var tyn)

1007 claim valn (Var tyn)

1010− letn <- unique_hole (MN 0 "letvar")

1008+ letn <- getNameFrom (sMN 0 "letvar")

1011 letbind letn (Var tyn) (Var valn)

1009 letbind letn (Var tyn) (Var valn)

1012 focus valn

1010 focus valn

1013− elab ist toplevel False [] (MN 0 "tac") v

1011+ elab ist toplevel False [] (sMN 0 "tac") v

1014 (value, _) <- get_type_val (Var letn)

1012 (value, _) <- get_type_val (Var letn)

1015 ctxt <- get_context

1013 ctxt <- get_context

1016 env <- get_env

1014 env <- get_env

@@ -1020,20 +1018,20 @@ runTac autoSolve ist tac

1020 runT (GoalType n tac) = do g <- goal

1018 runT (GoalType n tac) = do g <- goal

1021 case unApply g of

1019 case unApply g of

1022 (P _ n' _, _) ->

1020 (P _ n' _, _) ->

1023− if nsroot n' == UN n

1021+ if nsroot n' == sUN n

1024 then runT tac

1022 then runT tac

1025 else fail "Wrong goal type"

1023 else fail "Wrong goal type"

1026 _ -> fail "Wrong goal type"

1024 _ -> fail "Wrong goal type"

1027 runT ProofState = do g <- goal

1025 runT ProofState = do g <- goal

1028− trace (show g) $ return ()

1026+ return ()

1029 runT x = fail $ "Not implemented " ++ show x

1027 runT x = fail $ "Not implemented " ++ show x

1030

1028

1031 runReflected t = do t' <- reify ist t

1029 runReflected t = do t' <- reify ist t

1032 runTac autoSolve ist t'

1030 runTac autoSolve ist t'

1033

1031

1034−-- | Prefix a name with the "Reflection.Language" namespace

1032+-- | Prefix a name with the "Language.Reflection" namespace

1035reflm :: String -> Name

1033reflm :: String -> Name

1036−reflm n = NS (UN n) ["Reflection", "Language"]

1034+reflm n = sNS (sUN n) ["Reflection", "Language"]

1037

1035

1038

1036

1039-- | Reify tactics from their reflected representation

1037-- | Reify tactics from their reflected representation

@@ -1055,7 +1053,7 @@ reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist

1055reifyApp ist t [Constant (Str n), x]

1053reifyApp ist t [Constant (Str n), x]

1056 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1054 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1057reifyApp _ t [Constant (Str n)]

1055reifyApp _ t [Constant (Str n)]

1058− | t == reflm "Intro" = return $ Intro [UN n]

1056+ | t == reflm "Intro" = return $ Intro [sUN n]

1059reifyApp ist t [t']

1057reifyApp ist t [t']

1060 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1058 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1061reifyApp ist t [t']

1059reifyApp ist t [t']

@@ -1146,13 +1144,13 @@ reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

1146

1144

1147reifyTTNameApp :: Name -> [Term] -> ElabD Name

1145reifyTTNameApp :: Name -> [Term] -> ElabD Name

1148reifyTTNameApp t [Constant (Str n)]

1146reifyTTNameApp t [Constant (Str n)]

1149− | t == reflm "UN" = return $ UN n

1147+ | t == reflm "UN" = return $ sUN n

1150reifyTTNameApp t [n, ns]

1148reifyTTNameApp t [n, ns]

1151 | t == reflm "NS" = do n' <- reifyTTName n

1149 | t == reflm "NS" = do n' <- reifyTTName n

1152 ns' <- reifyTTNamespace ns

1150 ns' <- reifyTTNamespace ns

1153− return $ NS n' ns'

1151+ return $ sNS n' ns'

1154reifyTTNameApp t [Constant (I i), Constant (Str n)]

1152reifyTTNameApp t [Constant (I i), Constant (Str n)]

1155− | t == reflm "MN" = return $ MN i n

1153+ | t == reflm "MN" = return $ sMN i n

1156reifyTTNameApp t []

1154reifyTTNameApp t []

1157 | t == reflm "NErased" = return NErased

1155 | t == reflm "NErased" = return NErased

1158reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

1156reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

@@ -1161,9 +1159,9 @@ reifyTTNamespace :: Term -> ElabD [String]

1161reifyTTNamespace t@(App _ _)

1159reifyTTNamespace t@(App _ _)

1162 = case unApply t of

1160 = case unApply t of

1163 (P _ f _, [Constant StrType])

1161 (P _ f _, [Constant StrType])

1164− | f == NS (UN "Nil") ["List", "Prelude"] -> return []

1162+ | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

1165 (P _ f _, [Constant StrType, Constant (Str n), ns])

1163 (P _ f _, [Constant StrType, Constant (Str n), ns])

1166− | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

1164+ | f == sNS (sUN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

1167 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

1165 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

1168reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

1166reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

1169

1167

@@ -1285,19 +1283,19 @@ reflectNameType (TCon x y)

1285 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

1283 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

1286

1284

1287reflectName :: Name -> Raw

1285reflectName :: Name -> Raw

1288−reflectName (UN str)

1286+reflectName (UN s)

1289− = reflCall "UN" [RConstant (Str str)]

1287+ = reflCall "UN" [RConstant (Str (str s))]

1290reflectName (NS n ns)

1288reflectName (NS n ns)

1291 = reflCall "NS" [ reflectName n

1289 = reflCall "NS" [ reflectName n

1292 , foldr (\ n s ->

1290 , foldr (\ n s ->

1293− raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

1291+ raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

1294 [ RConstant StrType, RConstant (Str n), s ])

1292 [ RConstant StrType, RConstant (Str n), s ])

1295− ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

1293+ ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

1296 [ RConstant StrType ])

1294 [ RConstant StrType ])

1297− ns

1295+ (map str ns)

1298 ]

1296 ]

1299reflectName (MN i n)

1297reflectName (MN i n)

1300− = reflCall "MN" [RConstant (I i), RConstant (Str n)]

1298+ = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

1301reflectName (NErased) = Var (reflm "NErased")

1299reflectName (NErased) = Var (reflm "NErased")

1302reflectName n = Var (reflm "NErased") -- special name, not yet implemented

1300reflectName n = Var (reflm "NErased") -- special name, not yet implemented

1303

1301

@@ -1354,7 +1352,7 @@ reflectEnv = foldr consToEnvList emptyEnvList

1354 where

1352 where

1355 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

1353 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

1356 consToEnvList (n, b) l

1354 consToEnvList (n, b) l

1357− = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

1355+ = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

1358 [ envTupleType

1356 [ envTupleType

1359 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1357 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1360 , (RApp (Var $ reflm "Binder")

1358 , (RApp (Var $ reflm "Binder")

@@ -1366,14 +1364,182 @@ reflectEnv = foldr consToEnvList emptyEnvList

1366 ]

1364 ]

1367

1365

1368 emptyEnvList :: Raw

1366 emptyEnvList :: Raw

1369− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1367+ emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

1370 [envTupleType]

1368 [envTupleType]

1371

1369

1372-- | Reflect an error into the internal datatype of Idris -- TODO

1370-- | Reflect an error into the internal datatype of Idris -- TODO

1371+rawBool :: Bool -> Raw

1372+rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"])

1373+rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"])

1374+

1375+rawNil :: Raw -> Raw

1376+rawNil ty = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [ty]

1377+

1378+rawCons :: Raw -> Raw -> Raw -> Raw

1379+rawCons ty hd tl = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ty, hd, tl]

1380+

1381+rawList :: Raw -> [Raw] -> Raw

1382+rawList ty = foldr (rawCons ty) (rawNil ty)

1383+

1384+rawPairTy :: Raw -> Raw -> Raw

1385+rawPairTy t1 t2 = raw_apply (Var pairTy) [t1, t2]

1386+

1387+rawPair :: (Raw, Raw) -> (Raw, Raw) -> Raw

1388+rawPair (a, b) (x, y) = raw_apply (Var pairCon) [a, b, x, y]

1389+

1390+reflectCtxt :: [(Name, Type)] -> Raw

1391+reflectCtxt ctxt = rawList (rawPairTy (Var $ reflm "TTName") (Var $ reflm "TT"))

1392+ (map (\ (n, t) -> (rawPair (Var $ reflm "TTName", Var $ reflm "TT")

1393+ (reflectName n, reflect t)))

1394+ ctxt)

1395+

1373reflectErr :: Err -> Raw

1396reflectErr :: Err -> Raw

1374−reflectErr (Msg msg) = raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str msg)]

1397+reflectErr (Msg msg) = raw_apply (Var $ reflErrName "Msg") [RConstant (Str msg)]

1375−reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflection", "Language"])) [reflectConstant (Str msg)]

1398+reflectErr (InternalMsg msg) = raw_apply (Var $ reflErrName "InternalMsg") [RConstant (Str msg)]

1376−reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)]

1399+reflectErr (CantUnify b t1 t2 e ctxt i) =

1400+ raw_apply (Var $ reflErrName "CantUnify")

1401+ [ rawBool b

1402+ , reflect t1

1403+ , reflect t2

1404+ , reflectErr e

1405+ , reflectCtxt ctxt

1406+ , RConstant (I i)]

1407+reflectErr (InfiniteUnify n tm ctxt) =

1408+ raw_apply (Var $ reflErrName "InfiniteUnify")

1409+ [ reflectName n

1410+ , reflect tm

1411+ , reflectCtxt ctxt

1412+ ]

1413+reflectErr (CantConvert t t' ctxt) =

1414+ raw_apply (Var $ reflErrName "CantConvert")

1415+ [ reflect t

1416+ , reflect t'

1417+ , reflectCtxt ctxt

1418+ ]

1419+reflectErr (CantSolveGoal t ctxt) =

1420+ raw_apply (Var $ reflErrName "CantSolveGoal")

1421+ [ reflect t

1422+ , reflectCtxt ctxt

1423+ ]

1424+reflectErr (UnifyScope n n' t ctxt) =

1425+ raw_apply (Var $ reflErrName "UnifyScope")

1426+ [ reflectName n

1427+ , reflectName n'

1428+ , reflect t

1429+ , reflectCtxt ctxt

1430+ ]

1431+reflectErr (CantInferType str) =

1432+ raw_apply (Var $ reflErrName "CantInferType") [RConstant (Str str)]

1433+reflectErr (NonFunctionType t t') =

1434+ raw_apply (Var $ reflErrName "NonFunctionType") [reflect t, reflect t']

1435+reflectErr (NotEquality t t') =

1436+ raw_apply (Var $ reflErrName "NotEquality") [reflect t, reflect t']

1437+reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n]

1438+reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t]

1439+reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n]

1440+reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n]

1441+reflectErr (NotInjective t1 t2 t3) =

1442+ raw_apply (Var $ reflErrName "NotInjective")

1443+ [ reflect t1

1444+ , reflect t2

1445+ , reflect t3

1446+ ]

1447+reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

1448+reflectErr (CantResolveAlts ss) =

1449+ raw_apply (Var $ reflErrName "CantResolve")

1450+ [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)]

1451+reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

1452+reflectErr UniverseError = Var $ reflErrName "UniverseError"

1453+reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

1454+reflectErr (Inaccessible n) = raw_apply (Var $ reflErrName "Inaccessible") [reflectName n]

1455+reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollabsiblePostulate") [reflectName n]

1456+reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

1457+reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

1458+reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

1459+reflectErr (At fc err) = raw_apply (Var $ reflErrName "At") [reflectFC fc, reflectErr err]

1460+ where reflectFC (FC source line col) = raw_apply (Var $ reflErrName "FileLoc")

1461+ [ RConstant (Str source)

1462+ , RConstant (I line)

1463+ , RConstant (I col)

1464+ ]

1465+reflectErr (Elaborating str n e) =

1466+ raw_apply (Var $ reflErrName "Elaborating")

1467+ [ RConstant (Str str)

1468+ , reflectName n

1469+ , reflectErr e

1470+ ]

1471+reflectErr (ProviderError str) =

1472+ raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1473+reflectErr (LoadingFailed str err) =

1474+ raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1475+reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1476+

1477+withErrorReflection :: Idris a -> Idris a

1478+withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1479+ where handle :: Err -> Idris Err

1480+ handle e@(ReflectionError _ _) = do logLvl 3 "Skipping reflection of error reflection result"

1481+ return e -- Don't do meta-reflection of errors

1482+ handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

1483+ return e

1484+ handle e = do ist <- getIState

1485+ logLvl 2 "Starting error reflection"

1486+ let handlers = idris_errorhandlers ist

1487+ logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))

1488+ let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

1489+

1490+ -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1491+ handlers <- case mapM (check (tt_ctxt ist) []) reports of

1492+ Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1493+ OK hs -> return hs

1494+

1495+ -- Normalize error handler terms to produce the new messages

1496+ ctxt <- getContext

1497+ let results = map (normalise ctxt []) (map fst handlers)

1498+ logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1499+

1500+ -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1501+ let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1502+ errorparts <- mapM (mapM reifyReportPart) errorpartsTT

1503+

1504+ return $ case errorparts of

1505+ [] -> e

1506+ parts -> ReflectionError errorparts e

1507+

1508+ fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1509+ fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

1510+ | just == txt "Just" = Just tm

1511+ fromTTMaybe x = Nothing

1512+

1513+reflErrName :: String -> Name

1514+reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"]

1515+

1516+reifyReportPart :: Term -> Idris ErrorReportPart

1517+reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflErrName "TextPart" =

1518+ return (TextPart msg)

1519+reifyReportPart (App (P (DCon _ _) n _) ttn)

1520+ | n == reflErrName "NamePart" =

1521+ case runElab [] (reifyTTName ttn) (initElaborator NErased initContext Erased) of

1522+ Error e -> ierror . InternalMsg $

1523+ "could not reify name term " ++

1524+ show ttn ++

1525+ " when reflecting an error"

1526+ OK (n', _)-> return $ NamePart n'

1527+reifyReportPart (App (P (DCon _ _) n _) tm)

1528+ | n == reflErrName "TermPart" =

1529+ do ist <- getIState

1530+ case runElab [] (reifyTT tm) (initElaborator NErased initContext Erased) of

1531+ Error e -> ierror . InternalMsg $

1532+ "could not reify reflected term " ++

1533+ show tm ++

1534+ " when reflecting an error"

1535+ OK (tm', _) -> return $ TermPart tm'

1536+reifyReportPart (App (P (DCon _ _) n _) tm)

1537+ | n == reflErrName "SubReport" =

1538+ case unList tm of

1539+ Just xs -> do subParts <- mapM reifyReportPart xs

1540+ return (SubReport subParts)

1541+ Nothing -> ierror . InternalMsg $ "could not reify subreport " ++ show tm

1542+reifyReportPart x = ierror . InternalMsg $ "could not reify " ++ show x

1377

1543

1378envTupleType :: Raw

1544envTupleType :: Raw

1379envTupleType

1545envTupleType

@@ -1383,44 +1549,3 @@ envTupleType

1383

1549

1384solveAll = try (do solve; solveAll) (return ())

1550solveAll = try (do solve; solveAll) (return ())

1385

1551

1386−-- If the function application is specialisable, make a new

1387−-- top level function by normalising the application

1388−-- and elaborating the new expression.

1389−

1390−mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm

1391−mkSpecialised i fc n args def

1392− = do let tm' = def

1393− case lookupCtxt n (idris_statics i) of

1394− [as] -> if (not (or as)) then return tm' else

1395− mkSpecDecl i n (zip args as) tm'

1396− _ -> return tm'

1397−

1398−mkSpecDecl :: IState -> Name -> [(PTerm, Bool)] -> PTerm -> ElabD PTerm

1399−mkSpecDecl i n pargs tm'

1400− = do t <- goal

1401− g <- get_guess

1402− let (f, args) = unApply g

1403− let sargs = zip args (map snd pargs)

1404− let staticArgs = map fst (filter (\ (_,x) -> x) sargs)

1405− let ns = group (sort (concatMap staticFnNames staticArgs))

1406− let ntimes = map (\xs -> (head xs, length xs - 1)) ns

1407− if (not (null ns)) then

1408− do env <- get_env

1409− let g' = g -- specialise ctxt env ntimes g

1410− return tm'

1411−-- trace (show t ++ "\n" ++

1412−-- show ntimes ++ "\n" ++

1413−-- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO

1414− else return tm'

1415− where

1416− ctxt = tt_ctxt i

1417− cg = idris_callgraph i

1418−

1419− staticFnNames tm | (P _ f _, as) <- unApply tm

1420− = if not (isFnName f ctxt) then []

1421− else case lookupCtxt f cg of

1422− [ns] -> f : f : [] --(ns \\ [f])

1423− [] -> [f,f]

1424− _ -> []

1425− staticFnNames _ = []

1426−

src/Idris/Error.hs+3−1

@@ -12,7 +12,7 @@ import Idris.Core.Constraints

13import System.Console.Haskeline

14import System.Console.Haskeline.MonadException

15−import Control.Monad.State

15+import Control.Monad.State.Strict

16import Control.Monad.Error (throwError, catchError)

17import System.IO.Error(isUserError, ioeGetErrorString)

18import Data.Char

@@ -38,6 +38,7 @@ report e

38idrisCatch :: Idris a -> (Err -> Idris a) -> Idris a

39idrisCatch = catchError

41+

41setAndReport :: Err -> Idris ()

42setAndReport :: Err -> Idris ()

42setAndReport e = do ist <- getIState

43setAndReport e = do ist <- getIState

43 let h = idris_outh ist

44 let h = idris_outh ist

@@ -71,3 +72,4 @@ getErrLine _ = 0

71getErrColumn :: Err -> Int

72getErrColumn :: Err -> Int

72getErrColumn (At (FC _ _ c) _) = c

73getErrColumn (At (FC _ _ c) _) = c

73getErrColumn _ = 0

74getErrColumn _ = 0

75+

src/Idris/IBC.hs+156−54

@@ -8,25 +8,29 @@ import Idris.Core.CaseTree

8import Idris.AbsSyntax

9import Idris.Imports

10import Idris.Error

11+import Idris.Delaborate

12import Data.Binary

13import Data.Binary

13import Data.Vector.Binary

14import Data.Vector.Binary

14import Data.List

15import Data.List

15−import Data.ByteString.Lazy as B hiding (length, elem)

16+import Data.ByteString.Lazy as B hiding (length, elem, map)

17+import qualified Data.Text as T

18+

16import Control.Monad

19import Control.Monad

17−import Control.Monad.State hiding (get, put)

20+import Control.Monad.State.Strict hiding (get, put)

21+import qualified Control.Monad.State.Strict as ST

18import System.FilePath

22import System.FilePath

19import System.Directory

23import System.Directory

24+import Codec.Compression.Zlib (compress)

25+import Util.Zlib (decompressEither)

21−import Debug.Trace

22−

23−import Paths_idris

25ibcVersion :: Word8

28ibcVersion :: Word8

26−ibcVersion = 50

29+ibcVersion = 54

28data IBCFile = IBCFile { ver :: Word8,

31data IBCFile = IBCFile { ver :: Word8,

29 sourcefile :: FilePath,

32 sourcefile :: FilePath,

33+ symbols :: [Name],

30 ibc_imports :: [FilePath],

34 ibc_imports :: [FilePath],

31 ibc_implicits :: [(Name, [PArg])],

35 ibc_implicits :: [(Name, [PArg])],

32 ibc_fixes :: [FixDecl],

36 ibc_fixes :: [FixDecl],

@@ -61,13 +65,23 @@ deriving instance Binary IBCFile

61!-}

65!-}

63initIBC :: IBCFile

67initIBC :: IBCFile

64−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

68+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

66loadIBC :: FilePath -> Idris ()

70loadIBC :: FilePath -> Idris ()

67loadIBC fp = do iLOG $ "Loading ibc " ++ fp

71loadIBC fp = do iLOG $ "Loading ibc " ++ fp

68− ibcf <- runIO $ (decodeFile fp :: IO IBCFile)

72+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

69 process ibcf fp

73 process ibcf fp

75+bencode :: Binary a => FilePath -> a -> IO ()

76+bencode f d = B.writeFile f (compress (encode d))

77+

78+bdecode :: Binary b => FilePath -> IO b

79+bdecode f = do d' <- B.readFile f

80+ either

81+ (\(_, e) -> error $ "Invalid / corrupted zip format on " ++ show f ++ ": " ++ e)

82+ (return . decode)

83+ (decompressEither d')

84+

71writeIBC :: FilePath -> FilePath -> Idris ()

85writeIBC :: FilePath -> FilePath -> Idris ()

72writeIBC src f

86writeIBC src f

73 = do iLOG $ "Writing ibc " ++ show f

87 = do iLOG $ "Writing ibc " ++ show f

@@ -75,11 +89,12 @@ writeIBC src f

75 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

89 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

76 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

90 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

77 [] -> return ()

91 [] -> return ()

92+ resetNameIdx

78 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

93 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

79 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

94 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

80− runIO $ encodeFile f ibcf

95+ runIO $ bencode f ibcf

81 iLOG "Written")

96 iLOG "Written")

82− (\c -> do iLOG $ "Failed " ++ show c)

97+ (\c -> do iLOG $ "Failed " ++ pshow i c)

83 return ()

98 return ()

85mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

100mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

@@ -124,8 +139,64 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

124ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

139ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

125ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

140ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

126ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

141ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

142+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

127− [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

143+ return f' { ibc_defs = (n,v) : ibc_defs f' }

128 _ -> ifail "IBC write failed"

144 _ -> ifail "IBC write failed"

145+ where

146+ updateDef :: Def -> StateT (IBCFile, Int) Idris Def

147+ updateDef (CaseOp c t args o s cd)

148+ = do o' <- mapM updateOrig o

149+ cd' <- updateCD cd

150+ return (CaseOp c t args o' s cd')

151+ updateDef t = return t

152+

153+ updateOrig (Left t) = do t' <- update t

154+ return (Left t')

155+ updateOrig (Right (l,r)) = do l' <- update l

156+ r' <- update r

157+ return (Right (l', r'))

158+

159+ updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

160+ = do c' <- updateSC c; r' <- updateSC r

161+ return (CaseDefs (ts, t) (cs, c') (is, i) (rs, r'))

162+

163+ updateSC (Case n alts) = do alts' <- mapM updateAlt alts

164+ return (Case n alts')

165+ updateSC (ProjCase t alts) = do t' <- update t

166+ alts' <- mapM updateAlt alts

167+ return (ProjCase t' alts')

168+ updateSC (STerm t) = do t' <- update t

169+ return (STerm t')

170+ updateSC t = return t

171+

172+ updateAlt (ConCase n i a sc) = do sc' <- updateSC sc

173+ return (ConCase n i a sc')

174+ updateAlt (FnCase n a sc) = do sc' <- updateSC sc

175+ return (FnCase n a sc')

176+ updateAlt (ConstCase i sc) = do sc' <- updateSC sc

177+ return (ConstCase i sc')

178+ updateAlt (SucCase n sc) = do sc' <- updateSC sc

179+ return (SucCase n sc')

180+ updateAlt (DefaultCase sc) = do sc' <- updateSC sc

181+ return (DefaultCase sc')

182+

183+ update (P t n@(MN _ _) ty) = return (P t n ty)

184+ update (P t n@(UN _) ty) = return (P t n ty)

185+ update (P t n ty) = do (f, len) <- ST.get

186+ (i, _) <- lift (addNameIdx n)

187+ when (i >= len) $

188+ ST.put (f { symbols = symbols f ++ [n] }, len+1)

189+ return (P t (SymRef i) ty)

190+ update (App f a) = do f' <- update f; a' <- update a

191+ return (App f' a')

192+ update (Bind n b sc) = do b' <- fmapMB update b

193+ sc' <- update sc

194+ return (Bind n b' sc')

195+ update (Proj t i) = do t' <- update t

196+ return (Proj t' i)

197+ update t = return t

198+

199+

129ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

200ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

130 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

201 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

131 _ -> ifail "IBC write failed"

202 _ -> ifail "IBC write failed"

@@ -169,7 +240,7 @@ process i fn

169 pCGFlags (ibc_cgflags i)

240 pCGFlags (ibc_cgflags i)

170 pDyLibs (ibc_dynamic_libs i)

241 pDyLibs (ibc_dynamic_libs i)

171 pHdrs (ibc_hdrs i)

242 pHdrs (ibc_hdrs i)

172− pDefs (ibc_defs i)

243+ pDefs (symbols i) (ibc_defs i)

173 pAccess (ibc_access i)

244 pAccess (ibc_access i)

174 pTotal (ibc_total i)

245 pTotal (ibc_total i)

175 pCG (ibc_cg i)

246 pCG (ibc_cg i)

@@ -207,7 +278,9 @@ pImports fs

207pImps :: [(Name, [PArg])] -> Idris ()

278pImps :: [(Name, [PArg])] -> Idris ()

208pImps imps = mapM_ (\ (n, imp) ->

279pImps imps = mapM_ (\ (n, imp) ->

209 do i <- getIState

280 do i <- getIState

281+ case lookupDefAcc n False (tt_ctxt i) of

282+ [(n, Hidden)] -> return ()

210− putIState (i { idris_implicits

283+ _ -> putIState (i { idris_implicits

211 = addDef n imp (idris_implicits i) }))

284 = addDef n imp (idris_implicits i) }))

212 imps

285 imps

213

286

@@ -289,12 +362,32 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

289pHdrs :: [(Codegen, String)] -> Idris ()

362pHdrs :: [(Codegen, String)] -> Idris ()

290pHdrs hs = mapM_ (uncurry addHdr) hs

363pHdrs hs = mapM_ (uncurry addHdr) hs

291

364

292−pDefs :: [(Name, Def)] -> Idris ()

365+pDefs :: [Name] -> [(Name, Def)] -> Idris ()

366+pDefs syms ds

293−pDefs ds = mapM_ (\ (n, d) ->

367+ = mapM_ (\ (n, d) ->

294− do i <- getIState

368+ do i <- getIState

369+ let d' = updateDef d

295− logLvl 5 $ "Added " ++ show (n, d)

370+ logLvl 5 $ "Added " ++ show (n, d')

296− putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

371+ putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds

297− ds

372+ where

373+ updateDef (CaseOp c t args o s cd)

374+ = CaseOp c t args (map updateOrig o) s (updateCD cd)

375+ updateDef t = t

376+

377+ updateOrig (Left t) = Left (update t)

378+ updateOrig (Right (l, r)) = Right (update l, update r)

379+

380+ updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

381+ = CaseDefs (ts, fmap update t)

382+ (cs, fmap update c)

383+ (is, fmap update i)

384+ (rs, fmap update r)

385+

386+ update (P t (SymRef i) ty) = P t (syms!!i) ty

387+ update (App f a) = App (update f) (update a)

388+ update (Bind n b sc) = Bind n (fmap update b) (update sc)

389+ update (Proj t i) = Proj (update t) i

390+ update t = t

298

391

299pDocs :: [(Name, String)] -> Idris ()

392pDocs :: [(Name, String)] -> Idris ()

300pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

393pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -357,27 +450,24 @@ instance Binary CGInfo where

357 put (CGInfo x1 x2 x3 x4 x5)

450 put (CGInfo x1 x2 x3 x4 x5)

358 = do put x1

451 = do put x1

359 put x2

452 put x2

360− put x3

453+-- put x3 -- Already used SCG info for totality check

361 put x4

454 put x4

362 put x5

455 put x5

363 get

456 get

364 = do x1 <- get

457 = do x1 <- get

365 x2 <- get

458 x2 <- get

366− x3 <- get

367 x4 <- get

459 x4 <- get

368 x5 <- get

460 x5 <- get

369− return (CGInfo x1 x2 x3 x4 x5)

461+ return (CGInfo x1 x2 [] x4 x5)

370

462

371instance Binary FC where

463instance Binary FC where

372 put (FC x1 x2 x3)

464 put (FC x1 x2 x3)

373 = do put x1

465 = do put x1

374− put x2

466+ put (x2 * 65536 + x3)

375− put x3

376 get

467 get

377 = do x1 <- get

468 = do x1 <- get

378− x2 <- get

379− x3 <- get

469+ x2x3 <- get

380− return (FC x1 x2 x3)

470+ return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

381

471

382

472

383instance Binary Name where

473instance Binary Name where

@@ -394,6 +484,8 @@ instance Binary Name where

394 NErased -> putWord8 3

484 NErased -> putWord8 3

395 SN x1 -> do putWord8 4

485 SN x1 -> do putWord8 4

396 put x1

486 put x1

487+ SymRef x1 -> do putWord8 5

488+ put x1

397 get

489 get

398 = do i <- getWord8

490 = do i <- getWord8

399 case i of

491 case i of

@@ -408,8 +500,15 @@ instance Binary Name where

408 3 -> return NErased

500 3 -> return NErased

409 4 -> do x1 <- get

501 4 -> do x1 <- get

410 return (SN x1)

502 return (SN x1)

503+ 5 -> do x1 <- get

504+ return (SymRef x1)

411 _ -> error "Corrupted binary data for Name"

505 _ -> error "Corrupted binary data for Name"

412

506

507+instance Binary T.Text where

508+ put x = put (str x)

509+ get = do x <- get

510+ return (txt x)

511+

413instance Binary SpecialName where

512instance Binary SpecialName where

414 put x

513 put x

415 = case x of

514 = case x of

@@ -624,35 +723,34 @@ instance Binary NameType where

624 Bound -> putWord8 0

723 Bound -> putWord8 0

625 Ref -> putWord8 1

724 Ref -> putWord8 1

626 DCon x1 x2 -> do putWord8 2

725 DCon x1 x2 -> do putWord8 2

627− put x1

726+ put (x1 * 65536 + x2)

628− put x2

629 TCon x1 x2 -> do putWord8 3

727 TCon x1 x2 -> do putWord8 3

630− put x1

728+ put (x1 * 65536 + x2)

631− put x2

632 get

729 get

633 = do i <- getWord8

730 = do i <- getWord8

634 case i of

731 case i of

635 0 -> return Bound

732 0 -> return Bound

636 1 -> return Ref

733 1 -> return Ref

637− 2 -> do x1 <- get

638− x2 <- get

734+ 2 -> do x1x2 <- get

639− return (DCon x1 x2)

735+ return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

640− 3 -> do x1 <- get

641− x2 <- get

736+ 3 -> do x1x2 <- get

642− return (TCon x1 x2)

737+ return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

643 _ -> error "Corrupted binary data for NameType"

738 _ -> error "Corrupted binary data for NameType"

644

739

645

740

646−instance {-(Binary n) =>-} Binary (TT Name) where

741+instance {- (Binary n) => -} Binary (TT Name) where

647 put x

742 put x

648 = {-# SCC "putTT" #-}

743 = {-# SCC "putTT" #-}

649 case x of

744 case x of

650 P x1 x2 x3 -> do putWord8 0

745 P x1 x2 x3 -> do putWord8 0

651 put x1

746 put x1

652 put x2

747 put x2

653− put x3

748+-- put x3

749+ V x1 -> if (x1 >= 0 && x1 < 256)

654− V x1 -> do putWord8 1

750+ then do putWord8 1

751+ putWord8 (toEnum (x1 + 1))

752+ else do putWord8 9

655− put x1

753+ put x1

656 Bind x1 x2 x3 -> do putWord8 2

754 Bind x1 x2 x3 -> do putWord8 2

657 put x1

755 put x1

658 put x2

756 put x2

@@ -664,7 +762,7 @@ instance {-(Binary n) =>-} Binary (TT Name) where

664 put x1

762 put x1

665 Proj x1 x2 -> do putWord8 5

763 Proj x1 x2 -> do putWord8 5

666 put x1

764 put x1

667− put x2

765+ putWord8 (toEnum (x2 + 1))

668 Erased -> putWord8 6

766 Erased -> putWord8 6

669 TType x1 -> do putWord8 7

767 TType x1 -> do putWord8 7

670 put x1

768 put x1

@@ -674,10 +772,10 @@ instance {-(Binary n) =>-} Binary (TT Name) where

674 case i of

772 case i of

675 0 -> do x1 <- get

773 0 -> do x1 <- get

676 x2 <- get

774 x2 <- get

677− x3 <- get

775+-- x3 <- get

678− return (P x1 x2 x3)

776+ return (P x1 x2 Erased)

679− 1 -> do x1 <- get

777+ 1 -> do x1 <- getWord8

680− return (V x1)

778+ return (V ((fromEnum x1) - 1))

681 2 -> do x1 <- get

779 2 -> do x1 <- get

682 x2 <- get

780 x2 <- get

683 x3 <- get

781 x3 <- get

@@ -688,12 +786,14 @@ instance {-(Binary n) =>-} Binary (TT Name) where

688 4 -> do x1 <- get

786 4 -> do x1 <- get

689 return (Constant x1)

787 return (Constant x1)

690 5 -> do x1 <- get

788 5 -> do x1 <- get

691− x2 <- get

789+ x2 <- getWord8

692− return (Proj x1 x2)

790+ return (Proj x1 ((fromEnum x2)-1))

693 6 -> return Erased

791 6 -> return Erased

694 7 -> do x1 <- get

792 7 -> do x1 <- get

695 return (TType x1)

793 return (TType x1)

696 8 -> return Impossible

794 8 -> return Impossible

795+ 9 -> do x1 <- get

796+ return (V x1)

697 _ -> error "Corrupted binary data for TT"

797 _ -> error "Corrupted binary data for TT"

698

798

699instance Binary SC where

799instance Binary SC where

@@ -772,15 +872,13 @@ instance Binary CaseAlt where

772

872

773instance Binary CaseDefs where

873instance Binary CaseDefs where

774 put (CaseDefs x1 x2 x3 x4)

874 put (CaseDefs x1 x2 x3 x4)

775− = do -- don't need totality checked version

875+ = do -- don't need totality checked or inlined versions

776 put x2

876 put x2

777− put x3

778 put x4

877 put x4

779 get

878 get

780 = do x2 <- get

879 = do x2 <- get

781− x3 <- get -- use for totality checked version

782 x4 <- get

880 x4 <- get

783− return (CaseDefs x3 x2 x3 x4)

881+ return (CaseDefs x2 x2 x2 x4)

784

882

785instance Binary CaseInfo where

883instance Binary CaseInfo where

786 put x@(CaseInfo x1 x2) = do put x1

884 put x@(CaseInfo x1 x2) = do put x1

@@ -914,7 +1012,7 @@ instance Binary MetaInformation where

914 return (DataMI x1)

1012 return (DataMI x1)

915

1013

916instance Binary IBCFile where

1014instance Binary IBCFile where

917− 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)

1015+ 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)

918 = {-# SCC "putIBCFile" #-}

1016 = {-# SCC "putIBCFile" #-}

919 do put x1

1017 do put x1

920 put x2

1018 put x2

@@ -945,6 +1043,7 @@ instance Binary IBCFile where

945 put x27

1043 put x27

946 put x28

1044 put x28

947 put x29

1045 put x29

1046+ put x30

948 get

1047 get

949 = do x1 <- get

1048 = do x1 <- get

950 if x1 == ibcVersion then

1049 if x1 == ibcVersion then

@@ -976,7 +1075,8 @@ instance Binary IBCFile where

976 x27 <- get

1075 x27 <- get

977 x28 <- get

1076 x28 <- get

978 x29 <- get

1077 x29 <- get

1078+ x30 <- get

979− 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)

1079+ 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)

980 else return (initIBC { ver = x1 })

1080 else return (initIBC { ver = x1 })

981

1081

982instance Binary DataOpt where

1082instance Binary DataOpt where

@@ -1001,6 +1101,7 @@ instance Binary FnOpt where

1001 PartialFn -> putWord8 6

1101 PartialFn -> putWord8 6

1002 Implicit -> putWord8 7

1102 Implicit -> putWord8 7

1003 Reflection -> putWord8 8

1103 Reflection -> putWord8 8

1104+ ErrorHandler -> putWord8 9

1004 get

1105 get

1005 = do i <- getWord8

1106 = do i <- getWord8

1006 case i of

1107 case i of

@@ -1014,6 +1115,7 @@ instance Binary FnOpt where

1014 6 -> return PartialFn

1115 6 -> return PartialFn

1015 7 -> return Implicit

1116 7 -> return Implicit

1016 8 -> return Reflection

1117 8 -> return Reflection

1118+ 9 -> return ErrorHandler

1017 _ -> error "Corrupted binary data for FnOpt"

1119 _ -> error "Corrupted binary data for FnOpt"

1018

1120

1019instance Binary Fixity where

1121instance Binary Fixity where

src/Idris/Imports.hs+1−1

@@ -7,7 +7,7 @@ import Paths_idris

8import System.FilePath

9import System.Directory

10−import Control.Monad.State

10+import Control.Monad.State.Strict

12data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

13 deriving (Show, Eq)

src/Idris/ParseData.hs+14−10

@@ -49,7 +49,7 @@ record syn = do (doc, acc) <- try (do

49 ty <- typeExpr (allowImp syn)

50 let tyn = expandNS syn tyn_in

51 reserved "where"

52− (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)

52+ (cdoc, cn, cty, _, _) <- indentedBlockS (constructor syn)

53 accData acc tyn [cn]

54 let rsyn = syn { syn_namespace = show (nsroot tyn) :

55 syn_namespace syn }

@@ -113,7 +113,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

113 option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do

114 reserved "where"

115 cons <- indentedBlock (constructor syn)

116− accData acc tyn (map (\ (_, n, _, _) -> n) cons)

116+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons)

117 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

118 args <- many name

119 let ty = bindArgs (map (const PType) args) PType

@@ -133,10 +133,10 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

133 cons <- sepBy1 (simpleConstructor syn) (lchar '|')

134 terminator

135 let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)

136− cons' <- mapM (\ (doc, x, cargs, cfc) ->

136+ cons' <- mapM (\ (doc, x, cargs, cfc, fs) ->

137 do let cty = bindArgs cargs conty

138− return (doc, x, cty, cfc)) cons

138+ return (doc, x, cty, cfc, fs)) cons

139− accData acc tyn (map (\ (_, n, _, _) -> n) cons')

139+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons')

140 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons')))

141 <?> "data type declaration"

142 where

@@ -144,7 +144,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

144 mkPApp fc t [] = t

145 mkPApp fc t xs = PApp fc t (map pexp xs)

146 bindArgs :: [PTerm] -> PTerm -> PTerm

147− bindArgs xs t = foldr (PPi expl (MN 0 "_t")) t xs

147+ bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs

148 combineDataOpts :: DataOpts -> DataOpts

149 combineDataOpts opts = if Codata `elem` opts then delete DefaultEliminator opts else opts

150

@@ -152,20 +152,24 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

152{- | Parses a type constructor declaration

153 Constructor ::= DocComment? FnName TypeSig;

154-}

155−constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)

155+constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC, [Name])

156constructor syn

157 = do doc <- option "" (docComment '|')

158 cn_in <- fnName; fc <- getFC

159 let cn = expandNS syn cn_in

160 lchar ':'

161+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

162+ -- erasing non-forceable things

163+ fs <- option [] (do lchar '%'; reserved "erase"

164+ sepBy1 name (lchar ','))

161 ty <- typeExpr (allowImp syn)

165 ty <- typeExpr (allowImp syn)

162− return (doc, cn, ty, fc)

166+ return (doc, cn, ty, fc, fs)

163 <?> "constructor"

167 <?> "constructor"

164

168

165{- | Parses a constructor for simple discriminative union data types

169{- | Parses a constructor for simple discriminative union data types

166 SimpleConstructor ::= FnName SimpleExpr* DocComment?

170 SimpleConstructor ::= FnName SimpleExpr* DocComment?

167-}

171-}

168−simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)

172+simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC, [Name])

169simpleConstructor syn

173simpleConstructor syn

170 = do cn_in <- fnName

174 = do cn_in <- fnName

171 let cn = expandNS syn cn_in

175 let cn = expandNS syn cn_in

@@ -173,7 +177,7 @@ simpleConstructor syn

173 args <- many (do notEndApp

177 args <- many (do notEndApp

174 simpleExpr syn)

178 simpleExpr syn)

175 doc <- option "" (docComment '^')

179 doc <- option "" (docComment '^')

176− return (doc, cn, args, fc)

180+ return (doc, cn, args, fc, [])

177 <?> "constructor"

181 <?> "constructor"

178

182

179{- | Parses a dsl block declaration

183{- | Parses a dsl block declaration

src/Idris/ParseExpr.hs+58−28

@@ -114,7 +114,7 @@ extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm

114extension syn (Rule ssym ptm _)

115 = do smap <- mapM extensionSymbol ssym

116 let ns = mapMaybe id smap

117− return (update ns ptm) -- updated with smap

117+ return (flatten (update ns ptm)) -- updated with smap

118 where

119 extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))

120 extensionSymbol (Keyword n) = do reserved (show n); return Nothing

@@ -131,6 +131,10 @@ extension syn (Rule ssym ptm _)

131 dropn n ((x,t) : xs) | n == x = xs

132 | otherwise = (x,t):dropn n xs

133

134+ flatten :: PTerm -> PTerm -- flatten application

135+ flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))

136+ flatten t = t

137+

134 updateB :: [(Name, SynMatch)] -> Name -> Name

138 updateB :: [(Name, SynMatch)] -> Name -> Name

135 updateB ns n = case lookup n ns of

139 updateB ns n = case lookup n ns of

136 Just (SynBind t) -> t

140 Just (SynBind t) -> t

@@ -186,6 +190,7 @@ internalExpr syn =

186 try (app syn)

190 try (app syn)

187 <|> try (matchApp syn)

191 <|> try (matchApp syn)

188 <|> try (unifyLog syn)

192 <|> try (unifyLog syn)

193+ <|> try (disamb syn)

189 <|> try (noImplicits syn)

194 <|> try (noImplicits syn)

190 <|> recordType syn

195 <|> recordType syn

191 <|> lambda syn

196 <|> lambda syn

@@ -291,7 +296,7 @@ simpleExpr syn =

291 fc <- getFC

296 fc <- getFC

292 return (modifyConst syn fc (PConstant c)))

297 return (modifyConst syn fc (PConstant c)))

293 <|> try (do symbol "'"; fc <- getFC; str <- name

298 <|> try (do symbol "'"; fc <- getFC; str <- name

294− return (PApp fc (PRef fc (UN "Symbol_"))

299+ return (PApp fc (PRef fc (sUN "Symbol_"))

295 [pexp (PConstant (Str (show str)))]))

300 [pexp (PConstant (Str (show str)))]))

296 <|> do fc <- getFC

301 <|> do fc <- getFC

297 x <- fnName

302 x <- fnName

@@ -356,12 +361,12 @@ bracketed syn =

356 l <- expr' syn

361 l <- expr' syn

357 o <- operator

362 o <- operator

358 lchar ')'

363 lchar ')'

359− return $ PLam (MN 1000 "ARG") Placeholder

364+ return $ PLam (sMN 1000 "ARG") Placeholder

360− (PApp fc0 (PRef fc0 (UN o)) [pexp l,

365+ (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

361− pexp (PRef fc0 (MN 1000 "ARG"))]))

366+ pexp (PRef fc0 (sMN 1000 "ARG"))]))

362 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

367 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

363− return $ PLam (MN 1000 "ARG") Placeholder

368+ return $ PLam (sMN 1000 "ARG") Placeholder

364− (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),

369+ (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

365 pexp e]))

370 pexp e]))

366 <|> try (do ln <- name; lchar ':'

371 <|> try (do ln <- name; lchar ':'

367 lty <- expr syn

372 lty <- expr syn

@@ -384,7 +389,7 @@ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

384modifyConst syn fc (PConstant (BI x))

389modifyConst syn fc (PConstant (BI x))

385 | not (inPattern syn)

390 | not (inPattern syn)

386 = PAlternative False

391 = PAlternative False

387− (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]

392+ (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]

388 : consts)

393 : consts)

389 | otherwise = PAlternative False consts

394 | otherwise = PAlternative False consts

390 where

395 where

@@ -416,8 +421,8 @@ listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lc

416 <?> "list expression"

421 <?> "list expression"

417 where

422 where

418 mkList :: FC -> [PTerm] -> PTerm

423 mkList :: FC -> [PTerm] -> PTerm

419− mkList fc [] = PRef fc (UN "Nil")

424+ mkList fc [] = PRef fc (sUN "Nil")

420− mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]

425+ mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

421

426

422

427

423{- | Parses an alternative expression

428{- | Parses an alternative expression

@@ -462,10 +467,10 @@ matchApp syn = do ty <- simpleExpr syn

462 symbol "<=="

467 symbol "<=="

463 fc <- getFC

468 fc <- getFC

464 f <- fnName

469 f <- fnName

465− return (PLet (MN 0 "match")

470+ return (PLet (sMN 0 "match")

466 ty

471 ty

467 (PMatchApp fc f)

472 (PMatchApp fc f)

468− (PRef fc (MN 0 "match")))

473+ (PRef fc (sMN 0 "match")))

469 <?> "matching application expression"

474 <?> "matching application expression"

470

475

471{- | Parses a unification log expression

476{- | Parses a unification log expression

@@ -479,6 +484,19 @@ unifyLog syn = do lchar '%'; reserved "unifyLog";

479 return (PUnifyLog tm)

484 return (PUnifyLog tm)

480 <?> "unification log expression"

485 <?> "unification log expression"

481

486

487+{- | Parses a disambiguation expression

488+Disamb ::=

489+ '%' 'disamb' NameList Expr

490+ ;

491+-}

492+disamb :: SyntaxInfo -> IdrisParser PTerm

493+disamb syn = do reserved "with";

494+ ns <- sepBy1 name (lchar ',')

495+ tm <- expr' syn

496+ return (PDisamb (map tons ns) tm)

497+ <?> "unification log expression"

498+ where tons (NS n s) = txt (show n) : s

499+ tons n = [txt (show n)]

482{- | Parses a no implicits expression

500{- | Parses a no implicits expression

483@

501@

484NoImplicits ::=

502NoImplicits ::=

@@ -508,12 +526,12 @@ app syn = do f <- reserved "mkForeign"

508 i <- get

526 i <- get

509 -- mkForeign f args ==>

527 -- mkForeign f args ==>

510 -- liftPrimIO (\w => mkForeignPrim f args w)

528 -- liftPrimIO (\w => mkForeignPrim f args w)

511− let ap = PApp fc (PRef fc (UN "liftPrimIO"))

529+ let ap = PApp fc (PRef fc (sUN "liftPrimIO"))

512− [pexp (PLam (MN 0 "w")

530+ [pexp (PLam (sMN 0 "w")

513 Placeholder

531 Placeholder

514− (PApp fc (PRef fc (UN "mkForeignPrim"))

532+ (PApp fc (PRef fc (sUN "mkForeignPrim"))

515 (fn : args ++

533 (fn : args ++

516− [pexp (PRef fc (MN 0 "w"))])))]

534+ [pexp (PRef fc (sMN 0 "w"))])))]

517 return (dslify i ap)

535 return (dslify i ap)

518

536

519 <|> do f <- simpleExpr syn

537 <|> do f <- simpleExpr syn

@@ -562,7 +580,7 @@ implicitArg syn = do lchar '{'

562 v <- option (PRef fc n) (do lchar '='

580 v <- option (PRef fc n) (do lchar '='

563 expr syn)

581 expr syn)

564 lchar '}'

582 lchar '}'

565− return (pimp n v False)

583+ return (pimp n v True)

566 <?> "implicit function argument"

584 <?> "implicit function argument"

567

585

568{-| Parses a constraint argument (for selecting a named type class instance)

586{-| Parses a constraint argument (for selecting a named type class instance)

@@ -607,8 +625,8 @@ recordType syn

607 rec <- optional (simpleExpr syn)

625 rec <- optional (simpleExpr syn)

608 case rec of

626 case rec of

609 Nothing ->

627 Nothing ->

610− return (PLam (MN 0 "fldx") Placeholder

628+ return (PLam (sMN 0 "fldx") Placeholder

611− (applyAll fc fields (PRef fc (MN 0 "fldx"))))

629+ (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

612 Just v -> return (applyAll fc fields v)

630 Just v -> return (applyAll fc fields v)

613 <?> "record setting expression"

631 <?> "record setting expression"

614 where fieldType :: IdrisParser (Name, PTerm)

632 where fieldType :: IdrisParser (Name, PTerm)

@@ -624,8 +642,8 @@ recordType syn

624

642

625-- | Creates setters for record types on necessary functions

643-- | Creates setters for record types on necessary functions

626mkType :: Name -> Name

644mkType :: Name -> Name

627−mkType (UN n) = UN ("set_" ++ n)

645+mkType (UN n) = sUN ("set_" ++ str n)

628−mkType (MN 0 n) = MN 0 ("set_" ++ n)

646+mkType (MN 0 n) = sMN 0 ("set_" ++ str n)

629mkType (NS n s) = NS (mkType n) s

647mkType (NS n s) = NS (mkType n) s

630

648

631{- | Parses a type signature

649{- | Parses a type signature

@@ -641,7 +659,7 @@ TypeExpr ::= ConstraintList? Expr;

641typeExpr :: SyntaxInfo -> IdrisParser PTerm

659typeExpr :: SyntaxInfo -> IdrisParser PTerm

642typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

660typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

643 sc <- expr syn

661 sc <- expr syn

644− return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc)

662+ return (bindList (PPi constraint) (map (\x -> (sMN 0 "constrarg", x)) cs) sc)

645 <?> "type signature"

663 <?> "type signature"

646

664

647{- | Parses a lambda expression

665{- | Parses a lambda expression

@@ -674,8 +692,8 @@ lambda syn = do lchar '\\'

674 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

692 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

675 pmList [] sc = sc

693 pmList [] sc = sc

676 pmList ((i, (fc, x)) : xs) sc

694 pmList ((i, (fc, x)) : xs) sc

677− = PLam (MN i "lamp") Placeholder

695+ = PLam (sMN i "lamp") Placeholder

678− (PCase fc (PRef fc (MN i "lamp"))

696+ (PCase fc (PRef fc (sMN i "lamp"))

679 [(x, pmList xs sc)])

697 [(x, pmList xs sc)])

680

698

681{- | Parses a term rewrite expression

699{- | Parses a term rewrite expression

@@ -692,7 +710,7 @@ rewriteTerm syn = do reserved "rewrite"

692 giving <- optional (do symbol "==>"; expr' syn)

710 giving <- optional (do symbol "==>"; expr' syn)

693 reserved "in"; sc <- expr syn

711 reserved "in"; sc <- expr syn

694 return (PRewrite fc

712 return (PRewrite fc

695− (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc

713+ (PApp fc (PRef fc (sUN "sym")) [pexp prf]) sc

696 giving)

714 giving)

697 <?> "term rewrite expression"

715 <?> "term rewrite expression"

698

716

@@ -857,7 +875,7 @@ tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

857 where nameOrPlaceholder :: IdrisParser Name

875 where nameOrPlaceholder :: IdrisParser Name

858 nameOrPlaceholder = fnName

876 nameOrPlaceholder = fnName

859 <|> do symbol "_"

877 <|> do symbol "_"

860− return (MN 0 "underscore")

878+ return (sMN 0 "underscore")

861 <?> "name or placeholder"

879 <?> "name or placeholder"

862

880

863{- | Parses a list comprehension

881{- | Parses a list comprehension

@@ -881,11 +899,11 @@ comprehension syn

881 qs <- sepBy1 (do_ syn) (lchar ',')

899 qs <- sepBy1 (do_ syn) (lchar ',')

882 lchar ']'

900 lchar ']'

883 return (PDoBlock (map addGuard qs ++

901 return (PDoBlock (map addGuard qs ++

884− [DoExp fc (PApp fc (PRef fc (UN "return"))

902+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

885 [pexp pat])]))

903 [pexp pat])]))

886 <?> "list comprehension"

904 <?> "list comprehension"

887 where addGuard :: PDo -> PDo

905 where addGuard :: PDo -> PDo

888− addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (UN "guard"))

906+ addGuard (DoExp fc e) = DoExp fc (PApp fc (PRef fc (sUN "guard"))

889 [pexp e])

907 [pexp e])

890 addGuard x = x

908 addGuard x = x

891

909

@@ -983,6 +1001,7 @@ Constant ::=

983 | 'Bits64x2'

1001 | 'Bits64x2'

984 | Float_t

1002 | Float_t

985 | Natural_t

1003 | Natural_t

1004+ | VerbatimString_t

986 | String_t

1005 | String_t

987 | Char_t

1006 | Char_t

988 ;

1007 ;

@@ -1005,10 +1024,21 @@ constant = do reserved "Integer";return (AType (ATInt ITBig))

1005 <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))

1024 <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))

1006 <|> try (do f <- float; return $ Fl f)

1025 <|> try (do f <- float; return $ Fl f)

1007 <|> try (do i <- natural; return $ BI i)

1026 <|> try (do i <- natural; return $ BI i)

1027+ <|> try (do s <- verbatimStringLiteral; return $ Str s)

1008 <|> try (do s <- stringLiteral; return $ Str s)

1028 <|> try (do s <- stringLiteral; return $ Str s)

1009 <|> try (do c <- charLiteral; return $ Ch c)

1029 <|> try (do c <- charLiteral; return $ Ch c)

1010 <?> "constant or literal"

1030 <?> "constant or literal"

1011

1031

1032+{- | Parses a verbatim multi-line string literal (triple-quoted)

1033+@

1034+VerbatimString_t ::=

1035+ '"""' ~'"""' '"""'

1036+@

1037+ -}

1038+verbatimStringLiteral :: MonadicParsing m => m String

1039+verbatimStringLiteral = token $ do string "\"\"\""

1040+ manyTill anyChar $ try (string "\"\"\"")

1041+

1012{- | Parses a static modifier

1042{- | Parses a static modifier

1013

1043

1014@

1044@

src/Idris/ParseHelpers.hs+2−2

@@ -230,8 +230,8 @@ initsEndAt p (x:xs) | p x = [] : x_inits_xs

230 namespace.

231-}

232mkName :: (String, String) -> Name

233−mkName (n, "") = UN n

233+mkName (n, "") = sUN n

234−mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

234+mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))

235 where parseNS x = case span (/= '.') x of

236 (x, "") -> [x]

237 (x, '.':y) -> x : parseNS y

src/Idris/ParseOps.hs+6−5

@@ -33,21 +33,22 @@ import qualified Data.ByteString.UTF8 as UTF8

33-- using pre-build and user-defined operator/fixity declarations

34table :: [FixDecl] -> OperatorTable IdrisParser PTerm

35table fixes

36− = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))

36+ = [[prefix "-" (\fc x -> PApp fc (PRef fc (sUN "-"))

37− [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

37+ [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

38 ++ toTable (reverse fixes) ++

39 [[backtick],

40+ [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

40 [binary "=" PEq AssocLeft],

41 [binary "=" PEq AssocLeft],

41− [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]]

42+ [binary "->" (\fc x y -> PPi expl (sMN 42 "__pi_arg") x y) AssocRight]]

43-- | Calculates table for fixtiy declarations

44-- | Calculates table for fixtiy declarations

44toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

45toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

45toTable fs = map (map toBin)

46toTable fs = map (map toBin)

46 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

47 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

47 where toBin (Fix (PrefixN _) op) = prefix op

48 where toBin (Fix (PrefixN _) op) = prefix op

48− (\fc x -> PApp fc (PRef fc (UN op)) [pexp x])

49+ (\fc x -> PApp fc (PRef fc (sUN op)) [pexp x])

49 toBin (Fix f op)

50 toBin (Fix f op)

50− = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f)

51+ = binary op (\fc x y -> PApp fc (PRef fc (sUN op)) [pexp x,pexp y]) (assoc f)

51 assoc (Infixl _) = AssocLeft

52 assoc (Infixl _) = AssocLeft

52 assoc (Infixr _) = AssocRight

53 assoc (Infixr _) = AssocRight

53 assoc (InfixN _) = AssocNone

54 assoc (InfixN _) = AssocNone

src/Idris/Parser.hs+25−13

@@ -21,6 +21,7 @@ import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

21import Idris.AbsSyntax

22import Idris.DSL

23import Idris.Imports

24+import Idris.Delaborate

24import Idris.Error

25import Idris.Error

25import Idris.ElabDecls

26import Idris.ElabDecls

26import Idris.ElabTerm hiding (namespace, params)

27import Idris.ElabTerm hiding (namespace, params)

@@ -43,6 +44,7 @@ import Idris.Core.Evaluate

44import Control.Applicative

45import Control.Applicative

45import Control.Monad

46import Control.Monad

47+import Control.Monad.Error (throwError, catchError)

46import Control.Monad.State.Strict

48import Control.Monad.State.Strict

48import Data.Maybe

50import Data.Maybe

@@ -79,7 +81,9 @@ moduleHeader = try (do reserved "module"

79 i <- identifier

81 i <- identifier

80 option ';' (lchar ';')

82 option ';' (lchar ';')

81 return (moduleName i))

83 return (moduleName i))

84+ <|> try (do lchar '%'; reserved "unqualified"

82− <|> return []

85+ return [])

86+ <|> return (moduleName "Main")

83 where moduleName x = case span (/='.') x of

87 where moduleName x = case span (/='.') x of

84 (x, "") -> [x]

88 (x, "") -> [x]

85 (x, '.':y) -> x : moduleName y

89 (x, '.':y) -> x : moduleName y

@@ -298,9 +302,9 @@ fnDecl' syn = checkFixity $

298 getName (PTy _ _ _ _ n _) = Just n

302 getName (PTy _ _ _ _ n _) = Just n

299 getName _ = Nothing

303 getName _ = Nothing

300 fixityOK (NS n _) = fixityOK n

304 fixityOK (NS n _) = fixityOK n

301− fixityOK (UN n) | all (flip elem opChars) n =

305+ fixityOK (UN n) | all (flip elem opChars) (str n) =

302 do fixities <- fmap idris_infixes get

306 do fixities <- fmap idris_infixes get

303− return . elem n . map (\ (Fix _ op) -> op) $ fixities

307+ return . elem (str n) . map (\ (Fix _ op) -> op) $ fixities

304 | otherwise = return True

308 | otherwise = return True

305 fixityOK _ = return True

309 fixityOK _ = return True

306

310

@@ -309,6 +313,7 @@ FnOpts ::= 'total'

309 | 'partial'

313 | 'partial'

310 | 'implicit'

314 | 'implicit'

311 | '%' 'assert_total'

315 | '%' 'assert_total'

316+ | '%' 'error_handler'

312 | '%' 'reflection'

317 | '%' 'reflection'

313 | '%' 'specialise' '[' NameTimesList? ']'

318 | '%' 'specialise' '[' NameTimesList? ']'

314 ;

319 ;

@@ -330,6 +335,8 @@ fnOpts opts

330 fnOpts (CExport c : opts)

335 fnOpts (CExport c : opts)

331 <|> do try (lchar '%' *> reserved "assert_total");

336 <|> do try (lchar '%' *> reserved "assert_total");

332 fnOpts (AssertTotal : opts)

337 fnOpts (AssertTotal : opts)

338+ <|> do try (lchar '%' *> reserved "error_handler");

339+ fnOpts (ErrorHandler : opts)

333 <|> do try (lchar '%' *> reserved "reflection");

340 <|> do try (lchar '%' *> reserved "reflection");

334 fnOpts (Reflection : opts)

341 fnOpts (Reflection : opts)

335 <|> do lchar '%'; reserved "specialise";

342 <|> do lchar '%'; reserved "specialise";

@@ -512,7 +519,7 @@ instance_ syn = do reserved "instance"; fc <- getFC

512 cn <- name

519 cn <- name

513 args <- many (simpleExpr syn)

520 args <- many (simpleExpr syn)

514 let sc = PApp fc (PRef fc cn) (map pexp args)

521 let sc = PApp fc (PRef fc cn) (map pexp args)

515− let t = bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc

522+ let t = bindList (PPi constraint) (map (\x -> (sMN 0 "constraint", x)) cs) sc

516 ds <- option [] (instanceBlock syn)

523 ds <- option [] (instanceBlock syn)

517 return [PInstance syn fc cs cn args t en ds]

524 return [PInstance syn fc cs cn args t en ds]

518 <?> "instance declaration"

525 <?> "instance declaration"

@@ -570,7 +577,7 @@ Pattern ::= Clause;

570pattern :: SyntaxInfo -> IdrisParser PDecl

577pattern :: SyntaxInfo -> IdrisParser PDecl

571pattern syn = do fc <- getFC

578pattern syn = do fc <- getFC

572 clause <- clause syn

579 clause <- clause syn

573− return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later

580+ return (PClauses fc [] (sMN 2 "_") [clause]) -- collect together later

574 <?> "pattern"

581 <?> "pattern"

575

582

576{- | Parse a constant applicative form declaration

583{- | Parse a constant applicative form declaration

@@ -612,7 +619,7 @@ rhs syn n = do lchar '='; expr syn

612 <|> do reserved "impossible"; return PImpossible

619 <|> do reserved "impossible"; return PImpossible

613 <?> "function right hand side"

620 <?> "function right hand side"

614 where mkN :: Name -> Name

621 where mkN :: Name -> Name

615− mkN (UN x) = UN (x++"_lemma_1")

622+ mkN (UN x) = sUN (str x++"_lemma_1")

616 mkN (NS x n) = NS (mkN x) n

623 mkN (NS x n) = NS (mkN x) n

617 n' :: Name

624 n' :: Name

618 n' = mkN n

625 n' = mkN n

@@ -620,7 +627,7 @@ rhs syn n = do lchar '='; expr syn

620 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

627 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

621 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

628 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

622 where addLetC (l, r) = (l, addLet nm r)

629 where addLetC (l, r) = (l, addLet nm r)

623− addLet nm r = (PLet (UN "value") Placeholder r (PMetavar nm))

630+ addLet nm r = (PLet (sUN "value") Placeholder r (PMetavar nm))

624

631

625{- |Parses a function clause

632{- |Parses a function clause

626RHSOrWithBlock ::= RHS WhereOrTerminator

633RHSOrWithBlock ::= RHS WhereOrTerminator

@@ -674,10 +681,10 @@ clause syn

674 return x,

681 return x,

675 do terminator

682 do terminator

676 return ([], [])]

683 return ([], [])]

677− let capp = PLet (MN 0 "match")

684+ let capp = PLet (sMN 0 "match")

678 ty

685 ty

679 (PMatchApp fc n)

686 (PMatchApp fc n)

680− (PRef fc (MN 0 "match"))

687+ (PRef fc (sMN 0 "match"))

681 ist <- get

688 ist <- get

682 put (ist { lastParse = Just n })

689 put (ist { lastParse = Just n })

683 return $ PClause fc n capp [] r wheres

690 return $ PClause fc n capp [] r wheres

@@ -688,7 +695,7 @@ clause syn

688 when (op == "=" || op == "?=" ) $

695 when (op == "=" || op == "?=" ) $

689 fail "infix clause definition with \"=\" and \"?=\" not supported "

696 fail "infix clause definition with \"=\" and \"?=\" not supported "

690 return (l, op))

697 return (l, op))

691− let n = expandNS syn (UN op)

698+ let n = expandNS syn (sUN op)

692 r <- argExpr syn

699 r <- argExpr syn

693 fc <- getFC

700 fc <- getFC

694 wargs <- many (wExpr syn)

701 wargs <- many (wExpr syn)

@@ -863,8 +870,13 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

863 ty <- iName []

870 ty <- iName []

864 ns <- sepBy1 name (lchar ',')

871 ns <- sepBy1 name (lchar ',')

865 return [PDirective

872 return [PDirective

873+ (do i <- getIState

874+ ty' <- case lookupCtxtName ty (idris_implicits i) of

875+ [(tyn, _)] -> return tyn

876+ [] -> throwError (NoSuchVariable ty)

877+ tyns -> throwError (CantResolveAlts (map show (map fst tyns)))

866− (do mapM_ (addNameHint ty) ns

878+ mapM_ (addNameHint ty') ns

867− mapM_ (\n -> addIBC (IBCNameHint (ty, n))) ns)]

879+ mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

868 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

880 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

869 return [PDirective (addLangExt ext)]

881 return [PDirective (addLangExt ext)]

870 <?> "directive"

882 <?> "directive"

@@ -1001,7 +1013,7 @@ loadModule' outh f

1001 LIDR fn -> loadSource outh True fn

1013 LIDR fn -> loadSource outh True fn

1002 IBC fn src ->

1014 IBC fn src ->

1003 idrisCatch (loadIBC fn)

1015 idrisCatch (loadIBC fn)

1004− (\c -> do iLOG $ fn ++ " failed " ++ show c

1016+ (\c -> do iLOG $ fn ++ " failed " ++ pshow i c

1005 case src of

1017 case src of

1006 IDR sfn -> loadSource outh False sfn

1018 IDR sfn -> loadSource outh False sfn

1007 LIDR sfn -> loadSource outh True sfn)

1019 LIDR sfn -> loadSource outh True sfn)

src/Idris/PartialEval.hs+2−2

@@ -54,7 +54,7 @@ specType args ty = let (t, args') = runState (unifyEq args ty) [] in

54 sc' <- unifyEq xs sc

55 return (Bind n (Pi t) sc')

56 unifyEq xs t = do args <- get

57− put (args ++ (zip xs (repeat (UN "_"))))

57+ put (args ++ (zip xs (repeat (sUN "_"))))

58 return t

60mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

@@ -122,7 +122,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

122 | x && imparg imp = (ImplicitS, tm)

123 | x = (ExplicitS, tm)

124 | imparg imp = (ImplicitD, tm)

125− | otherwise = (ExplicitD, (P Ref (UN (show n ++ "arg")) Erased))

125+ | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126

127 imparg (PExp _ _ _ _) = False

128 imparg _ = True

src/Idris/Primitives.hs+50−50

@@ -26,7 +26,7 @@ data Prim = Prim { p_name :: Name,

27ty :: [Const] -> Const -> Type

28ty [] x = Constant x

29−ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x)

29+ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x)

31total, partial :: Totality

32total = Total []

@@ -94,83 +94,83 @@ primitives =

94 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,

95 iCoerce ITBig ITChar "trunc" trunc LTrunc,

97− Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

97+ Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

98 (2, LPlus ATFloat) total,

99− Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

99+ Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

100 (2, LMinus ATFloat) total,

101− Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

101+ Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

102 (2, LTimes ATFloat) total,

103− Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

103+ Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

104 (2, LSDiv ATFloat) total,

105− Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

105+ Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

106 (2, LEq ATFloat) total,

107− Prim (UN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

107+ Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

108 (2, LSLt ATFloat) total,

109− Prim (UN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

109+ Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

110 (2, LSLe ATFloat) total,

111− Prim (UN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

111+ Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

112 (2, LSGt ATFloat) total,

113− Prim (UN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

113+ Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

114 (2, LSGe ATFloat) total,

115− Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

115+ Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

116 (2, LStrConcat) total,

117− Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

117+ Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

118 (2, LStrEq) total,

119− Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

119+ Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

120 (2, LStrLt) total,

121− Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

121+ Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

122 (1, LStrLen) total,

123 -- Conversions

124− Prim (UN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

124+ Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

125 (1, LChInt ITNative) total,

126− Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

126+ Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

127 (1, LIntCh ITNative) total,

128− Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

128+ Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

129 (1, LStrFloat) total,

130− Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

130+ Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

131 (1, LFloatStr) total,

132

133− Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

133+ Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

134 (1, LFExp) total,

135− Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

135+ Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

136 (1, LFLog) total,

137− Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

137+ Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

138 (1, LFSin) total,

139− Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

139+ Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

140 (1, LFCos) total,

141− Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

141+ Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

142 (1, LFTan) total,

143− Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

143+ Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

144 (1, LFASin) total,

145− Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

145+ Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

146 (1, LFACos) total,

147− Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

147+ Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

148 (1, LFATan) total,

149− Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

149+ Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

150 (1, LFSqrt) total,

151− Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

151+ Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

152 (1, LFFloor) total,

153− Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

153+ Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

154 (1, LFCeil) total,

155

156− Prim (UN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

156+ Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

157 (1, LStrHead) partial,

158− Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

158+ Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

159 (1, LStrTail) partial,

160− Prim (UN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

160+ Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

161 (2, LStrCons) total,

162− Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

162+ Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

163 (2, LStrIndex) partial,

164− Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

164+ Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

165 (1, LStrRev) total,

166− Prim (UN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

166+ Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

167 (1, LReadStr) partial,

168− Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

168+ Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

169 (0, LVMPtr) total,

170 -- Streams

171− Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

171+ Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

172 (0, LStdIn) partial,

173− Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

173+ Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

174 (0, LNullPtr) total

175 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]

176 ++ concatMap vecOps vecTypes

@@ -221,13 +221,13 @@ intArith ity =

221

222intConv :: IntTy -> [Prim]

223intConv ity =

224− [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

224+ [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

225 (1, LIntStr ity) total

226− , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

226+ , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

227 (1, LStrInt ity) total

228− , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

228+ , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

229 (1, LIntFloat ity) total

230− , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

230+ , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

231 (1, LFloatInt ity) total

232 ]

233

@@ -246,13 +246,13 @@ vecCmps ity =

246

247vecOps :: IntTy -> [Prim]

248vecOps ity@(ITVec elem count) =

249− [ Prim (UN $ "prim__mk" ++ intTyName ity)

249+ [ Prim (sUN $ "prim__mk" ++ intTyName ity)

250 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))

251 count (mkVecCon elem count) (count, LMkVec elem count) total

252− , Prim (UN $ "prim__index" ++ intTyName ity)

252+ , Prim (sUN $ "prim__index" ++ intTyName ity)

253 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))

254 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces

255− , Prim (UN $ "prim__update" ++ intTyName ity)

255+ , Prim (sUN $ "prim__update" ++ intTyName ity)

256 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]

257 (AType . ATInt $ ity))

258 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces

@@ -260,7 +260,7 @@ vecOps ity@(ITVec elem count) =

260

261bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim

262bitcastPrim from to impl prim =

263− Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

263+ Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

264 (1, prim) total

265

266vecBitcasts :: [IntTy] -> [Prim]

@@ -377,23 +377,23 @@ intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show cou

377

378iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

379iCmp ity op self impl irop totality

380− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

380+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

381 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))

382 2 impl (2, irop ity) totality

383

384iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

385iBinOp ity op impl irop totality

386− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

386+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

387 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))

388 2 impl (2, irop ity) totality

389iUnOp ity op impl irop totality

390− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

390+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

391 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))

392 1 impl (1, irop ity) totality

393

394iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

395iCoerce from to op impl irop =

396− Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

396+ Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

397 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total

398

399fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const

src/Idris/Prover.hs+3−2

@@ -20,7 +20,7 @@ import Text.Trifecta.Result(Result(..))

21import System.Console.Haskeline

22import System.Console.Haskeline.History

23−import Control.Monad.State

23+import Control.Monad.State.Strict

25import Util.Pretty

26import Debug.Trace

@@ -102,7 +102,8 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

102 tPretty t = pretty $ delab ist t

103

104 prettyPs [] = empty

105− prettyPs ((MN _ "rewrite_rule", _) : bs) = prettyPs bs

105+ prettyPs ((MN _ r, _) : bs)

106+ | r == txt "rewrite_rule" = prettyPs bs

106 prettyPs ((n, Let t v) : bs) =

107 prettyPs ((n, Let t v) : bs) =

107 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108 tPretty t $$ prettyPs bs)

109 tPretty t $$ prettyPs bs)

src/Idris/Providers.hs+14−7

@@ -11,17 +11,24 @@ import Debug.Trace

12-- | Wrap a type provider in the type of type providers

13providerTy :: FC -> PTerm -> PTerm

14−providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

14+providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 False tm ""]

15+

16+ioret = sUN "prim_io_return"

17+ermod = sNS (sUN "Error") ["Providers"]

18+prmod = sNS (sUN "Provide") ["Providers"]

16-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

20-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

17getProvided :: TT Name -> Idris (TT Name)

21getProvided :: TT Name -> Idris (TT Name)

18−getProvided tm | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

22+getProvided tm | (P _ pioret _, [tp, result]) <- unApply tm

19− , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =

23+ , (P _ nm _, [_, err]) <- unApply result

24+ , pioret == ioret && nm == ermod

20− case err of

25+ = case err of

21 Constant (Str msg) -> ierror . ProviderError $ msg

26 Constant (Str msg) -> ierror . ProviderError $ msg

22 _ -> ifail "Internal error in type provider, non-normalised error"

27 _ -> ifail "Internal error in type provider, non-normalised error"

23− | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

28+ | (P _ pioret _, [tp, result]) <- unApply tm

24− , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =

29+ , (P _ nm _, [_, res]) <- unApply result

30+ , pioret == ioret && nm == prmod

25− return res

31+ = return res

26 | otherwise = ifail $ "Internal type provider error: result was not " ++

32 | otherwise = ifail $ "Internal type provider error: result was not " ++

27 "IO (Provider a), or perhaps missing normalisation."

33 "IO (Provider a), or perhaps missing normalisation."

34+

src/Idris/REPL.hs+75−57

@@ -80,31 +80,33 @@ repl :: IState -- ^ The initial state

80 -> [FilePath] -- ^ The loaded modules

81 -> InputT Idris ()

82repl orig mods

83− = H.catch

83+ = -- H.catch

84− (do let quiet = opt_quiet (idris_options orig)

84+ do let quiet = opt_quiet (idris_options orig)

85− i <- lift getIState

85+ i <- lift getIState

86− let colour = idris_colourRepl i

86+ let colour = idris_colourRepl i

87− let theme = idris_colourTheme i

87+ let theme = idris_colourTheme i

88− let mvs = idris_metavars i

88+ let mvs = idris_metavars i

89− let prompt = if quiet

89+ let prompt = if quiet

90− then ""

90+ then ""

91− else showMVs colour theme mvs ++

91+ else showMVs colour theme mvs ++

92− let str = mkPrompt mods ++ ">" in

92+ let str = mkPrompt mods ++ ">" in

93− (if colour then colourisePrompt theme str else str) ++ " "

93+ (if colour then colourisePrompt theme str else str) ++ " "

94− x <- getInputLine prompt

94+ x <- H.catch (getInputLine prompt)

95+ (ctrlC (return Nothing))

95− case x of

96+ case x of

96− Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

97+ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

97− return ()

98+ return ()

98− Just input -> H.catch

99+ Just input -> -- H.catch

99− (do ms <- lift $ processInput input orig mods

100+ do ms <- H.catch (lift $ processInput input orig mods)

101+ (ctrlC (return (Just mods)))

100− case ms of

102+ case ms of

101− Just mods -> repl orig mods

103+ Just mods -> repl orig mods

102− Nothing -> return ())

104+ Nothing -> return ()

103− ctrlC)

105+-- ctrlC)

104− ctrlC

106+-- ctrlC

105− where ctrlC :: SomeException -> InputT Idris ()

107+ where ctrlC :: InputT Idris a -> SomeException -> InputT Idris a

106− ctrlC e = do lift $ iputStrLn (show e)

108+ ctrlC act e = do lift $ iputStrLn (show e)

107− repl orig mods

109+ act -- repl orig mods

108

110

109 showMVs c thm [] = ""

111 showMVs c thm [] = ""

110 showMVs c thm ms = "Metavariables: " ++

112 showMVs c thm ms = "Metavariables: " ++

@@ -245,19 +247,19 @@ ideslave orig mods

245 Just x -> iPrintError $ "didn't load " ++ filename

247 Just x -> iPrintError $ "didn't load " ++ filename

246 ideslave orig [filename]

248 ideslave orig [filename]

247 Just (IdeSlave.TypeOf name) ->

249 Just (IdeSlave.TypeOf name) ->

248− process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (UN name)))

250+ process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (sUN name)))

249 Just (IdeSlave.CaseSplit line name) ->

251 Just (IdeSlave.CaseSplit line name) ->

250− process stdout fn (CaseSplitAt False line (UN name))

252+ process stdout fn (CaseSplitAt False line (sUN name))

251 Just (IdeSlave.AddClause line name) ->

253 Just (IdeSlave.AddClause line name) ->

252− process stdout fn (AddClauseFrom False line (UN name))

254+ process stdout fn (AddClauseFrom False line (sUN name))

253 Just (IdeSlave.AddProofClause line name) ->

255 Just (IdeSlave.AddProofClause line name) ->

254− process stdout fn (AddProofClauseFrom False line (UN name))

256+ process stdout fn (AddProofClauseFrom False line (sUN name))

255 Just (IdeSlave.AddMissing line name) ->

257 Just (IdeSlave.AddMissing line name) ->

256− process stdout fn (AddMissing False line (UN name))

258+ process stdout fn (AddMissing False line (sUN name))

257 Just (IdeSlave.MakeWithBlock line name) ->

259 Just (IdeSlave.MakeWithBlock line name) ->

258− process stdout fn (MakeWith False line (UN name))

260+ process stdout fn (MakeWith False line (sUN name))

259 Just (IdeSlave.ProofSearch line name hints) ->

261 Just (IdeSlave.ProofSearch line name hints) ->

260− process stdout fn (DoProofSearch False line (UN name) (map UN hints))

262+ process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

261 Nothing -> do iPrintError "did not understand")

263 Nothing -> do iPrintError "did not understand")

262 (\e -> do iPrintError $ show e))

264 (\e -> do iPrintError $ show e))

263 (\e -> do iPrintError $ show e)

265 (\e -> do iPrintError $ show e)

@@ -406,6 +408,7 @@ edit f orig

406 , idris_colourTheme = idris_colourTheme i

408 , idris_colourTheme = idris_colourTheme i

407 }

409 }

408 loadInputs stdout [f]

410 loadInputs stdout [f]

411+-- clearOrigPats

409 iucheck

412 iucheck

410 return ()

413 return ()

411 where getEditor env | Just ed <- lookup "EDITOR" env = ed

414 where getEditor env | Just ed <- lookup "EDITOR" env = ed

@@ -436,19 +439,19 @@ process h fn (ChangeDirectory f)

436 = do runIO $ setCurrentDirectory f

439 = do runIO $ setCurrentDirectory f

437 return ()

440 return ()

438process h fn (Eval t)

441process h fn (Eval t)

439− = do (tm, ty) <- elabVal toplevel False t

442+ = withErrorReflection $ do (tm, ty) <- elabVal toplevel False t

440− ctxt <- getContext

443+ ctxt <- getContext

441− let tm' = force (normaliseAll ctxt [] tm)

444+ let tm' = force (normaliseAll ctxt [] tm)

442− let ty' = force (normaliseAll ctxt [] ty)

445+ let ty' = force (normaliseAll ctxt [] ty)

443− -- Add value to context, call it "it"

446+ -- Add value to context, call it "it"

444− updateContext (addCtxtDef (UN "it") (Function ty' tm'))

447+ updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

445− ist <- getIState

448+ ist <- getIState

446− logLvl 3 $ "Raw: " ++ show (tm', ty')

449+ logLvl 3 $ "Raw: " ++ show (tm', ty')

447− logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

450+ logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

448− imp <- impShow

451+ imp <- impShow

449− c <- colourise

452+ c <- colourise

450− ihPrintResult h (showImp (Just ist) imp c (delab ist tm') ++ " : " ++

453+ ihPrintResult h (showImp (Just ist) imp c (delab ist tm') ++ " : " ++

451− showImp (Just ist) imp c (delab ist ty'))

454+ showImp (Just ist) imp c (delab ist ty'))

452process h fn (ExecVal t)

455process h fn (ExecVal t)

453 = do ctxt <- getContext

456 = do ctxt <- getContext

454 ist <- getIState

457 ist <- getIState

@@ -482,7 +485,7 @@ process h fn (Check (PRef _ n))

482 = let current = " " ++

485 = let current = " " ++

483 (case n of

486 (case n of

484 MN _ _ -> "_"

487 MN _ _ -> "_"

485− UN ('_':'_':_) -> "_"

488+ UN nm | ('_':'_':_) <- str nm -> "_"

486 _ -> showName (Just ist) [] False c n) ++

489 _ -> showName (Just ist) [] False c n) ++

487 " : " ++ showImp (Just ist) imp c t ++ "\n"

490 " : " ++ showImp (Just ist) imp c t ++ "\n"

488 in

491 in

@@ -741,7 +744,7 @@ process h fn (DoProofSearch updatefile l n hints)

741 | length cs >= length n

744 | length cs >= length n

742 = case splitAt (length n) cs of

745 = case splitAt (length n) cs of

743 (mv, c:cs) ->

746 (mv, c:cs) ->

744− if (isSpace c && mv == n)

747+ if ((isSpace c || c == ')' || c == '}') && mv == n)

745 then addBracket brack new ++ (c : cs)

748 then addBracket brack new ++ (c : cs)

746 else '?' : mv ++ c : updateMeta True cs n new

749 else '?' : mv ++ c : updateMeta True cs n new

747 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

750 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

@@ -849,8 +852,8 @@ process h fn (TestInline t)

849process h fn Execute

852process h fn Execute

850 = do (m, _) <- elabVal toplevel False

853 = do (m, _) <- elabVal toplevel False

851 (PApp fc

854 (PApp fc

852− (PRef fc (UN "run__IO"))

855+ (PRef fc (sUN "run__IO"))

853− [pexp $ PRef fc (NS (UN "main") ["Main"])])

856+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

854-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

857-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

855 (tmpn, tmph) <- runIO tempfile

858 (tmpn, tmph) <- runIO tempfile

856 runIO $ hClose tmph

859 runIO $ hClose tmph

@@ -861,8 +864,8 @@ process h fn Execute

861 where fc = fileFC "main"

864 where fc = fileFC "main"

862process h fn (Compile codegen f)

865process h fn (Compile codegen f)

863 = do (m, _) <- elabVal toplevel False

866 = do (m, _) <- elabVal toplevel False

864− (PApp fc (PRef fc (UN "run__IO"))

867+ (PApp fc (PRef fc (sUN "run__IO"))

865− [pexp $ PRef fc (NS (UN "main") ["Main"])])

868+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

866 compile codegen f m

869 compile codegen f m

867 where fc = fileFC "main"

870 where fc = fileFC "main"

868process h fn (LogLvl i) = setLogLevel i

871process h fn (LogLvl i) = setLogLevel i

@@ -919,6 +922,12 @@ process h fn ColourOn

919process h fn ColourOff

922process h fn ColourOff

920 = do ist <- getIState

923 = do ist <- getIState

921 putIState $ ist { idris_colourRepl = False }

924 putIState $ ist { idris_colourRepl = False }

925+process h fn ListErrorHandlers =

926+ do ist <- getIState

927+ case idris_errorhandlers ist of

928+ [] -> iPrintResult "No registered error handlers"

929+ handlers ->

930+ iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers

922

931

923classInfo :: ClassInfo -> Idris ()

932classInfo :: ClassInfo -> Idris ()

924classInfo ci = do iputStrLn "Methods:\n"

933classInfo ci = do iputStrLn "Methods:\n"

@@ -999,11 +1008,14 @@ parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)

999parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

1008parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

1000parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

1009parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

1001parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1010parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1011+-- Package Related options

1002parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

1012parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

1003parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

1013parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

1004parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

1014parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

1005parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

1015parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

1006parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1016parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1017+parseArgs ("--checkpkg":n:ns) = PkgCheck n : (parseArgs ns)

1018+-- Misc Options

1007parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

1019parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

1008parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

1020parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

1009parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

1021parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

@@ -1095,12 +1107,13 @@ loadInputs h inputs

1095 when (not loadCode) $ tryLoad $ nub (concat ifiles)

1107 when (not loadCode) $ tryLoad $ nub (concat ifiles)

1096 _ -> return ()

1108 _ -> return ()

1097 putIState inew)

1109 putIState inew)

1110+ (\e -> do i <- getIState

1098− (\e -> do case e of

1111+ case e of

1099 At f _ -> do setErrLine (fc_line f)

1112 At f _ -> do setErrLine (fc_line f)

1100 iputStrLn (show e)

1113 iputStrLn (show e)

1101 ProgramLineComment -> return () -- fail elsewhere

1114 ProgramLineComment -> return () -- fail elsewhere

1102 _ -> do setErrLine 3 -- FIXME! Propagate it

1115 _ -> do setErrLine 3 -- FIXME! Propagate it

1103− iputStrLn (show e))

1116+ iputStrLn (pshow i e))

1104 where -- load all files, stop if any fail

1117 where -- load all files, stop if any fail

1105 tryLoad :: [IFileType] -> Idris ()

1118 tryLoad :: [IFileType] -> Idris ()

1106 tryLoad [] = return ()

1119 tryLoad [] = return ()

@@ -1186,8 +1199,8 @@ idrisMain opts =

1186 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

1199 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

1187 return ()

1200 return ()

1188 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1201 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1189− ist <- getIState

1190

1202

1203+ orig <- getIState

1191 loadInputs stdout inputs

1204 loadInputs stdout inputs

1192

1205

1193 runIO $ hSetBuffering stdout LineBuffering

1206 runIO $ hSetBuffering stdout LineBuffering

@@ -1211,10 +1224,11 @@ idrisMain opts =

1211 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

1224 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

1212

1225

1213 when (runrepl && not idesl) $ do

1226 when (runrepl && not idesl) $ do

1227+-- clearOrigPats

1214 initScript

1228 initScript

1215− startServer ist inputs

1229+ startServer orig inputs

1216− runInputT (replSettings (Just historyFile)) $ repl ist inputs

1230+ runInputT (replSettings (Just historyFile)) $ repl orig inputs

1217− when (idesl) $ ideslaveStart ist inputs

1231+ when (idesl) $ ideslaveStart orig inputs

1218 ok <- noErrors

1232 ok <- noErrors

1219 when (not ok) $ runIO (exitWith (ExitFailure 1))

1233 when (not ok) $ runIO (exitWith (ExitFailure 1))

1220 where

1234 where

@@ -1316,6 +1330,10 @@ getPkgClean :: Opt -> Maybe String

1316getPkgClean (PkgClean str) = Just str

1330getPkgClean (PkgClean str) = Just str

1317getPkgClean _ = Nothing

1331getPkgClean _ = Nothing

1318

1332

1333+getPkgCheck :: Opt -> Maybe String

1334+getPkgCheck (PkgCheck str) = Just str

1335+getPkgCheck _ = Nothing

1336+

1319getCodegen :: Opt -> Maybe Codegen

1337getCodegen :: Opt -> Maybe Codegen

1320getCodegen (UseCodegen x) = Just x

1338getCodegen (UseCodegen x) = Just x

1321getCodegen _ = Nothing

1339getCodegen _ = Nothing

src/Idris/REPLParser.hs+1

@@ -96,6 +96,7 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

96 eof; return (AddProof n))

97 <|> try (do cmd ["x"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (ExecVal t))

98 <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t))

99+ <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)

99 <|> do P.whiteSpace; do eof; return NOP

100 <|> do P.whiteSpace; do eof; return NOP

100 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

101 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

101

102

src/Idris/Transforms.hs+3−3

@@ -39,8 +39,8 @@ instance Transform CaseAlt where

40natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

42−zname = NS (UN "Z") ["Nat","Prelude"]

42+zname = sNS (sUN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

43+sname = sNS (sUN "S") ["Nat","Prelude"]

45zero :: TT Name -> TT Name

46zero (P _ n _) | n == zname

@@ -49,7 +49,7 @@ zero x = x

50suc :: TT Name -> TT Name

51suc (App (P _ s _) a) | s == sname

52− = mkApp (P Ref (UN "prim__addBigInt") Erased) [Constant (BI 1), a]

52+ = mkApp (P Ref (sUN "prim__addBigInt") Erased) [Constant (BI 1), a]

53suc x = x

55natcase :: SC -> SC

src/Idris/UnusedArgs.hs+2−1

@@ -23,6 +23,7 @@ traceUnused n

23 recused <- mapM (\ (argn, i, (g, j)) ->

24 do u <- used [(n, i)] g j

25 return (argn, u)) fargs

26+ logLvl 4 $ show n ++ " recused TRACE: " ++ show recused

26 let fused = nub $ usedns ++ map fst (filter snd recused)

27 let fused = nub $ usedns ++ map fst (filter snd recused)

27 logLvl 1 $ show n ++ " used args: " ++ show fused

28 logLvl 1 $ show n ++ " used args: " ++ show fused

28 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

29 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

@@ -50,7 +51,7 @@ used path g j

50 recused <- mapM (\ (argn, j, (g', j')) ->

51 recused <- mapM (\ (argn, j, (g', j')) ->

51 used ((g,j):path) g' j') garg

52 used ((g,j):path) g' j') garg

52 -- used on any route from here, or not used recursively

53 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

54+ return (directuse || or recused)

54 _ -> return True -- no definition, assume used

55 _ -> return True -- no definition, assume used

56getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

57getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+1−1

@@ -27,7 +27,7 @@ data PkgDesc = PkgDesc { pkgname :: String,

27 }

28 deriving Show

30−defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (UN "") Nothing

30+defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing

32parseDesc :: FilePath -> IO PkgDesc

33parseDesc fp = do p <- readFile fp

src/Pkg/Package.hs+44−5

@@ -24,13 +24,14 @@ import Pkg.PParser

25import Paths_idris (getDataDir)

27+-- | Run the package through the idris compiler.

28+--

27-- To build a package:

29-- To build a package:

28-- * read the package description

30-- * read the package description

29-- * check all the library dependencies exist

31-- * check all the library dependencies exist

30-- * invoke the makefile if there is one

32-- * invoke the makefile if there is one

31-- * invoke idris on each module, with idris_opts

33-- * invoke idris on each module, with idris_opts

32-- * install everything into datadir/pname, if install flag is set

34-- * install everything into datadir/pname, if install flag is set

33−

34buildPkg :: Bool -> (Bool, FilePath) -> IO ()

35buildPkg :: Bool -> (Bool, FilePath) -> IO ()

35buildPkg warnonly (install, fp)

36buildPkg warnonly (install, fp)

36 = do pkgdesc <- parseDesc fp

37 = do pkgdesc <- parseDesc fp

@@ -63,7 +64,33 @@ buildPkg warnonly (install, fp)

63 putStrLn $ "\t" ++ show ms

64 putStrLn $ "\t" ++ show ms

64 exitWith (ExitFailure 1)

65 exitWith (ExitFailure 1)

67+-- | Type check packages only

68+--

69+-- This differs from build in that executables are not built, if the

70+-- package contains an executable.

71+checkPkg :: Bool -- ^ Show Warnings

72+ -> FilePath -- ^ Path to ipkg file.

73+ -> IO ()

74+checkPkg warnonly fpath

75+ = do pkgdesc <-parseDesc fpath

76+ ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)

77+ when (and ok) $

78+ do dir <- getCurrentDirectory

79+ setCurrentDirectory $ dir </> sourcedir pkgdesc

80+ make (makefile pkgdesc)

81+ res <- buildMods (NoREPL : Verbose : idris_opts pkgdesc)

82+ (modules pkgdesc)

83+ setCurrentDirectory dir

84+ case res of

85+ Nothing -> exitWith (ExitFailure 1)

86+ Just res' -> do

87+ case errLine res' of

88+ Just _ -> exitWith (ExitFailure 1)

89+ _ -> return ()

90+

91+-- | Clean Package build files

66−cleanPkg :: FilePath -> IO ()

92+cleanPkg :: FilePath -- ^ Path to ipkg file.

93+ -> IO ()

67cleanPkg fp

94cleanPkg fp

68 = do pkgdesc <- parseDesc fp

95 = do pkgdesc <- parseDesc fp

69 dir <- getCurrentDirectory

96 dir <- getCurrentDirectory

@@ -74,6 +101,7 @@ cleanPkg fp

74 Nothing -> return ()

101 Nothing -> return ()

75 Just s -> rmFile $ dir </> s

102 Just s -> rmFile $ dir </> s

103

104+-- | Install package

77installPkg :: PkgDesc -> IO ()

105installPkg :: PkgDesc -> IO ()

78installPkg pkgdesc

106installPkg pkgdesc

79 = do dir <- getCurrentDirectory

107 = do dir <- getCurrentDirectory

@@ -83,6 +111,11 @@ installPkg pkgdesc

83 Just o -> return () -- do nothing, keep executable locally, for noe

111 Just o -> return () -- do nothing, keep executable locally, for noe

84 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

112 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

113

114+

115+-- ---------------------------------------------------------- [ Helper Methods ]

116+-- Methods for building, testing, installing, and removal of idris

117+-- packages.

118+

86buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

119buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

87buildMods opts ns = do let f = map (toPath . showCG) ns

120buildMods opts ns = do let f = map (toPath . showCG) ns

88-- putStrLn $ "MODULE: " ++ show f

121-- putStrLn $ "MODULE: " ++ show f

@@ -108,8 +141,8 @@ testLib warn p f

108rmIBC :: Name -> IO ()

141rmIBC :: Name -> IO ()

109rmIBC m = rmFile $ toIBCFile m

142rmIBC m = rmFile $ toIBCFile m

110

143

111−toIBCFile (UN n) = n ++ ".ibc"

144+toIBCFile (UN n) = str n ++ ".ibc"

112−toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

145+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))

113

146

114installIBC :: String -> Name -> IO ()

147installIBC :: String -> Name -> IO ()

115installIBC p m = do let f = toIBCFile m

148installIBC p m = do let f = toIBCFile m

@@ -120,7 +153,8 @@ installIBC p m = do let f = toIBCFile m

120 copyFile f (destdir </> takeFileName f)

153 copyFile f (destdir </> takeFileName f)

121 return ()

154 return ()

122 where getDest (UN n) = ""

155 where getDest (UN n) = ""

123− getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))

156+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns))

157+

124

158

125installObj :: String -> String -> IO ()

159installObj :: String -> String -> IO ()

126installObj p o = do d <- getTargetDir

160installObj p o = do d <- getTargetDir

@@ -136,12 +170,17 @@ mkDirCmd = "mkdir "

136mkDirCmd = "mkdir -p "

170mkDirCmd = "mkdir -p "

137#endif

171#endif

138

172

173+-- ------------------------------------------------------- [ Makefile Commands ]

174+-- | Invoke a Makefile's default target.

139make :: Maybe String -> IO ()

175make :: Maybe String -> IO ()

140make Nothing = return ()

176make Nothing = return ()

141make (Just s) = do system $ "make -f " ++ s

177make (Just s) = do system $ "make -f " ++ s

142 return ()

178 return ()

143

179

180+-- | Invoke a Makefile's clean target.

144clean :: Maybe String -> IO ()

181clean :: Maybe String -> IO ()

145clean Nothing = return ()

182clean Nothing = return ()

146clean (Just s) = do system $ "make -f " ++ s ++ " clean"

183clean (Just s) = do system $ "make -f " ++ s ++ " clean"

147 return ()

184 return ()

185+

186+-- --------------------------------------------------------------------- [ EOF ]

src/Util/Zlib.hsnew file+15

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

1+module Util.Zlib (decompressEither) where

3+-- From http://stackoverflow.com/questions/10043102/how-to-catch-the-decompress-ioerror/10045963#10045963

4+import Codec.Compression.Zlib.Internal

5+import Data.ByteString.Lazy (ByteString, fromChunks)

6+import Control.Arrow (right)

8+decompressEither :: ByteString -> Either (DecompressError, String) ByteString

9+decompressEither = finalise

10+ . foldDecompressStream cons nil err

11+ . decompressWithErrors zlibFormat defaultDecompressParams

12+ where err errorCode errorString = Left (errorCode, errorString)

13+ nil = Right []

14+ cons chunk = right (chunk :)

15+ finalise = right fromChunks

support/Makefile+1−1

@@ -12,4 +12,4 @@ install: check

12 install $(LIBTARGET) $(TARGET)

13 install $(HDRS) $(TARGET)

15−.PHONY:

15+.PHONY: check install

test/Makefile+2−1

@@ -1,3 +1,5 @@

1+.PHONY: test test_java test_js update diff distclean $(TESTS)

1TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

3TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

3test: $(TESTS)

5test: $(TESTS)

@@ -105,4 +107,3 @@ distclean:

105 rm -f *~

107 rm -f *~

106 rm -f */output

108 rm -f */output

107

109

108−.phony: test test_java test_js update diff distclean $(TESTS)

test/reg001/reg001.idr−3

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

1−apply : (a -> b) -> a -> b

2−apply f x = f x

3−

4class Functor f => VerifiedFunctor (f : Type -> Type) where

1class Functor f => VerifiedFunctor (f : Type -> Type) where

5 identity : (fa : f a) -> map id fa = fa

2 identity : (fa : f a) -> map id fa = fa

test/reg003/expected+1−6

@@ -1,7 +1,2 @@

1−reg003a.idr:4:20:When elaborating constructor ECons:

1+reg003a.idr:4:20:When elaborating constructor Main.ECons:

2No such variable OddList

3−reg003a.idr:7:20:When elaborating constructor OCons:

4−No such variable EvenList

5−reg003a.idr:9:8:When elaborating type of test:

6−No such variable EvenList

7−reg003a.idr:10:1:No type declaration for test

test/reg030/expectednew file

No changes to the content.

test/reg030/reg030.idrnew file+15

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

1+import Control.Isomorphism

3+class Set univ where

4+ member : univ -> univ -> Type

6+isSubsetOf : Set univ => univ -> univ -> Type

7+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

9+class Set univ => HasPower univ where

10+ Powerset : (a : univ) ->

11+ Exists univ (\Pa => (c : univ) ->

12+ (isSubsetOf c a) -> member c Pa)

13+

14+powerset : HasPower univ => univ -> univ

15+powerset {univ} a = getWitness (Powerset a)

test/reg030/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ reg030.idr --check

3+rm -f *.ibc

test/reg031/expectednew file+1

@@ -0,0 +1 @@

1+[10, 128, 201, 255, 10, 51, 10, 52]

test/reg031/reg031.idrnew file+8

@@ -0,0 +1,8 @@

1+module Main

3+main : IO ()

4+main = print . map val . unpack $ "\x0a\x80\xC9\xFF\n3\n4"

5+ where

6+ -- make the values positive if the backend has signed chars

7+ val : Char -> Int

8+ val = flip mod 256 . (+256) . ord

test/reg031/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ reg031.idr -o reg031

3+./reg031

4+rm -f *.ibc reg031

test/test010/expected+1−1

@@ -1,3 +1,3 @@

1−test010.idr:13:1:foo is possibly not total due to: MkBad

1+test010.idr:13:1:Main.foo is possibly not total due to: Main.MkBad

2test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad

3test010b.idr:9:1:main.bar is possibly not total due to: main.MkBad

test/test037/ErrorReflection.idrnew file+79

@@ -0,0 +1,79 @@

1+module Main

3+import Language.Reflection

4+import Language.Reflection.Errors

5+import Language.Reflection.Utils

7+%language ErrorReflection

9+-- Well-typed terms

10+

11+data Ty = TUnit | TFun Ty Ty

12+

13+instance Show Ty where

14+ show TUnit = "()"

15+ show (TFun t1 t2) = "(" ++ show t1 ++ " => " ++ show t2 ++ ")"

16+

17+using (n : Nat, G : Vect n Ty)

18+ data HasType : Vect n Ty -> Ty -> Type where

19+ Here : HasType (t::G) t

20+ There : HasType G t -> HasType (t' :: G) t

21+

22+ data Tm : Vect n Ty -> Ty -> Type where

23+ U : Tm G TUnit

24+ Var : HasType G t -> Tm G t

25+ Lam : Tm (t :: G) t' -> Tm G (TFun t t')

26+ App : Tm G (TFun t t') -> Tm G t -> Tm G t'

27+

28+-- Extract the type from a reflected term type

29+

30+namespace ErrorReports

31+ data Ty' = TUnit

32+ | TFun Ty' Ty'

33+ | TVar Int String -- To show in unification failures

34+

35+ instance Show Ty' where

36+ show TUnit = "()"

37+ show (TFun x y) = "(" ++ show x ++ " => " ++ show y ++ ")"

38+ show (TVar i n) = n ++ "(" ++ cast i ++ ")"

39+

40+getTmTy : TT -> Maybe TT

41+getTmTy (App (App (App (P (TCon _ _) (NS (UN "Tm") _) _) _) _) ty) = Just ty

42+getTmTy _ = Nothing

43+

44+

45+reifyTy : TT -> Maybe Ty'

46+reifyTy (P (DCon _ _) (NS (UN "TUnit") _) _) = Just TUnit

47+reifyTy (App (App (P (DCon _ _) (NS (UN "TFun") _) _) t1) t2) = do ty1 <- reifyTy t1

48+ ty2 <- reifyTy t2

49+ return $ TFun ty1 ty2

50+reifyTy (P _ (MN i n) _) = Just (TVar i n)

51+reifyTy _ = Nothing

52+

53+-- Friendly error reporting

54+

55+total %error_handler

56+dslerr : Err -> Maybe (List ErrorReportPart)

57+dslerr (CantUnify _ tm1 tm2 _ _ _) = do tm1' <- getTmTy tm1

58+ tm2' <- getTmTy tm2

59+ ty1 <- reifyTy tm1'

60+ ty2 <- reifyTy tm2'

61+ return [TextPart $ "DSL type error: " ++ (show ty1) ++ " doesn't match " ++(show ty2)]

62+dslerr (At (FileLoc f l c) err) = do err' <- dslerr err

63+ return [ TextPart "In file"

64+ , TextPart f

65+ , TextPart "line", TextPart (cast l)

66+ , TextPart "column", TextPart (cast c)

67+ , SubReport err']

68+dslerr (Elaborating s n err) = do err' <- dslerr err

69+ return ([ TextPart $ "When elaborating " ++ s

70+ , NamePart n

71+ , TextPart ":"

72+ , SubReport err'])

73+dslerr _ = Nothing

74+

75+

76+-- Report the error

77+bad : Tm [] TUnit

78+bad = Lam (Var Here)

79+

test/test037/expectednew file+18

@@ -0,0 +1,18 @@

1+In file ErrorReflection.idr line 78 column 5

2+ When elaborating right hand side of Main.bad :

3+ DSL type error: (t'(504) => t'(504)) doesn't match ()

5+Original error:

7+ ErrorReflection.idr:78:5:When elaborating right hand side of bad:

8+ Can't unify

9+ Tm [] (Main.TFun t' t')

10+ with

11+ Tm [] Main.TUnit

12+

13+ Specifically:

14+ Can't unify

15+ Main.TFun t' t'

16+ with

17+ Main.TUnit

18+

test/test037/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ ErrorReflection.idr --nocolour --check

3+rm -f *.ibc