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

CHANGELOG+6−1

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

11New in 0.9.11:

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

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

33

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

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

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

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

99 same name.

1010

11+Internal changes

12+

13+* Faster elaboration

14+* Smaller .ibc files

15+

1116New in 0.9.10:

1217--------------

1318

examples/Makefile+2−2

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

1−check: .PHONY

1+check:

22 rm -f *.ibc

33 for x in *.idr ; do \

44 echo "Checking $$x"; \

55 idris --check $$x; \

66 done

77

8−.PHONY:

8+.PHONY: check

idris.cabal+24−3

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

1414 Dependent types allow types to be predicated on values,

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

1616 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

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

1919 Features include:

2020 .

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

9595 libs/effects/Effect/*.idr

9696 libs/effects/*.idr

9797

98+ libs/neweffects/Makefile

99+ libs/neweffects/neweffects.ipkg

100+ libs/neweffects/Effect/*.idr

101+ libs/neweffects/*.idr

102+

98103 libs/javascript/*.idr

99104 libs/javascript/JavaScript/*.idr

100105 libs/javascript/Makefile

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

192197 test/reg029/run

193198 test/reg029/*.idr

194199 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

195206 test/test001/run

196207 test/test001/*.idr

197208 test/test001/expected

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

303314 test/test035/run

304315 test/test035/expected

305316 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

306323

307324source-repository head

308325 type: git

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

335352 Exposed-modules:

336353 Idris.Core.CaseTree

337354 , Idris.Core.Constraints

355+ , Idris.Core.DeepSeq

338356 , Idris.Core.Elaborate

339357 , Idris.Core.Evaluate

340358 , Idris.Core.Execute

341359 , Idris.Core.ProofState

360+ , Idris.Core.TC

342361 , Idris.Core.TT

343362 , Idris.Core.Typecheck

344363 , Idris.Core.Unify

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

404423 Util.Pretty

405424 , Util.System

406425 , Util.Net

426+ , Util.Zlib

407427

408428 , Pkg.PParser

409429

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

439459 , network

440460 , xml

441461 , deepseq

462+ , zlib

442463 Extensions: MultiParamTypeClasses

443464 , FunctionalDependencies

444465 , FlexibleInstances

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

453474 if os(freebsd)

454475 cpp-options: -DFREEBSD

455476 build-depends: unix

456− if os(dragonfly)

477+ if os(dragonfly)

457478 cpp-options: -DDRAGONFLY

458479 build-depends: unix

459480 if os(darwin)

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

487508 , transformers

488509

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

490− ghc-options: -threaded -rtsopts

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

491512

492513

libs/Makefile+7−4

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

1−build: .PHONY

1+build:

22 $(MAKE) -C prelude build

33 $(MAKE) -C base build

44 $(MAKE) -C effects build

5+ $(MAKE) -C neweffects build

56 $(MAKE) -C javascript build

67

78

8−install: .PHONY

9+install:

910 $(MAKE) -C prelude install

1011 $(MAKE) -C base install

1112 $(MAKE) -C effects install

13+ $(MAKE) -C neweffects install

1214 $(MAKE) -C javascript install

1315

14−clean: .PHONY

16+clean:

1517 $(MAKE) -C prelude clean

1618 $(MAKE) -C base clean

1719 $(MAKE) -C effects clean

20+ $(MAKE) -C neweffects clean

1821 $(MAKE) -C javascript clean

1922

20−.PHONY:

23+.PHONY: build install clean

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

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

1+module Data.Fun

2+

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

2+

3+import Data.Fun

4+

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

11module Decidable.Decidable

22

3+import Data.Rel

4+

35%access public

46

57--------------------------------------------------------------------------------

68-- Typeclass for decidable n-ary Relations

79--------------------------------------------------------------------------------

810

9−{-

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

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

12−have any clues...

13−

14−using (t : Type)

15− class Rel (p : t) where

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

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

12+-- at the moment.

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

14+ total decide : liftRel ts p Dec

1715

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

19− total decide : liftRel Dec

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

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

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

2019

2120using (P : Type, p : P)

2221 data Given : Dec P -> Type where

2322 always : Given (Yes p)

24−-}

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

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

11module Decidable.Order

22

3−%access public

4−

5−{-

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

7−

83import Decidable.Decidable

94import Decidable.Equality

105

6+%access public

7+

118--------------------------------------------------------------------------------

129-- Utility Lemmas

1310--------------------------------------------------------------------------------

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

7471 | Yes nLTEm = Yes (nLTESm nLTEm)

7572 | No nGTm = No (nGTSm nGTm)

7673

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

8175 decide = decideNatLTE

8276

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

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

85−

86−-}

87−

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

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

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

1010 -- ^ Machine chosen names

1111 | NErased

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

13+%name TTName n, n'

1314

1415implicit

1516userSuppliedName : String -> TTName

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

1920 -- ^ universe variable

2021 | UVal Int

2122 -- ^ explicit universe variable

23+%name TTUExp uexp

2224

2325-- | Primitive constants

2426data 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

2729 | B8Type | B16Type | B32Type | B64Type

2830 | PtrType | VoidType | Forgot

2931

32+%name Const c, c'

33+

3034abstract class ReflConst (a : Type) where

3135 toConst : a -> Const

3236

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

7175 -- ^ constructor with tag and number

7276 | TCon Int Int

7377 -- ^ type constructor with tag and number

78+%name NameType nt, nt'

7479

7580-- | Types annotations for bound variables in different

7681-- binding contexts

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

8388 | Guess a a

8489 | PVar a

8590 | PVTy a

86−

91+%name Binder b, b'

8792

8893instance Functor Binder where

8994 map f (Lam x) = Lam (f x)

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

139144 | TType TTUExp

140145 -- ^ types

141146

147+%name TT tm, tm'

148+

142149-- | Raw terms without types

143150data Raw = Var TTName

144151 | RBind TTName (Binder Raw) Raw

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

147154 | RForce Raw

148155 | RConstant Const

149156

157+%name Raw tm, tm'

158+

150159data Tactic = Try Tactic Tactic

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

152161 | GoalType String Tactic

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

185194 -- ^ name a reflected term and type it

186195 | Compute

187196 -- ^ 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

22

33import Language.Reflection

44

5−data SourceLocation = FileLoc String Int

5+record SourceLocation : Type where

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

7+

8+%name SourceLocation loc

69

710data Err = Msg String

811 | InternalMsg String

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

1215 -- unification succeed

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

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

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

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

1620 | CantInferType String

1721 | NonFunctionType TT TT

22+ | NotEquality TT TT

23+ | TooManyArguments TTName

1824 | CantIntroduce TT

1925 | NoSuchVariable TTName

2026 | NoTypeDecl TTName

2127 | NotInjective TT TT TT

2228 | CantResolve TT

2329 | CantResolveAlts (List String)

24− | IncompleteTT TT

30+ | IncompleteTerm TT

2531 | UniverseError

2632 | ProgramLineComment

2733 | Inaccessible TTName

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

3238 | At SourceLocation Err

3339 | Elaborating String TTName Err

3440 | ProviderError String

41+ | LoadingFailed String Err

3542

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

37−data ErrorReport = Message String

38− | Name TTName

39− | Term TT

43+%name Err err, e

4044

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

4151

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

11module Language.Reflection.Utils

22

33import Language.Reflection

4+import Language.Reflection.Errors

45

56--------------------------------------------------------

67-- Tactic construction conveniences

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

185186 equalp Impossible Impossible = True

186187 equalp (TType u) (TType u') = u == u'

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

11IDRIS := idris

22

3−build: .PHONY

3+build:

44 $(IDRIS) --build base.ipkg

55

66install:

77 $(IDRIS) --install base.ipkg

88

9−clean: .PHONY

9+clean:

1010 $(IDRIS) --clean base.ipkg

1111

1212rebuild: clean build

1313

14−linecount: .PHONY

14+linecount:

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

1616

17−.PHONY:

17+.PHONY: build install clean rebuild linecount

libs/base/base.ipkg+2−1

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

2323 Data.ZZ, Data.Sign,

2424 Data.SortedMap, Data.SortedSet, Data.BoundedList,

2525 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,

2728

2829 Control.Isomorphism,

2930 Control.Monad.Identity,

libs/effects/Makefile+3−3

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

11IDRIS := idris

22

3−build: .PHONY

3+build:

44 $(IDRIS) --build effects.ipkg

55

6−clean: .PHONY

6+clean:

77 $(IDRIS) --clean effects.ipkg

88

99install:

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

1111

1212rebuild: clean build

1313

14−.PHONY:

14+.PHONY: build clean install rebuild

libs/javascript/Makefile+3−3

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

11IDRIS := idris

22

3−build: .PHONY

3+build:

44 $(IDRIS) --build javascript.ipkg

55

66install:

77 $(IDRIS) --install javascript.ipkg

88

9−clean: .PHONY

9+clean:

1010 $(IDRIS) --clean javascript.ipkg

1111

1212rebuild: clean build

1313

14−.PHONY:

14+.PHONY: build install clean rebuild

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

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

1+module Default

2+

3+class Default a where

4+ default : a

5+

6+instance Default Int where

7+ default = 0

8+

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

2+

3+import Effects

4+import System

5+import Control.IOExcept

6+

7+data Exception : Type -> Effect where

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

9+

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

2+

3+import Effects

4+import Control.IOExcept

5+

6+data OpenFile : Mode -> Type where

7+ FH : File -> OpenFile m

8+

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

2+

3+import Effects

4+import Control.IOExcept

5+

6+%access public

7+

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

2+

3+import Effects

4+

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

6+

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

2+

3+import Effects

4+

5+data Random : Effect where

6+ getRandom : { Integer } Random Integer

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

8+

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

2+

3+import Effects

4+

5+data Selection : Effect where

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

7+

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

2+

3+import Effects

4+

5+%access public

6+

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

2+

3+import Effects

4+import Control.IOExcept

5+

6+data StdIO : Effect where

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

8+ GetStr : { () } StdIO String

9+

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

2+

3+import Language.Reflection

4+import Control.Catchable

5+import Effect.Default

6+

7+%access public

8+

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

2+

3+build:

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

5+

6+clean:

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

8+

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

2+

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

4+modules = Effects, Effect.Default,

5+

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

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

8+ Effect.Memory

9+

libs/prelude/Builtins.idr+2

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

1+%unqualified

2+

13%access public

24%default total

35

libs/prelude/IO.idr+2

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

1+%unqualified

2+

13import Prelude.List

24

35%access public

libs/prelude/Makefile+4−4

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

11IDRIS := idris

22

3−build: .PHONY

3+build:

44 $(IDRIS) --build prelude.ipkg

55

66install:

77 $(IDRIS) --install prelude.ipkg

88

9−clean: .PHONY

9+clean:

1010 $(IDRIS) --clean prelude.ipkg

1111

1212rebuild: clean build

1313

14−linecount: .PHONY

14+linecount:

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

1616

17−.PHONY:

17+.PHONY: build install clean rebuild linecount

libs/prelude/Prelude.idr+11−7

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

275275instance Applicative (Vect k) where

276276 pure = replicate _

277277

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

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

279279

280280instance Applicative Stream where

281281 pure = repeat

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

282+ (<$>) = zipWith apply

283283

284284---- Alternative instances

285285

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

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

335335

336336---- some mathematical operations

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

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

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

339339pow x Z = 1

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

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

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

377377 enumFromTo n m = if n <= m

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

379− else []

379+ else []

380380 where go : List Nat -> List Integer

381381 go [] = []

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

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

392392 toNat n = cast n

393393 fromNat n = cast n

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

395− enumFromTo n m = if n <= m

395+ enumFromTo n m = if n <= m

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

397397 else []

398398 where go : List Nat -> List Int

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

532532partial

533533nullPtr : Ptr -> IO Bool

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

535− return (ok /= 0);

535+ return (ok /= 0)

536536

537537partial

538538nullStr : String -> IO Bool

539539nullStr 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)

541545

542546partial

543547validFile : File -> IO Bool

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

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

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

3434flip f x y = f y x

3535

36−infixr 1 $

37−

3836-- | Function application.

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

40−f $ a = f a

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

38+apply f a = f a

4139

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

4341cong refl = refl

llvm/Makefile+3−3

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

1414.c.o:

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

1616

17−install: $(LIB) .PHONY

17+install: $(LIB)

1818 mkdir -p $(TARGET)

1919 install $(LIB) $(TARGET)

2020

21−clean: .PHONY

21+clean:

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

2323

24−.PHONY:

24+.PHONY: build install clean

main/Main.hs+57−30

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

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

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

5555 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

5660 case opt getPkgClean opts of

5761 [] -> return ()

5862 fs -> do runIO $ mapM_ cleanPkg fs

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

7983 putStrLn incFlags

8084 exitWith ExitSuccess

8185

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

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

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

85− "Options:\n" ++

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

108− "\t node or llvm\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−

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

87+

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

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

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

91+ "Common flags:\n" ++

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

93+ "\t --clean=IPKG Clean Package\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" ++

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" ++

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

112139

papers/impl-paper/Makefile+5−5

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

11PAPER = impldtp

22

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

3+all: ${PAPER}.pdf

44

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

66 typechecking.tex elaboration.tex delab.tex \

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

2828 -latex ${PAPER}

2929 -latex ${PAPER}

3030

31−progress: .PHONY

31+progress:

3232 wc -w ${TEXFILES}

3333

3434%.png : %.diag

3535 $(DITAA) -o -E $<

3636

37−todropbox: .PHONY

37+todropbox:

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

3939

40−fromdropbox: .PHONY

40+fromdropbox:

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

4242

43−.PHONY:

43+.PHONY: all progress todropbox fromdropbox

rts/Makefile+3−3

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

1515 ar r $(LIBTARGET) $(OBJS)

1616 ranlib $(LIBTARGET)

1717

18−install : .PHONY

18+install :

1919 mkdir -p $(TARGET)

2020 install $(LIBTARGET) $(HDRS) $(TARGET)

2121

22−clean : .PHONY

22+clean :

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

2424

2525idris_rts.o: idris_rts.h

2626

27−.PHONY:

27+.PHONY: build install clean

rts/idris_stdfgn.c+4

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

3636 return ptr==NULL;

3737}

3838

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

40+ return x==y;

41+}

42+

3943void* idris_stdin() {

4044 return (void*)stdin;

4145}

rts/idris_stdfgn.h+1

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

1212int fileError(void* h);

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

1414

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

1516int isNull(void* ptr);

1617void* idris_stdin();

1718

src/IRTS/CodegenC.hs+19−2

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

1010import Paths_idris

1111import Util.System

1212

13+import Numeric

1314import Data.Char

1415import Data.List (intercalate)

1516import System.Process

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

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

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

106107

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+

107124bcc :: Int -> BC -> String

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

109126bcc i (ASSIGNCONST l c)

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

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

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

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

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

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

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

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

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

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

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

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

446463

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 ++ "))"

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

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

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

src/IRTS/CodegenJava.hs+5−5

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

369369 | otherwise = decls

370370 where

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

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

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

373373 findMain (_:decls) = findMain decls

374374 findMain [] = False

375375

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

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

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

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

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

379379 findMainMethod (_:decls) = findMainMethod decls

380380 findMainMethod [] = False

381381

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

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

391391 , jConst "args"

392392 ]

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

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

394394 ]

395395

396396-----------------------------------------------------------------------

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

749749

750750mkThread :: LVar -> CodeGeneration Exp

751751mkThread arg =

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

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

753753

754754

src/IRTS/CodegenJavaScript.hs+192−32

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

6464 | JSArray [JS]

6565 | JSObject [(String, JS)]

6666 | JSString String

67+ | JSChar String

6768 | JSNum JSNum

6869 | JSAssign JS JS

6970 | JSAlloc String (Maybe JS)

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

153154compileJS (JSString str) =

154155 show str

155156

157+compileJS (JSChar chr) =

158+ chr

159+

156160compileJS (JSNum num)

157161 | JSInt i <- num = show i

158162 | JSFloat f <- num = show f

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

170174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"

171175

172176compileJS (JSCond branches) =

173− intercalate " else " $ map createIfBlock branches

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

174178 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}"

175187 createIfBlock (cond, e) =

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

177189 ++ "return " ++ compileJS e

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

233245 )

234246 ) [value]

235247

248+

236249jsSubst :: String -> JS -> JS -> JS

237250jsSubst var new (JSVar old)

238251 | var == translateVariableName old = new

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

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

261274 )]

262275

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+

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

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

265288

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

291314jsSubst var new (JSCond conds) =

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

293316

317+jsSubst var new (JSAssign lhs rhs) =

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

319+

294320jsSubst _ _ js = js

295321

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+

296333inlineJS :: JS -> JS

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

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

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

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

299361

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

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

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

365427inlineJS (JSObject fields) =

366428 JSObject (map (second inlineJS) fields)

367429

430+inlineJS (JSOp op lhs rhs) =

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

432+

368433inlineJS js = js

369434

370435reduceJS :: [JS] -> [JS]

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

373438funName :: JS -> String

374439funName (JSAlloc fun _) = fun

375440

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+

376531removeIDs :: [JS] -> [JS]

377532removeIDs js =

378533 case partition isID js of

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

536691 reduceCall funs (JSProj obj field) =

537692 JSProj (reduceCall funs obj) field

538693

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+

539700 reduceCall funs (JSCond conds) =

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

541702

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

588749

589750 functions :: [String]

590751 functions =

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

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

592753

593754 mainLoop :: String

594755 mainLoop = compileJS $

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

606767 mainFun = jsTailcall $ jsCall runMain []

607768

608769 runMain :: String

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

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

610771

611772 invokeLoop :: String

612773 invokeLoop = compileJS $ jsCall "main" []

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

671832

672833translateNamespace :: Name -> String

673834translateNamespace (UN _) = idrNamespace

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

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

675836translateNamespace (MN _ _) = idrNamespace

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

677838translateNamespace NErased = idrNamespace

678839

679840translateName :: Name -> String

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

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

681842translateName (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

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

684845translateName NErased = "e"

685846

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

688849 | WhereN i m n <- name =

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

690851 | InstanceN n s <- name =

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

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

692853 | ParentN n s <- name =

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

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

694855 | MethodN n <- name =

695856 'm' : translateName n

696857 | CaseN n <- name =

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

699860translateConstant :: Const -> JS

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

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

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

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

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

702866translateConstant (Ch c) = JSString [c]

703867translateConstant (Str s) = JSString s

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

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

714878

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

716880translateDeclaration (path, SFun name params stackSize body)

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

881+ | (MN _ ap) <- name

718882 , (SLet var val next) <- body

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

883+ , (SChkCase cvar cases) <- next

884+ , ap == txt "APPLY" =

720885 let lvar = translateVariableName var

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

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

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

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

725− , JSReturn $ jsLet (translateVariableName var) (

726− translateExpression val

727− ) (JSTernary (

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

729− (hasProp lookupTableName (translateVariableName var))

730− ) (JSIdent $

731− lookupTableName ++ lookup

732− ) JSNull

733− )

890+ , JSAlloc (translateVariableName var) (

891+ Just $ translateExpression val

892+ )

893+ , JSReturn $ (JSTernary (

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

895+ (hasProp lookupTableName (translateVariableName var))

896+ ) (JSIdent $

897+ lookupTableName ++ lookup

898+ ) JSNull

899+ )

734900 ]

735901 )

736902 ]

737903

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

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

904+ | (MN _ ev) <- name

905+ , (SChkCase var cases) <- body

906+ , ev == txt "EVAL" =

740907 JSSeq [ lookupTable [] var cases

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

742909 JSTernary (

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

798965 JSFunction (p ++ map snd aux) (

799966 JSSeq $

800967 zipWith assignVar [0..] p ++

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

802968 map assignAux aux ++

803969 [JSReturn body]

804970 )

805971 where

806− numP :: Int

807− numP = length params

808−

809− allocVar :: Int -> JS

810− allocVar n = JSAlloc (jsVar n) Nothing

811−

812972 assignVar :: Int -> String -> JS

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

814974

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

816− assignAux (var, val) =

817− JSAssign (JSIdent $ translateVariableName var) (JSIdent val)

976+ assignAux (Loc var, val) =

977+ JSAlloc (jsVar var) (Just $ JSIdent val)

818978

819979 p :: [String]

820980 p = map translateName params

src/IRTS/Compiler.hs+34−31

@@ -40,7 +40,7 @@ compile codegen f tm

4040 = do checkMVs

4141 let tmnames = namesUsed (STerm tm)

4242 usedIn <- mapM (allNames []) tmnames

43− let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn

43+ let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn

4444 defsIn <- mkDecls tm (concat used)

4545 findUnusedArgs (concat used)

4646 maindef <- irMain tm

@@ -49,7 +49,7 @@ compile codegen f tm

4949 flags <- getFlags codegen

5050 hdrs <- getHdrs codegen

5151 impdirs <- allImportDirs

52− let defs = defsIn ++ [(MN 0 "runMain", maindef)]

52+ let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

5353 -- iputStrLn $ showSep "\n" (map show defs)

5454 let (nexttag, tagged) = addTags 65536 (liftAll defs)

5555 let ctxtIn = addAlist tagged emptyContext

@@ -108,7 +108,7 @@ compile codegen f tm

108108

109109irMain :: TT Name -> Idris LDecl

110110irMain tm = do i <- ir tm

111− return $ LFun [] (MN 0 "runMain") [] (LForce i)

111+ return $ LFun [] (sMN 0 "runMain") [] (LForce i)

112112

113113mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

114114mkDecls t used

@@ -137,7 +137,7 @@ build (n, d)

137137 = do i <- getIState

138138 case lookup n (idris_scprims i) of

139139 Just (ar, op) ->

140− let args = map (\x -> MN x "op") [0..] in

140+ let args = map (\x -> sMN x "op") [0..] in

141141 return (n, (LFun [] n (take ar args)

142142 (LOp op (map (LV . Glob) (take ar args)))))

143143 _ -> do def <- mkLDecl n d

@@ -168,40 +168,38 @@ mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)

168168instance ToIR (TT Name) where

169169 ir tm = ir' [] tm where

170170 ir' env tm@(App f a)

171− | (P _ (UN "mkForeignPrim") _, args) <- unApply tm

171+ | (P _ (UN m) _, args) <- unApply tm,

172+ m == txt "mkForeignPrim"

172173 = doForeign env args

173− | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm

174+ | (P _ (UN u) _, [_, arg]) <- unApply tm,

175+ u == txt "unsafePerformPrimIO"

174176 = ir' env arg

175177 -- TMP HACK - until we get inlining.

176− | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm

178+ | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,

179+ r == txt "replace"

177180 = ir' env arg

178− | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

181+ | (P _ (UN l) _, [_, arg]) <- unApply tm,

182+ l == txt "lazy"

179183 = do arg' <- ir' env arg

180184 return $ LLazyExp arg'

181− | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm

185+ | (P _ (UN a) _, [_, _, _, arg]) <- unApply tm,

186+ a == txt "assert_smaller"

182187 = ir' env arg

183− | (P _ (UN "par") _, [_, arg]) <- unApply tm

188+ | (P _ (UN p) _, [_, arg]) <- unApply tm,

189+ p == txt "par"

184190 = do arg' <- ir' env arg

185191 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"

187194 = do arg' <- ir' env arg

188195 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"

201198 = do size' <- ir' env size

202199 t' <- ir' env t

203200 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"

205203 = do t' <- ir' env t

206204 return t' -- TODO

207205-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm

@@ -272,7 +270,7 @@ instance ToIR (TT Name) where

272270 (args ++ map (\n -> P Bound n undefined) extra)

273271 return $ LLam extra sc'

274272

275− satArgs n = map (\i -> MN i "sat") [1..n]

273+ satArgs n = map (\i -> sMN i "sat") [1..n]

276274

277275 buildApp env e [] = return e

278276 buildApp env e xs = do xs' <- mapM (ir' env) xs

@@ -300,10 +298,15 @@ getFTypes tm = case unApply tm of

300298 fmap (mkIty' ty :) (getFTypes xs)

301299 _ -> Nothing

302300

303−mkIty' (P _ (UN ty) _) = mkIty ty

304−mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy

305−mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO

306−mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction

301+mkIty' (P _ (UN ty) _) = mkIty (str ty)

302+mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

303+ | fi == txt "FIntT" = mkIntIty (str intTy)

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

308+mkIty' (App (App (P _ (UN ff) _) _) _)

309+ | ff == txt "FFunction" = FFunction

307310mkIty' _ = FAny

308311

309312-- would be better if these FInt types were evaluated at compile time

@@ -337,8 +340,8 @@ mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

337340mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

338341mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

339342

340−zname = NS (UN "Z") ["Nat","Prelude"]

341−sname = NS (UN "S") ["Nat","Prelude"]

343+zname = sNS (sUN "Z") ["Nat","Prelude"]

344+sname = sNS (sUN "S") ["Nat","Prelude"]

342345

343346instance ToIR ([Name], SC) where

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

143143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

144144

145145 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

147147

148148 -- if anything in the DExp is projected from, we'll need to evaluate it,

149149 -- but we only want to do it once, rather than every time we project.

@@ -171,7 +171,7 @@ addApps defs (n, LFun _ _ args e)

171171 needsEval x (DProj (DV (Glob x')) _) = x == x'

172172 needsEval x _ = False

173173

174−eEVAL x = DApp False (MN 0 "EVAL") [x]

174+eEVAL x = DApp False (sMN 0 "EVAL") [x]

175175

176176data EvalApply a = EvalCase (Name -> a)

177177 | ApplyCase a

@@ -198,26 +198,26 @@ mkApplyCase fname n ar

198198 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

199199 (DApp False (mkUnderCon fname (ar - (n + 1)))

200200 (map (DV . Glob) (take n (genArgs 0) ++

201− [MN 0 "arg"])))))

201+ [sMN 0 "arg"])))))

202202 : mkApplyCase fname (n + 1) ar

203203

204204mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

205−mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]

206− (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))

205+mkEval xs = (sMN 0 "EVAL", DFun (sMN 0 "EVAL") [sMN 0 "arg"]

206+ (mkBigCase (sMN 0 "EVAL") 256 (DV (Glob (sMN 0 "arg")))

207207 (mapMaybe evalCase xs ++

208− [DDefaultCase (DV (Glob (MN 0 "arg")))])))

208+ [DDefaultCase (DV (Glob (sMN 0 "arg")))])))

209209 where

210− evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

210+ evalCase (n, t, EvalCase x) = Just (x (sMN 0 "arg"))

211211 evalCase _ = Nothing

212212

213213mkApply :: [(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"]

215215 (case mapMaybe applyCase xs of

216216 [] -> DNothing

217217 cases ->

218− mkBigCase (MN 0 "APPLY") 256

219− (DApp False (MN 0 "EVAL")

220− [DV (Glob (MN 0 "fn"))])

218+ mkBigCase (sMN 0 "APPLY") 256

219+ (DApp False (sMN 0 "EVAL")

220+ [DV (Glob (sMN 0 "fn"))])

221221 (cases ++

222222 [DDefaultCase DNothing])))

223223 where

@@ -231,11 +231,11 @@ declare t xs = dec' t xs [] where

231231 dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, DConstructor n t ar) : acc)

232232

233233

234−genArgs i = MN i "P_c" : genArgs (i + 1)

234+genArgs i = sMN i "P_c" : genArgs (i + 1)

235235

236−mkFnCon n = MN 0 ("P_" ++ show n)

236+mkFnCon n = sMN 0 ("P_" ++ show n)

237237mkUnderCon n 0 = n

238−mkUnderCon n missing = MN missing ("U_" ++ show n)

238+mkUnderCon n missing = sMN missing ("U_" ++ show n)

239239

240240instance Show DExp where

241241 show e = show' [] e where

src/IRTS/Java/Mangling.hs+3−3

@@ -26,7 +26,7 @@ prefixCallNamespaces name (SFun fname args i e) =

2626 where

2727 prefixCallNamespacesExp :: Ident -> SExp -> SExp

2828 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

3030 prefixCallNamespacesExp name (SLet var e1 e2) =

3131 SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)

3232 prefixCallNamespacesExp name (SUpdate var e) =

@@ -63,7 +63,7 @@ mangleWithPrefix prefix (UN name) =

6363 . parser ident

6464 . (prefix ++)

6565 . cleanNonLetter

66− $ cleanWs False name

66+ $ cleanWs False (str name)

6767 where

6868 cleanNonLetter (x:xs)

6969 | x == '#' = "_Hash" ++ cleanNonLetter xs

@@ -96,7 +96,7 @@ mangleWithPrefix prefix (UN name) =

9696 | capitalize = (toUpper x) : (cleanWs False xs)

9797 | otherwise = x : (cleanWs False xs)

9898 cleanWs _ [] = []

99−mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (UN (showCG s))

99+mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (sUN (showCG s))

100100

101101mangle :: (Applicative m, MonadError String m) => Name -> m Ident

102102mangle = mangleWithPrefix "__IDRCG__"

src/IRTS/Lang.hs+1−1

@@ -102,7 +102,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

102102

103103lname (NS n x) i = NS (lname n i) x

104104lname (UN n) i = MN i n

105−lname x i = MN i (show x)

105+lname x i = sMN i (show x)

106106

107107liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

108108liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

src/IRTS/Simplified.hs+2−1

@@ -2,6 +2,7 @@ module IRTS.Simplified where

22

33import IRTS.Defunctionalise

44import Idris.Core.TT

5+import Idris.Core.Typecheck

56import Data.Maybe

67import Control.Monad.State

78

@@ -94,7 +95,7 @@ sVar (DV (Glob x))

9495sVar (DV x) = return (x, Nothing)

9596sVar e = do e' <- simplify False e

9697 i <- hvar

97− return (Glob (MN i "R"), Just e')

98+ return (Glob (sMN i "R"), Just e')

9899

99100mkapp f args = mkapp' f args [] where

100101 mkapp' f [] args = return $ f (reverse args)

src/Idris/AbsSyntax.hs+270−122

@@ -19,9 +19,11 @@ import System.Console.Haskeline

1919import System.IO

2020

2121import Control.Monad.State

22+import Control.Monad.Error(throwError)

2223

2324import Data.List

2425import Data.Char

26+import qualified Data.Text as T

2527import Data.Either

2628import Data.Maybe

2729import Data.Word (Word)

@@ -180,7 +182,7 @@ addNameHint ty n

180182 putIState $ i { idris_namehints = addDef ty' ns' (idris_namehints i) }

181183

182184getNameHints :: IState -> Name -> [Name]

183−getNameHints i (UN "->") = [UN "f",UN "g"]

185+getNameHints i (UN arr) | arr == txt "->" = [sUN "f",sUN "g"]

184186getNameHints i n =

185187 case lookupCtxt n (idris_namehints i) of

186188 [ns] -> ns

@@ -200,7 +202,7 @@ addInstance int n i

200202 [CI a b c d e ins] ->

201203 do let cs = addDef n (CI a b c d e (addI i ins)) (idris_classes ist)

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

204206 putIState $ ist { idris_classes = cs }

205207 where addI i ins | int = i : ins

206208 | chaser n = ins ++ [i]

@@ -209,7 +211,8 @@ addInstance int n i

209211 insI i (n : ns) | chaser n = i : n : ns

210212 | otherwise = n : insI i ns

211213

212− chaser (UN ('@':'@':_)) = True

214+ chaser (UN nm)

215+ | ('@':'@':_) <- str nm = True

213216 chaser (NS n _) = chaser n

214217 chaser _ = False

215218

@@ -234,6 +237,24 @@ addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

234237clearIBC :: Idris ()

235238clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

236239

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+

237258getHdrs :: Codegen -> Idris [String]

238259getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

239260

@@ -284,12 +305,33 @@ getInternalApp fp l = do i <- getIState

284305 Nothing -> return Placeholder

285306 -- TODO: What if it's not there?

286307

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+

287329checkUndefined :: FC -> Name -> Idris ()

288330checkUndefined fc n

289331 = do i <- getContext

290332 case lookupTy n i of

291− (_:_) -> fail $ show fc ++ ":" ++

292− show n ++ " already defined"

333+ (_:_) -> throwError . Msg $ show fc ++ ":" ++

334+ show n ++ " already defined"

293335 _ -> return ()

294336

295337isUndefined :: FC -> Name -> Idris Bool

@@ -650,16 +692,16 @@ setTypeCase t = do i <- getIState

650692

651693bi = fileFC "builtin"

652694

653−inferTy = MN 0 "__Infer"

654−inferCon = MN 0 "__infer"

695+inferTy = sMN 0 "__Infer"

696+inferCon = sMN 0 "__infer"

655697inferDecl = PDatadecl inferTy

656698 PType

657− [("", inferCon, PPi impl (MN 0 "iType") PType (

658− PPi expl (MN 0 "ival") (PRef bi (MN 0 "iType"))

659− (PRef bi inferTy)), bi)]

699+ [("", inferCon, PPi impl (sMN 0 "iType") PType (

700+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

701+ (PRef bi inferTy)), bi, [])]

660702inferOpts = []

661703

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]

663705infP = P (TCon 6 0) inferTy (TType (UVal 0))

664706

665707getInferTerm, getInferType :: Term -> Term

@@ -676,52 +718,52 @@ primNames = [unitTy, unitCon,

676718 falseTy, pairTy, pairCon,

677719 eqTy, eqCon, inferTy, inferCon]

678720

679−unitTy = MN 0 "__Unit"

680−unitCon = MN 0 "__II"

721+unitTy = sMN 0 "__Unit"

722+unitCon = sMN 0 "__II"

681723unitDecl = PDatadecl unitTy PType

682− [("", unitCon, PRef bi unitTy, bi)]

724+ [("", unitCon, PRef bi unitTy, bi, [])]

683725unitOpts = [DefaultEliminator]

684726

685−falseTy = MN 0 "__False"

727+falseTy = sMN 0 "__False"

686728falseDecl = PDatadecl falseTy PType []

687729falseOpts = []

688730

689−pairTy = MN 0 "__Pair"

690−pairCon = MN 0 "__MkPair"

731+pairTy = sMN 0 "__Pair"

732+pairCon = sMN 0 "__MkPair"

691733pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

692734 [("", pairCon, PPi impl (n "A") PType (

693735 PPi impl (n "B") PType (

694736 PPi expl (n "a") (PRef bi (n "A")) (

695737 PPi expl (n "b") (PRef bi (n "B"))

696738 (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

697− pexp (PRef bi (n "B"))])))), bi)]

698− where n a = MN 0 a

739+ pexp (PRef bi (n "B"))])))), bi, [])]

740+ where n a = sMN 0 a

699741pairOpts = []

700742

701−eqTy = UN "="

702−eqCon = UN "refl"

703−eqDecl = PDatadecl eqTy (piBind [(n "a", PType), (n "b", PType),

704− (n "x", PRef bi (n "a")), (n "y", PRef bi (n "b"))]

743+eqTy = sUN "="

744+eqCon = sUN "refl"

745+eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

746+ (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

705747 PType)

706− [("", eqCon, PPi impl (n "a") PType (

707− PPi impl (n "x") (PRef bi (n "a"))

708− (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder False,

709− pimp (n "b") Placeholder False,

748+ [("", eqCon, PPi impl (n "A") PType (

749+ PPi impl (n "x") (PRef bi (n "A"))

750+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

751+ pimp (n "B") Placeholder False,

710752 pexp (PRef bi (n "x")),

711− pexp (PRef bi (n "x"))])), bi)]

712− where n a = MN 0 a

753+ pexp (PRef bi (n "x"))])), bi, [])]

754+ where n a = sMN 0 a

713755eqOpts = []

714756

715−elimName = UN "__Elim"

716−elimMethElimTy = UN "__elimTy"

717−elimMethElim = UN "elim"

718−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(UN "scrutineeType", PType)]

757+elimName = sUN "__Elim"

758+elimMethElimTy = sUN "__elimTy"

759+elimMethElim = sUN "elim"

760+elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

719761 [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,

720762 PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

721763

722764-- Defined in builtins.idr

723−sigmaTy = UN "Exists"

724−existsCon = UN "Ex_intro"

765+sigmaTy = sUN "Exists"

766+existsCon = sUN "Ex_intro"

725767

726768piBind :: [(Name, PTerm)] -> PTerm -> PTerm

727769piBind = piBindp expl

@@ -859,7 +901,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

859901 updateps yn nm [] = []

860902 updateps yn nm (((a, t), i):as)

861903 | (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

863905

864906 removeBound lhs ns = ns \\ nub (bnames lhs)

865907

@@ -879,8 +921,8 @@ expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

879921 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

880922 (map econ cons)

881923 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

882− econ (doc, n, t, fc)

883− = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc)

924+ econ (doc, n, t, fc, fs)

925+ = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

884926expandParamsD rhs ist dec ps ns (PParams f params pds)

885927 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

886928 (map (expandParamsD True ist dec ps ns) pds)

@@ -998,7 +1040,7 @@ addUsingConstraints syn fc t

9981040 -- if all of args in ns, then add it

9991041 doAdd (UConstraint c args : cs) ns t

10001042 | all (\n -> elem n ns) args

1001− = PPi (Constraint False Dynamic "") (MN 0 "cu")

1043+ = PPi (Constraint False Dynamic "") (sMN 0 "cu")

10021044 (mkConst c args) (doAdd cs ns t)

10031045 | otherwise = doAdd cs ns t

10041046

@@ -1068,7 +1110,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

10681110 imps top env (PPi (Imp l _ doc _) n ty sc)

10691111 = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

10701112 (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,

10721114 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

10731115 imps True (n:env) sc

10741116 imps top env (PPi (Exp l _ doc _) n ty sc)

@@ -1076,7 +1118,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

10761118 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

10771119 _ -> [])

10781120 (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,

10801122 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

10811123 imps True (n:env) sc

10821124 imps top env (PPi (Constraint l _ doc) n ty sc)

@@ -1084,7 +1126,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

10841126 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

10851127 _ -> [])

10861128 (decls, ns) <- get -- ignore decls in HO types

1087− put (PConstraint 10 l ty doc : decls,

1129+ put (PConstraint 10 l Placeholder doc : decls,

10881130 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

10891131 imps True (n:env) sc

10901132 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) $

10921134 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

10931135 _ -> [])

10941136 (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,

10961138 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

10971139 imps True (n:env) sc

10981140 imps top env (PEq _ l r)

@@ -1154,71 +1196,84 @@ addImpl = addImpl' False [] []

11541196-- and *not* inside a PHidden

11551197

11561198addImpl' :: 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)

11581201 where

1159− ai env (PRef fc f)

1202+ ai env ds (PRef fc f)

11601203 | f `elem` infns = PInferRef fc f

1161− | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f []

1162− ai env (PHidden (PRef fc f))

1163− | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f []

1164− ai env (PEq fc l r) = let l' = ai env l

1165− r' = ai env r in

1166− PEq fc l' r'

1167− ai env (PRewrite fc l r g) = let l' = ai env l

1168− r' = ai env r

1169− g' = fmap (ai env) g in

1170− PRewrite fc l' r' g'

1171− ai env (PTyped l r) = let l' = ai env l

1172− r' = ai env r in

1173− PTyped l' r'

1174− ai env (PPair fc l r) = let l' = ai env l

1175− r' = ai env r in

1176− PPair fc l' r'

1177− ai env (PDPair fc l t r) = let l' = ai env l

1178− t' = ai env t

1179− r' = ai env r in

1180− PDPair fc l' t' r'

1181− ai env (PAlternative a as) = let as' = map (ai env) as in

1182− PAlternative a as'

1183− ai env (PApp fc (PInferRef _ f) as)

1184− = let as' = map (fmap (ai env)) as in

1204+ | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f ds []

1205+ ai env ds (PHidden (PRef fc f))

1206+ | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f ds []

1207+ ai env ds (PEq fc l r)

1208+ = let l' = ai env ds l

1209+ r' = ai env ds r in

1210+ PEq fc l' r'

1211+ ai env ds (PRewrite fc l r g)

1212+ = let l' = ai env ds l

1213+ r' = ai env ds r

1214+ g' = fmap (ai env ds) g in

1215+ PRewrite fc l' r' g'

1216+ ai env ds (PTyped l r)

1217+ = let l' = ai env ds l

1218+ r' = ai env ds r in

1219+ PTyped l' r'

1220+ ai env ds (PPair fc l r)

1221+ = let l' = ai env ds l

1222+ r' = ai env ds r in

1223+ PPair fc l' r'

1224+ ai env ds (PDPair fc l t r)

1225+ = let l' = ai env ds l

1226+ t' = ai env ds t

1227+ r' = ai env ds r in

1228+ PDPair fc l' t' r'

1229+ ai env ds (PAlternative a as)

1230+ = let as' = map (ai env ds) as in

1231+ PAlternative a as'

1232+ ai env _ (PDisamb ds' as) = ai env ds' as

1233+ ai env ds (PApp fc (PInferRef _ f) as)

1234+ = let as' = map (fmap (ai env ds)) as in

11851235 PApp fc (PInferRef fc f) as'

1186− ai env (PApp fc ftm@(PRef _ f) as)

1187− | f `elem` infns = ai env (PApp fc (PInferRef fc f) as)

1236+ ai env ds (PApp fc ftm@(PRef _ f) as)

1237+ | f `elem` infns = ai env ds (PApp fc (PInferRef fc f) as)

11881238 | not (f `elem` map fst env)

1189− = let as' = map (fmap (ai env)) as in

1190− handleErr $ aiFn inpat False ist fc f as'

1191− | Just (Just ty) <- lookup f env

1192− = let as' = map (fmap (ai env)) as

1193− arity = getPArity ty in

1194− mkPApp fc arity ftm as'

1195− ai env (PApp fc f as) = let f' = ai env f

1196− as' = map (fmap (ai env)) as in

1197− mkPApp fc 1 f' as'

1198− ai env (PCase fc c os) = let c' = ai env c

1199− os' = map (pmap (ai env)) os in

1200− PCase fc c' os'

1201− ai env (PLam n ty sc) = let ty' = ai env ty

1202− sc' = ai ((n, Just ty):env) sc in

1203− PLam n ty' sc'

1204− ai env (PLet n ty val sc)

1205− = let ty' = ai env ty

1206− val' = ai env val

1207− sc' = ai ((n, Just ty):env) sc in

1208− PLet n ty' val' sc'

1209− ai env (PPi p n ty sc) = let ty' = ai env ty

1210− sc' = ai ((n, Just ty):env) sc in

1211− PPi p n ty' sc'

1212− ai env (PGoal fc r n sc) = let r' = ai env r

1213− sc' = ai ((n, Nothing):env) sc in

1214− PGoal fc r' n sc'

1215− ai env (PHidden tm) = PHidden (ai env tm)

1216− ai env (PProof ts) = PProof (map (fmap (ai env)) ts)

1217− ai env (PTactics ts) = PTactics (map (fmap (ai env)) ts)

1218− ai env (PRefl fc tm) = PRefl fc (ai env tm)

1219− ai env (PUnifyLog tm) = PUnifyLog (ai env tm)

1220− ai env (PNoImplicits tm) = PNoImplicits (ai env tm)

1221− ai env tm = tm

1239+ = let as' = map (fmap (ai env ds)) as in

1240+ handleErr $ aiFn inpat False ist fc f ds as'

1241+ | Just (Just ty) <- lookup f env =

1242+ let as' = map (fmap (ai env ds)) as

1243+ arity = getPArity ty in

1244+ mkPApp fc arity ftm as'

1245+ ai env ds (PApp fc f as)

1246+ = let f' = ai env ds f

1247+ as' = map (fmap (ai env ds)) as in

1248+ mkPApp fc 1 f' as'

1249+ ai env ds (PCase fc c os)

1250+ = let c' = ai env ds c

1251+ os' = map (pmap (ai env ds)) os in

1252+ PCase fc c' os'

1253+ ai env ds (PLam n ty sc)

1254+ = let ty' = ai env ds ty

1255+ sc' = ai ((n, Just ty):env) ds sc in

1256+ PLam n ty' sc'

1257+ ai env ds (PLet n ty val sc)

1258+ = let ty' = ai env ds ty

1259+ val' = ai env ds val

1260+ sc' = ai ((n, Just ty):env) ds sc in

1261+ PLet n ty' val' sc'

1262+ ai env ds (PPi p n ty sc)

1263+ = let ty' = ai env ds ty

1264+ sc' = ai ((n, Just ty):env) ds sc in

1265+ PPi p n ty' sc'

1266+ ai env ds (PGoal fc r n sc)

1267+ = let r' = ai env ds r

1268+ sc' = ai ((n, Nothing):env) ds sc in

1269+ PGoal fc r' n sc'

1270+ ai env ds (PHidden tm) = PHidden (ai env ds tm)

1271+ ai env ds (PProof ts) = PProof (map (fmap (ai env ds)) ts)

1272+ ai env ds (PTactics ts) = PTactics (map (fmap (ai env ds)) ts)

1273+ ai env ds (PRefl fc tm) = PRefl fc (ai env ds tm)

1274+ ai env ds (PUnifyLog tm) = PUnifyLog (ai env ds tm)

1275+ ai env ds (PNoImplicits tm) = PNoImplicits (ai env ds tm)

1276+ ai env ds tm = tm

12221277

12231278 handleErr (Left err) = PElabError err

12241279 handleErr (Right x) = x

@@ -1226,8 +1281,8 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

12261281-- if in a pattern, and there are no arguments, and there's no possible

12271282-- names with zero explicit arguments, don't add implicits.

12281283

1229−aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm

1230−aiFn inpat True ist fc f []

1284+aiFn :: Bool -> Bool -> IState -> FC -> Name -> [[T.Text]] -> [PArg] -> Either Err PTerm

1285+aiFn inpat True ist fc f ds []

12311286 = case lookupDef f (tt_ctxt ist) of

12321287 [] -> Right $ PPatvar fc f

12331288 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

@@ -1235,7 +1290,7 @@ aiFn inpat True ist fc f []

12351290 if (not (vname f) || tcname f

12361291 || any (conCaf (tt_ctxt ist)) ialts)

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

12391294 else Right $ PPatvar fc f

12401295 where imp (PExp _ _ _ _) = False

12411296 imp _ = True

@@ -1249,22 +1304,32 @@ aiFn inpat True ist fc f []

12491304 vname (UN n) = True -- non qualified

12501305 vname _ = False

12511306

1252−aiFn inpat expat ist fc f as

1307+aiFn inpat expat ist fc f ds as

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

12551310 -- This is where namespaces get resolved by adding PAlternative

12561311 = 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

12581316 case ns' of

12591317 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

12601318 [] -> if f `elem` (map fst (idris_metavars ist))

12611319 then Right $ PApp fc (PRef fc f) as

12621320 else Right $ mkPApp fc (length as) (PRef fc f) as

12631321 alts -> Right $

1264− PAlternative True $

1265− map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1266− (insertImpl ns as)) alts

1322+ PAlternative True $

1323+ map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1324+ (insertImpl ns as)) alts

12671325 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+

12681333 notHidden n = case getAccessibility n of

12691334 Hidden -> False

12701335 _ -> True

@@ -1286,7 +1351,8 @@ aiFn inpat expat ist fc f as

12861351 case find n given [] of

12871352 Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'

12881353 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

12901356 case find n given [] of

12911357 Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

12921358 Nothing -> if inpat

@@ -1422,12 +1488,14 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

14221488 fullApp x = x

14231489

14241490 match' x y = match (fullApp x) (fullApp y)

1425− match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x'

1426− | PConstant (I _) <- getTm x = match (getTm x) x'

1427− match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x])

1428− | PConstant (I _) <- getTm x = match (getTm x) x'

1429− match (PApp _ (PRef _ (UN "lazy")) [_,x]) x' = match (getTm x) x'

1430− match x (PApp _ (PRef _ (UN "lazy")) [_,x']) = match x (getTm x')

1491+ match (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x]) x'

1492+ | fi == txt "fromInteger" && b == txt "builtins",

1493+ PConstant (I _) <- getTm x = match (getTm x) x'

1494+ match x' (PApp _ (PRef _ (NS (UN fi) [b])) [_,_,x])

1495+ | fi == txt "fromInteger" && b == txt "builtins",

1496+ PConstant (I _) <- getTm x = match (getTm x) x'

1497+ match (PApp _ (PRef _ (UN l)) [_,x]) x' | l == txt "lazy" = match (getTm x) x'

1498+ match x (PApp _ (PRef _ (UN l)) [_,x']) | l == txt "lazy" = match x (getTm x')

14311499 match (PApp _ f args) (PApp _ f' args')

14321500 | length args == length args'

14331501 = do mf <- match' f f'

@@ -1558,9 +1626,11 @@ substMatchShadow n shs tm t = sm shs t where

15581626shadow :: Name -> Name -> PTerm -> PTerm

15591627shadow n n' t = sm t where

15601628 sm (PRef fc x) | n == x = PRef fc n'

1561− sm (PLam x t sc) = PLam x (sm t) (sm sc)

1562− sm (PPi p x t sc) = PPi p x (sm t) (sm sc)

1629+ sm (PLam x t sc) | n /= x = PLam 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)

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

15641634 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

15651635 sm (PEq f x y) = PEq f (sm x) (sm y)

15661636 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

15681638 sm (PPair f x y) = PPair f (sm x) (sm y)

15691639 sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)

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

15711643 sm (PHidden x) = PHidden (sm x)

15721644 sm (PUnifyLog x) = PUnifyLog (sm x)

15731645 sm (PNoImplicits x) = PNoImplicits (sm x)

15741646 sm x = x

15751647

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

15761724

src/Idris/AbsSyntaxTree.hs+67−27

@@ -24,6 +24,7 @@ import Control.Monad.Trans.Error

2424

2525import Data.List

2626import Data.Char

27+import qualified Data.Text as T

2728import Data.Either

2829import Data.Word (Word)

2930

@@ -131,7 +132,9 @@ data IState = IState {

131132 idris_outputmode :: OutputMode,

132133 idris_colourRepl :: Bool,

133134 idris_colourTheme :: ColourTheme,

134− idris_outh :: Handle

135+ idris_outh :: Handle,

136+ idris_errorhandlers :: [Name],

137+ idris_nameIdx :: (Int, Ctxt (Int, Name))

135138 }

136139

137140data SizeChange = Smaller | Same | Bigger | Unknown

@@ -154,10 +157,10 @@ deriving instance Binary CGInfo

154157deriving instance NFData CGInfo

155158!-}

156159

157−primDefs = [UN "unsafePerformPrimIO",

158− UN "mkLazyForeignPrim",

159− UN "mkForeignPrim",

160− UN "FalseElim"]

160+primDefs = [sUN "unsafePerformPrimIO",

161+ sUN "mkLazyForeignPrim",

162+ sUN "mkForeignPrim",

163+ sUN "FalseElim"]

161164

162165-- information that needs writing for the current module's .ibc file

163166data IBCWrite = IBCFix FixDecl

@@ -189,13 +192,15 @@ data IBCWrite = IBCFix FixDecl

189192 | IBCLineApp FilePath Int PTerm

190193 deriving Show

191194

195+-- | The initial state for the compiler

196+idrisInit :: IState

192197idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

193198 emptyContext emptyContext emptyContext emptyContext

194199 emptyContext emptyContext emptyContext emptyContext

195200 emptyContext

196201 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

197202 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

198− True defaultTheme stdout

203+ True defaultTheme stdout [] (0, emptyContext)

199204

200205-- | The monad for the main REPL - reading and processing files and updating

201206-- global state (hence the IO inner monad).

@@ -258,6 +263,7 @@ data Command = Quit

258263 | SetColour ColourType IdrisColour

259264 | ColourOn

260265 | ColourOff

266+ | ListErrorHandlers

261267

262268data Opt = Filename String

263269 | Ver

@@ -289,6 +295,7 @@ data Opt = Filename String

289295 | PkgBuild String

290296 | PkgInstall String

291297 | PkgClean String

298+ | PkgCheck String

292299 | WarnOnly

293300 | Pkg String

294301 | BCAsm String

@@ -380,6 +387,7 @@ data FnOpt = Inlinable -- always evaluate when simplifying

380387 -- a function argument, and further evaluation resutls

381388 | Implicit -- implicit coercion

382389 | CExport String -- export, with a C name

390+ | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension

383391 | Reflection -- a reflecting function, compile-time only

384392 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

385393 deriving (Show, Eq)

@@ -470,7 +478,7 @@ deriving instance NFData PClause'

470478-- | Data declaration

471479data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

472480 d_tcon :: t, -- ^ Type constructor

473− d_cons :: [(String, Name, t, FC)] -- ^ Constructors

481+ d_cons :: [(String, Name, t, FC, [Name])] -- ^ Constructors

474482 }

475483 -- ^ Data declaration

476484 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -497,7 +505,7 @@ declared (PPostulate _ _ _ _ n t) = [n]

497505declared (PClauses _ _ n _) = [] -- not a declaration

498506declared (PCAF _ n _) = [n]

499507declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

500− where fstt (_, a, _, _) = a

508+ where fstt (_, a, _, _, _) = a

501509declared (PData _ _ _ _ (PLaterdecl n _)) = [n]

502510declared (PParams _ _ ds) = concatMap declared ds

503511declared (PNamespace _ ds) = concatMap declared ds

@@ -517,7 +525,7 @@ tldeclared (PPostulate _ _ _ _ n t) = [n]

517525tldeclared (PClauses _ _ n _) = [] -- not a declaration

518526tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

519527tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

520− where fstt (_, a, _, _) = a

528+ where fstt (_, a, _, _, _) = a

521529tldeclared (PParams _ _ ds) = []

522530tldeclared (PMutual _ ds) = concatMap tldeclared ds

523531tldeclared (PNamespace _ ds) = concatMap tldeclared ds

@@ -532,7 +540,7 @@ defined (PPostulate _ _ _ _ n t) = []

532540defined (PClauses _ _ n _) = [n] -- not a declaration

533541defined (PCAF _ n _) = [n]

534542defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

535− where fstt (_, a, _, _) = a

543+ where fstt (_, a, _, _, _) = a

536544defined (PData _ _ _ _ (PLaterdecl n _)) = []

537545defined (PParams _ _ ds) = concatMap defined ds

538546defined (PNamespace _ ds) = concatMap defined ds

@@ -602,6 +610,7 @@ data PTerm = PQuote Raw

602610 | PElabError Err -- ^ Error to report on elaboration

603611 | PImpossible -- ^ Special case for declaring when an LHS can't typecheck

604612 | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice

613+ | PDisamb [[T.Text]] PTerm -- ^ Preferences for explicit namespaces

605614 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

606615 | PNoImplicits PTerm -- ^ never run implicit converions on the term

607616 deriving Eq

@@ -632,6 +641,7 @@ mapPT f t = f (mpt t) where

632641 mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

633642 mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

634643 mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

644+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

635645 mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

636646 mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

637647 mpt x = x

@@ -838,10 +848,10 @@ deriving instance Binary SSymbol

838848deriving instance NFData SSymbol

839849!-}

840850

841−initDSL = DSL (PRef f (UN ">>="))

842− (PRef f (UN "return"))

843− (PRef f (UN "<$>"))

844− (PRef f (UN "pure"))

851+initDSL = DSL (PRef f (sUN ">>="))

852+ (PRef f (sUN "return"))

853+ (PRef f (sUN "<$>"))

854+ (PRef f (sUN "pure"))

845855 Nothing

846856 Nothing

847857 Nothing

@@ -877,7 +887,7 @@ expandNS :: SyntaxInfo -> Name -> Name

877887expandNS syn n@(NS _ _) = n

878888expandNS syn n = case syn_namespace syn of

879889 [] -> n

880− xs -> NS n xs

890+ xs -> sNS n xs

881891

882892

883893--- Pretty printing declarations and terms

@@ -935,7 +945,7 @@ showDImp :: Bool -> PData -> String

935945showDImp impl (PDatadecl n ty cons)

936946 = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t"

937947 ++ 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)

939949

940950getImps :: [PArg] -> [(Name, PTerm)]

941951getImps [] = []

@@ -974,8 +984,8 @@ prettyImp impl = prettySe 10

974984 prettyBasic n

975985 where

976986 prettyBasic n@(UN _) = pretty n

977− prettyBasic (MN _ s) = text s

978− prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map text $ reverse s))) <> prettyBasic n

987+ prettyBasic (MN _ s) = text (str s)

988+ prettyBasic (NS n s) = (foldr (<>) empty (intersperse (text ".") (map (text.str) $ reverse s))) <> prettyBasic n

979989 prettyBasic (SN sn) = text (show sn)

980990 prettySe p (PLam n ty sc) =

981991 bracket p 2 $

@@ -1046,8 +1056,9 @@ prettyImp impl = prettySe 10

10461056 | not impl = pretty f

10471057 prettySe p (PAppBind _ (PRef _ f) [])

10481058 | not impl = text "!" <+> pretty f

1049− prettySe p (PApp _ (PRef _ op@(UN (f:_))) args)

1050− | length (getExps args) == 2 && (not impl) && (not $ isAlpha f) =

1059+ prettySe p (PApp _ (PRef _ op@(UN nm)) args)

1060+ | not (tnull nm) &&

1061+ length (getExps args) == 2 && (not impl) && (not $ isAlpha (thead nm)) =

10511062 let [l, r] = getExps args in

10521063 bracket p 1 $

10531064 if size r > breakingSize then

@@ -1160,8 +1171,8 @@ showName ist bnd impl colour n = case ist of

11601171 Nothing -> showbasic n

11611172 where name = if impl then show n else showbasic n

11621173 showbasic n@(UN _) = showCG n

1163− showbasic (MN _ s) = s

1164− showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

1174+ showbasic (MN _ s) = str s

1175+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

11651176 showbasic (SN s) = show s

11661177 fst3 (x, _, _) = x

11671178 colourise n t = let ctxt' = fmap tt_ctxt ist in

@@ -1235,8 +1246,9 @@ showImp ist impl colour tm = se 10 [] tm where

12351246 | not impl = se p bnd hd

12361247 se p bnd (PAppBind _ hd@(PRef _ f) [])

12371248 | not impl = "!" ++ se p bnd hd

1238− se p bnd (PApp _ op@(PRef _ (UN (f:_))) args)

1239− | length (getExps args) == 2 && not impl && not (isAlpha f)

1249+ se p bnd (PApp _ op@(PRef _ (UN nm)) args)

1250+ | not (tnull nm) &&

1251+ length (getExps args) == 2 && not impl && not (isAlpha (thead nm))

12401252 = let [l, r] = getExps args in

12411253 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

12421254 se p bnd (PApp _ f as)

@@ -1280,13 +1292,14 @@ showImp ist impl colour tm = se 10 [] tm where

12801292 se p bnd (PElabError s) = show s

12811293 se p bnd (PCoerced t) = se p bnd t

12821294 se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t

1295+ se p bnd (PDisamb ns t) = "%disamb " ++ show ns ++ se p bnd t

12831296 se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t

12841297-- se p bnd x = "Not implemented"

12851298

12861299 slist' p bnd (PApp _ (PRef _ nil) _)

1287− | not impl && nsroot nil == UN "Nil" = Just []

1300+ | not impl && nsroot nil == sUN "Nil" = Just []

12881301 slist' p bnd (PApp _ (PRef _ cons) args)

1289− | nsroot cons == UN "::",

1302+ | nsroot cons == sUN "::",

12901303 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

12911304 all isImp imps,

12921305 Just tl' <- slist' p bnd tl

@@ -1360,6 +1373,7 @@ instance Sized PTerm where

13601373 size (PAlternative a alts) = 1 + size alts

13611374 size (PHidden hidden) = size hidden

13621375 size (PUnifyLog tm) = size tm

1376+ size (PDisamb _ tm) = size tm

13631377 size (PNoImplicits tm) = size tm

13641378 size PType = 1

13651379 size (PConstant const) = 1 + size const

@@ -1383,6 +1397,7 @@ allNamesIn tm = nub $ ni [] tm

13831397 where

13841398 ni env (PRef _ n)

13851399 | not (n `elem` env) = [n]

1400+ ni env (PPatvar _ n) = [n]

13861401 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

13871402 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

13881403 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

@@ -1397,11 +1412,34 @@ allNamesIn tm = nub $ ni [] tm

13971412 ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r

13981413 ni env (PAlternative a ls) = concatMap (ni env) ls

13991414 ni env (PUnifyLog tm) = ni env tm

1415+ ni env (PDisamb _ tm) = ni env tm

14001416 ni env (PNoImplicits tm) = ni env tm

14011417 ni env _ = []

14021418

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 _ = []

14041441

1442+-- Return names which are free in the given term.

14051443namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

14061444namesIn uvars ist tm = nub $ ni [] tm

14071445 where

@@ -1424,6 +1462,7 @@ namesIn uvars ist tm = nub $ ni [] tm

14241462 ni env (PAlternative a as) = concatMap (ni env) as

14251463 ni env (PHidden tm) = ni env tm

14261464 ni env (PUnifyLog tm) = ni env tm

1465+ ni env (PDisamb _ tm) = ni env tm

14271466 ni env (PNoImplicits tm) = ni env tm

14281467 ni env _ = []

14291468

@@ -1451,6 +1490,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

14511490 ni env (PAlternative a as) = concatMap (ni env) as

14521491 ni env (PHidden tm) = ni env tm

14531492 ni env (PUnifyLog tm) = ni env tm

1493+ ni env (PDisamb _ tm) = ni env tm

14541494 ni env (PNoImplicits tm) = ni env tm

14551495 ni env _ = []

14561496

src/Idris/CaseSplit.hs+13−12

@@ -91,7 +91,8 @@ inventName ist ty n =

9191 Nothing -> []

9292 Just t -> getNameHints ist t

9393 let nsupp = case n of

94− MN i ('_':_) -> mkSupply (supp ++ varlist)

94+ MN i n | not (tnull n) && thead n == '_'

95+ -> mkSupply (supp ++ varlist)

9596 MN i n -> mkSupply (UN n : supp ++ varlist)

9697 x -> mkSupply (x : supp)

9798 let badnames = map snd (namemap ms) ++ map snd (invented ms) ++

@@ -106,7 +107,7 @@ inventName ist ty n =

106107mkSupply ns = mkSupply' ns (map nextName ns)

107108 where mkSupply' xs ns' = xs ++ mkSupply ns'

108109

109−varlist = map (UN . (:[])) "xyzwstuv" -- EB's personal preference :)

110+varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

110111

111112stripNS tm = mapPT dens tm where

112113 dens (PRef fc n) = PRef fc (nsroot n)

@@ -164,7 +165,7 @@ argTys ist (PRef fc n)

164165 = case lookupTy n (tt_ctxt ist) of

165166 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166167 _ -> repeat Nothing

167− where tyName (Bind _ (Pi _) _) = Just (UN "->")

168+ where tyName (Bind _ (Pi _) _) = Just (sUN "->")

168169 tyName t | (P _ n _, _) <- unApply t = Just n

169170 | otherwise = Nothing

170171argTys _ _ = repeat Nothing

@@ -264,8 +265,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

264265

265266 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266267 -- this isn't supported in a pattern, so special case here

267− nshow (PRef _ (UN "Z")) = "Z"

268− nshow (PApp _ (PRef _ (UN "S")) [x]) =

268+ nshow (PRef _ (UN z)) | z == txt "Z" = "Z"

269+ nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" =

269270 "S " ++ addBrackets (nshow (getTm x))

270271 nshow t = show t

271272

@@ -296,7 +297,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

296297getUniq nm i

297298 = do ist <- getIState

298299 let n = nameRoot [] nm ++ "_" ++ show i

299− case lookupTy (UN n) (tt_ctxt ist) of

300+ case lookupTy (sUN n) (tt_ctxt ist) of

300301 [] -> return (n, i+1)

301302 _ -> getUniq nm (i+1)

302303

@@ -324,14 +325,14 @@ getClause l fn fp = do ty <- getInternalApp fp l

324325 mkApp i _ _ = ""

325326

326327 getNameFrom i used (PPi _ _ _ _)

327− = uniqueNameFrom (mkSupply [UN "f", UN "g"]) used

328+ = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

328329 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

330331 getNameFrom i used (PRef fc f)

331332 = case getNameHints i f of

332− [] -> uniqueName (UN "x") used

333+ [] -> uniqueName (sUN "x") used

333334 ns -> uniqueNameFrom (mkSupply ns) used

334− getNameFrom i used _ = uniqueName (UN "x") used

335+ getNameFrom i used _ = uniqueName (sUN "x") used

335336

336337getProofClause :: Int -- ^ line number that the type is declared

337338 -> Name -- ^ Function name

@@ -363,11 +364,11 @@ mkWith str n = let str' = replaceRHS str "with (_)"

363364nameMissing :: [PTerm] -> Idris [PTerm]

364365nameMissing ps = do ist <- get

365366 newPats <- mapM nm ps

366− let newPats' = mergeAllPats ist (UN "_") (base (head ps))

367+ let newPats' = mergeAllPats ist (sUN "_") (base (head ps))

367368 newPats

368369 return (map fst newPats')

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

371372 base t = t

372373

373374 nm ptm = do mptm <- elabNewPat ptm

src/Idris/Completion.hs+3−3

@@ -54,9 +54,9 @@ tactics = map fst tacticArgs

5454-- | Convert a name into a string usable for completion. Filters out names

5555-- that users probably don't want to see.

5656nameString :: Name -> Maybe String

57−nameString (UN ('@':_)) = Nothing

58−nameString (UN ('#':_)) = Nothing

59−nameString (UN n) = Just n

57+nameString (UN nm)

58+ | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing

59+nameString (UN n) = Just (str n)

6060nameString (NS n _) = nameString n

6161nameString _ = Nothing

6262

src/Idris/Core/CaseTree.hs+10−7

@@ -21,7 +21,8 @@ data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

2121 | ImpossibleCase -- ^ already checked to be impossible

2222 deriving (Eq, Ord, Functor)

2323{-!

24−deriving instance Binary SC

24+deriving instance Binary SC'

25+deriving instance NFData SC'

2526!-}

2627

2728type SC = SC' Term

@@ -33,7 +34,8 @@ data CaseAlt' t = ConCase Name Int [Name] !(SC' t)

3334 | DefaultCase !(SC' t)

3435 deriving (Show, Eq, Ord, Functor)

3536{-!

36−deriving instance Binary CaseAlt

37+deriving instance Binary CaseAlt'

38+deriving instance NFData CaseAlt'

3739!-}

3840

3941type CaseAlt = CaseAlt' Term

@@ -155,6 +157,7 @@ directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

155157directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

156158directUse fn@(App f a)

157159 | (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

158161 | otherwise = nub $ directUse f ++ directUse a

159162directUse (Proj x i) = nub $ directUse x

160163directUse _ = []

@@ -214,7 +217,7 @@ simpleCase tc cover reflect phase fc argtys cs

214217 then return t

215218 else Error (At fc (Msg "Typecase is not allowed"))

216219 Error err -> Error (At fc err)

217− where args = map (\i -> MN i "e") [0..]

220+ where args = map (\i -> sMN i "e") [0..]

218221 defaultCase True = STerm Erased

219222 defaultCase False = UnmatchedCase "Error"

220223 fstT (x, _, _) = x

@@ -298,8 +301,8 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

298301 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

299302 return $ PCon n t args'

300303 -- n + 1

301− toPat' (P _ (UN "prim__addBigInt") _)

302− [p, Constant (BI 1)]

304+ toPat' (P _ (UN pabi) _)

305+ [p, Constant (BI 1)] | pabi == txt "prim__addBigInt"

303306 = do p' <- toPat' p []

304307 return $ PSuc p'

305308 -- Typecase

@@ -331,7 +334,7 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

331334 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

332335 = do t' <- toPat' t []

333336 sc' <- toPat' sc []

334− return $ PReflected (UN "->") (t':sc':[])

337+ return $ PReflected (sUN "->") (t':sc':[])

335338 toPat' (P _ n _) args | reflect

336339 = do args' <- mapM (\x -> toPat' x []) args

337340 return $ PReflected n args'

@@ -488,7 +491,7 @@ argsToAlt rs@((r, m) : rest)

488491 uniq i n = n

489492

490493getVar :: 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)

492495

493496groupCons :: [Clause] -> State CS [Group]

494497groupCons cs = gc [] cs

src/Idris/Core/Constraints.hs+1

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

22module Idris.Core.Constraints(ucheck) where

33

44import Idris.Core.TT

5+import Idris.Core.Typecheck

56

67import Control.Applicative

78import Control.Arrow

src/Idris/Core/DeepSeq.hsnew file+114

@@ -0,0 +1,114 @@

1+module Idris.Core.DeepSeq where

2+

3+import Idris.Core.TT

4+import Idris.Core.CaseTree

5+

6+import Control.DeepSeq

7+

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

1616import Idris.Core.Evaluate

1717import Idris.Core.Typecheck

1818import Idris.Core.Unify

19+import Idris.Core.DeepSeq

1920

20−import Control.Monad.State

21+import Control.DeepSeq

22+import Control.Monad.State.Strict

2123import Data.Char

2224import Data.List

2325import Debug.Trace

@@ -46,7 +48,7 @@ proofFail :: Elab' aux a -> Elab' aux a

4648proofFail e = do s <- get

4749 case runStateT e s of

4850 OK (a, s') -> do put s'

49− return a

51+ return $! a

5052 Error err -> lift $ Error (ProofSearchFail err)

5153

5254explicit :: Name -> Elab' aux ()

@@ -64,11 +66,39 @@ loadState = do (ES p s e) <- get

6466 Just st -> put st

6567 _ -> fail "Nothing to undo"

6668

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+

6797errAt :: String -> Name -> Elab' aux a -> Elab' aux a

6898errAt thing n elab = do s <- get

6999 case runStateT elab s of

70100 OK (a, s') -> do put s'

71− return a

101+ return $! a

72102 Error (At f e) ->

73103 lift $ Error (At f (Elaborating thing n e))

74104 Error e -> lift $ Error (Elaborating thing n e)

@@ -77,7 +107,7 @@ erun :: FC -> Elab' aux a -> Elab' aux a

77107erun f elab = do s <- get

78108 case runStateT elab s of

79109 OK (a, s') -> do put s'

80− return a

110+ return $! a

81111 Error (ProofSearchFail (At f e))

82112 -> lift $ Error (ProofSearchFail (At f e))

83113 Error (At f e) -> lift $ Error (At f e)

@@ -95,7 +125,11 @@ initElaborator = newProof

95125elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

96126elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

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

99133

100134updateAux :: (aux -> aux) -> Elab' aux ()

101135updateAux f = do ES (ps, a) l p <- get

@@ -103,23 +137,27 @@ updateAux f = do ES (ps, a) l p <- get

103137

104138getAux :: Elab' aux aux

105139getAux = do ES (ps, a) _ _ <- get

106− return a

140+ return $! a

107141

108142unifyLog :: Bool -> Elab' aux ()

109143unifyLog log = do ES (ps, a) l p <- get

110144 put (ES (ps { unifylog = log }, a) l p)

111145

146+getUnifyLog :: Elab' aux Bool

147+getUnifyLog = do ES (ps, a) l p <- get

148+ return (unifylog ps)

149+

112150processTactic' t = do ES (p, a) logs prev <- get

113151 (p', log) <- lift $ processTactic t p

114152 put (ES (p', a) (logs ++ log) prev)

115− return ()

153+ return $! ()

116154

117155-- Some handy gadgets for pulling out bits of state

118156

119157-- get the global context

120158get_context :: Elab' aux Context

121159get_context = do ES p _ _ <- get

122− return (context (fst p))

160+ return $! (context (fst p))

123161

124162-- update the context

125163-- (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

131169-- get the proof term

132170get_term :: Elab' aux Term

133171get_term = do ES p _ _ <- get

134− return (pterm (fst p))

172+ return $! (pterm (fst p))

135173

136174-- get the proof term

137175update_term :: (Term -> Term) -> Elab' aux ()

@@ -146,24 +184,24 @@ get_env = do ES p _ _ <- get

146184

147185get_holes :: Elab' aux [Name]

148186get_holes = do ES p _ _ <- get

149− return (holes (fst p))

187+ return $! (holes (fst p))

150188

151189get_probs :: Elab' aux Fails

152190get_probs = do ES p _ _ <- get

153− return (problems (fst p))

191+ return $! (problems (fst p))

154192

155193-- get the current goal type

156194goal :: Elab' aux Type

157195goal = do ES p _ _ <- get

158196 b <- lift $ goalAtFocus (fst p)

159− return (binderTy b)

197+ return $! (binderTy b)

160198

161199-- Get the guess at the current hole, if there is one

162200get_guess :: Elab' aux Type

163201get_guess = do ES p _ _ <- get

164202 b <- lift $ goalAtFocus (fst p)

165203 case b of

166− Guess t v -> return v

204+ Guess t v -> return $! v

167205 _ -> fail "Not a guess"

168206

169207-- typecheck locally

@@ -171,22 +209,22 @@ get_type :: Raw -> Elab' aux Type

171209get_type tm = do ctxt <- get_context

172210 env <- get_env

173211 (val, ty) <- lift $ check ctxt env tm

174− return (finalise ty)

212+ return $! (finalise ty)

175213

176214get_type_val :: Raw -> Elab' aux (Term, Type)

177215get_type_val tm = do ctxt <- get_context

178216 env <- get_env

179217 (val, ty) <- lift $ check ctxt env tm

180− return (finalise val, finalise ty)

218+ return $! (finalise val, finalise ty)

181219

182220-- get holes we've deferred for later definition

183221get_deferred :: Elab' aux [Name]

184222get_deferred = do ES p _ _ <- get

185− return (deferred (fst p))

223+ return $! (deferred (fst p))

186224

187225checkInjective :: (Term, Term, Term) -> Elab' aux ()

188226checkInjective (tm, l, r) = do ctxt <- get_context

189− if isInj ctxt tm then return ()

227+ if isInj ctxt tm then return $! ()

190228 else lift $ tfail (NotInjective tm l r)

191229 where isInj ctxt (P _ n _)

192230 | isConName n ctxt = True

@@ -199,7 +237,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

199237-- get instance argument names

200238get_instances :: Elab' aux [Name]

201239get_instances = do ES p _ _ <- get

202− return (instances (fst p))

240+ return $! (instances (fst p))

203241

204242-- given a desired hole name, return a unique hole name

205243unique_hole = unique_hole' False

@@ -209,13 +247,14 @@ unique_hole' reusable n

209247 = do ES p _ _ <- get

210248 let bs = bound_in (pterm (fst p)) ++

211249 bound_in (ptype (fst p))

212− n' <- return $ uniqueNameCtxt (context (fst p)) n (holes (fst p)

213− ++ bs ++ dontunify (fst p) ++ usedns (fst p))

250+ let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p)

251+ n' <- return $! uniqueNameCtxt (context (fst p)) n nouse

214252 ES (p, a) s u <- get

215− -- Hmm: Do we need this level of uniqueness?

216− let p' = p -- if reusable then p else p { usedns = n' : usedns p }

217− put (ES (p', a) s u)

218− return n'

253+ case n' of

254+ MN i _ -> when (i >= nextname p) $

255+ put (ES (p { nextname = i + 1 }, a) s u)

256+ _ -> return $! ()

257+ return $! n'

219258 where

220259 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

221260 where

@@ -231,7 +270,7 @@ elog str = do ES p logs prev <- get

231270

232271getLog :: Elab' aux String

233272getLog = do ES p logs _ <- get

234− return logs

273+ return $! logs

235274

236275-- The primitives, from ProofState

237276

@@ -312,11 +351,12 @@ equiv tm = processTactic' (Equiv tm)

312351

313352patvar :: Name -> Elab' aux ()

314353patvar n = do env <- get_env

354+ hs <- get_holes

315355 if (n `elem` map fst env) then do apply (Var n) []; solve

316356 else do n' <- case n of

317− UN _ -> return n

357+ UN _ -> return $! n

318358 MN _ _ -> unique_hole n

319− NS _ _ -> return n

359+ NS _ _ -> return $! n

320360 processTactic' (PatVar n')

321361

322362patbind :: Name -> Elab' aux ()

@@ -356,13 +396,13 @@ reorder_claims n = processTactic' (Reorder n)

356396qed :: Elab' aux Term

357397qed = do processTactic' QED

358398 ES p _ _ <- get

359− return (pterm (fst p))

399+ return $! (pterm (fst p))

360400

361401undo :: Elab' aux ()

362402undo = processTactic' Undo

363403

364404prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

365−prepare_apply fn imps =

405+prepare_apply fn imps =

366406 do ty <- get_type fn

367407 ctxt <- get_context

368408 env <- get_env

@@ -377,18 +417,18 @@ prepare_apply fn imps =

377417-- case claims of

378418-- [] -> return ()

379419-- (h : _) -> reorder_claims h

380− return claims

420+ return $! claims

381421 where

382422 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

383423 do let t = rebind hs t_in

384− n <- unique_hole (mkMN n')

424+ n <- getNameFrom (mkMN n')

385425-- when (null claims) (start_unify n)

386426 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)) $

388428 claim n (forget t)

389429 when i (movelast n)

390430 mkClaims sc' is (n : claims) hs

391− mkClaims t [] claims _ = return (reverse claims)

431+ mkClaims t [] claims _ = return $! (reverse claims)

392432 mkClaims _ _ _ _

393433 | Var n <- fn

394434 = do ctxt <- get_context

@@ -400,9 +440,9 @@ prepare_apply fn imps =

400440 doClaim ((i, _), n, t) = do claim n t

401441 when i (movelast n)

402442

403− mkMN n@(MN _ _) = n

404− mkMN n@(UN x) = MN 1000 x

405− mkMN n@(SN s) = MN 1000 (show s)

443+ mkMN n@(MN i _) = n

444+ mkMN n@(UN x) = MN 99999 x

445+ mkMN n@(SN s) = sMN 99999 (show s)

406446 mkMN (NS n xs) = NS (mkMN n) xs

407447

408448 rebind hs (Bind n t sc)

@@ -419,16 +459,13 @@ match_apply = apply' match_fill

419459apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

420460apply' fillt fn imps =

421461 do args <- prepare_apply fn (map fst imps)

422− env <- get_env

423− g <- goal

424462 -- _Don't_ solve the arguments we're specifying by hand.

425463 -- (remove from unified list before calling end_unify)

426464 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

427465 -- so do nothing

428− ptm <- get_term

429466 hs <- get_holes

430467 ES (p, a) s prev <- get

431− let dont = nub $ head hs : dontunify p ++

468+ let dont = head hs : dontunify p ++

432469 if null imps then [] -- do all we can

433470 else

434471 map fst (filter (not.snd) (zip args (map fst imps)))

@@ -441,13 +478,10 @@ apply' fillt fn imps =

441478 put (ES (p { dontunify = dont, unified = (n, unify),

442479 notunified = notunify ++ notunified p }, a) s prev)

443480 fillt (raw_apply fn (map Var args))

444− ptm <- get_term

445− g <- goal

446481-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

447482 end_unify

448− ptm <- get_term

449− return (map (updateUnify unify) args)

450− where updateUnify hs n = case lookup n hs of

483+ return $! (map (updateUnify unify) args)

484+ where updateUnify us n = case lookup n us of

451485 Just (P _ t _) -> t

452486 _ -> n

453487

@@ -460,7 +494,7 @@ apply2 fn elabs =

460494 let (n, hs) = unified p

461495 end_unify

462496 solve

463− where elabArgs [] [] = return ()

497+ where elabArgs [] [] = return $! ()

464498 elabArgs (n:ns) (Just e:es) = do focus n; e

465499 elabArgs ns es

466500 elabArgs (n:ns) (_:es) = elabArgs ns es

@@ -491,18 +525,18 @@ apply_elab n args =

491525 let sc' = instantiate (P Bound n t) sc

492526 claim n (forget t)

493527 case i of

494− Nothing -> return ()

528+ Nothing -> return $! ()

495529 Just _ -> -- don't solve by unification as there is an explicit value

496530 do ES (p, a) s prev <- get

497531 put (ES (p { dontunify = n : dontunify p }, a) s prev)

498532 doClaims sc' is ((n, i) : claims)

499− doClaims t [] claims = return (reverse claims)

533+ doClaims t [] claims = return $! (reverse claims)

500534 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

501535

502536 elabClaims failed r []

503− | null failed = return ()

537+ | null failed = return $! ()

504538 | otherwise = if r then elabClaims [] False failed

505− else return ()

539+ else return $! ()

506540 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

507541 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

508542 | r = try (do ES p _ _ <- get

@@ -512,7 +546,7 @@ apply_elab n args =

512546 focus n; elaboration; elabClaims failed r xs

513547

514548 mkMN n@(MN _ _) = n

515− mkMN n@(UN x) = MN 1000 x

549+ mkMN n@(UN x) = MN 0 x

516550 mkMN (NS n ns) = NS (mkMN n) ns

517551

518552-- If the goal is not a Pi-type, invent some names and make it a pi type

@@ -521,9 +555,9 @@ checkPiGoal n

521555 = do g <- goal

522556 case g of

523557 Bind _ (Pi _) _ -> return ()

524− _ -> do a <- unique_hole (MN 0 "pargTy")

525− b <- unique_hole (MN 0 "pretTy")

526− f <- unique_hole (MN 0 "pf")

558+ _ -> do a <- getNameFrom (sMN 0 "pargTy")

559+ b <- getNameFrom (sMN 0 "pretTy")

560+ f <- getNameFrom (sMN 0 "pf")

527561 claim a RType

528562 claim b RType

529563 claim f (RBind n (Pi (Var a)) (Var b))

@@ -535,13 +569,13 @@ checkPiGoal n

535569

536570simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

537571simple_app fun arg appstr =

538− do a <- unique_hole (MN 0 "argTy")

539− b <- unique_hole (MN 0 "retTy")

540− f <- unique_hole (MN 0 "f")

541− s <- unique_hole (MN 0 "s")

572+ do a <- getNameFrom (sMN 0 "argTy")

573+ b <- getNameFrom (sMN 0 "retTy")

574+ f <- getNameFrom (sMN 0 "f")

575+ s <- getNameFrom (sMN 0 "s")

542576 claim a RType

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

545579 tm <- get_term

546580 start_unify s

547581 claim s (Var a)

@@ -570,17 +604,24 @@ arg n tyhole = do ty <- unique_hole tyhole

570604 forall n (Var ty)

571605

572606-- try a tactic, if it adds any unification problem, return an error

573−no_errors :: Elab' aux () -> Elab' aux ()

574−no_errors tac

575− = do ps <- get_probs

576− tac

577− ps' <- get_probs

578− if (length ps' > length ps) then

579− case reverse ps' of

580− ((x,y,env,err) : _) ->

581− let env' = map (\(x, b) -> (x, binderTy b)) env in

582− lift $ tfail $ CantUnify False x y err env' 0

583− else return ()

607+no_errors :: Elab' aux () -> Maybe Err -> Elab' aux ()

608+no_errors tac err

609+ = do ps <- get_probs

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

618+ ps' <- get_probs

619+ if (length ps' > length ps) then

620+ case reverse ps' of

621+ ((x,y,env,err) : _) ->

622+ let env' = map (\(x, b) -> (x, binderTy b)) env in

623+ lift $ tfail $ CantUnify False x y err env' 0

624+ else return $! ()

584625

585626-- Try a tactic, if it fails, try another

586627try :: Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -592,10 +633,10 @@ try' t1 t2 proofSearch

592633 ps <- get_probs

593634 case prunStateT 999999 False ps t1 s of

594635 OK ((v, _), s') -> do put s'

595− return v

636+ return $! v

596637 Error e1 -> if recoverableErr e1 then

597638 do case runStateT t2 s of

598− OK (v, s') -> do put s'; return v

639+ OK (v, s') -> do put s'; return $! v

599640 Error e2 -> if score e1 >= score e2

600641 then lift (tfail e1)

601642 else lift (tfail e2)

@@ -603,6 +644,7 @@ try' t1 t2 proofSearch

603644 where recoverableErr err@(CantUnify r x y _ _ _)

604645 = -- traceWhen r (show err) $

605646 r || proofSearch

647+ recoverableErr (CantSolveGoal _ _) = False

606648 recoverableErr (ProofSearchFail _) = False

607649 recoverableErr _ = True

608650

@@ -632,8 +674,8 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

632674 case prunStateT pmax True ps x s of

633675 OK ((v, newps), s') ->

634676 do let cs' = if (newps < pmax)

635− then [do put s'; return v]

636− else (do put s'; return v) : cs

677+ then [do put s'; return $! v]

678+ else (do put s'; return $! v) : cs

637679 tryAll' cs' newps f xs

638680 Error err -> do put s

639681 if (score err) < 100

src/Idris/Core/Evaluate.hs+31−25

@@ -9,11 +9,12 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

99 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

1010 addDatatype, addCasedef, simplifyCasedef, addOperator,

1111 lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

12+ mapDefCtxt,

1213 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

1314 Value(..), Quote(..), initEval, uniqueNameCtxt) where

1415

1516import Debug.Trace

16−import Control.Monad.State

17+import Control.Monad.State -- not Strict!

1718import qualified Data.Binary as B

1819import Data.Binary hiding (get, put)

1920

@@ -98,11 +99,11 @@ specialise ctxt env limits t

9899

99100simplify :: Context -> Env -> TT Name -> TT Name

100101simplify ctxt env t

101− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

102− (UN "assert_smaller", 0),

103− (UN "par", 0),

104− (UN "prim__syntactic_eq", 0),

105− (UN "fork", 0)]

102+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

103+ (sUN "assert_smaller", 0),

104+ (sUN "par", 0),

105+ (sUN "prim__syntactic_eq", 0),

106+ (sUN "fork", 0)]

106107 (map finalEntry env) (finalise t)

107108 [Simplify]

108109 quote 0 val) initEval

@@ -110,11 +111,11 @@ simplify ctxt env t

110111-- | Simplify for run-time (i.e. basic inlining)

111112rt_simplify :: Context -> Env -> TT Name -> TT Name

112113rt_simplify ctxt env t

113− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

114− (UN "assert_smaller", 0),

115− (UN "par", 0),

116− (UN "prim__syntactic_eq", 0),

117− (UN "prim_fork", 0)]

114+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

115+ (sUN "assert_smaller", 0),

116+ (sUN "par", 0),

117+ (sUN "prim__syntactic_eq", 0),

118+ (sUN "prim_fork", 0)]

118119 (map finalEntry env) (finalise t)

119120 [RunTT]

120121 quote 0 val) initEval

@@ -189,7 +190,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

189190 = not (inl || dict) || elem n stk

190191 | Simplify `elem` opts

191192 = (not (inl || dict) || elem n stk)

192− || (n == UN "prim__syntactic_eq")

193+ || (n == sUN "prim__syntactic_eq")

193194 | otherwise = False

194195

195196 getCases cd | simpl = cases_totcheck cd

@@ -227,11 +228,11 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

227228 ev ntimes stk top env (P nt n ty)

228229 = liftM (VP nt n) (ev ntimes stk top env ty)

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

231232 | otherwise = return $ VV i

232233 ev ntimes stk top env (Bind n (Let t v) sc)

233234 = 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

235236 wknV (-1) sc'

236237-- | otherwise

237238-- = do t' <- ev ntimes stk top env t

@@ -246,12 +247,13 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

246247 ev ntimes stk top env (Bind n (NLet t v) sc)

247248 = do t' <- ev ntimes stk top env (finalise t)

248249 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

250251 return $ VBind True n (Let t' v') (\x -> return sc')

251252 ev ntimes stk top env (Bind n b sc)

252253 = do b' <- vbind env b

254+ let n' = uniqueName n (map fst env)

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

255257 where vbind env t

256258-- | simpl

257259-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

@@ -344,7 +346,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

344346-- _ -> return $ unload env f args

345347-- specApply stk env f args = return $ unload env f args

346348

347− unload :: [Value] -> Value -> [Value] -> Value

349+ unload :: [(Name, Value)] -> Value -> [Value] -> Value

348350 unload env f [] = f

349351 unload env f (a:as) = unload env (VApp f a) as

350352

@@ -359,12 +361,12 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

359361 | otherwise = return (Nothing, args)

360362

361363 evTree :: [(Name, Int)] -> [Name] -> Bool ->

362− [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

364+ [(Name, Value)] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

363365 evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing

364366 evTree ntimes stk top env amap (STerm tm)

365367 = do let etm = pToVs (map fst amap) tm

366368 etm' <- ev ntimes stk (not (conHeaded tm))

367− (map snd amap ++ env) etm

369+ (amap ++ env) etm

368370 return $ Just etm'

369371 evTree ntimes stk top env amap (ProjCase t alts)

370372 = do t' <- ev ntimes stk top env t

@@ -393,7 +395,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

393395 chooseAlt env f' (getValArgs f')

394396 alts amap

395397

396− chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

398+ chooseAlt :: [(Name, Value)] -> Value -> (Value, [Value]) -> [CaseAlt] ->

397399 [(Name, Value)] ->

398400 Eval (Maybe ([(Name, Value)], SC))

399401 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

411413 chooseAlt env _ (VP _ n _, args) alts amap

412414 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

413415 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

414− | Just (ns, sc) <- findFn (UN "->") alts

416+ | Just (ns, sc) <- findFn (sUN "->") alts

415417 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

416418 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

417419 chooseAlt _ _ _ alts amap

@@ -491,7 +493,7 @@ instance Quote Value where

491493 = do sc' <- quote i sc

492494 t' <- quote i t

493495 v' <- quote i v

494− let sc'' = pToV (MN vd "vlet") (addBinder sc')

496+ let sc'' = pToV (sMN vd "vlet") (addBinder sc')

495497 return (Bind n (Let t' v') sc'')

496498 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

497499 quote i (VType u) = return $ TType u

@@ -512,9 +514,9 @@ wknV i t = return t

512514

513515convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

514516

515−convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

517+convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

516518convEq 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

518520 ceq ps (P xt x _) (P yt y _)

519521 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

520522 | otherwise = sameDefs ps x y

@@ -696,6 +698,10 @@ data Context = MkContext {

696698-- | The initial empty context

697699initContext = MkContext [] 0 emptyContext

698700

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+

699705-- | Get the definitions from a context

700706ctxtAlist :: Context -> [(Name, Def)]

701707ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

@@ -886,7 +892,7 @@ lookupDefAcc :: Name -> Bool -> Context ->

886892lookupDefAcc n mkpublic ctxt

887893 = map mkp $ lookupCtxt n (definitions ctxt)

888894 -- 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"))

890896 then (d, Public) else (d, a)

891897

892898lookupTotal :: Name -> Context -> [Totality]

src/Idris/Core/Execute.hs+65−49

@@ -96,7 +96,7 @@ toTT (EApp e1 e2) = do e1' <- toTT e1

9696toTT (EType u) = return $ TType u

9797toTT EErased = return Erased

9898toTT (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

100100toTT (EHandle _) = return Erased

101101

102102unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -173,7 +173,7 @@ execute tm = do est <- initState

173173 Right tm' -> return tm'

174174

175175ioWrap :: 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]

177177

178178ioUnit :: ExecVal

179179ioUnit = ioWrap (EP Ref unitCon EErased)

@@ -219,8 +219,9 @@ execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

219219execApp env ctxt (f, args) = do newF <- doExec env ctxt f

220220 laziness <- (++ repeat False) <$> (getLaziness newF)

221221 newArgs <- mapM argExec (zip args laziness)

222− execApp' env ctxt newF newArgs

223− where getLaziness (EP _ (UN "lazy") _) = return [False, True]

222+ res <- execApp' env ctxt newF newArgs

223+ return res

224+ where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

224225 getLaziness (EP _ n _) = do est <- getExecState

225226 let argInfo = exec_implicits est

226227 case lookupCtxtName n argInfo of

@@ -235,28 +236,36 @@ execApp env ctxt (f, args) = do newF <- doExec env ctxt f

235236

236237execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237238execApp' 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 v rest

240−

241−execApp' env ctxt (EP _ (UN "prim_io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =

239+execApp' env ctxt (EP _ fp _) (ty:action:rest)

240+ | fp == upio,

241+ (prim__IO, [_, v]) <- unApplyV action

242+ = execApp' env ctxt v rest

243+

244+execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

245+ | fp == piobind,

246+ (prim__IO, [_, v']) <- unApplyV v =

242247 do v'' <- tryForce v'

243248 res <- execApp' env ctxt k [v''] >>= tryForce

244249 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 =

246252 do v' <- tryForce v

247253 execApp' env ctxt (mkEApp con [tp, v']) rest

248254

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

251− | Just (FFun "putStr" _ _) <- foreignFromTT fn

256+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

257+ | fp == mkfprim,

258+ Just (FFun "putStr" _ _) <- foreignFromTT fn

252259 = do execIO (putStr arg)

253260 execApp' env ctxt ioUnit rest

254−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

255− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

261+execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

262+ | fp == mkfprim,

263+ Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

256264 = do contents <- execIO $ hGetLine h

257265 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

258−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

259− | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

266+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

267+ | fp == mkfprim,

268+ Just (FFun "fileOpen" _ _) <- foreignFromTT fn

260269 = do m <- case mode of

261270 "r" -> return ReadMode

262271 "w" -> return WriteMode

@@ -268,42 +277,46 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268277 h <- execIO $ openFile f m

269278 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

270279

271−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

272− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

280+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

281+ | fp == mkfprim,

282+ Just (FFun "fileEOF" _ _) <- foreignFromTT fn

273283 = do eofp <- execIO $ hIsEOF h

274284 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

275285 execApp' env ctxt res (tail rest)

276286

277−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

278− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

287+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

288+ | fp == mkfprim,

289+ Just (FFun "fileClose" _ _) <- foreignFromTT fn

279290 = do execIO $ hClose h

280291 execApp' env ctxt ioUnit (tail rest)

281292

282−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

283− | Just (FFun "isNull" _ _) <- foreignFromTT fn

293+execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

294+ | fp == mkfprim,

295+ Just (FFun "isNull" _ _) <- foreignFromTT fn

284296 = let res = ioWrap . EConstant . I $

285297 if p == nullPtr then 1 else 0

286298 in execApp' env ctxt res (tail rest)

287299

288300-- A foreign-returned char* has to be tested for NULL sometimes

289−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str s):rest)

290− | Just (FFun "isNull" _ _) <- foreignFromTT fn

301+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

302+ | fp == mkfprim,

303+ Just (FFun "isNull" _ _) <- foreignFromTT fn

291304 = let res = ioWrap . EConstant . I $ 0

292305 in execApp' env ctxt res (tail rest)

293306

294307-- Throw away the 'World' argument to the foreign function

295308

296−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

297− | Just (FFun f argTs retT) <- foreignFromTT fn

298− , length xs >= length argTs =

299− do let (args', xs') = (take (length argTs) xs, -- foreign args

300− drop (length argTs + 1) xs) -- rest

301− res <- stepForeign (ty:fn:args')

302− case res of

303− Nothing -> fail $ "Could not call foreign function \"" ++ f ++

304− "\" with args " ++ show args

305− Just r -> return (mkEApp r xs')

306− | otherwise = return (mkEApp f args)

309+execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

310+ = case foreignFromTT fn of

311+ Just (FFun f argTs retT) | length xs >= length argTs ->

312+ do let (args', xs') = (take (length argTs) xs, -- foreign args

313+ drop (length argTs + 1) xs) -- rest

314+ res <- stepForeign (ty:fn:args')

315+ case res of

316+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++

317+ "\" with args " ++ show args

318+ Just r -> return (mkEApp r xs')

319+ Nothing -> return (mkEApp f args)

307320

308321execApp' env ctxt c@(EP (DCon _ arity) n _) args =

309322 do args' <- mapM tryForce (take arity args)

@@ -343,13 +356,23 @@ execApp' env ctxt (EThunk i) args = do f <- force i

343356execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

344357execApp' env ctxt f args = return (mkEApp f args)

345358

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+

346367-- | Look up primitive operations in the global table and transform them into ExecVal functions

347368getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

348−getOp (UN "prim__believe_me") [_, _, x] = Just (return x)

349−getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =

369+getOp fn [_, _, x] | fn == pbm = Just (return x)

370+getOp fn [EP _ fn' _]

371+ | fn == prs && fn' == pstd =

350372 Just $ do line <- execIO getLine

351373 return (EConstant (Str line))

352−getOp (UN "prim__readString") [EHandle h] =

374+getOp fn [EHandle h]

375+ | fn == prs =

353376 Just $ do contents <- execIO $ hGetLine h

354377 return (EConstant (Str (contents ++ "\n")))

355378getOp n args = getPrim n primitives >>= flip applyPrim args

@@ -478,11 +501,12 @@ foreignFromTT t = case (unApplyV t) of

478501 argFTy <- sequence $ map getFTy argTy

479502 retFTy <- getFTy ret

480503 return $ FFun name argFTy retFTy

481− _ -> trace "failed to construct ffun" Nothing

504+ _ -> trace ("failed to construct ffun") Nothing

482505

483506getFTy :: ExecVal -> Maybe FType

484−getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

485− case intTy of

507+getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))

508+ | fi == txt "FIntT" =

509+ case str intTy of

486510 "ITNative" -> Just (FArith (ATInt ITNative))

487511 "ITChar" -> Just (FArith (ATInt ITChar))

488512 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

@@ -491,7 +515,7 @@ getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

491515 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

492516 _ -> Nothing

493517getFTy (EP _ (UN t) _) =

494− case t of

518+ case str t of

495519 "FFloat" -> Just (FArith ATFloat)

496520 "FString" -> Just FString

497521 "FPtr" -> Just FPtr

@@ -499,14 +523,6 @@ getFTy (EP _ (UN t) _) =

499523 _ -> Nothing

500524getFTy _ = Nothing

501525

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−

510526unEList :: ExecVal -> Maybe [ExecVal]

511527unEList tm = case unApplyV tm of

512528 (nil, [_]) -> Just []

src/Idris/Core/ProofState.hs+33−31

@@ -13,7 +13,7 @@ import Idris.Core.Evaluate

1313import Idris.Core.TT

1414import Idris.Core.Unify

1515

16−import Control.Monad.State

16+import Control.Monad.State.Strict

1717import Control.Applicative hiding (empty)

1818import Data.List

1919import Debug.Trace

@@ -159,7 +159,7 @@ hole (Hole _) = True

159159hole (Guess _ _) = True

160160hole _ = False

161161

162−holeName i = MN i "hole"

162+holeName i = sMN i "hole"

163163

164164qshow :: Fails -> String

165165qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

@@ -209,7 +209,7 @@ getName :: Monad m => String -> StateT TState m Name

209209getName tag = do ps <- get

210210 let n = nextname ps

211211 put (ps { nextname = n+1 })

212− return $ MN n tag

212+ return $ sMN n tag

213213

214214action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

215215action a = do ps <- get

@@ -476,18 +476,12 @@ solve ctxt env (Bind x (Guess ty val) sc)

476476 | True = do ps <- get

477477 let (uh, uns) = unified ps

478478 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

482480 _ -> return []

483481 action (\ps -> ps { holes = holes ps \\ [x],

484482 solved = Just (x, val),

485−-- problems = solveInProblems

486−-- x val (problems ps),

487− -- dontunify = dontunify ps \\ [x],

488− -- unified = (uh, uns ++ [(x, val)]),

489483 instances = instances ps \\ [x] })

490− let tm' = instantiate val (pToV x sc) in

484+ let tm' = subst x val sc in

491485 return tm'

492486 | otherwise = lift $ tfail $ IncompleteTerm val

493487solve _ _ h@(Bind x t sc)

@@ -513,7 +507,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

513507 (tyv, tyt) <- lift $ check ctxt env ty

514508-- ns <- lift $ unify ctxt env tyv t'

515509 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

517511 do ns <- unify' ctxt env s tyv

518512 ps <- get

519513 let (uh, uns) = unified ps

@@ -532,7 +526,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

532526 _ -> hnf ctxt env t

533527 case t' of

534528 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

536530 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

537531 _ -> lift $ tfail $ CantIntroduce t'

538532intro n ctxt env _ = fail "Can't introduce here."

@@ -548,7 +542,7 @@ forall n ty ctxt env _ = fail "Can't pi bind here"

548542patvar :: Name -> RunTactic

549543patvar n ctxt env (Bind x (Hole t) sc) =

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

552546patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

553547

554548letbind :: Name -> Raw -> Raw -> RunTactic

@@ -568,16 +562,16 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

568562 do (tmv, tmt) <- lift $ check ctxt env tm

569563 let tmt' = normalise ctxt env tmt

570564 case unApply tmt' of

571− (P _ (UN "=") _, [lt,rt,l,r]) ->

565+ (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->

572566 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

573567 let newt = mkP l r l t

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

576570 [lt, l, r, p, tmv, xp]))

577571 (scv, sct) <- lift $ check ctxt env sc

578572 return scv

579573 _ -> lift $ tfail (NotEquality tmv tmt')

580− where rname = MN 0 "replaced"

574+ where rname = sMN 0 "replaced"

581575rewrite _ _ _ _ = fail "Can't rewrite here"

582576

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

633627 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

634628 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

635629 _ -> fail "Unkown type for induction"

636− where scname = MN 0 "scarg"

630+ where scname = sMN 0 "scarg"

637631 makeConsArg (nm, ty) = P Bound nm ty

638632 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

639633 bindConsArgs [] v = v

@@ -642,7 +636,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

642636 splitTyArgs param_pos tyargs =

643637 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

644638 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) []

646640 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

647641 let var = P Bound idnm idxt

648642 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' =

662656 x@(Bind y (PVTy s) t) -> x

663657 _ -> hnf ctxt env t

664658 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

666660 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

667661 _ -> fail "Nothing to pattern bind"

668662patbind n ctxt env _ = fail "Can't pattern bind here"

@@ -739,34 +733,42 @@ keepGiven du (u@(n, _) : us) hs

739733 | n `elem` du = u : keepGiven du us hs

740734keepGiven du (u : us) hs = keepGiven du us hs

741735

742−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

743− updateSolved' xs x

736+updateSolved xs x = updateSolved' xs x

737+updateSolved' [] x = x

744738updateSolved' 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)

746743updateSolved' xs (Bind n b t)

747744 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

748−updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

749−updateSolved' xs (P _ n _)

745+updateSolved' xs (App f a)

746+ = App (updateSolved' xs f) (updateSolved' xs a)

747+updateSolved' xs (P _ n@(MN _ _) _)

750748 | Just v <- lookup n xs = v

751749updateSolved' xs t = t

752750

751+updateEnv [] e = e

753752updateEnv ns [] = []

754753updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

755754

755+updateError [] err = err

756756updateError ns (CantUnify b l r e xs sc)

757757 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

758758updateError ns e = e

759759

760760solveInProblems x val [] = []

761761solveInProblems 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,

763763 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

764764

765+updateNotunified [] nu = nu

765766updateNotunified ns nu = up nu where

766767 up [] = []

767− up ((n, t) : ns) = let t' = updateSolved ns t in

768− ((n, t') : up ns)

768+ up ((n, t) : nus) = let t' = updateSolved ns t in

769+ ((n, t') : up nus)

769770

771+updateProblems ctxt [] ps inj holes = ([], ps)

770772updateProblems ctxt ns ps inj holes = up ns ps where

771773 up ns [] = (ns, [])

772774 up ns ((x, y, env, err) : ps) =

@@ -811,12 +813,11 @@ processTactic EndUnify ps

811813 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

812814 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

813815 (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

816817 return (ps { pterm = tm',

817818 unified = (h, []),

818819 problems = probs',

819− notunified = updateNotunified ns (notunified ps),

820+ notunified = updateNotunified ns'' (notunified ps),

820821 holes = holes ps \\ map fst ns'' }, "")

821822processTactic (Reorder n) ps

822823 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

@@ -841,6 +842,7 @@ processTactic MatchProblems ps

841842 pterm' = updateSolved ns' (pterm ps) in

842843 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843844 previous = Just ps, plog = "",

845+ notunified = updateNotunified ns' (notunified ps),

844846 holes = holes ps \\ (map fst ns') }, plog ps)

845847processTactic t ps

846848 = case holes ps of

src/Idris/Core/TC.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+

3+module Idris.Core.TC(TC'(..)) where

4+

5+import Control.Monad

6+import Control.Monad.Trans.Error(Error(..))

7+

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

1818 programs with implicit syntax into fully explicit terms.

1919-}

2020

21−module Idris.Core.TT where

21+module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where

2222

23−import Control.Monad.State

23+import Idris.Core.TC

24+

25+import Control.Monad.State.Strict

2426import Control.Monad.Trans.Error (Error(..))

2527import Debug.Trace

26−import qualified Data.Map as Map

28+import qualified Data.Map.Strict as Map

2729import Data.Char

30+import qualified Data.Text as T

2831import Data.List

2932import Data.Vector.Unboxed (Vector)

3033import qualified Data.Vector.Unboxed as V

@@ -74,37 +77,53 @@ instance Sized FC where

7477instance Show FC where

7578 show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c

7679

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.

7793data Err = Msg String

78− | InternalMsg String

79− | CantUnify Bool Term Term Err [(Name, Type)] Int

80− -- Int is 'score' - how much we did unify

81− -- Bool indicates recoverability, True indicates more info may make

82− -- unification succeed

83− | InfiniteUnify Name Term [(Name, Type)]

84− | CantConvert Term Term [(Name, Type)]

85− | UnifyScope Name Name Term [(Name, Type)]

86− | CantInferType String

87− | NonFunctionType Term Term

88− | NotEquality Term Term

89− | TooManyArguments Name

90− | CantIntroduce Term

91− | NoSuchVariable Name

92− | NoTypeDecl Name

93− | NotInjective Term Term Term

94− | CantResolve Term

95− | CantResolveAlts [String]

96− | IncompleteTerm Term

97− | UniverseError

98− | ProgramLineComment

99− | Inaccessible Name

100− | NonCollapsiblePostulate Name

101− | AlreadyDefined Name

102− | ProofSearchFail Err

103− | NoRewriting Term

104− | At FC Err

105− | Elaborating String Name Err

106− | ProviderError String

107− | LoadingFailed String Err

94+ | InternalMsg String

95+ | CantUnify Bool Term Term Err [(Name, Type)] Int

96+ -- Int is 'score' - how much we did unify

97+ -- Bool indicates recoverability, True indicates more info may make

98+ -- unification succeed

99+ | InfiniteUnify Name Term [(Name, Type)]

100+ | CantConvert Term Term [(Name, Type)]

101+ | CantSolveGoal Term [(Name, Type)]

102+ | UnifyScope Name Name Term [(Name, Type)]

103+ | CantInferType String

104+ | NonFunctionType Term Term

105+ | NotEquality Term Term

106+ | TooManyArguments Name

107+ | CantIntroduce Term

108+ | NoSuchVariable Name

109+ | NoTypeDecl Name

110+ | NotInjective Term Term Term

111+ | CantResolve Term

112+ | CantResolveAlts [String]

113+ | IncompleteTerm Term

114+ | UniverseError

115+ | ProgramLineComment

116+ | Inaccessible Name

117+ | NonCollapsiblePostulate Name

118+ | AlreadyDefined Name

119+ | ProofSearchFail Err

120+ | NoRewriting Term

121+ | At FC Err

122+ | Elaborating String Name Err

123+ | ProviderError String

124+ | LoadingFailed String Err

125+ | ReflectionError [[ErrorReportPart]] Err

126+ | ReflectionFailed String Err

108127 deriving Eq

109128{-!

110129deriving instance NFData Err

@@ -137,6 +156,7 @@ score (CantUnify _ _ _ m _ s) = s + score m

137156score (CantResolve _) = 20

138157score (NoSuchVariable _) = 1000

139158score (ProofSearchFail _) = 10000

159+score (CantSolveGoal _ _) = 10000

140160score (InternalMsg _) = -1

141161score _ = 0

142162

@@ -145,9 +165,10 @@ instance Show Err where

145165 show (InternalMsg s) = "Internal error: " ++ show s

146166 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

147167 ++ show e ++ " in " ++ show sc ++ " " ++ show i

168+ show (CantSolveGoal g _) = "CantSolve " ++ show g

148169 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

149170 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

151172 show ProgramLineComment = "Program line next to comment"

152173 show (At f e) = show f ++ ":" ++ show e

153174 show _ = "Error"

@@ -167,13 +188,11 @@ instance Pretty Err where

167188 pretty _ = text "Error"

168189

169190instance Error Err where

170− strMsg = Msg

191+ strMsg = InternalMsg

171192

172−data TC a = OK a

173− | Error Err

174− deriving (Eq, Functor)

193+type TC = TC' Err

175194

176−instance Pretty a => Pretty (TC a) where

195+instance (Pretty a) => Pretty (TC a) where

177196 pretty (OK ok) = pretty ok

178197 pretty (Error err) =

179198 if size err > breakingSize then

@@ -185,29 +204,16 @@ instance Show a => Show (TC a) where

185204 show (OK x) = show x

186205 show (Error str) = "Error: " ++ show str

187206

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−

198207tfail :: Err -> TC a

199208tfail e = Error e

200209

210+failMsg :: String -> TC a

211+failMsg str = Error (Msg str)

212+

201213trun :: FC -> TC a -> TC a

202214trun fc (OK a) = OK a

203215trun fc (Error e) = Error (At fc e)

204216

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−

211217discard :: Monad m => m a -> m ()

212218discard f = f >> return ()

213219

@@ -225,20 +231,44 @@ traceWhen False _ a = a

225231

226232-- | Names are hierarchies of strings, describing scope (so no danger of

227233-- duplicate names, but need to be careful on lookup).

228−data Name = UN String -- ^ User-provided name

229− | NS Name [String] -- ^ Root, namespaces

230− | MN Int String -- ^ Machine chosen names

234+data Name = UN T.Text -- ^ User-provided name

235+ | NS Name [T.Text] -- ^ Root, namespaces

236+ | MN Int T.Text -- ^ Machine chosen names

231237 | NErased -- ^ Name of somethng which is never used in scope

232238 | SN SpecialName -- ^ Decorated function names

239+ | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

233240 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+

234264{-!

235265deriving instance Binary Name

236266deriving instance NFData Name

237267!-}

238268

239269data SpecialName = WhereN Int Name Name

240− | InstanceN Name [String]

241− | ParentN Name String

270+ | InstanceN Name [T.Text]

271+ | ParentN Name T.Text

242272 | MethodN Name

243273 | CaseN Name

244274 | ElimN Name

@@ -248,6 +278,12 @@ deriving instance Binary SpecialName

248278deriving instance NFData SpecialName

249279!-}

250280

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+

251287instance Sized Name where

252288 size (UN n) = 1

253289 size (NS n els) = 1 + length els

@@ -255,36 +291,36 @@ instance Sized Name where

255291 size _ = 1

256292

257293instance Pretty Name where

258− pretty (UN n) = text n

294+ pretty (UN n) = text (T.unpack n)

259295 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

261297 pretty (SN s) = text (show s)

262298

263299instance Show Name where

264− show (UN n) = n

265− show (NS n s) = showSep "." (reverse s) ++ "." ++ show n

266− show (MN _ "underscore") = "_"

267− show (MN i s) = "{" ++ s ++ show i ++ "}"

300+ show (UN n) = str n

301+ show (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ show n

302+ show (MN _ u) | u == txt "underscore" = "_"

303+ show (MN i s) = "{" ++ str s ++ show i ++ "}"

268304 show (SN s) = show s

269305 show NErased = "_"

270306

271307instance Show SpecialName where

272308 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

274310 show (MethodN m) = "method " ++ show m

275− show (ParentN p c) = show p ++ "#" ++ c

311+ show (ParentN p c) = show p ++ "#" ++ T.unpack c

276312 show (CaseN n) = "case block in " ++ show n

277313 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

278314

279315-- Show a name in a way decorated for code generation, not human reading

280316showCG :: Name -> String

281−showCG (UN n) = n

282−showCG (NS n s) = showSep "." (reverse s) ++ "." ++ showCG n

283−showCG (MN _ "underscore") = "_"

284−showCG (MN i s) = "{" ++ s ++ show i ++ "}"

317+showCG (UN n) = T.unpack n

318+showCG (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCG n

319+showCG (MN _ u) | u == txt "underscore" = "_"

320+showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}"

285321showCG (SN s) = showCG' s

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

288324 showCG' (MethodN m) = '!':showCG m

289325 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

290326 showCG' (CaseN c) = showCG c ++ "_case"

@@ -297,9 +333,13 @@ showCG NErased = "_"

297333type Ctxt a = Map.Map Name (Map.Map Name a)

298334emptyContext = Map.empty

299335

336+mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b

337+mapCtxt = fmap . fmap

338+

300339-- |Return True if the argument 'Name' should be interpreted as the name of a

301340-- typeclass.

302−tcname (UN ('@':_)) = True

341+tcname (UN xs) | T.null xs = False

342+ | otherwise = T.head xs == '@'

303343tcname (NS n _) = tcname n

304344tcname (SN (InstanceN _ _)) = True

305345tcname (SN (MethodN _)) = True

@@ -307,7 +347,8 @@ tcname (SN (ParentN _ _)) = True

307347tcname _ = False

308348

309349implicitable (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)

311352implicitable (MN _ _) = True

312353implicitable _ = False

313354

@@ -472,22 +513,22 @@ deriving instance NFData Raw

472513-- | All binding forms are represented in a uniform fashion. This type only represents

473514-- the types of bindings (and their values, if any); the attached identifiers are part

474515-- of the 'Bind' constructor for the 'TT' type.

475−data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

476− | Pi { binderTy :: b }

516+data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

517+ | Pi { binderTy :: !b }

477518 {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -}

478− | Let { binderTy :: b,

519+ | Let { binderTy :: !b,

479520 binderVal :: b {-^ value for bound variable-}}

480521 -- ^ A binding that occurs in a @let@ expression

481− | NLet { binderTy :: b,

522+ | NLet { binderTy :: !b,

482523 binderVal :: b }

483− | Hole { binderTy :: b}

524+ | Hole { binderTy :: !b}

484525 | GHole { envlen :: Int,

485− binderTy :: b}

486− | Guess { binderTy :: b,

526+ binderTy :: !b}

527+ | Guess { binderTy :: !b,

487528 binderVal :: b }

488− | PVar { binderTy :: b }

529+ | PVar { binderTy :: !b }

489530 -- ^ A pattern variable

490− | PVTy { binderTy :: b }

531+ | PVTy { binderTy :: !b }

491532 deriving (Show, Eq, Ord, Functor)

492533{-!

493534deriving instance Binary Binder

@@ -592,12 +633,12 @@ instance Eq NameType where

592633data TT n = P NameType n (TT n) -- ^ named references with type

593634 -- (P for "Parameter", motivated by McKinna and Pollack's

594635 -- Pure Type Systems Formalized)

595− | V Int -- ^ a resolved de Bruijn-indexed variable

596− | Bind n (Binder (TT n)) (TT n) -- ^ a binding

597− | App (TT n) (TT n) -- ^ function, function type, arg

636+ | V !Int -- ^ a resolved de Bruijn-indexed variable

637+ | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

638+ | App !(TT n) (TT n) -- ^ function, function type, arg

598639 | Constant Const -- ^ constant

599− | Proj (TT n) Int -- ^ argument projection; runtime only

600− -- (-1) is a special case for 'subtract one from BI'

640+ | Proj (TT n) !Int -- ^ argument projection; runtime only

641+ -- (-1) is a special case for 'subtract one from BI'

601642 | Erased -- ^ an erased term

602643 | Impossible -- ^ special case for totality checking

603644 | TType UExp -- ^ the type of types at some level

@@ -624,10 +665,10 @@ instance TermSize (TT Name) where

624665 -- variable is the same as the name we're using

625666 -- So generate a different name in that case.

626667 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

628669 termsize rn v + termsize rn sc

629670 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

631672 termsize rn sc

632673 termsize n (App f a) = termsize n f + termsize n a

633674 termsize n (Proj t i) = termsize n t

@@ -656,8 +697,8 @@ data Datatype n = Data { d_typename :: n,

656697instance Eq n => Eq (TT n) where

657698 (==) (P xt x _) (P yt y _) = x == y

658699 (==) (V x) (V y) = x == y

659− (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys

660− (==) (App fx ax) (App fy ay) = fx == fy && ax == ay

700+ (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

701+ (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

661702 (==) (TType _) (TType _) = True -- deal with constraints later

662703 (==) (Constant x) (Constant y) = x == y

663704 (==) (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))

770811finalise (App f a) = App (finalise f) (finalise a)

771812finalise t = t

772813

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+

773823-- | As 'instantiate', but in addition to replacing @'V' 0@,

774824-- replace references to the given 'Name'-like id.

775825subst :: Eq n => n {-^ The id to replace -} ->

@@ -778,6 +828,16 @@ subst :: Eq n => n {-^ The id to replace -} ->

778828 TT n

779829subst n v tm = instantiate v (pToV n tm)

780830

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+

781841-- | As 'subst', but takes a list of (name, substitution) pairs instead

782842-- of a single name and substitution

783843substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

@@ -837,6 +897,14 @@ mkApp :: TT n -> [TT n] -> TT n

837897mkApp f [] = f

838898mkApp f (a:as) = mkApp (App f a) as

839899

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+

840908-- | Cast a 'TT' term to a 'Raw' value, discarding universe information and

841909-- the types of named references and replacing all de Bruijn indices

842910-- with the corresponding name. It is an error if there are free de

@@ -846,8 +914,9 @@ forget tm = fe [] tm

846914 where

847915 fe env (P _ n _) = Var n

848916 fe env (V i) = Var (env !! i)

849− fe env (Bind n b sc) = RBind n (fmap (fe env) b)

850− (fe (n:env) sc)

917+ fe env (Bind n b sc) = let n' = uniqueName n env in

918+ RBind n' (fmap (fe env) b)

919+ (fe (n':env) sc)

851920 fe env (App f a) = RApp (fe env f) (fe env a)

852921 fe env (Constant c)

853922 = RConstant c

@@ -898,13 +967,13 @@ uniqueBinders ns t = t

898967

899968nextName (NS x s) = NS (nextName x) s

900969nextName (MN i n) = MN (i+1) n

901−nextName (UN x) = let (num', nm') = span isDigit (reverse x)

902− nm = reverse nm'

903− num = readN (reverse num') in

904− UN (nm ++ show (num+1))

970+nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

971+ nm = T.reverse nm'

972+ num = readN (T.reverse num') in

973+ UN (nm `T.append` txt (show (num+1)))

905974 where

906− readN "" = 0

907− readN x = read x

975+ readN x | not (T.null x) = read (T.unpack x)

976+ readN x = 0

908977nextName (SN x) = SN (nextName' x)

909978 where

910979 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

10561125 pureBinder (Let t v) = pureTerm t && pureTerm v

10571126 pureBinder t = pureTerm (binderTy t)

10581127

1059− notClassName (MN _ "class") = False

1128+ notClassName (MN _ c) | c == txt "class" = False

10601129 notClassName _ = True

10611130

10621131pureTerm _ = True

src/Idris/Core/Typecheck.hs+1−1

@@ -88,7 +88,7 @@ check' holes ctxt env top = chk env top where

8888 -- make sure bound names in function types are locally unique, machine

8989 -- generated names, we'll be fine.

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

9292 (renameBinders (i+1) t)

9393 renameBinders i sc = sc

9494 chk env RType

src/Idris/Core/Unify.hs+27−7

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

66import Idris.Core.Evaluate

77

88import Control.Monad

9−import Control.Monad.State

9+import Control.Monad.State.Strict

1010import Data.List

1111import Debug.Trace

1212

@@ -35,22 +35,24 @@ match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

3535 TC [(Name, TT Name)]

3636match_unify ctxt env topx topy dont holes =

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

3939 res ->

4040 let topxn = normalise ctxt env topx

4141 topyn = normalise ctxt env topy in

4242 case runStateT (un [] topxn topyn)

4343 (UI 0 []) of

4444 OK (v, UI _ fails) ->

45− return (trimSolutions v)

45+ return (map (renameBinders env) (trimSolutions v))

4646 Error e ->

4747 -- just normalise the term we're matching against

4848 case runStateT (un [] topxn topy)

4949 (UI 0 []) of

5050 OK (v, UI _ fails) ->

51− return (trimSolutions v)

51+ return (map (renameBinders env) (trimSolutions v))

5252 _ -> tfail e

5353 where

54+

55+

5456 un names (P _ x _) tm

5557 | holeIn env x || x `elem` holes

5658 = do sc 1; checkCycle names (x, tm)

@@ -127,6 +129,23 @@ match_unify ctxt env topx topy dont holes =

127129 (inst ns tm) (errEnv env))

128130 where inst [] tm = tm

129131 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

130149

131150trimSolutions ns = dropPairs ns

132151 where dropPairs [] = []

@@ -154,7 +173,7 @@ unify ctxt env topx topy dont holes =

154173-- trace ("Unifying " ++ show (topx, topy)) $

155174 -- don't bother if topx and topy are different at the head

156175 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),

158177 [])

159178 res ->

160179 let topxn = normalise ctxt env topx

@@ -163,7 +182,8 @@ unify ctxt env topx topy dont holes =

163182 case runStateT (un False [] topxn topyn)

164183 (UI 0 []) of

165184 OK (v, UI _ fails) ->

166− return (trimSolutions v, reverse fails)

185+ return (map (renameBinders env) (trimSolutions v),

186+ reverse fails)

167187-- Error e@(CantUnify False _ _ _ _ _) -> tfail e

168188 Error e -> tfail e

169189 where

@@ -277,7 +297,7 @@ unify ctxt env topx topy dont holes =

277297

278298 un' fn bnames (App f x) (Bind n (Pi t) y)

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

281301 (Bind n (Pi t) (V 1)))

282302

283303 un' fn bnames (Bind x bx sx) (Bind y by sy)

src/Idris/Coverage.hs+13−10

@@ -15,7 +15,7 @@ import Data.Either

1515import Data.Maybe

1616import Debug.Trace

1717

18−import Control.Monad.State

18+import Control.Monad.State.Strict

1919

2020mkPatTm :: PTerm -> Idris Term

2121mkPatTm t = do i <- getIState

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

3131 return $ mkApp t' args'

3232 toTT _ = do v <- get

3333 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (sMN v "imp") Erased)

3535

3636-- Given a list of LHSs, generate a extra clauses which cover the remaining

3737-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -166,13 +166,13 @@ genAll i args

166166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167167 otherPats o@(PPair fc l r)

168168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

170− pimp (UN "B") Placeholder True] ++

169+ ([pimp (sUN "A") Placeholder True,

170+ pimp (sUN "B") Placeholder True] ++

171171 [pexp l, pexp r]) o

172172 otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

175− pimp (UN "P") Placeholder True] ++

173+ = ops fc (sUN "Ex_intro")

174+ ([pimp (sUN "a") Placeholder True,

175+ pimp (sUN "P") Placeholder True] ++

176176 [pexp t,pexp v]) o

177177 otherPats o@(PConstant c) = return o

178178 otherPats arg = return Placeholder

@@ -191,7 +191,8 @@ genAll i args

191191 getExpTm t = getTm t

192192

193193 -- 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"

195196 = PDPair fc (getTm t) Placeholder (getTm v)

196197 resugar (PApp _ (PRef fc n) [_,_,l,r])

197198 | n == pairCon

@@ -258,7 +259,8 @@ calcProd i fc topn pats

258259

259260 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260261 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

262264 | (P nt f _, args) <- unApply ap

263265 = do recOK <- checkProdRec (n:done) f

264266 let ctxt = tt_ctxt i

@@ -405,7 +407,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

405407 findCalls (dePat rhs) (patvars lhs) pargs

406408

407409 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"

409412 = findCalls arg pvs pargs

410413 | (P _ n _, args) <- unApply ap

411414 = mkChange n args pargs ++

src/Idris/DSL.hs+6−5

@@ -8,7 +8,7 @@ import Paths_idris

88import Idris.Core.TT

99import Idris.Core.Evaluate

1010

11−import Control.Monad.State

11+import Control.Monad.State.Strict

1212import Debug.Trace

1313

1414debindApp :: SyntaxInfo -> PTerm -> PTerm

@@ -44,6 +44,7 @@ expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

4444expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

4545expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)

4646expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t)

47+expandDo dsl (PDisamb ns t) = PDisamb ns (expandDo dsl t)

4748expandDo dsl (PReturn fc) = dsl_return dsl

4849expandDo dsl (PRewrite fc r t ty)

4950 = PRewrite fc r (expandDo dsl t) ty

@@ -57,8 +58,8 @@ expandDo dsl (PDoBlock ds)

5758 block b (DoBind fc n tm : rest)

5859 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

5960 block b (DoBindP fc p tm : rest)

60− = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

61− (PCase fc (PRef fc (MN 0 "bpat"))

61+ = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

62+ (PCase fc (PRef fc (sMN 0 "bpat"))

6263 [(p, block b rest)]))]

6364 block b (DoLet fc n ty tm : rest)

6465 = PLet n ty tm (block b rest)

@@ -67,7 +68,7 @@ expandDo dsl (PDoBlock ds)

6768 block b (DoExp fc tm : rest)

6869 = PApp fc b

6970 [pexp tm,

70− pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

71+ pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))]

7172 block b _ = PElabError (Msg "Invalid statement in do block")

7273

7374expandDo 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

131132 db' (PAppBind fc t args)

132133 = do args' <- dbs args

133134 (bs, n) <- get

134− let nm = MN n ("bindApp" ++ show n)

135+ let nm = sUN ("_bindApp" ++ show n)

135136 put ((nm, fc, PApp fc t args') : bs, n+1)

136137 return (PRef fc nm)

137138 db' (PApp fc t args)

src/Idris/DataOpts.hs+40−20

@@ -18,14 +18,16 @@ type ForceMap = M.IntMap Forceability

1818

1919-- Calculate the forceable arguments to a constructor

2020-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> Type -> Idris ()

22−forceArgs typeName n t = do

21+forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22+forceArgs typeName n expforce t = do

2323 ist <- getIState

2424 let fargs = getForcedArgs ist typeName t

2525 copt = case lookupCtxt n (idris_optimisation ist) of

2626 [] -> Optimise False False [] []

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

2931 putIState (ist { idris_optimisation = opts })

3032 addIBC (IBCOpt n)

3133 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

@@ -37,7 +39,7 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

3739

3840 -- Label all occurrences of the variable bound in Pi in the rest of

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

4143

4244 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

4345 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

@@ -73,7 +75,8 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

7375 guardedArgs t = bareArg t

7476

7577 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

7780 bareArg _ = M.empty

7881

7982 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

@@ -196,8 +199,14 @@ instance Optimisable Raw where

196199

197200 stripCollapsed t = return t

198201

199−instance Optimisable t => Optimisable (Binder t) where

200− applyOpts (Let t v) = Let <$> applyOpts t <*> applyOpts v

202+-- Erase types (makes ibc smaller, and we don't need them)

203+instance Optimisable (Binder (TT Name)) where

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

201210 applyOpts b = do t' <- applyOpts (binderTy b)

202211 return (b { binderTy = t' })

203212 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

@@ -221,17 +230,24 @@ applyDataOpt oi n args

221230

222231-- Run-time: do everything

223232

233+prel = [txt "Nat", txt "Prelude"]

234+

224235instance Optimisable (TT Name) where

225− applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _)

226− = return (P Ref (UN "prim__addBigInt") Erased)

227− applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _)

228− = return (P Ref (UN "prim__mulBigInt") Erased)

229− applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x)

236+ applyOpts (P _ (NS (UN fn) mod) _)

237+ | fn == txt "plus" && mod == prel

238+ = return (P Ref (sUN "prim__addBigInt") Erased)

239+ applyOpts (P _ (NS (UN fn) mod) _)

240+ | fn == txt "mult" && mod == prel

241+ = return (P Ref (sUN "prim__mulBigInt") Erased)

242+ applyOpts (App (P _ (NS (UN fn) mod) _) x)

243+ | fn == txt "fromIntegerNat" && mod == prel

230244 = applyOpts x

231− applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _)

232− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

233− applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _)

234− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

245+ applyOpts (P _ (NS (UN fn) mod) _)

246+ | fn == txt "fromIntegerNat" && mod == prel

247+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

248+ applyOpts (P _ (NS (UN fn) mod) _)

249+ | fn == txt "toIntegerNat" && mod == prel

250+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

235251 applyOpts c@(P (DCon t arity) n _)

236252 = do i <- getIState

237253 case lookupCtxt n (idris_optimisation i) of

@@ -282,16 +298,19 @@ applyDataOptRT oi n tag arity args

282298 (collapsible oi) (M.fromList $ forceable oi) in

283299 bind extra tm

284300 where

285− satArgs n = map (\i -> MN i "sat") [1..n]

301+ satArgs n = map (\i -> sMN i "sat") [1..n]

286302

287303 bind [] tm = tm

288304 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

289305

290306 -- Nat special cases

291307 -- TODO: Would be nice if this was configurable in idris source!

292− doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

293− doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

294− = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

308+ doOpts (NS (UN z) [nat, prelude]) [] _ _

309+ | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310+ = Constant (BI 0)

311+ doOpts (NS (UN s) [nat, prelude]) [k] _ _

312+ | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313+ = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

295314

296315 doOpts n args True _ = Erased

297316 doOpts n args _ forceMap

@@ -302,3 +321,4 @@ applyDataOptRT oi n tag arity args

302321 where

303322 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

304323 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

22

3+import Idris.Core.DeepSeq

34import Idris.Core.TT

4−import Idris.AbsSyntax

55import Idris.AbsSyntaxTree

66

77import Control.DeepSeq

@@ -12,32 +12,6 @@ instance NFData Forceability where

1212 rnf Conditional = ()

1313 rnf Unconditional = ()

1414

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−

4115instance NFData IntTy where

4216 rnf (ITFixed x1) = rnf x1 `seq` ()

4317 rnf ITNative = ()

@@ -45,85 +19,16 @@ instance NFData IntTy where

4519 rnf ITChar = ()

4620 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

4721

48−

4922instance NFData NativeTy where

5023 rnf IT8 = ()

5124 rnf IT16 = ()

5225 rnf IT32 = ()

5326 rnf IT64 = ()

54−

5527

5628instance NFData ArithTy where

5729 rnf (ATInt x1) = rnf x1 `seq` ()

5830 rnf ATFloat = ()

5931

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−

12732instance NFData SizeChange where

12833 rnf Smaller = ()

12934 rnf Same = ()

src/Idris/Delaborate.hs+30−9

@@ -9,6 +9,8 @@ import Idris.AbsSyntax

99import Idris.Core.TT

1010import Idris.Core.Evaluate

1111

12+import Data.List (intersperse)

13+

1214import Debug.Trace

1315

1416bugaddr = "https://github.com/idris-lang/Idris-dev/issues"

@@ -40,7 +42,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

4042

4143 de env _ (App f a) = deFn env f [a]

4244 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 ++ ""))

4446 de env _ (P _ n _) | n == unitTy = PTrue un

4547 | n == unitCon = PTrue un

4648 | n == falseTy = PFalse un

@@ -61,8 +63,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

6163 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

6264 de env _ (Bind n (Let ty val) sc)

6365 = 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

65− de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

66+ de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

67+ de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

6668 de env _ (Bind n _ sc) = de ((n,n):env) [] sc

6769 de env _ (Constant i) = PConstant i

6870 de env _ Erased = Placeholder

@@ -80,16 +82,16 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

8082 deFn env (P _ n _) [l,r]

8183 | n == pairTy = PPair un (de env [] l) (de env [] r)

8284 | n == eqCon = PRefl un (de env [] r)

83− | n == UN "lazy" = de env [] r

85+ | n == sUN "lazy" = de env [] r

8486 deFn env (P _ n _) [ty, Bind x (Lam _) r]

85− | n == UN "Exists"

87+ | n == sUN "Exists"

8688 = PDPair un (PRef un x) (de env [] ty)

8789 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

8890 deFn env (P _ n _) [_,_,l,r]

8991 | n == pairCon = PPair un (de env [] l) (de env [] r)

9092 | n == eqTy = PEq un (de env [] l) (de env [] r)

91− | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

92− (de env [] r)

93+ | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder

94+ (de env [] r)

9395 deFn env (P _ n _) args | not mvs

9496 = case lookup n (idris_metavars ist) of

9597 Just (Just _, mi, _) ->

@@ -140,6 +142,11 @@ pshow i (CantConvert x y env)

140142 "Can't convert" ++ indented (showImp (Just i) imps colour (delab i x)) ++ "with"

141143 ++ indented (showImp (Just i) imps colour (delab i y)) ++

142144 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 ""

143150pshow i (UnifyScope n out tm env)

144151 = let imps = opt_showimp (idris_options i) in

145152 let colour = idris_colourRepl i in

@@ -190,6 +197,20 @@ pshow i (Elaborating s n e) = "When elaborating " ++ s ++

190197 showqual i n ++ ":\n" ++ pshow i e

191198pshow i (ProviderError msg) = "Type provider error: " ++ msg

192199pshow 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+

193214

194215showSc i [] = ""

195216showSc 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)

204225 dens n = n

205226

206227showbasic n@(UN _) = show n

207−showbasic (MN _ s) = s

208−showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

228+showbasic (MN _ s) = str s

229+showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

209230showbasic (SN s) = show s

210231

211232

src/Idris/Docs.hs+1−1

@@ -107,7 +107,7 @@ docFun n

107107

108108 return (Doc n docstr args (delab i ty) f)

109109 where funName :: Name -> String

110− funName (UN n) = n

110+ funName (UN n) = str n

111111 funName (NS n _) = funName n

112112

113113

src/Idris/ElabDecls.hs+161−109

@@ -28,12 +28,13 @@ import Idris.Core.CaseTree

2828

2929import Control.DeepSeq

3030import Control.Monad

31−import Control.Monad.State

31+import Control.Monad.State.Strict as State

3232import Data.List

3333import Data.Maybe

3434import Debug.Trace

3535

3636import qualified Data.Map as Map

37+import qualified Data.Text as T

3738import Data.Char(isLetter, toLower)

3839import Data.List.Split (splitOn)

3940

@@ -91,8 +92,10 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

9192 let nty' = normalise ctxt [] nty

9293

9394 -- Add normalised type to internals

94− 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')))

95+ rep <- useREPL

96+ when rep $ do

97+ addInternalApp (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')))

9699

97100 let (t, _) = unApply (getRetTy nty')

98101 let corec = case t of

@@ -112,6 +115,19 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

112115 addIBC (IBCFlags n opts')

113116 when (Implicit `elem` opts) $ do addCoercion n

114117 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."

115131 when corec $ do setAccessibility n Frozen

116132 addIBC (IBCAccess n Frozen)

117133 return usety

@@ -124,6 +140,22 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

124140 | otherwise = mergeTy sc sc'

125141 mergeTy _ sc = sc

126142

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+

127159

128160elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

129161 FC -> FnOpts -> Name -> PTerm -> Idris ()

@@ -272,7 +304,8 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

272304type EliminatorState = StateT (Map.Map String Int) Idris

273305

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

276309elabEliminator paramPos n ty cons info = do

277310 elimLog $ "Elaborating eliminator"

278311 let (cnstrs, _) = splitPi ty

@@ -280,7 +313,7 @@ elabEliminator paramPos n ty cons info = do

280313 generalParams <- namePis False pms

281314 motiveIdxs <- namePis False idxs

282315 let motive = mkMotive n paramPos generalParams motiveIdxs

283− consTerms <- mapM (\(c@(_,cnm,_,_)) -> do

316+ consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

284317 name <- freshName $ "elim_" ++ simpleName cnm

285318 consTerm <- extractConsTerm c generalParams

286319 return (name, expl, consTerm)) cons

@@ -296,13 +329,13 @@ elabEliminator paramPos n ty cons info = do

296329 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

297330 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

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

300333 -- Do not elaborate clauses if there aren't any

301334 case eliminatorClauses of

302335 [] -> return ()

303− _ -> Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

336+ _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

304337 where elimLog :: String -> EliminatorState ()

305− elimLog s = Control.Monad.State.lift (logLvl 2 s)

338+ elimLog s = State.lift (logLvl 2 s)

306339

307340 elimFC :: FC

308341 elimFC = fileFC "(eliminator)"

@@ -312,7 +345,7 @@ elabEliminator paramPos n ty cons info = do

312345

313346 applyNS :: Name -> [String] -> Name

314347 applyNS n [] = n

315− applyNS n ns = NS n ns

348+ applyNS n ns = sNS n ns

316349

317350 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

318351 splitPi = splitPi' []

@@ -351,11 +384,11 @@ elabEliminator paramPos n ty cons info = do

351384

352385 simpleName :: Name -> String

353386 simpleName (NS n _) = simpleName n

354− simpleName (MN i n) = n ++ show i

387+ simpleName (MN i n) = str n ++ show i

355388 simpleName n = show n

356389

357390 nameSpaces :: Name -> [String]

358− nameSpaces (NS _ ns) = ns

391+ nameSpaces (NS _ ns) = map str ns

359392 nameSpaces _ = []

360393

361394 freshName :: String -> EliminatorState Name

@@ -364,16 +397,16 @@ elabEliminator paramPos n ty cons info = do

364397 let i = fromMaybe 0 (Map.lookup key nameMap)

365398 let name = key ++ show i

366399 put $ Map.insert key (i+1) nameMap

367− return (UN name)

400+ return (sUN name)

368401

369402 scrutineeName :: Name

370− scrutineeName = UN "scrutinee"

403+ scrutineeName = sUN "scrutinee"

371404

372405 scrutineeArgName :: Name

373− scrutineeArgName = UN "scrutineeArg"

406+ scrutineeArgName = sUN "scrutineeArg"

374407

375408 motiveName :: Name

376− motiveName = UN "prop"

409+ motiveName = sUN "prop"

377410

378411 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

379412 mkMotive n paramPos params indicies =

@@ -437,9 +470,9 @@ elabEliminator paramPos n ty cons info = do

437470 splitArgPms _ = ([],[])

438471

439472

440− implicitIndexes :: (String, Name, PTerm, FC) -> EliminatorState [(Name, Plicity, PTerm)]

441− implicitIndexes (cns@(doc, cnm, ty, fc)) = do

442− i <- Control.Monad.State.lift getIState

473+ implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

474+ implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

475+ i <- State.lift getIState

443476 implargs' <- case lookupCtxt cnm (idris_implicits i) of

444477 [] -> do fail $ "Error while showing implicits for " ++ show cnm

445478 [args] -> do return args

@@ -452,18 +485,18 @@ elabEliminator paramPos n ty cons info = do

452485 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

453486 _ -> return implargs

454487

455− extractConsTerm :: (String, Name, PTerm, FC) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

456− extractConsTerm (doc, cnm, ty, fc) generalParameters = do

488+ extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

489+ extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

457490 let cons' = replaceParams paramPos generalParameters ty

458491 let (args, resTy) = splitPi cons'

459− implidxs <- implicitIndexes (doc, cnm, ty, fc)

492+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

460493 consArgs <- namePis True args

461494 let recArgs = findRecArgs consArgs

462495 let recMotives = map applyRecMotive recArgs

463496 let (_, consIdxs) = splitArgPms resTy

464497 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

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

467500 where (_, idxs) = splitArgPms ty

468501

469502 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

@@ -488,12 +521,12 @@ elabEliminator paramPos n ty cons info = do

488521 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

489522 convertImplPi _ = Nothing

490523

491− generateEliminatorClauses :: (String, Name, PTerm, FC) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

492− generateEliminatorClauses (doc, cnm, ty, fc) cnsElim generalArgs generalParameters = do

524+ generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

525+ generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

493526 let cons' = replaceParams paramPos generalParameters ty

494527 let (args, resTy) = splitPi cons'

495− i <- Control.Monad.State.lift getIState

496− implidxs <- implicitIndexes (doc, cnm, ty, fc)

528+ i <- State.lift getIState

529+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

497530 let (_, generalIdxs') = splitArgPms resTy

498531 let generalIdxs = map pexp generalIdxs'

499532 consArgs <- namePis True args

@@ -514,7 +547,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

514547 (zip

515548 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

516549 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

517− addNameHint eqTy (UN "prf")

550+ addNameHint eqTy (sUN "prf")

518551 elabDecl EAll toplevel elimDecl

519552 mapM_ elabPrim primitives

520553 -- Special case prim__believe_me because it doesn't work on just constants

@@ -537,11 +570,11 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

537570

538571 p_believeMe [_,_,x] = Just x

539572 p_believeMe _ = Nothing

540− believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

541− (Bind (UN "b") (Pi (TType (UVar (-2))))

542− (Bind (UN "x") (Pi (V 1)) (V 1)))

573+ believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))))

574+ (Bind (sUN "b") (Pi (TType (UVar (-2))))

575+ (Bind (sUN "x") (Pi (V 1)) (V 1)))

543576 elabBelieveMe

544− = do let prim__believe_me = (UN "prim__believe_me")

577+ = do let prim__believe_me = sUN "prim__believe_me"

545578 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

546579 setTotality prim__believe_me (Partial NotCovering)

547580 i <- getIState

@@ -555,19 +588,19 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

555588 | otherwise = Just (VApp vnNothing VErased)

556589 p_synEq args = Nothing

557590

558− nMaybe = P (TCon 0 2) (NS (UN "Maybe") ["Maybe", "Prelude"]) Erased

559− vnJust = VP (DCon 1 2) (NS (UN "Just") ["Maybe", "Prelude"]) VErased

560− vnNothing = VP (DCon 0 1) (NS (UN "Nothing") ["Maybe", "Prelude"]) VErased

591+ nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased

592+ vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased

593+ vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased

561594 vnRefl = VP (DCon 0 2) eqCon VErased

562595

563− synEqTy = Bind (UN "a") (Pi (TType (UVar (-3))))

564− (Bind (UN "b") (Pi (TType (UVar (-3))))

565− (Bind (UN "x") (Pi (V 1))

566− (Bind (UN "y") (Pi (V 1))

596+ synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))))

597+ (Bind (sUN "b") (Pi (TType (UVar (-3))))

598+ (Bind (sUN "x") (Pi (V 1))

599+ (Bind (sUN "y") (Pi (V 1))

567600 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

568601 [V 3, V 2, V 1, V 0]]))))

569602 elabSynEq

570− = do let synEq = UN "prim__syntactic_eq"

603+ = do let synEq = sUN "prim__syntactic_eq"

571604

572605 updateContext (addOperator synEq synEqTy 4 p_synEq)

573606 setTotality synEq (Total [])

@@ -605,7 +638,7 @@ elabProvider info syn fc n ty tm

605638 -- Execute the type provider and normalise the result

606639 -- use 'run__provider' to convert to a primitive IO action

607640

608− rhs <- execute (mkApp (P Ref (UN "run__provider") Erased)

641+ rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

609642 [Erased, e])

610643 let rhs' = normalise ctxt [] rhs

611644 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

@@ -623,9 +656,10 @@ elabProvider info syn fc n ty tm

623656

624657 isProviderOf :: TT Name -> TT Name -> Bool

625658 isProviderOf tp prov

626− | (P _ (UN "IO") _, [prov']) <- unApply prov

627− , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'

628− , tp == tp' = True

659+ | (P _ (UN io) _, [prov']) <- unApply prov

660+ , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'

661+ , tp == tp', io == txt "IO"

662+ , prov == txt "Provider" && provs == txt "Providers" = True

629663 isProviderOf _ _ = False

630664

631665-- | Elaborate a type provider

@@ -635,8 +669,8 @@ elabTransform info fc safe lhs_in rhs_in

635669 i <- getIState

636670 let lhs = addImplPat i lhs_in

637671 ((lhs', dlhs, []), _) <-

638− tclift $ elaborate ctxt (MN 0 "transLHS") infP []

639− (erun fc (buildTC i info True [] (UN "transform")

672+ tclift $ elaborate ctxt (sMN 0 "transLHS") infP []

673+ (erun fc (buildTC i info True [] (sUN "transform")

640674 (infTerm lhs)))

641675 let lhs_tm = orderPats (getInferTerm lhs')

642676 let lhs_ty = getInferType lhs'

@@ -646,13 +680,13 @@ elabTransform info fc safe lhs_in rhs_in

646680 logLvl 3 ("Transform LHS " ++ show clhs_tm)

647681 let rhs = addImplBound i (map fst newargs) rhs_in

648682 ((rhs', defer), _) <-

649− tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty []

683+ tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []

650684 (do pbinds lhs_tm

651− erun fc (build i info False [] (UN "transform") rhs)

685+ setNextName

686+ erun fc (build i info False [] (sUN "transform") rhs)

652687 erun fc $ psolve lhs_tm

653688 tt <- get_term

654− let (tm, ds) = runState (collectDeferred Nothing tt) []

655− return (tm, ds))

689+ return (runState (collectDeferred Nothing tt) []))

656690 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

657691 logLvl 3 ("Transform RHS " ++ show crhs_tm)

658692 when safe $ case converts ctxt [] clhs_tm crhs_tm of

@@ -665,7 +699,7 @@ elabTransform info fc safe lhs_in rhs_in

665699elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

666700 PTerm -> String -> Name -> PTerm -> Idris ()

667701elabRecord 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, [])])

669703 cty' <- implicit syn cn cty

670704 i <- getIState

671705 cty <- case lookupTy cn (tt_ctxt i) of

@@ -719,18 +753,18 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

719753 getRecTy (PPi _ n ty s) = getRecTy s

720754 getRecTy t = t

721755

722− rec = MN 0 "rec"

756+ rec = sMN 0 "rec"

723757

724− mkp (UN n) = MN 0 ("p_" ++ n)

725− mkp (MN i n) = MN i ("p_" ++ n)

758+ mkp (UN n) = sMN 0 ("p_" ++ str n)

759+ mkp (MN i n) = sMN i ("p_" ++ str n)

726760 mkp (NS n s) = NS (mkp n) s

727761

728− mkImp (UN n) = UN ("implicit_" ++ n)

729− mkImp (MN i n) = MN i ("implicit_" ++ n)

762+ mkImp (UN n) = sUN ("implicit_" ++ str n)

763+ mkImp (MN i n) = sMN i ("implicit_" ++ str n)

730764 mkImp (NS n s) = NS (mkImp n) s

731765

732− mkType (UN n) = UN ("set_" ++ n)

733− mkType (MN i n) = MN i ("set_" ++ n)

766+ mkType (UN n) = sUN ("set_" ++ str n)

767+ mkType (MN i n) = sMN i ("set_" ++ str n)

734768 mkType (NS n s) = NS (mkType n) s

735769

736770 mkProj recty substs cimp ((pn_in, pty), pos)

@@ -753,11 +787,11 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

753787

754788 mkUpdate recty k num ((pn, pty), pos)

755789 = do let setname = expandNS syn $ mkType pn

756− let valname = MN 0 "updateval"

790+ let valname = sMN 0 "updateval"

757791 let pt = k (PPi expl pn pty

758792 (PPi expl rec recty recty))

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

761795 let lhsArgs = pls

762796 let rhsArgs = take pos pls ++ (PRef fc valname) :

763797 drop (pos + 1) pls

@@ -772,8 +806,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

772806 return (pn, pfnTy, PClauses fc [] setname [pclause])

773807

774808elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

775− (String, Name, PTerm, FC) -> Idris (Name, Type)

776−elabCon info syn tn codata (doc, n, t_in, fc)

809+ (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

810+elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

777811 = do checkUndefined fc n

778812 ctxt <- getContext

779813 i <- getIState

@@ -796,7 +830,10 @@ elabCon info syn tn codata (doc, n, t_in, fc)

796830 addIBC (IBCDef n)

797831 addDocStr n doc

798832 addIBC (IBCDoc n)

799− forceArgs tn n cty'

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

836+ forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

800837 return (n, cty')

801838 where

802839 tyIs (Bind n b sc) = tyIs sc

@@ -808,6 +845,11 @@ elabCon info syn tn codata (doc, n, t_in, fc)

808845 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

809846 mkLazy t = t

810847

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+

811853-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

812854-- top-level definition.

813855elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

@@ -1120,7 +1162,7 @@ elabPE info fc caller r =

11201162 _ -> error "Can't happen (getSpecTy)"

11211163

11221164 getSpecClause ist (n, args)

1123− = let newnm = UN ("__"++show (nsroot n) ++ "_" ++

1165+ = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++

11241166 showSep "_" (map showArg args)) in

11251167 -- UN (show n ++ show (map snd args)) in

11261168 (n, newnm, mkPE_TermDecl ist newnm n args)

@@ -1145,8 +1187,8 @@ elabValBind info aspat tm_in

11451187 ((tm', defer, is), _) <-

11461188-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

11471189-- (build i info aspat (MN 0 "val") tm))

1148− tclift (elaborate ctxt (MN 0 "val") infP []

1149− (build i info aspat [Reflection] (MN 0 "val") (infTerm tm)))

1190+ tclift (elaborate ctxt (sMN 0 "val") infP []

1191+ (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

11501192 let vtm = orderPats (getInferTerm tm')

11511193

11521194 def' <- checkDef (fileFC "(input)") defer

@@ -1176,7 +1218,7 @@ checkPossible info fc tcgen fname lhs_in

11761218 i <- getIState

11771219 let lhs = addImpl i lhs_in

11781220 -- if the LHS type checks, it is possible

1179− case elaborate ctxt (MN 0 "patLHS") infP []

1221+ case elaborate ctxt (sMN 0 "patLHS") infP []

11801222 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

11811223 OK ((lhs', _, _), _) ->

11821224 do let lhs_tm = orderPats (getInferTerm lhs')

@@ -1231,7 +1273,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12311273 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

12321274

12331275 ((lhs', dlhs, []), _) <-

1234− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1276+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

12351277 (errAt "left hand side of " fname

12361278 (erun fc (buildTC i info True opts fname (infTerm lhs))))

12371279 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1244,8 +1286,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12441286

12451287 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

12461288

1247− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1248− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1289+ rep <- useREPL

1290+ when rep $ do

1291+ addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1292+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

12491293

12501294 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

12511295 -- Elaborate where block

@@ -1273,10 +1317,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12731317 ctxt <- getContext -- new context with where block added

12741318 logLvl 5 "STARTING CHECK"

12751319 ((rhs', defer, is), _) <-

1276− tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

1320+ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []

12771321 (do pbinds lhs_tm

1322+ setNextName

12781323 (_, _, 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))

12801325 errAt "right hand side of " fname

12811326 (erun fc $ psolve lhs_tm)

12821327 hs <- get_holes

@@ -1287,7 +1332,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12871332 return (tm, ds, is))

12881333 logLvl 5 "DONE CHECK"

12891334 logLvl 2 $ "---> " ++ show rhs'

1290− when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer

1335+ when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer)

12911336 def' <- checkDef fc defer

12921337 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

12931338 addDeferred def''

@@ -1303,6 +1348,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13031348

13041349 ctxt <- getContext

13051350 logLvl 5 $ "Rechecking"

1351+ logLvl 6 $ " ==> " ++ show (forget rhs')

13061352 (crhs, crhsty) <- recheckC fc [] rhs'

13071353 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

13081354 case converts ctxt [] clhsty crhsty of

@@ -1408,7 +1454,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

14081454 let lhs = addImplPat i (stripLinear i lhs_in)

14091455 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

14101456 ((lhs', dlhs, []), _) <-

1411− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1457+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

14121458 (errAt "left hand side of with in " fname

14131459 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

14141460 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1422,9 +1468,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

14221468 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

14231469 -- Elaborate wval in this context

14241470 ((wval', defer, is), _) <-

1425− tclift $ elaborate ctxt (MN 0 "withRHS")

1471+ tclift $ elaborate ctxt (sMN 0 "withRHS")

14261472 (bindTyArgs PVTy bargs infP) []

14271473 (do pbinds lhs_tm

1474+ setNextName

14281475 -- TODO: may want where here - see winfo abpve

14291476 (_', d, is) <- errAt "with value in " fname

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

14541501 let wargtype = getRetTy cwvaltyN

14551502 logLvl 5 ("Abstract over " ++ show wargval)

14561503 let wtype = bindTyArgs Pi (bargs_pre ++

1457− (MN 0 "warg", wargtype) :

1458− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1459− (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

1504+ (sMN 0 "warg", wargtype) :

1505+ map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)

1506+ (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)

14601507 logLvl 3 ("New function type " ++ show wtype)

1461− let wname = MN windex (show fname)

1508+ let wname = sMN windex (show fname)

14621509

14631510 let imps = getImps wtype -- add to implicits context

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

14861533 ctxt <- getContext -- New context with block added

14871534 i <- getIState

14881535 ((rhs', defer, is), _) <-

1489− tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty []

1536+ tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []

14901537 (do pbinds lhs_tm

1538+ setNextName

14911539 (_, d, is) <- erun fc (build i info False opts fname rhs)

14921540 psolve lhs_tm

14931541 tt <- get_term

@@ -1566,7 +1614,7 @@ elabClass :: ElabInfo -> SyntaxInfo -> String ->

15661614 FC -> [PTerm] ->

15671615 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

15681616elabClass 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)

15701618 let tty = pibind ps PType

15711619 let constraint = PApp fc (PRef fc tn)

15721620 (map (pexp . PRef fc) (map fst ps))

@@ -1589,7 +1637,7 @@ elabClass info syn doc fc constraints tn ps ds

15891637 let cty = impbind ps $ conbind constraints

15901638 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

15911639 constraint

1592− let cons = [("", cn, cty, fc)]

1640+ let cons = [("", cn, cty, fc, [])]

15931641 let ddecl = PDatadecl tn tty cons

15941642 logLvl 5 $ "Class data " ++ showDImp True ddecl

15951643 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

16271675

16281676 impbind [] x = x

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

16311679 conbind [] x = x

16321680

16331681 getMName (PTy _ _ _ _ n _) = nsroot n

@@ -1651,7 +1699,7 @@ elabClass info syn doc fc constraints tn ps ds

16511699 _ -> ifail $ show n ++ " is not a method"

16521700 defdecl _ _ _ = ifail "Can't happen (defdecl)"

16531701

1654− defaultdec (UN n) = UN ("default#" ++ n)

1702+ defaultdec (UN n) = sUN ("default#" ++ str n)

16551703 defaultdec (NS n ns) = NS (defaultdec n) ns

16561704

16571705 tydecl (PTy _ _ _ _ _ _) = True

@@ -1663,13 +1711,13 @@ elabClass info syn doc fc constraints tn ps ds

16631711

16641712 -- Generate a function for chasing a dictionary constraint

16651713 cfun cn c syn all con

1666− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1714+ = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con)

16671715 -- 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..]

16691717 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

16701718 let lhs = PApp fc (PRef fc cfn) [pconst capp]

16711719 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

16731721 iLOG (showImp Nothing True False ty)

16741722 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

16751723 i <- getIState

@@ -1689,10 +1737,10 @@ elabClass info syn doc fc constraints tn ps ds

16891737 -- dictionary (this is inlinable, always)

16901738 tfun cn c syn all (m, (doc, o, ty))

16911739 = 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..]

16931741 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

16941742 let margs = getMArgs ty

1695− let anames = map (\x -> MN x "arg") [0..]

1743+ let anames = map (\x -> sMN x "arg") [0..]

16961744 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

16971745 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

16981746 iLOG (showImp Nothing True False ty)

@@ -1721,7 +1769,7 @@ elabClass info syn doc fc constraints tn ps ds

17211769

17221770 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

17231771 = 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

17251773

17261774 -- make arguments explicit and don't bind class parameters

17271775 toExp ns e (PPi (Imp l s _ p) n ty sc)

@@ -1731,19 +1779,21 @@ elabClass info syn doc fc constraints tn ps ds

17311779 toExp ns e sc = sc

17321780

17331781elabInstance :: ElabInfo -> SyntaxInfo ->

1782+ ElabWhat -> -- phase

17341783 FC -> [PTerm] -> -- constraints

17351784 Name -> -- the class

17361785 [PTerm] -> -- class parameters (i.e. instance)

17371786 PTerm -> -- full instance type

17381787 Maybe Name -> -- explicit name

17391788 [PDecl] -> Idris ()

1740−elabInstance info syn fc cs n ps t expn ds

1741− = do i <- getIState

1742− (n, ci) <- case lookupCtxtName n (idris_classes i) of

1743− [c] -> return c

1744− _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1745− let constraint = PApp fc (PRef fc n) (map pexp ps)

1746− let iname = mkiname n ps expn

1789+elabInstance info syn what fc cs n ps t expn ds = do

1790+ i <- getIState

1791+ (n, ci) <- case lookupCtxtName n (idris_classes i) of

1792+ [c] -> return c

1793+ _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1794+ let constraint = PApp fc (PRef fc n) (map pexp ps)

1795+ let iname = mkiname n ps expn

1796+ when (what /= EDefns) $ do

17471797 nty <- elabType' True info syn "" fc [] iname t

17481798 -- if the instance type matches any of the instances we have already,

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

17521802 (class_instances ci)

17531803 addInstance intInst n iname

17541804 Just _ -> addInstance intInst n iname

1805+ when (what /= ETypes) $ do

17551806 let ips = zip (class_params ci) ps

17561807 let ns = case n of

17571808 NS n ns' -> ns'

@@ -1804,7 +1855,7 @@ elabInstance info syn fc cs n ps t expn ds

18041855

18051856 mkiname n' ps' expn' =

18061857 case expn' of

1807− Nothing -> SN (InstanceN n' (map show ps'))

1858+ Nothing -> SN (sInstanceN n' (map show ps'))

18081859 Just nm -> nm

18091860

18101861 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

18521903 mkMethApp (n, _, _, ty)

18531904 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

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

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

18581909 lamBind i _ sc = sc

18591910 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

18611912 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

18631914 methArgs i (PPi (Constraint _ _ _) n ty sc)

18641915 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

18651916 methArgs i _ = []

@@ -1882,14 +1933,14 @@ elabInstance info syn fc cs n ps t expn ds

18821933

18831934 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

18841935

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)

18861937 conbind [] x = x

18871938

18881939 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

18891940 coninsert cs sc = conbind cs sc

18901941

18911942 insertDefaults :: IState -> Name ->

1892− [(Name, (Name, PDecl))] -> [String] ->

1943+ [(Name, (Name, PDecl))] -> [T.Text] ->

18931944 [PDecl] -> [PDecl]

18941945 insertDefaults i iname [] ns ds = ds

18951946 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

@@ -1980,7 +2031,7 @@ elabDecls info ds = do mapM_ (elabDecl EAll info) ds

19802031

19812032elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()

19822033elabDecl what info d

1983− = idrisCatch (elabDecl' what info d) (setAndReport)

2034+ = idrisCatch (withErrorReflection $ elabDecl' what info d) (setAndReport)

19842035

19852036elabDecl' _ info (PFix _ _ _)

19862037 = return () -- nothing to elaborate

@@ -2011,8 +2062,10 @@ elabDecl' what info d@(PClauses f o n ps)

20112062 [] -> []

20122063 elabClauses info f (o ++ o') n ps

20132064elabDecl' what info (PMutual f ps)

2014− = do mapM_ (elabDecl ETypes info) ps

2015− mapM_ (elabDecl EDefns info) ps

2065+ = do case ps of

2066+ [p] -> elabDecl what info p

2067+ _ -> do mapM_ (elabDecl ETypes info) ps

2068+ mapM_ (elabDecl EDefns info) ps

20162069 -- Do totality checking after entire mutual block

20172070 i <- get

20182071 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2048,9 +2101,8 @@ elabDecl' what info (PClass doc s f cs n ps ds)

20482101 = do iLOG $ "Elaborating class " ++ show n

20492102 elabClass info (s { syn_params = [] }) doc f cs n ps ds

20502103elabDecl' what info (PInstance s f cs n ps t expn ds)

2051− | what /= ETypes

20522104 = 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

20542106elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

20552107 | what /= ETypes

20562108 = do iLOG $ "Elaborating record " ++ show tyn

@@ -2074,7 +2126,7 @@ elabDecl' _ _ _ = return () -- skipped this time

20742126

20752127elabCaseBlock info opts d@(PClauses f o n ps)

20762128 = do addIBC (IBCDef n)

2077− logLvl 6 $ "CASE BLOCK: " ++ show (n, d)

2129+ logLvl 5 $ "CASE BLOCK: " ++ show (n, d)

20782130 let opts' = nub (o ++ opts)

20792131 -- propagate totality assertion to the new definitions

20802132 when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]

src/Idris/ElabTerm.hs+308−183

@@ -5,15 +5,18 @@ module Idris.ElabTerm where

55import Idris.AbsSyntax

66import Idris.DSL

77import Idris.Delaborate

8+import Idris.Error

89import Idris.ProofSearch

910

1011import Idris.Core.Elaborate hiding (Tactic(..))

1112import Idris.Core.TT

1213import Idris.Core.Evaluate

14+import Idris.Core.Typecheck (check)

1315

1416import Control.Monad

15−import Control.Monad.State

17+import Control.Monad.State.Strict

1618import Data.List

19+import Data.Maybe (mapMaybe)

1720

1821import Debug.Trace

1922

@@ -78,7 +81,10 @@ build ist info pattern opts fn tm

7881buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->

7982 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

8083buildTC ist info pattern opts fn tm

81− = do elab 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

87+ elab ist info pattern opts fn tm

8288 probs <- get_probs

8389 tm <- get_term

8490 case probs of

@@ -104,7 +110,6 @@ elab ist info pattern opts fn tm

104110 end_unify

105111 when pattern -- convert remaining holes to pattern vars

106112 (do update_term orderPats

107− tm <- get_term

108113 mkPat)

109114 where

110115 tcgen = Dictionary `elem` opts

@@ -168,18 +173,18 @@ elab ist info pattern opts fn tm

168173 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

169174 = do g <- goal; resolveTC 5 g fn ist

170175 elab' ina (PResolveTC fc)

171− | True = do c <- unique_hole (MN 0 "class")

176+ | True = do c <- getNameFrom (sMN 0 "class")

172177 instanceArg c

173178 | otherwise = do g <- goal

174179 try (resolveTC 2 g fn ist)

175− (do c <- unique_hole (MN 0 "class")

180+ (do c <- getNameFrom (sMN 0 "class")

176181 instanceArg c)

177182 elab' ina (PRefl fc t)

178− = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

179− pimp (MN 0 "x") t False])

183+ = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,

184+ pimp (sMN 0 "x") t False])

180185 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

181− [pimp (MN 0 "a") Placeholder True,

182− pimp (MN 0 "b") Placeholder False,

186+ [pimp (sMN 0 "A") Placeholder True,

187+ pimp (sMN 0 "B") Placeholder False,

183188 pexp l, pexp r])

184189 elab' ina@(_, a, inty) (PPair fc l r)

185190 = do hnf_compute

@@ -188,8 +193,8 @@ elab ist info pattern opts fn tm

188193 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

189194 [pexp l,pexp r])

190195 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

191− [pimp (MN 0 "A") Placeholder True,

192− pimp (MN 0 "B") Placeholder True,

196+ [pimp (sMN 0 "A") Placeholder True,

197+ pimp (sMN 0 "B") Placeholder True,

193198 pexp l, pexp r])

194199 elab' ina (PDPair fc l@(PRef _ n) t r)

195200 = case t of

@@ -204,12 +209,12 @@ elab ist info pattern opts fn tm

204209 [pexp t,

205210 pexp (PLam n Placeholder r)])

206211 asValue = elab' ina (PApp fc (PRef fc existsCon)

207− [pimp (MN 0 "a") t False,

208− pimp (MN 0 "P") Placeholder True,

212+ [pimp (sMN 0 "a") t False,

213+ pimp (sMN 0 "P") Placeholder True,

209214 pexp l, pexp r])

210215 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

211− [pimp (MN 0 "a") t False,

212− pimp (MN 0 "P") Placeholder True,

216+ [pimp (sMN 0 "a") t False,

217+ pimp (sMN 0 "P") Placeholder True,

213218 pexp l, pexp r])

214219 elab' ina (PAlternative True as)

215220 = do hnf_compute

@@ -256,38 +261,35 @@ elab ist info pattern opts fn tm

256261 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

257262 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

258263 elab' ina@(_, a, inty) (PLam n Placeholder sc)

259− = do -- n' <- unique_hole n

260− -- let sc' = mapPT (repN n n') sc

261− ptm <- get_term

262− g <- goal

264+ = do -- if n is a type constructor name, this makes no sense...

265+ ctxt <- get_context

266+ when (isTConName n ctxt) $

267+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

263268 checkPiGoal n

264269 attack; intro (Just n);

265270 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

266271 elabE (True, a, inty) sc; solve

267− where repN n n' (PRef fc x) | x == n' = PRef fc n'

268− repN _ _ t = t

269272 elab' ina@(_, a, inty) (PLam n ty sc)

270− = do hsin <- get_holes

271− ptmin <- get_term

272− tyn <- unique_hole (MN 0 "lamty")

273+ = do tyn <- getNameFrom (sMN 0 "lamty")

274+ -- if n is a type constructor name, this makes no sense...

275+ ctxt <- get_context

276+ when (isTConName n ctxt) $

277+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

273278 checkPiGoal n

274279 claim tyn RType

275280 explicit tyn

276281 attack

277282 ptm <- get_term

278283 hs <- get_holes

279− -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

280− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

281284 introTy (Var tyn) (Just n)

282− -- end_unify

283285 focus tyn

284286 elabE (True, a, True) ty

285287 elabE (True, a, inty) sc

286288 solve

287289 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

289291 elab' ina@(_, a, _) (PPi _ n ty sc)

290− = do attack; tyn <- unique_hole (MN 0 "ty")

292+ = do attack; tyn <- getNameFrom (sMN 0 "ty")

291293 claim tyn RType

292294 n' <- case n of

293295 MN _ _ -> unique_hole n

@@ -299,9 +301,9 @@ elab ist info pattern opts fn tm

299301 solve

300302 elab' ina@(_, a, inty) (PLet n ty val sc)

301303 = do attack;

302− tyn <- unique_hole (MN 0 "letty")

304+ tyn <- getNameFrom (sMN 0 "letty")

303305 claim tyn RType

304− valn <- unique_hole (MN 0 "letval")

306+ valn <- getNameFrom (sMN 0 "letval")

305307 claim valn (Var tyn)

306308 explicit valn

307309 letbind n (Var tyn) (Var valn)

@@ -322,9 +324,9 @@ elab ist info pattern opts fn tm

322324 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

323325 rty <- goal

324326 attack

325− tyn <- unique_hole (MN 0 "letty")

327+ tyn <- getNameFrom (sMN 0 "letty")

326328 claim tyn RType

327− valn <- unique_hole (MN 0 "letval")

329+ valn <- getNameFrom (sMN 0 "letval")

328330 claim valn (Var tyn)

329331 letbind n (Var tyn) (Var valn)

330332 focus valn

@@ -343,7 +345,7 @@ elab ist info pattern opts fn tm

343345 -- new function name

344346 env <- get_env

345347 argTys <- claimArgTys env args

346− fn <- unique_hole (MN 0 "inf_fn")

348+ fn <- getNameFrom (sMN 0 "inf_fn")

347349 let fty = fnTy argTys rty

348350-- trace (show (ptm, map fst argTys)) $ focus fn

349351 -- build and defer the function application

@@ -357,8 +359,8 @@ elab ist info pattern opts fn tm

357359 ans <- claimArgTys env xs

358360 return ((n, (False, forget nty)) : ans)

359361 claimArgTys env (_ : xs)

360− = do an <- unique_hole (MN 0 "inf_argTy")

361− aval <- unique_hole (MN 0 "inf_arg")

362+ = do an <- getNameFrom (sMN 0 "inf_argTy")

363+ aval <- getNameFrom (sMN 0 "inf_arg")

362364 claim an RType

363365 claim aval (Var an)

364366 ans <- claimArgTys env xs

@@ -378,7 +380,7 @@ elab ist info pattern opts fn tm

378380 mkN n@(NS _ _) = n

379381 mkN n@(SN _) = n

380382 mkN n = case namespace info of

381− Just xs@(_:_) -> NS n xs

383+ Just xs@(_:_) -> sNS n xs

382384 _ -> n

383385

384386 elab' ina (PMatchApp fc fn)

@@ -391,16 +393,12 @@ elab ist info pattern opts fn tm

391393 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

392394 = lift $ tfail (Msg "Typecase is not allowed")

393395 -- if f is local, just do a simple_app

394− 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

400− if (f `elem` map fst env && length args' == 1)

396+ elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args)

397+ = do env <- get_env

398+ if (f `elem` map fst env && length args == 1)

401399 then -- simple app, as below

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

404402 (show tm)

405403 solve

406404 else

@@ -413,24 +411,17 @@ elab ist info pattern opts fn tm

413411 -- we can unify with them

414412 case lookupCtxt f (idris_classes ist) of

415413 [] -> return ()

416− _ -> mapM_ setInjective (map getTm args')

414+ _ -> mapM_ setInjective (map getTm args)

417415 ctxt <- get_context

418416 let guarded = isConName f ctxt

419417 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

423419 let (ns', eargs) = unzip $

424− sortBy (\(_,x) (_,y) ->

425− compare (priority x) (priority y))

426− (zip ns args)

420+ sortBy cmpArg (zip ns args)

427421 elabArgs (ina || not isinf, guarded, inty)

428422 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

429− mkSpecialised ist fc f (map getTm args') tm

430423 solve

431− ptm <- get_term

432424 ivs' <- get_instances

433− ps' <- get_probs

434425 -- Attempt to resolve any type classes which have 'complete' types,

435426 -- i.e. no holes in them

436427 when (not pattern || (ina && not tcgen && not guarded)) $

@@ -446,6 +437,13 @@ elab ist info pattern opts fn tm

446437 (ivs' \\ ivs)

447438 where tcArg (n, PConstraint _ _ Placeholder _) = True

448439 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

449447

450448 tacTm (PTactics _) = True

451449 tacTm (PProof _) = True

@@ -466,7 +464,7 @@ elab ist info pattern opts fn tm

466464 do attack; defer n'; solve

467465 where mkN n@(NS _ _) = n

468466 mkN n = case namespace info of

469− Just xs@(_:_) -> NS n xs

467+ Just xs@(_:_) -> sNS n xs

470468 _ -> n

471469 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

472470 elab' ina (PTactics ts)

@@ -475,11 +473,11 @@ elab ist info pattern opts fn tm

475473 elab' ina (PElabError e) = fail (pshow ist e)

476474 elab' ina (PRewrite fc r sc newg)

477475 = do attack

478− tyn <- unique_hole (MN 0 "rty")

476+ tyn <- getNameFrom (sMN 0 "rty")

479477 claim tyn RType

480− valn <- unique_hole (MN 0 "rval")

478+ valn <- getNameFrom (sMN 0 "rval")

481479 claim valn (Var tyn)

482− letn <- unique_hole (MN 0 "rewrite_rule")

480+ letn <- getNameFrom (sMN 0 "rewrite_rule")

483481 letbind letn (Var tyn) (Var valn)

484482 focus valn

485483 elab' ina r

@@ -494,11 +492,11 @@ elab ist info pattern opts fn tm

494492 solve

495493 where doEquiv t sc =

496494 do attack

497− tyn <- unique_hole (MN 0 "ety")

495+ tyn <- getNameFrom (sMN 0 "ety")

498496 claim tyn RType

499− valn <- unique_hole (MN 0 "eqval")

497+ valn <- getNameFrom (sMN 0 "eqval")

500498 claim valn (Var tyn)

501− letn <- unique_hole (MN 0 "equiv_val")

499+ letn <- getNameFrom (sMN 0 "equiv_val")

502500 letbind letn (Var tyn) (Var valn)

503501 focus tyn

504502 elab' ina t

@@ -508,10 +506,10 @@ elab ist info pattern opts fn tm

508506 solve

509507 elab' ina@(_, a, inty) c@(PCase fc scr opts)

510508 = do attack

511− tyn <- unique_hole (MN 0 "scty")

509+ tyn <- getNameFrom (sMN 0 "scty")

512510 claim tyn RType

513− valn <- unique_hole (MN 0 "scval")

514− scvn <- unique_hole (MN 0 "scvar")

511+ valn <- getNameFrom (sMN 0 "scval")

512+ scvn <- getNameFrom (sMN 0 "scvar")

515513 claim valn (Var tyn)

516514 letbind scvn (Var tyn) (Var valn)

517515 focus valn

@@ -537,7 +535,7 @@ elab ist info pattern opts fn tm

537535-- mkCaseName (MN i x) = MN i (x ++ "_case")

538536 mkN n@(NS _ _) = n

539537 mkN n = case namespace info of

540− Just xs@(_:_) -> NS n xs

538+ Just xs@(_:_) -> sNS n xs

541539 _ -> n

542540 elab' ina (PUnifyLog t) = do unifyLog True

543541 elab' ina t

@@ -617,8 +615,8 @@ elab ist info pattern opts fn tm

617615 = elabArgs ina failed fc r ns args

618616 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

619617 | lazy && not pattern

620− = do elabArg n (PApp bi (PRef bi (UN "lazy"))

621− [pimp (UN "a") Placeholder True,

618+ = do elabArg n (PApp bi (PRef bi (sUN "lazy"))

619+ [pimp (sUN "a") Placeholder True,

622620 pexp t]);

623621 | otherwise = elabArg n t

624622 where elabArg n t

@@ -698,9 +696,9 @@ findInstances ist t

698696 | otherwise = []

699697

700698trivial' ist

701− = trivial (elab ist toplevel False [] (MN 0 "tac")) ist

699+ = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

702700proofSearch' 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

704702

705703

706704resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

@@ -710,9 +708,10 @@ resolveTC depth topg fn ist

710708 = do hnf_compute

711709 g <- goal

712710 ptm <- get_term

711+ ulog <- getUnifyLog

713712 hs <- get_holes

714− if True -- all (\n -> not (n `elem` hs)) (freeNames g)

715− then try' (trivial' ist)

713+ traceWhen ulog ("Resolving class " ++ show g) $

714+ try' (trivial' ist)

716715 (do t <- goal

717716 let (tc, ttypes) = unApply t

718717 scopeOnly <- needsDefault t tc ttypes

@@ -720,28 +719,23 @@ resolveTC depth topg fn ist

720719 let insts = if scopeOnly then filter chaser insts_in

721720 else insts_in

722721 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

726722 let depth' = if scopeOnly then 2 else depth

727723 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

733724 where

734725 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

735726 | otherwise = (fail "Can't resolve", show n)

736727

737728 -- HACK! Rather than giving a special name, better to have some kind

738729 -- of flag in ClassInfo structure

739− chaser (UN ('@':'@':_)) = True -- old way

730+ chaser (UN nm)

731+ | ('@':'@':_) <- str nm = True -- old way

740732 chaser (SN (ParentN _ _)) = True

741733 chaser (NS n _) = chaser n

742734 chaser _ = False

743735

744− needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _]

736+ numclass = sNS (sUN "Num") ["Classes","Prelude"]

737+

738+ needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass

745739 = do focus a

746740 fill (RConstant (AType (ATInt ITBig))) -- default Integer

747741 solve

@@ -774,8 +768,8 @@ resolveTC depth topg fn ist

774768 [args] -> map isImp (snd args) -- won't be overloaded!

775769 ps <- get_probs

776770 tm <- get_term

777− args <- try' (match_apply (Var n) imps)

778− (apply (Var n) imps) True

771+ args <- try' (apply (Var n) imps)

772+ (match_apply (Var n) imps) True

779773 ps' <- get_probs

780774 when (length ps < length ps') $ fail "Can't apply type class"

781775-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

@@ -787,7 +781,9 @@ resolveTC depth topg fn ist

787781 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

788782 -- if there's any arguments left, we've failed to resolve

789783 hs <- get_holes

790− solve

784+ ulog <- getUnifyLog

785+ solve

786+ traceWhen ulog ("Got " ++ show n) $ return ()

791787 where isImp (PImp p _ _ _ _ _) = (True, p)

792788 isImp arg = (False, priority arg)

793789

@@ -814,7 +810,9 @@ collectDeferred top t = return t

814810runTac :: Bool -> IState -> PTactic -> ElabD ()

815811runTac autoSolve ist tac

816812 = do env <- get_env

817− no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

813+ g <- goal

814+ no_errors (runT (fmap (addImplBound ist (map fst env)) tac))

815+ (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))

818816 where

819817 runT (Intro []) = do g <- goal

820818 attack; intro (bname g)

@@ -829,7 +827,7 @@ runTac autoSolve ist tac

829827 where

830828 bname (Bind n _ _) = Just n

831829 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

833831 when autoSolve solveAll

834832 runT (MatchRefine fn)

835833 = do fnimps <-

@@ -869,27 +867,27 @@ runTac autoSolve ist tac

869867 when autoSolve solveAll

870868 runT (Equiv tm) -- let bind tm, then

871869 = do attack

872− tyn <- unique_hole (MN 0 "ety")

870+ tyn <- getNameFrom (sMN 0 "ety")

873871 claim tyn RType

874− valn <- unique_hole (MN 0 "eqval")

872+ valn <- getNameFrom (sMN 0 "eqval")

875873 claim valn (Var tyn)

876− letn <- unique_hole (MN 0 "equiv_val")

874+ letn <- getNameFrom (sMN 0 "equiv_val")

877875 letbind letn (Var tyn) (Var valn)

878876 focus tyn

879− elab ist toplevel False [] (MN 0 "tac") tm

877+ elab ist toplevel False [] (sMN 0 "tac") tm

880878 focus valn

881879 when autoSolve solveAll

882880 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

883881 = do attack; -- (h:_) <- get_holes

884− tyn <- unique_hole (MN 0 "rty")

882+ tyn <- getNameFrom (sMN 0 "rty")

885883 -- start_unify h

886884 claim tyn RType

887− valn <- unique_hole (MN 0 "rval")

885+ valn <- getNameFrom (sMN 0 "rval")

888886 claim valn (Var tyn)

889− letn <- unique_hole (MN 0 "rewrite_rule")

887+ letn <- getNameFrom (sMN 0 "rewrite_rule")

890888 letbind letn (Var tyn) (Var valn)

891889 focus valn

892− elab ist toplevel False [] (MN 0 "tac") tm

890+ elab ist toplevel False [] (sMN 0 "tac") tm

893891 rewrite (Var letn)

894892 when autoSolve solveAll

895893 runT (Induction nm)

@@ -897,27 +895,27 @@ runTac autoSolve ist tac

897895 when autoSolve solveAll

898896 runT (LetTac n tm)

899897 = do attack

900− tyn <- unique_hole (MN 0 "letty")

898+ tyn <- getNameFrom (sMN 0 "letty")

901899 claim tyn RType

902− valn <- unique_hole (MN 0 "letval")

900+ valn <- getNameFrom (sMN 0 "letval")

903901 claim valn (Var tyn)

904902 letn <- unique_hole n

905903 letbind letn (Var tyn) (Var valn)

906904 focus valn

907− elab ist toplevel False [] (MN 0 "tac") tm

905+ elab ist toplevel False [] (sMN 0 "tac") tm

908906 when autoSolve solveAll

909907 runT (LetTacTy n ty tm)

910908 = do attack

911− tyn <- unique_hole (MN 0 "letty")

909+ tyn <- getNameFrom (sMN 0 "letty")

912910 claim tyn RType

913− valn <- unique_hole (MN 0 "letval")

911+ valn <- getNameFrom (sMN 0 "letval")

914912 claim valn (Var tyn)

915913 letn <- unique_hole n

916914 letbind letn (Var tyn) (Var valn)

917915 focus tyn

918− elab ist toplevel False [] (MN 0 "tac") ty

916+ elab ist toplevel False [] (sMN 0 "tac") ty

919917 focus valn

920− elab ist toplevel False [] (MN 0 "tac") tm

918+ elab ist toplevel False [] (sMN 0 "tac") tm

921919 when autoSolve solveAll

922920 runT Compute = compute

923921 runT Trivial = do trivial' ist; when autoSolve solveAll

@@ -930,16 +928,16 @@ runTac autoSolve ist tac

930928 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

931929 tgoal <- goal -- store the goal

932930 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

933− script <- unique_hole (MN 0 "script")

931+ script <- getNameFrom (sMN 0 "script")

934932 claim script scriptTy

935− scriptvar <- unique_hole (MN 0 "scriptvar" )

933+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

936934 letbind scriptvar scriptTy (Var script)

937935 focus script

938− elab ist toplevel False [] (MN 0 "tac") tm

936+ elab ist toplevel False [] (sMN 0 "tac") tm

939937 (script', _) <- get_type_val (Var scriptvar)

940938 -- now that we have the script apply

941939 -- it to the reflected goal and context

942− restac <- unique_hole (MN 0 "restac")

940+ restac <- getNameFrom (sMN 0 "restac")

943941 claim restac tacticTy

944942 focus restac

945943 fill (raw_apply (forget script')

@@ -953,27 +951,27 @@ runTac autoSolve ist tac

953951 let tactic = normalise ctxt env restac'

954952 runReflected tactic

955953 where tacticTy = Var (reflm "Tactic")

956− listTy = Var (NS (UN "List") ["List", "Prelude"])

957− scriptTy = (RBind (UN "__pi_arg")

954+ listTy = Var (sNS (sUN "List") ["List", "Prelude"])

955+ scriptTy = (RBind (sUN "__pi_arg")

958956 (Pi (RApp listTy envTupleType))

959− (RBind (UN "__pi_arg1")

957+ (RBind (sUN "__pi_arg1")

960958 (Pi (Var $ reflm "TT")) tacticTy))

961959 runT (ByReflection tm) -- run the reflection function 'tm' on the

962960 -- goal, then apply the resulting reflected Tactic

963961 = do tgoal <- goal

964962 attack

965− script <- unique_hole (MN 0 "script")

963+ script <- getNameFrom (sMN 0 "script")

966964 claim script scriptTy

967− scriptvar <- unique_hole (MN 0 "scriptvar" )

965+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

968966 letbind scriptvar scriptTy (Var script)

969967 focus script

970968 ptm <- get_term

971− elab ist toplevel False [] (MN 0 "tac")

969+ elab ist toplevel False [] (sMN 0 "tac")

972970 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

973971 (script', _) <- get_type_val (Var scriptvar)

974972 -- now that we have the script apply

975973 -- it to the reflected goal

976− restac <- unique_hole (MN 0 "restac")

974+ restac <- getNameFrom (sMN 0 "restac")

977975 claim restac tacticTy

978976 focus restac

979977 fill (forget script')

@@ -989,28 +987,28 @@ runTac autoSolve ist tac

989987 scriptTy = tacticTy

990988

991989 runT (Reflect v) = do attack -- let x = reflect v in ...

992− tyn <- unique_hole (MN 0 "letty")

990+ tyn <- getNameFrom (sMN 0 "letty")

993991 claim tyn RType

994− valn <- unique_hole (MN 0 "letval")

992+ valn <- getNameFrom (sMN 0 "letval")

995993 claim valn (Var tyn)

996− letn <- unique_hole (MN 0 "letvar")

994+ letn <- getNameFrom (sMN 0 "letvar")

997995 letbind letn (Var tyn) (Var valn)

998996 focus valn

999− elab ist toplevel False [] (MN 0 "tac") v

997+ elab ist toplevel False [] (sMN 0 "tac") v

1000998 (value, _) <- get_type_val (Var letn)

1001999 ctxt <- get_context

10021000 env <- get_env

10031001 let value' = hnf ctxt env value

10041002 runTac autoSolve ist (Exact $ PQuote (reflect value'))

10051003 runT (Fill v) = do attack -- let x = fill x in ...

1006− tyn <- unique_hole (MN 0 "letty")

1004+ tyn <- getNameFrom (sMN 0 "letty")

10071005 claim tyn RType

1008− valn <- unique_hole (MN 0 "letval")

1006+ valn <- getNameFrom (sMN 0 "letval")

10091007 claim valn (Var tyn)

1010− letn <- unique_hole (MN 0 "letvar")

1008+ letn <- getNameFrom (sMN 0 "letvar")

10111009 letbind letn (Var tyn) (Var valn)

10121010 focus valn

1013− elab ist toplevel False [] (MN 0 "tac") v

1011+ elab ist toplevel False [] (sMN 0 "tac") v

10141012 (value, _) <- get_type_val (Var letn)

10151013 ctxt <- get_context

10161014 env <- get_env

@@ -1020,20 +1018,20 @@ runTac autoSolve ist tac

10201018 runT (GoalType n tac) = do g <- goal

10211019 case unApply g of

10221020 (P _ n' _, _) ->

1023− if nsroot n' == UN n

1021+ if nsroot n' == sUN n

10241022 then runT tac

10251023 else fail "Wrong goal type"

10261024 _ -> fail "Wrong goal type"

10271025 runT ProofState = do g <- goal

1028− trace (show g) $ return ()

1026+ return ()

10291027 runT x = fail $ "Not implemented " ++ show x

10301028

10311029 runReflected t = do t' <- reify ist t

10321030 runTac autoSolve ist t'

10331031

1034−-- | Prefix a name with the "Reflection.Language" namespace

1032+-- | Prefix a name with the "Language.Reflection" namespace

10351033reflm :: String -> Name

1036−reflm n = NS (UN n) ["Reflection", "Language"]

1034+reflm n = sNS (sUN n) ["Reflection", "Language"]

10371035

10381036

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

10551053reifyApp ist t [Constant (Str n), x]

10561054 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

10571055reifyApp _ t [Constant (Str n)]

1058− | t == reflm "Intro" = return $ Intro [UN n]

1056+ | t == reflm "Intro" = return $ Intro [sUN n]

10591057reifyApp ist t [t']

10601058 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

10611059reifyApp ist t [t']

@@ -1146,13 +1144,13 @@ reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

11461144

11471145reifyTTNameApp :: Name -> [Term] -> ElabD Name

11481146reifyTTNameApp t [Constant (Str n)]

1149− | t == reflm "UN" = return $ UN n

1147+ | t == reflm "UN" = return $ sUN n

11501148reifyTTNameApp t [n, ns]

11511149 | t == reflm "NS" = do n' <- reifyTTName n

11521150 ns' <- reifyTTNamespace ns

1153− return $ NS n' ns'

1151+ return $ sNS n' ns'

11541152reifyTTNameApp t [Constant (I i), Constant (Str n)]

1155− | t == reflm "MN" = return $ MN i n

1153+ | t == reflm "MN" = return $ sMN i n

11561154reifyTTNameApp t []

11571155 | t == reflm "NErased" = return NErased

11581156reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

@@ -1161,9 +1159,9 @@ reifyTTNamespace :: Term -> ElabD [String]

11611159reifyTTNamespace t@(App _ _)

11621160 = case unApply t of

11631161 (P _ f _, [Constant StrType])

1164− | f == NS (UN "Nil") ["List", "Prelude"] -> return []

1162+ | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

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

11671165 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

11681166reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

11691167

@@ -1285,19 +1283,19 @@ reflectNameType (TCon x y)

12851283 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

12861284

12871285reflectName :: Name -> Raw

1288−reflectName (UN str)

1289− = reflCall "UN" [RConstant (Str str)]

1286+reflectName (UN s)

1287+ = reflCall "UN" [RConstant (Str (str s))]

12901288reflectName (NS n ns)

12911289 = reflCall "NS" [ reflectName n

12921290 , foldr (\ n s ->

1293− raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

1291+ raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

12941292 [ RConstant StrType, RConstant (Str n), s ])

1295− ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

1293+ ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

12961294 [ RConstant StrType ])

1297− ns

1295+ (map str ns)

12981296 ]

12991297reflectName (MN i n)

1300− = reflCall "MN" [RConstant (I i), RConstant (Str n)]

1298+ = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

13011299reflectName (NErased) = Var (reflm "NErased")

13021300reflectName n = Var (reflm "NErased") -- special name, not yet implemented

13031301

@@ -1354,7 +1352,7 @@ reflectEnv = foldr consToEnvList emptyEnvList

13541352 where

13551353 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

13561354 consToEnvList (n, b) l

1357− = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

1355+ = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

13581356 [ envTupleType

13591357 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

13601358 , (RApp (Var $ reflm "Binder")

@@ -1366,14 +1364,182 @@ reflectEnv = foldr consToEnvList emptyEnvList

13661364 ]

13671365

13681366 emptyEnvList :: Raw

1369− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1367+ emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

13701368 [envTupleType]

13711369

13721370-- | 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+

13731396reflectErr :: Err -> Raw

1374−reflectErr (Msg msg) = raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str msg)]

1375−reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflection", "Language"])) [reflectConstant (Str msg)]

1376−reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)]

1397+reflectErr (Msg msg) = raw_apply (Var $ reflErrName "Msg") [RConstant (Str msg)]

1398+reflectErr (InternalMsg msg) = raw_apply (Var $ reflErrName "InternalMsg") [RConstant (Str msg)]

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

13771543

13781544envTupleType :: Raw

13791545envTupleType

@@ -1383,44 +1549,3 @@ envTupleType

13831549

13841550solveAll = try (do solve; solveAll) (return ())

13851551

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

1212

1313import System.Console.Haskeline

1414import System.Console.Haskeline.MonadException

15−import Control.Monad.State

15+import Control.Monad.State.Strict

1616import Control.Monad.Error (throwError, catchError)

1717import System.IO.Error(isUserError, ioeGetErrorString)

1818import Data.Char

@@ -38,6 +38,7 @@ report e

3838idrisCatch :: Idris a -> (Err -> Idris a) -> Idris a

3939idrisCatch = catchError

4040

41+

4142setAndReport :: Err -> Idris ()

4243setAndReport e = do ist <- getIState

4344 let h = idris_outh ist

@@ -71,3 +72,4 @@ getErrLine _ = 0

7172getErrColumn :: Err -> Int

7273getErrColumn (At (FC _ _ c) _) = c

7374getErrColumn _ = 0

75+

src/Idris/IBC.hs+156−54

@@ -8,25 +8,29 @@ import Idris.Core.CaseTree

88import Idris.AbsSyntax

99import Idris.Imports

1010import Idris.Error

11+import Idris.Delaborate

1112

1213import Data.Binary

1314import Data.Vector.Binary

1415import 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+

1619import 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

1822import System.FilePath

1923import System.Directory

24+import Codec.Compression.Zlib (compress)

25+import Util.Zlib (decompressEither)

2026

21−import Debug.Trace

22−

23−import Paths_idris

2427

2528ibcVersion :: Word8

26−ibcVersion = 50

29+ibcVersion = 54

2730

2831data IBCFile = IBCFile { ver :: Word8,

2932 sourcefile :: FilePath,

33+ symbols :: [Name],

3034 ibc_imports :: [FilePath],

3135 ibc_implicits :: [(Name, [PArg])],

3236 ibc_fixes :: [FixDecl],

@@ -61,13 +65,23 @@ deriving instance Binary IBCFile

6165!-}

6266

6367initIBC :: IBCFile

64−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

68+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

6569

6670loadIBC :: FilePath -> Idris ()

6771loadIBC fp = do iLOG $ "Loading ibc " ++ fp

68− ibcf <- runIO $ (decodeFile fp :: IO IBCFile)

72+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

6973 process ibcf fp

7074

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+

7185writeIBC :: FilePath -> FilePath -> Idris ()

7286writeIBC src f

7387 = do iLOG $ "Writing ibc " ++ show f

@@ -75,11 +89,12 @@ writeIBC src f

7589 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

7690 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

7791 [] -> return ()

92+ resetNameIdx

7893 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

7994 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

80− runIO $ encodeFile f ibcf

95+ runIO $ bencode f ibcf

8196 iLOG "Written")

82− (\c -> do iLOG $ "Failed " ++ show c)

97+ (\c -> do iLOG $ "Failed " ++ pshow i c)

8398 return ()

8499

85100mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

@@ -124,8 +139,64 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

124139ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

125140ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

126141ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

127− [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

142+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

143+ return f' { ibc_defs = (n,v) : ibc_defs f' }

128144 _ -> 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+

129200ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

130201 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

131202 _ -> ifail "IBC write failed"

@@ -169,7 +240,7 @@ process i fn

169240 pCGFlags (ibc_cgflags i)

170241 pDyLibs (ibc_dynamic_libs i)

171242 pHdrs (ibc_hdrs i)

172− pDefs (ibc_defs i)

243+ pDefs (symbols i) (ibc_defs i)

173244 pAccess (ibc_access i)

174245 pTotal (ibc_total i)

175246 pCG (ibc_cg i)

@@ -207,7 +278,9 @@ pImports fs

207278pImps :: [(Name, [PArg])] -> Idris ()

208279pImps imps = mapM_ (\ (n, imp) ->

209280 do i <- getIState

210− putIState (i { idris_implicits

281+ case lookupDefAcc n False (tt_ctxt i) of

282+ [(n, Hidden)] -> return ()

283+ _ -> putIState (i { idris_implicits

211284 = addDef n imp (idris_implicits i) }))

212285 imps

213286

@@ -289,12 +362,32 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

289362pHdrs :: [(Codegen, String)] -> Idris ()

290363pHdrs hs = mapM_ (uncurry addHdr) hs

291364

292−pDefs :: [(Name, Def)] -> Idris ()

293−pDefs ds = mapM_ (\ (n, d) ->

294− do i <- getIState

295− logLvl 5 $ "Added " ++ show (n, d)

296− putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

297− ds

365+pDefs :: [Name] -> [(Name, Def)] -> Idris ()

366+pDefs syms ds

367+ = mapM_ (\ (n, d) ->

368+ do i <- getIState

369+ let d' = updateDef d

370+ logLvl 5 $ "Added " ++ show (n, d')

371+ putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) 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

298391

299392pDocs :: [(Name, String)] -> Idris ()

300393pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -357,27 +450,24 @@ instance Binary CGInfo where

357450 put (CGInfo x1 x2 x3 x4 x5)

358451 = do put x1

359452 put x2

360− put x3

453+-- put x3 -- Already used SCG info for totality check

361454 put x4

362455 put x5

363456 get

364457 = do x1 <- get

365458 x2 <- get

366− x3 <- get

367459 x4 <- get

368460 x5 <- get

369− return (CGInfo x1 x2 x3 x4 x5)

461+ return (CGInfo x1 x2 [] x4 x5)

370462

371463instance Binary FC where

372464 put (FC x1 x2 x3)

373465 = do put x1

374− put x2

375− put x3

466+ put (x2 * 65536 + x3)

376467 get

377468 = do x1 <- get

378− x2 <- get

379− x3 <- get

380− return (FC x1 x2 x3)

469+ x2x3 <- get

470+ return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

381471

382472

383473instance Binary Name where

@@ -394,6 +484,8 @@ instance Binary Name where

394484 NErased -> putWord8 3

395485 SN x1 -> do putWord8 4

396486 put x1

487+ SymRef x1 -> do putWord8 5

488+ put x1

397489 get

398490 = do i <- getWord8

399491 case i of

@@ -408,8 +500,15 @@ instance Binary Name where

408500 3 -> return NErased

409501 4 -> do x1 <- get

410502 return (SN x1)

503+ 5 -> do x1 <- get

504+ return (SymRef x1)

411505 _ -> error "Corrupted binary data for Name"

412506

507+instance Binary T.Text where

508+ put x = put (str x)

509+ get = do x <- get

510+ return (txt x)

511+

413512instance Binary SpecialName where

414513 put x

415514 = case x of

@@ -624,35 +723,34 @@ instance Binary NameType where

624723 Bound -> putWord8 0

625724 Ref -> putWord8 1

626725 DCon x1 x2 -> do putWord8 2

627− put x1

628− put x2

726+ put (x1 * 65536 + x2)

629727 TCon x1 x2 -> do putWord8 3

630− put x1

631− put x2

728+ put (x1 * 65536 + x2)

632729 get

633730 = do i <- getWord8

634731 case i of

635732 0 -> return Bound

636733 1 -> return Ref

637− 2 -> do x1 <- get

638− x2 <- get

639− return (DCon x1 x2)

640− 3 -> do x1 <- get

641− x2 <- get

642− return (TCon x1 x2)

734+ 2 -> do x1x2 <- get

735+ return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

736+ 3 -> do x1x2 <- get

737+ return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

643738 _ -> error "Corrupted binary data for NameType"

644739

645740

646−instance {-(Binary n) =>-} Binary (TT Name) where

741+instance {- (Binary n) => -} Binary (TT Name) where

647742 put x

648743 = {-# SCC "putTT" #-}

649744 case x of

650745 P x1 x2 x3 -> do putWord8 0

651746 put x1

652747 put x2

653− put x3

654− V x1 -> do putWord8 1

655− put x1

748+-- put x3

749+ V x1 -> if (x1 >= 0 && x1 < 256)

750+ then do putWord8 1

751+ putWord8 (toEnum (x1 + 1))

752+ else do putWord8 9

753+ put x1

656754 Bind x1 x2 x3 -> do putWord8 2

657755 put x1

658756 put x2

@@ -664,7 +762,7 @@ instance {-(Binary n) =>-} Binary (TT Name) where

664762 put x1

665763 Proj x1 x2 -> do putWord8 5

666764 put x1

667− put x2

765+ putWord8 (toEnum (x2 + 1))

668766 Erased -> putWord8 6

669767 TType x1 -> do putWord8 7

670768 put x1

@@ -674,10 +772,10 @@ instance {-(Binary n) =>-} Binary (TT Name) where

674772 case i of

675773 0 -> do x1 <- get

676774 x2 <- get

677− x3 <- get

678− return (P x1 x2 x3)

679− 1 -> do x1 <- get

680− return (V x1)

775+-- x3 <- get

776+ return (P x1 x2 Erased)

777+ 1 -> do x1 <- getWord8

778+ return (V ((fromEnum x1) - 1))

681779 2 -> do x1 <- get

682780 x2 <- get

683781 x3 <- get

@@ -688,12 +786,14 @@ instance {-(Binary n) =>-} Binary (TT Name) where

688786 4 -> do x1 <- get

689787 return (Constant x1)

690788 5 -> do x1 <- get

691− x2 <- get

692− return (Proj x1 x2)

789+ x2 <- getWord8

790+ return (Proj x1 ((fromEnum x2)-1))

693791 6 -> return Erased

694792 7 -> do x1 <- get

695793 return (TType x1)

696794 8 -> return Impossible

795+ 9 -> do x1 <- get

796+ return (V x1)

697797 _ -> error "Corrupted binary data for TT"

698798

699799instance Binary SC where

@@ -772,15 +872,13 @@ instance Binary CaseAlt where

772872

773873instance Binary CaseDefs where

774874 put (CaseDefs x1 x2 x3 x4)

775− = do -- don't need totality checked version

875+ = do -- don't need totality checked or inlined versions

776876 put x2

777− put x3

778877 put x4

779878 get

780879 = do x2 <- get

781− x3 <- get -- use for totality checked version

782880 x4 <- get

783− return (CaseDefs x3 x2 x3 x4)

881+ return (CaseDefs x2 x2 x2 x4)

784882

785883instance Binary CaseInfo where

786884 put x@(CaseInfo x1 x2) = do put x1

@@ -914,7 +1012,7 @@ instance Binary MetaInformation where

9141012 return (DataMI x1)

9151013

9161014instance 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)

9181016 = {-# SCC "putIBCFile" #-}

9191017 do put x1

9201018 put x2

@@ -945,6 +1043,7 @@ instance Binary IBCFile where

9451043 put x27

9461044 put x28

9471045 put x29

1046+ put x30

9481047 get

9491048 = do x1 <- get

9501049 if x1 == ibcVersion then

@@ -976,7 +1075,8 @@ instance Binary IBCFile where

9761075 x27 <- get

9771076 x28 <- get

9781077 x29 <- 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)

1078+ x30 <- get

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)

9801080 else return (initIBC { ver = x1 })

9811081

9821082instance Binary DataOpt where

@@ -1001,6 +1101,7 @@ instance Binary FnOpt where

10011101 PartialFn -> putWord8 6

10021102 Implicit -> putWord8 7

10031103 Reflection -> putWord8 8

1104+ ErrorHandler -> putWord8 9

10041105 get

10051106 = do i <- getWord8

10061107 case i of

@@ -1014,6 +1115,7 @@ instance Binary FnOpt where

10141115 6 -> return PartialFn

10151116 7 -> return Implicit

10161117 8 -> return Reflection

1118+ 9 -> return ErrorHandler

10171119 _ -> error "Corrupted binary data for FnOpt"

10181120

10191121instance Binary Fixity where

src/Idris/Imports.hs+1−1

@@ -7,7 +7,7 @@ import Paths_idris

77

88import System.FilePath

99import System.Directory

10−import Control.Monad.State

10+import Control.Monad.State.Strict

1111

1212data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

1313 deriving (Show, Eq)

src/Idris/ParseData.hs+14−10

@@ -49,7 +49,7 @@ record syn = do (doc, acc) <- try (do

4949 ty <- typeExpr (allowImp syn)

5050 let tyn = expandNS syn tyn_in

5151 reserved "where"

52− (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)

52+ (cdoc, cn, cty, _, _) <- indentedBlockS (constructor syn)

5353 accData acc tyn [cn]

5454 let rsyn = syn { syn_namespace = show (nsroot tyn) :

5555 syn_namespace syn }

@@ -113,7 +113,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

113113 option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do

114114 reserved "where"

115115 cons <- indentedBlock (constructor syn)

116− accData acc tyn (map (\ (_, n, _, _) -> n) cons)

116+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons)

117117 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

118118 args <- many name

119119 let ty = bindArgs (map (const PType) args) PType

@@ -133,10 +133,10 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

133133 cons <- sepBy1 (simpleConstructor syn) (lchar '|')

134134 terminator

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

137137 do let cty = bindArgs cargs conty

138− return (doc, x, cty, cfc)) cons

139− accData acc tyn (map (\ (_, n, _, _) -> n) cons')

138+ return (doc, x, cty, cfc, fs)) cons

139+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons')

140140 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons')))

141141 <?> "data type declaration"

142142 where

@@ -144,7 +144,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

144144 mkPApp fc t [] = t

145145 mkPApp fc t xs = PApp fc t (map pexp xs)

146146 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

148148 combineDataOpts :: DataOpts -> DataOpts

149149 combineDataOpts opts = if Codata `elem` opts then delete DefaultEliminator opts else opts

150150

@@ -152,20 +152,24 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

152152{- | Parses a type constructor declaration

153153 Constructor ::= DocComment? FnName TypeSig;

154154-}

155−constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)

155+constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC, [Name])

156156constructor syn

157157 = do doc <- option "" (docComment '|')

158158 cn_in <- fnName; fc <- getFC

159159 let cn = expandNS syn cn_in

160160 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 ','))

161165 ty <- typeExpr (allowImp syn)

162− return (doc, cn, ty, fc)

166+ return (doc, cn, ty, fc, fs)

163167 <?> "constructor"

164168

165169{- | Parses a constructor for simple discriminative union data types

166170 SimpleConstructor ::= FnName SimpleExpr* DocComment?

167171-}

168−simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)

172+simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC, [Name])

169173simpleConstructor syn

170174 = do cn_in <- fnName

171175 let cn = expandNS syn cn_in

@@ -173,7 +177,7 @@ simpleConstructor syn

173177 args <- many (do notEndApp

174178 simpleExpr syn)

175179 doc <- option "" (docComment '^')

176− return (doc, cn, args, fc)

180+ return (doc, cn, args, fc, [])

177181 <?> "constructor"

178182

179183{- | Parses a dsl block declaration

src/Idris/ParseExpr.hs+58−28

@@ -114,7 +114,7 @@ extension :: SyntaxInfo -> Syntax -> IdrisParser PTerm

114114extension syn (Rule ssym ptm _)

115115 = do smap <- mapM extensionSymbol ssym

116116 let ns = mapMaybe id smap

117− return (update ns ptm) -- updated with smap

117+ return (flatten (update ns ptm)) -- updated with smap

118118 where

119119 extensionSymbol :: SSymbol -> IdrisParser (Maybe (Name, SynMatch))

120120 extensionSymbol (Keyword n) = do reserved (show n); return Nothing

@@ -131,6 +131,10 @@ extension syn (Rule ssym ptm _)

131131 dropn n ((x,t) : xs) | n == x = xs

132132 | otherwise = (x,t):dropn n xs

133133

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+

134138 updateB :: [(Name, SynMatch)] -> Name -> Name

135139 updateB ns n = case lookup n ns of

136140 Just (SynBind t) -> t

@@ -186,6 +190,7 @@ internalExpr syn =

186190 try (app syn)

187191 <|> try (matchApp syn)

188192 <|> try (unifyLog syn)

193+ <|> try (disamb syn)

189194 <|> try (noImplicits syn)

190195 <|> recordType syn

191196 <|> lambda syn

@@ -291,7 +296,7 @@ simpleExpr syn =

291296 fc <- getFC

292297 return (modifyConst syn fc (PConstant c)))

293298 <|> try (do symbol "'"; fc <- getFC; str <- name

294− return (PApp fc (PRef fc (UN "Symbol_"))

299+ return (PApp fc (PRef fc (sUN "Symbol_"))

295300 [pexp (PConstant (Str (show str)))]))

296301 <|> do fc <- getFC

297302 x <- fnName

@@ -356,12 +361,12 @@ bracketed syn =

356361 l <- expr' syn

357362 o <- operator

358363 lchar ')'

359− return $ PLam (MN 1000 "ARG") Placeholder

360− (PApp fc0 (PRef fc0 (UN o)) [pexp l,

361− pexp (PRef fc0 (MN 1000 "ARG"))]))

364+ return $ PLam (sMN 1000 "ARG") Placeholder

365+ (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

366+ pexp (PRef fc0 (sMN 1000 "ARG"))]))

362367 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

363− return $ PLam (MN 1000 "ARG") Placeholder

364− (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),

368+ return $ PLam (sMN 1000 "ARG") Placeholder

369+ (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

365370 pexp e]))

366371 <|> try (do ln <- name; lchar ':'

367372 lty <- expr syn

@@ -384,7 +389,7 @@ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

384389modifyConst syn fc (PConstant (BI x))

385390 | not (inPattern syn)

386391 = 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)))]

388393 : consts)

389394 | otherwise = PAlternative False consts

390395 where

@@ -416,8 +421,8 @@ listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lc

416421 <?> "list expression"

417422 where

418423 mkList :: FC -> [PTerm] -> PTerm

419− mkList fc [] = PRef fc (UN "Nil")

420− mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]

424+ mkList fc [] = PRef fc (sUN "Nil")

425+ mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

421426

422427

423428{- | Parses an alternative expression

@@ -462,10 +467,10 @@ matchApp syn = do ty <- simpleExpr syn

462467 symbol "<=="

463468 fc <- getFC

464469 f <- fnName

465− return (PLet (MN 0 "match")

470+ return (PLet (sMN 0 "match")

466471 ty

467472 (PMatchApp fc f)

468− (PRef fc (MN 0 "match")))

473+ (PRef fc (sMN 0 "match")))

469474 <?> "matching application expression"

470475

471476{- | Parses a unification log expression

@@ -479,6 +484,19 @@ unifyLog syn = do lchar '%'; reserved "unifyLog";

479484 return (PUnifyLog tm)

480485 <?> "unification log expression"

481486

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

482500{- | Parses a no implicits expression

483501@

484502NoImplicits ::=

@@ -508,12 +526,12 @@ app syn = do f <- reserved "mkForeign"

508526 i <- get

509527 -- mkForeign f args ==>

510528 -- liftPrimIO (\w => mkForeignPrim f args w)

511− let ap = PApp fc (PRef fc (UN "liftPrimIO"))

512− [pexp (PLam (MN 0 "w")

529+ let ap = PApp fc (PRef fc (sUN "liftPrimIO"))

530+ [pexp (PLam (sMN 0 "w")

513531 Placeholder

514− (PApp fc (PRef fc (UN "mkForeignPrim"))

532+ (PApp fc (PRef fc (sUN "mkForeignPrim"))

515533 (fn : args ++

516− [pexp (PRef fc (MN 0 "w"))])))]

534+ [pexp (PRef fc (sMN 0 "w"))])))]

517535 return (dslify i ap)

518536

519537 <|> do f <- simpleExpr syn

@@ -562,7 +580,7 @@ implicitArg syn = do lchar '{'

562580 v <- option (PRef fc n) (do lchar '='

563581 expr syn)

564582 lchar '}'

565− return (pimp n v False)

583+ return (pimp n v True)

566584 <?> "implicit function argument"

567585

568586{-| Parses a constraint argument (for selecting a named type class instance)

@@ -607,8 +625,8 @@ recordType syn

607625 rec <- optional (simpleExpr syn)

608626 case rec of

609627 Nothing ->

610− return (PLam (MN 0 "fldx") Placeholder

611− (applyAll fc fields (PRef fc (MN 0 "fldx"))))

628+ return (PLam (sMN 0 "fldx") Placeholder

629+ (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

612630 Just v -> return (applyAll fc fields v)

613631 <?> "record setting expression"

614632 where fieldType :: IdrisParser (Name, PTerm)

@@ -624,8 +642,8 @@ recordType syn

624642

625643-- | Creates setters for record types on necessary functions

626644mkType :: Name -> Name

627−mkType (UN n) = UN ("set_" ++ n)

628−mkType (MN 0 n) = MN 0 ("set_" ++ n)

645+mkType (UN n) = sUN ("set_" ++ str n)

646+mkType (MN 0 n) = sMN 0 ("set_" ++ str n)

629647mkType (NS n s) = NS (mkType n) s

630648

631649{- | Parses a type signature

@@ -641,7 +659,7 @@ TypeExpr ::= ConstraintList? Expr;

641659typeExpr :: SyntaxInfo -> IdrisParser PTerm

642660typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

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

645663 <?> "type signature"

646664

647665{- | Parses a lambda expression

@@ -674,8 +692,8 @@ lambda syn = do lchar '\\'

674692 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

675693 pmList [] sc = sc

676694 pmList ((i, (fc, x)) : xs) sc

677− = PLam (MN i "lamp") Placeholder

678− (PCase fc (PRef fc (MN i "lamp"))

695+ = PLam (sMN i "lamp") Placeholder

696+ (PCase fc (PRef fc (sMN i "lamp"))

679697 [(x, pmList xs sc)])

680698

681699{- | Parses a term rewrite expression

@@ -692,7 +710,7 @@ rewriteTerm syn = do reserved "rewrite"

692710 giving <- optional (do symbol "==>"; expr' syn)

693711 reserved "in"; sc <- expr syn

694712 return (PRewrite fc

695− (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc

713+ (PApp fc (PRef fc (sUN "sym")) [pexp prf]) sc

696714 giving)

697715 <?> "term rewrite expression"

698716

@@ -857,7 +875,7 @@ tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

857875 where nameOrPlaceholder :: IdrisParser Name

858876 nameOrPlaceholder = fnName

859877 <|> do symbol "_"

860− return (MN 0 "underscore")

878+ return (sMN 0 "underscore")

861879 <?> "name or placeholder"

862880

863881{- | Parses a list comprehension

@@ -881,11 +899,11 @@ comprehension syn

881899 qs <- sepBy1 (do_ syn) (lchar ',')

882900 lchar ']'

883901 return (PDoBlock (map addGuard qs ++

884− [DoExp fc (PApp fc (PRef fc (UN "return"))

902+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

885903 [pexp pat])]))

886904 <?> "list comprehension"

887905 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"))

889907 [pexp e])

890908 addGuard x = x

891909

@@ -983,6 +1001,7 @@ Constant ::=

9831001 | 'Bits64x2'

9841002 | Float_t

9851003 | Natural_t

1004+ | VerbatimString_t

9861005 | String_t

9871006 | Char_t

9881007 ;

@@ -1005,10 +1024,21 @@ constant = do reserved "Integer";return (AType (ATInt ITBig))

10051024 <|> do reserved "Bits64x2"; return (AType (ATInt (ITVec IT64 2)))

10061025 <|> try (do f <- float; return $ Fl f)

10071026 <|> try (do i <- natural; return $ BI i)

1027+ <|> try (do s <- verbatimStringLiteral; return $ Str s)

10081028 <|> try (do s <- stringLiteral; return $ Str s)

10091029 <|> try (do c <- charLiteral; return $ Ch c)

10101030 <?> "constant or literal"

10111031

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+

10121042{- | Parses a static modifier

10131043

10141044@

src/Idris/ParseHelpers.hs+2−2

@@ -230,8 +230,8 @@ initsEndAt p (x:xs) | p x = [] : x_inits_xs

230230 namespace.

231231-}

232232mkName :: (String, String) -> Name

233−mkName (n, "") = UN n

234−mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

233+mkName (n, "") = sUN n

234+mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))

235235 where parseNS x = case span (/= '.') x of

236236 (x, "") -> [x]

237237 (x, '.':y) -> x : parseNS y

src/Idris/ParseOps.hs+6−5

@@ -33,21 +33,22 @@ import qualified Data.ByteString.UTF8 as UTF8

3333-- using pre-build and user-defined operator/fixity declarations

3434table :: [FixDecl] -> OperatorTable IdrisParser PTerm

3535table fixes

36− = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))

37− [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

36+ = [[prefix "-" (\fc x -> PApp fc (PRef fc (sUN "-"))

37+ [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

3838 ++ toTable (reverse fixes) ++

3939 [[backtick],

40+ [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

4041 [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]]

4243

4344-- | Calculates table for fixtiy declarations

4445toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

4546toTable fs = map (map toBin)

4647 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

4748 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])

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

5152 assoc (Infixl _) = AssocLeft

5253 assoc (Infixr _) = AssocRight

5354 assoc (InfixN _) = AssocNone

src/Idris/Parser.hs+25−13

@@ -21,6 +21,7 @@ import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

2121import Idris.AbsSyntax

2222import Idris.DSL

2323import Idris.Imports

24+import Idris.Delaborate

2425import Idris.Error

2526import Idris.ElabDecls

2627import Idris.ElabTerm hiding (namespace, params)

@@ -43,6 +44,7 @@ import Idris.Core.Evaluate

4344

4445import Control.Applicative

4546import Control.Monad

47+import Control.Monad.Error (throwError, catchError)

4648import Control.Monad.State.Strict

4749

4850import Data.Maybe

@@ -79,7 +81,9 @@ moduleHeader = try (do reserved "module"

7981 i <- identifier

8082 option ';' (lchar ';')

8183 return (moduleName i))

82− <|> return []

84+ <|> try (do lchar '%'; reserved "unqualified"

85+ return [])

86+ <|> return (moduleName "Main")

8387 where moduleName x = case span (/='.') x of

8488 (x, "") -> [x]

8589 (x, '.':y) -> x : moduleName y

@@ -298,9 +302,9 @@ fnDecl' syn = checkFixity $

298302 getName (PTy _ _ _ _ n _) = Just n

299303 getName _ = Nothing

300304 fixityOK (NS n _) = fixityOK n

301− fixityOK (UN n) | all (flip elem opChars) n =

305+ fixityOK (UN n) | all (flip elem opChars) (str n) =

302306 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

304308 | otherwise = return True

305309 fixityOK _ = return True

306310

@@ -309,6 +313,7 @@ FnOpts ::= 'total'

309313 | 'partial'

310314 | 'implicit'

311315 | '%' 'assert_total'

316+ | '%' 'error_handler'

312317 | '%' 'reflection'

313318 | '%' 'specialise' '[' NameTimesList? ']'

314319 ;

@@ -330,6 +335,8 @@ fnOpts opts

330335 fnOpts (CExport c : opts)

331336 <|> do try (lchar '%' *> reserved "assert_total");

332337 fnOpts (AssertTotal : opts)

338+ <|> do try (lchar '%' *> reserved "error_handler");

339+ fnOpts (ErrorHandler : opts)

333340 <|> do try (lchar '%' *> reserved "reflection");

334341 fnOpts (Reflection : opts)

335342 <|> do lchar '%'; reserved "specialise";

@@ -512,7 +519,7 @@ instance_ syn = do reserved "instance"; fc <- getFC

512519 cn <- name

513520 args <- many (simpleExpr syn)

514521 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

516523 ds <- option [] (instanceBlock syn)

517524 return [PInstance syn fc cs cn args t en ds]

518525 <?> "instance declaration"

@@ -570,7 +577,7 @@ Pattern ::= Clause;

570577pattern :: SyntaxInfo -> IdrisParser PDecl

571578pattern syn = do fc <- getFC

572579 clause <- clause syn

573− return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later

580+ return (PClauses fc [] (sMN 2 "_") [clause]) -- collect together later

574581 <?> "pattern"

575582

576583{- | Parse a constant applicative form declaration

@@ -612,7 +619,7 @@ rhs syn n = do lchar '='; expr syn

612619 <|> do reserved "impossible"; return PImpossible

613620 <?> "function right hand side"

614621 where mkN :: Name -> Name

615− mkN (UN x) = UN (x++"_lemma_1")

622+ mkN (UN x) = sUN (str x++"_lemma_1")

616623 mkN (NS x n) = NS (mkN x) n

617624 n' :: Name

618625 n' = mkN n

@@ -620,7 +627,7 @@ rhs syn n = do lchar '='; expr syn

620627 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

621628 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

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

624631

625632{- |Parses a function clause

626633RHSOrWithBlock ::= RHS WhereOrTerminator

@@ -674,10 +681,10 @@ clause syn

674681 return x,

675682 do terminator

676683 return ([], [])]

677− let capp = PLet (MN 0 "match")

684+ let capp = PLet (sMN 0 "match")

678685 ty

679686 (PMatchApp fc n)

680− (PRef fc (MN 0 "match"))

687+ (PRef fc (sMN 0 "match"))

681688 ist <- get

682689 put (ist { lastParse = Just n })

683690 return $ PClause fc n capp [] r wheres

@@ -688,7 +695,7 @@ clause syn

688695 when (op == "=" || op == "?=" ) $

689696 fail "infix clause definition with \"=\" and \"?=\" not supported "

690697 return (l, op))

691− let n = expandNS syn (UN op)

698+ let n = expandNS syn (sUN op)

692699 r <- argExpr syn

693700 fc <- getFC

694701 wargs <- many (wExpr syn)

@@ -863,8 +870,13 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

863870 ty <- iName []

864871 ns <- sepBy1 name (lchar ',')

865872 return [PDirective

866− (do mapM_ (addNameHint ty) ns

867− mapM_ (\n -> addIBC (IBCNameHint (ty, n))) ns)]

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

878+ mapM_ (addNameHint ty') ns

879+ mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

868880 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

869881 return [PDirective (addLangExt ext)]

870882 <?> "directive"

@@ -1001,7 +1013,7 @@ loadModule' outh f

10011013 LIDR fn -> loadSource outh True fn

10021014 IBC fn src ->

10031015 idrisCatch (loadIBC fn)

1004− (\c -> do iLOG $ fn ++ " failed " ++ show c

1016+ (\c -> do iLOG $ fn ++ " failed " ++ pshow i c

10051017 case src of

10061018 IDR sfn -> loadSource outh False sfn

10071019 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

5454 sc' <- unifyEq xs sc

5555 return (Bind n (Pi t) sc')

5656 unifyEq xs t = do args <- get

57− put (args ++ (zip xs (repeat (UN "_"))))

57+ put (args ++ (zip xs (repeat (sUN "_"))))

5858 return t

5959

6060mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

@@ -122,7 +122,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

122122 | x && imparg imp = (ImplicitS, tm)

123123 | x = (ExplicitS, tm)

124124 | imparg imp = (ImplicitD, tm)

125− | otherwise = (ExplicitD, (P Ref (UN (show n ++ "arg")) Erased))

125+ | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126126

127127 imparg (PExp _ _ _ _) = False

128128 imparg _ = True

src/Idris/Primitives.hs+50−50

@@ -26,7 +26,7 @@ data Prim = Prim { p_name :: Name,

2626

2727ty :: [Const] -> Const -> Type

2828ty [] 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)

3030

3131total, partial :: Totality

3232total = Total []

@@ -94,83 +94,83 @@ primitives =

9494 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,

9595 iCoerce ITBig ITChar "trunc" trunc LTrunc,

9696

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

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

100100 (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 (*))

102102 (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 (/))

104104 (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 (==))

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

108108 (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 (<=))

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

112112 (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 (>=))

114114 (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 (++))

116116 (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 (==))

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

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

122122 (1, LStrLen) total,

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

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

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

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

131131 (1, LFloatStr) total,

132132

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)

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

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

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

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

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

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

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

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

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

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

154154 (1, LFCeil) total,

155155

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)

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

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

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

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

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

167167 (1, LReadStr) partial,

168− Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

168+ Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

169169 (0, LVMPtr) total,

170170 -- Streams

171− Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

171+ Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

172172 (0, LStdIn) partial,

173− Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

173+ Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

174174 (0, LNullPtr) total

175175 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]

176176 ++ concatMap vecOps vecTypes

@@ -221,13 +221,13 @@ intArith ity =

221221

222222intConv :: IntTy -> [Prim]

223223intConv 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

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

227227 (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

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

231231 (1, LFloatInt ity) total

232232 ]

233233

@@ -246,13 +246,13 @@ vecCmps ity =

246246

247247vecOps :: IntTy -> [Prim]

248248vecOps ity@(ITVec elem count) =

249− [ Prim (UN $ "prim__mk" ++ intTyName ity)

249+ [ Prim (sUN $ "prim__mk" ++ intTyName ity)

250250 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))

251251 count (mkVecCon elem count) (count, LMkVec elem count) total

252− , Prim (UN $ "prim__index" ++ intTyName ity)

252+ , Prim (sUN $ "prim__index" ++ intTyName ity)

253253 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))

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

256256 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]

257257 (AType . ATInt $ ity))

258258 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces

@@ -260,7 +260,7 @@ vecOps ity@(ITVec elem count) =

260260

261261bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim

262262bitcastPrim 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)

264264 (1, prim) total

265265

266266vecBitcasts :: [IntTy] -> [Prim]

@@ -377,23 +377,23 @@ intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show cou

377377

378378iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

379379iCmp ity op self impl irop totality

380− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

380+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

381381 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))

382382 2 impl (2, irop ity) totality

383383

384384iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

385385iBinOp ity op impl irop totality

386− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

386+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

387387 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))

388388 2 impl (2, irop ity) totality

389389iUnOp ity op impl irop totality

390− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

390+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

391391 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))

392392 1 impl (1, irop ity) totality

393393

394394iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

395395iCoerce from to op impl irop =

396− Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

396+ Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

397397 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total

398398

399399fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const

src/Idris/Prover.hs+3−2

@@ -20,7 +20,7 @@ import Text.Trifecta.Result(Result(..))

2020

2121import System.Console.Haskeline

2222import System.Console.Haskeline.History

23−import Control.Monad.State

23+import Control.Monad.State.Strict

2424

2525import Util.Pretty

2626import Debug.Trace

@@ -102,7 +102,8 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

102102 tPretty t = pretty $ delab ist t

103103

104104 prettyPs [] = empty

105− prettyPs ((MN _ "rewrite_rule", _) : bs) = prettyPs bs

105+ prettyPs ((MN _ r, _) : bs)

106+ | r == txt "rewrite_rule" = prettyPs bs

106107 prettyPs ((n, Let t v) : bs) =

107108 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108109 tPretty t $$ prettyPs bs)

src/Idris/Providers.hs+14−7

@@ -11,17 +11,24 @@ import Debug.Trace

1111

1212-- | Wrap a type provider in the type of type providers

1313providerTy :: 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"]

1519

1620-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

1721getProvided :: TT Name -> Idris (TT Name)

18−getProvided tm | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

19− , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =

20− case err of

22+getProvided tm | (P _ pioret _, [tp, result]) <- unApply tm

23+ , (P _ nm _, [_, err]) <- unApply result

24+ , pioret == ioret && nm == ermod

25+ = case err of

2126 Constant (Str msg) -> ierror . ProviderError $ msg

2227 _ -> ifail "Internal error in type provider, non-normalised error"

23− | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

24− , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =

25− return res

28+ | (P _ pioret _, [tp, result]) <- unApply tm

29+ , (P _ nm _, [_, res]) <- unApply result

30+ , pioret == ioret && nm == prmod

31+ = return res

2632 | otherwise = ifail $ "Internal type provider error: result was not " ++

2733 "IO (Provider a), or perhaps missing normalisation."

34+

src/Idris/REPL.hs+75−57

@@ -80,31 +80,33 @@ repl :: IState -- ^ The initial state

8080 -> [FilePath] -- ^ The loaded modules

8181 -> InputT Idris ()

8282repl orig mods

83− = H.catch

84− (do let quiet = opt_quiet (idris_options orig)

85− i <- lift getIState

86− let colour = idris_colourRepl i

87− let theme = idris_colourTheme i

88− let mvs = idris_metavars i

89− let prompt = if quiet

90− then ""

91− else showMVs colour theme mvs ++

92− let str = mkPrompt mods ++ ">" in

93− (if colour then colourisePrompt theme str else str) ++ " "

94− x <- getInputLine prompt

95− case x of

96− Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

97− return ()

98− Just input -> H.catch

99− (do ms <- lift $ processInput input orig mods

100− case ms of

101− Just mods -> repl orig mods

102− Nothing -> return ())

103− ctrlC)

104− ctrlC

105− where ctrlC :: SomeException -> InputT Idris ()

106− ctrlC e = do lift $ iputStrLn (show e)

107− repl orig mods

83+ = -- H.catch

84+ do let quiet = opt_quiet (idris_options orig)

85+ i <- lift getIState

86+ let colour = idris_colourRepl i

87+ let theme = idris_colourTheme i

88+ let mvs = idris_metavars i

89+ let prompt = if quiet

90+ then ""

91+ else showMVs colour theme mvs ++

92+ let str = mkPrompt mods ++ ">" in

93+ (if colour then colourisePrompt theme str else str) ++ " "

94+ x <- H.catch (getInputLine prompt)

95+ (ctrlC (return Nothing))

96+ case x of

97+ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

98+ return ()

99+ Just input -> -- H.catch

100+ do ms <- H.catch (lift $ processInput input orig mods)

101+ (ctrlC (return (Just mods)))

102+ case ms of

103+ Just mods -> repl orig mods

104+ Nothing -> return ()

105+-- ctrlC)

106+-- ctrlC

107+ where ctrlC :: InputT Idris a -> SomeException -> InputT Idris a

108+ ctrlC act e = do lift $ iputStrLn (show e)

109+ act -- repl orig mods

108110

109111 showMVs c thm [] = ""

110112 showMVs c thm ms = "Metavariables: " ++

@@ -245,19 +247,19 @@ ideslave orig mods

245247 Just x -> iPrintError $ "didn't load " ++ filename

246248 ideslave orig [filename]

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

249251 Just (IdeSlave.CaseSplit line name) ->

250− process stdout fn (CaseSplitAt False line (UN name))

252+ process stdout fn (CaseSplitAt False line (sUN name))

251253 Just (IdeSlave.AddClause line name) ->

252− process stdout fn (AddClauseFrom False line (UN name))

254+ process stdout fn (AddClauseFrom False line (sUN name))

253255 Just (IdeSlave.AddProofClause line name) ->

254− process stdout fn (AddProofClauseFrom False line (UN name))

256+ process stdout fn (AddProofClauseFrom False line (sUN name))

255257 Just (IdeSlave.AddMissing line name) ->

256− process stdout fn (AddMissing False line (UN name))

258+ process stdout fn (AddMissing False line (sUN name))

257259 Just (IdeSlave.MakeWithBlock line name) ->

258− process stdout fn (MakeWith False line (UN name))

260+ process stdout fn (MakeWith False line (sUN name))

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

261263 Nothing -> do iPrintError "did not understand")

262264 (\e -> do iPrintError $ show e))

263265 (\e -> do iPrintError $ show e)

@@ -406,6 +408,7 @@ edit f orig

406408 , idris_colourTheme = idris_colourTheme i

407409 }

408410 loadInputs stdout [f]

411+-- clearOrigPats

409412 iucheck

410413 return ()

411414 where getEditor env | Just ed <- lookup "EDITOR" env = ed

@@ -436,19 +439,19 @@ process h fn (ChangeDirectory f)

436439 = do runIO $ setCurrentDirectory f

437440 return ()

438441process h fn (Eval t)

439− = do (tm, ty) <- elabVal toplevel False t

440− ctxt <- getContext

441− let tm' = force (normaliseAll ctxt [] tm)

442− let ty' = force (normaliseAll ctxt [] ty)

443− -- Add value to context, call it "it"

444− updateContext (addCtxtDef (UN "it") (Function ty' tm'))

445− ist <- getIState

446− logLvl 3 $ "Raw: " ++ show (tm', ty')

447− logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

448− imp <- impShow

449− c <- colourise

450− ihPrintResult h (showImp (Just ist) imp c (delab ist tm') ++ " : " ++

451− showImp (Just ist) imp c (delab ist ty'))

442+ = withErrorReflection $ do (tm, ty) <- elabVal toplevel False t

443+ ctxt <- getContext

444+ let tm' = force (normaliseAll ctxt [] tm)

445+ let ty' = force (normaliseAll ctxt [] ty)

446+ -- Add value to context, call it "it"

447+ updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

448+ ist <- getIState

449+ logLvl 3 $ "Raw: " ++ show (tm', ty')

450+ logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

451+ imp <- impShow

452+ c <- colourise

453+ ihPrintResult h (showImp (Just ist) imp c (delab ist tm') ++ " : " ++

454+ showImp (Just ist) imp c (delab ist ty'))

452455process h fn (ExecVal t)

453456 = do ctxt <- getContext

454457 ist <- getIState

@@ -482,7 +485,7 @@ process h fn (Check (PRef _ n))

482485 = let current = " " ++

483486 (case n of

484487 MN _ _ -> "_"

485− UN ('_':'_':_) -> "_"

488+ UN nm | ('_':'_':_) <- str nm -> "_"

486489 _ -> showName (Just ist) [] False c n) ++

487490 " : " ++ showImp (Just ist) imp c t ++ "\n"

488491 in

@@ -741,7 +744,7 @@ process h fn (DoProofSearch updatefile l n hints)

741744 | length cs >= length n

742745 = case splitAt (length n) cs of

743746 (mv, c:cs) ->

744− if (isSpace c && mv == n)

747+ if ((isSpace c || c == ')' || c == '}') && mv == n)

745748 then addBracket brack new ++ (c : cs)

746749 else '?' : mv ++ c : updateMeta True cs n new

747750 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

@@ -849,8 +852,8 @@ process h fn (TestInline t)

849852process h fn Execute

850853 = do (m, _) <- elabVal toplevel False

851854 (PApp fc

852− (PRef fc (UN "run__IO"))

853− [pexp $ PRef fc (NS (UN "main") ["Main"])])

855+ (PRef fc (sUN "run__IO"))

856+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

854857-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

855858 (tmpn, tmph) <- runIO tempfile

856859 runIO $ hClose tmph

@@ -861,8 +864,8 @@ process h fn Execute

861864 where fc = fileFC "main"

862865process h fn (Compile codegen f)

863866 = do (m, _) <- elabVal toplevel False

864− (PApp fc (PRef fc (UN "run__IO"))

865− [pexp $ PRef fc (NS (UN "main") ["Main"])])

867+ (PApp fc (PRef fc (sUN "run__IO"))

868+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

866869 compile codegen f m

867870 where fc = fileFC "main"

868871process h fn (LogLvl i) = setLogLevel i

@@ -919,6 +922,12 @@ process h fn ColourOn

919922process h fn ColourOff

920923 = do ist <- getIState

921924 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

922931

923932classInfo :: ClassInfo -> Idris ()

924933classInfo ci = do iputStrLn "Methods:\n"

@@ -999,11 +1008,14 @@ parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)

9991008parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

10001009parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

10011010parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1011+-- Package Related options

10021012parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

10031013parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

10041014parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

10051015parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

10061016parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1017+parseArgs ("--checkpkg":n:ns) = PkgCheck n : (parseArgs ns)

1018+-- Misc Options

10071019parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

10081020parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

10091021parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

@@ -1095,12 +1107,13 @@ loadInputs h inputs

10951107 when (not loadCode) $ tryLoad $ nub (concat ifiles)

10961108 _ -> return ()

10971109 putIState inew)

1098− (\e -> do case e of

1110+ (\e -> do i <- getIState

1111+ case e of

10991112 At f _ -> do setErrLine (fc_line f)

11001113 iputStrLn (show e)

11011114 ProgramLineComment -> return () -- fail elsewhere

11021115 _ -> do setErrLine 3 -- FIXME! Propagate it

1103− iputStrLn (show e))

1116+ iputStrLn (pshow i e))

11041117 where -- load all files, stop if any fail

11051118 tryLoad :: [IFileType] -> Idris ()

11061119 tryLoad [] = return ()

@@ -1186,8 +1199,8 @@ idrisMain opts =

11861199 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

11871200 return ()

11881201 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1189− ist <- getIState

11901202

1203+ orig <- getIState

11911204 loadInputs stdout inputs

11921205

11931206 runIO $ hSetBuffering stdout LineBuffering

@@ -1211,10 +1224,11 @@ idrisMain opts =

12111224 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

12121225

12131226 when (runrepl && not idesl) $ do

1227+-- clearOrigPats

12141228 initScript

1215− startServer ist inputs

1216− runInputT (replSettings (Just historyFile)) $ repl ist inputs

1217− when (idesl) $ ideslaveStart ist inputs

1229+ startServer orig inputs

1230+ runInputT (replSettings (Just historyFile)) $ repl orig inputs

1231+ when (idesl) $ ideslaveStart orig inputs

12181232 ok <- noErrors

12191233 when (not ok) $ runIO (exitWith (ExitFailure 1))

12201234 where

@@ -1316,6 +1330,10 @@ getPkgClean :: Opt -> Maybe String

13161330getPkgClean (PkgClean str) = Just str

13171331getPkgClean _ = Nothing

13181332

1333+getPkgCheck :: Opt -> Maybe String

1334+getPkgCheck (PkgCheck str) = Just str

1335+getPkgCheck _ = Nothing

1336+

13191337getCodegen :: Opt -> Maybe Codegen

13201338getCodegen (UseCodegen x) = Just x

13211339getCodegen _ = Nothing

src/Idris/REPLParser.hs+1

@@ -96,6 +96,7 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

9696 eof; return (AddProof n))

9797 <|> try (do cmd ["x"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (ExecVal t))

9898 <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t))

99+ <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)

99100 <|> do P.whiteSpace; do eof; return NOP

100101 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

101102

src/Idris/Transforms.hs+3−3

@@ -39,8 +39,8 @@ instance Transform CaseAlt where

3939

4040natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

4141

42−zname = NS (UN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

42+zname = sNS (sUN "Z") ["Nat","Prelude"]

43+sname = sNS (sUN "S") ["Nat","Prelude"]

4444

4545zero :: TT Name -> TT Name

4646zero (P _ n _) | n == zname

@@ -49,7 +49,7 @@ zero x = x

4949

5050suc :: TT Name -> TT Name

5151suc (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]

5353suc x = x

5454

5555natcase :: SC -> SC

src/Idris/UnusedArgs.hs+2−1

@@ -23,6 +23,7 @@ traceUnused n

2323 recused <- mapM (\ (argn, i, (g, j)) ->

2424 do u <- used [(n, i)] g j

2525 return (argn, u)) fargs

26+ logLvl 4 $ show n ++ " recused TRACE: " ++ show recused

2627 let fused = nub $ usedns ++ map fst (filter snd recused)

2728 logLvl 1 $ show n ++ " used args: " ++ show fused

2829 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

@@ -50,7 +51,7 @@ used path g j

5051 recused <- mapM (\ (argn, j, (g', j')) ->

5152 used ((g,j):path) g' j') garg

5253 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

54+ return (directuse || or recused)

5455 _ -> return True -- no definition, assume used

5556

5657getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+1−1

@@ -27,7 +27,7 @@ data PkgDesc = PkgDesc { pkgname :: String,

2727 }

2828 deriving Show

2929

30−defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (UN "") Nothing

30+defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing

3131

3232parseDesc :: FilePath -> IO PkgDesc

3333parseDesc fp = do p <- readFile fp

src/Pkg/Package.hs+44−5

@@ -24,13 +24,14 @@ import Pkg.PParser

2424

2525import Paths_idris (getDataDir)

2626

27+-- | Run the package through the idris compiler.

28+--

2729-- To build a package:

2830-- * read the package description

2931-- * check all the library dependencies exist

3032-- * invoke the makefile if there is one

3133-- * invoke idris on each module, with idris_opts

3234-- * install everything into datadir/pname, if install flag is set

33−

3435buildPkg :: Bool -> (Bool, FilePath) -> IO ()

3536buildPkg warnonly (install, fp)

3637 = do pkgdesc <- parseDesc fp

@@ -63,7 +64,33 @@ buildPkg warnonly (install, fp)

6364 putStrLn $ "\t" ++ show ms

6465 exitWith (ExitFailure 1)

6566

66−cleanPkg :: FilePath -> IO ()

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

92+cleanPkg :: FilePath -- ^ Path to ipkg file.

93+ -> IO ()

6794cleanPkg fp

6895 = do pkgdesc <- parseDesc fp

6996 dir <- getCurrentDirectory

@@ -74,6 +101,7 @@ cleanPkg fp

74101 Nothing -> return ()

75102 Just s -> rmFile $ dir </> s

76103

104+-- | Install package

77105installPkg :: PkgDesc -> IO ()

78106installPkg pkgdesc

79107 = do dir <- getCurrentDirectory

@@ -83,6 +111,11 @@ installPkg pkgdesc

83111 Just o -> return () -- do nothing, keep executable locally, for noe

84112 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

85113

114+

115+-- ---------------------------------------------------------- [ Helper Methods ]

116+-- Methods for building, testing, installing, and removal of idris

117+-- packages.

118+

86119buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

87120buildMods opts ns = do let f = map (toPath . showCG) ns

88121-- putStrLn $ "MODULE: " ++ show f

@@ -108,8 +141,8 @@ testLib warn p f

108141rmIBC :: Name -> IO ()

109142rmIBC m = rmFile $ toIBCFile m

110143

111−toIBCFile (UN n) = n ++ ".ibc"

112−toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

144+toIBCFile (UN n) = str n ++ ".ibc"

145+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))

113146

114147installIBC :: String -> Name -> IO ()

115148installIBC p m = do let f = toIBCFile m

@@ -120,7 +153,8 @@ installIBC p m = do let f = toIBCFile m

120153 copyFile f (destdir </> takeFileName f)

121154 return ()

122155 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+

124158

125159installObj :: String -> String -> IO ()

126160installObj p o = do d <- getTargetDir

@@ -136,12 +170,17 @@ mkDirCmd = "mkdir "

136170mkDirCmd = "mkdir -p "

137171#endif

138172

173+-- ------------------------------------------------------- [ Makefile Commands ]

174+-- | Invoke a Makefile's default target.

139175make :: Maybe String -> IO ()

140176make Nothing = return ()

141177make (Just s) = do system $ "make -f " ++ s

142178 return ()

143179

180+-- | Invoke a Makefile's clean target.

144181clean :: Maybe String -> IO ()

145182clean Nothing = return ()

146183clean (Just s) = do system $ "make -f " ++ s ++ " clean"

147184 return ()

185+

186+-- --------------------------------------------------------------------- [ EOF ]

src/Util/Zlib.hsnew file+15

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

1+module Util.Zlib (decompressEither) where

2+

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)

7+

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

1212 install $(LIBTARGET) $(TARGET)

1313 install $(HDRS) $(TARGET)

1414

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)

2+

13TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

24

35test: $(TESTS)

@@ -105,4 +107,3 @@ distclean:

105107 rm -f *~

106108 rm -f */output

107109

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−

41class Functor f => VerifiedFunctor (f : Type -> Type) where

52 identity : (fa : f a) -> map id fa = fa

63

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:

22No 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

2+

3+class Set univ where

4+ member : univ -> univ -> Type

5+

6+isSubsetOf : Set univ => univ -> univ -> Type

7+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

8+

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

2+

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

22test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad

33test010b.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

2+

3+import Language.Reflection

4+import Language.Reflection.Errors

5+import Language.Reflection.Utils

6+

7+%language ErrorReflection

8+

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

4+

5+Original error:

6+

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