0690def · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge remote-tracking branch 'upstream/master' into error-reflection

0690defDavid Raymond Christiansen13 years ago

CHANGELOG+6−1

compare with master

unifiedsplit

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

1New in 0.9.11:

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

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

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

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

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

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

9 same name.

11+Internal changes

12+

13+* Faster elaboration

14+* Smaller .ibc files

15+

11New in 0.9.10:

16New in 0.9.10:

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

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

idris.cabal+6−3

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

14 Dependent types allow types to be predicated on values,

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

16 specified precisely in the type. The language is closely

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

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

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

19 Features include:

20 .

@@ -341,10 +341,12 @@ Library

341 Exposed-modules:

342 Idris.Core.CaseTree

343 , Idris.Core.Constraints

344+ , Idris.Core.DeepSeq

344 , Idris.Core.Elaborate

345 , Idris.Core.Elaborate

345 , Idris.Core.Evaluate

346 , Idris.Core.Evaluate

346 , Idris.Core.Execute

347 , Idris.Core.Execute

347 , Idris.Core.ProofState

348 , Idris.Core.ProofState

349+ , Idris.Core.TC

348 , Idris.Core.TT

350 , Idris.Core.TT

349 , Idris.Core.Typecheck

351 , Idris.Core.Typecheck

350 , Idris.Core.Unify

352 , Idris.Core.Unify

@@ -445,6 +447,7 @@ Library

445 , network

447 , network

446 , xml

448 , xml

447 , deepseq

449 , deepseq

450+ , zlib

448 Extensions: MultiParamTypeClasses

451 Extensions: MultiParamTypeClasses

449 , FunctionalDependencies

452 , FunctionalDependencies

450 , FlexibleInstances

453 , FlexibleInstances

@@ -459,7 +462,7 @@ Library

459 if os(freebsd)

462 if os(freebsd)

460 cpp-options: -DFREEBSD

463 cpp-options: -DFREEBSD

461 build-depends: unix

464 build-depends: unix

462− if os(dragonfly)

465+ if os(dragonfly)

463 cpp-options: -DDRAGONFLY

466 cpp-options: -DDRAGONFLY

464 build-depends: unix

467 build-depends: unix

465 if os(darwin)

468 if os(darwin)

@@ -493,6 +496,6 @@ Executable idris

493 , transformers

496 , transformers

494

497

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

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

496− ghc-options: -threaded -rtsopts

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

497

500

498

501

libs/base/Decidable/Decidable.idr+1−7

@@ -6,19 +6,13 @@ module Decidable.Decidable

6-- Typeclass for decidable n-ary Relations

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

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−

14using (t : Type)

9using (t : Type)

15 class Rel (p : t) where

10 class Rel (p : t) where

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

11 total liftRel : (Type -> Type) -> Type

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

13 class (Rel p) => Decidable (p : t) where

19− total decide : liftRel Dec

14+ total decide : liftRel {p} Dec

21using (P : Type, p : P)

16using (P : Type, p : P)

22 data Given : Dec P -> Type where

17 data Given : Dec P -> Type where

23 always : Given (Yes p)

18 always : Given (Yes p)

24−-}

libs/base/Decidable/Order.idr+2−7

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

1module Decidable.Order

3−%access public

4−

5−{-

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

7−

8import Decidable.Decidable

3import Decidable.Decidable

9import Decidable.Equality

4import Decidable.Equality

6+%access public

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

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

12-- Utility Lemmas

9-- Utility Lemmas

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

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

@@ -83,5 +80,3 @@ instance Decidable NatLTE where

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

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

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

81lte m n = decide {p = NatLTE} m n

86−-}

87−

libs/prelude/Builtins.idr+2

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

1+%unqualified

1%access public

3%access public

2%default total

4%default total

libs/prelude/IO.idr+2

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

1+%unqualified

1import Prelude.List

3import Prelude.List

3%access public

5%access public

libs/prelude/Prelude.idr+5−5

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

275instance Applicative (Vect k) where

276 pure = replicate _

277

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

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

279

280instance Applicative Stream where

281 pure = repeat

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

282+ (<$>) = zipWith apply

283

284---- Alternative instances

285

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

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

335

336---- some mathematical operations

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

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

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

339pow x Z = 1

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

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

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

377 enumFromTo n m = if n <= m

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

379− else []

379+ else []

380 where go : List Nat -> List Integer

381 go [] = []

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

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

392 toNat n = cast n

393 fromNat n = cast n

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

395− enumFromTo n m = if n <= m

395+ enumFromTo n m = if n <= m

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

397 else []

398 where go : List Nat -> List Int

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

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

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

34flip f x y = f y x

36−infixr 1 $

37−

38-- | Function application.

36-- | Function application.

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

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

40−f $ a = f a

38+apply f a = f a

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

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

43cong refl = refl

41cong refl = refl

main/Main.hs+57−30

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

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

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

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

56+ case opt getPkgCheck opts of

57+ [] -> return ()

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

59+ runIO $ exitWith ExitSuccess

56 case opt getPkgClean opts of

60 case opt getPkgClean opts of

57 [] -> return ()

61 [] -> return ()

58 fs -> do runIO $ mapM_ cleanPkg fs

62 fs -> do runIO $ mapM_ cleanPkg fs

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

79 putStrLn incFlags

83 putStrLn incFlags

80 exitWith ExitSuccess

84 exitWith ExitSuccess

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

87+

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

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

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

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

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

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

85− "Options:\n" ++

91+ "Common flags:\n" ++

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

111−

112

139

src/IRTS/CodegenC.hs+19−2

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

10import Paths_idris

11import Util.System

13+import Numeric

13import Data.Char

14import Data.Char

14import Data.List (intercalate)

15import Data.List (intercalate)

15import System.Process

16import System.Process

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

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

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

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

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

106

107

108+showCStr :: String -> String

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

110+ where

111+ showChar :: Char -> String

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

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

114+ showChar c

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

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

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

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

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

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

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

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

123+

107bcc :: Int -> BC -> String

124bcc :: Int -> BC -> String

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

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

109bcc i (ASSIGNCONST l c)

126bcc i (ASSIGNCONST l c)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

446

463

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

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

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

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

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

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

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

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

src/IRTS/CodegenJava.hs+5−5

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

369 | otherwise = decls

370 where

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

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

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

373 findMain (_:decls) = findMain decls

374 findMain [] = False

375

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

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

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

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

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

379 findMainMethod (_:decls) = findMainMethod decls

380 findMainMethod [] = False

381

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

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

391 , jConst "args"

392 ]

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

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

394 ]

395

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

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

749

750mkThread :: LVar -> CodeGeneration Exp

751mkThread arg =

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

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

753

754

src/IRTS/CodegenJavaScript.hs+81−20

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

64 | JSArray [JS]

65 | JSObject [(String, JS)]

66 | JSString String

67+ | JSChar String

67 | JSNum JSNum

68 | JSNum JSNum

68 | JSAssign JS JS

69 | JSAssign JS JS

69 | JSAlloc String (Maybe JS)

70 | JSAlloc String (Maybe JS)

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

153compileJS (JSString str) =

154compileJS (JSString str) =

154 show str

155 show str

155

156

157+compileJS (JSChar chr) =

158+ chr

159+

156compileJS (JSNum num)

160compileJS (JSNum num)

157 | JSInt i <- num = show i

161 | JSInt i <- num = show i

158 | JSFloat f <- num = show f

162 | JSFloat f <- num = show f

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

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

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

171

175

172compileJS (JSCond branches) =

176compileJS (JSCond branches) =

173− intercalate " else " $ map createIfBlock branches

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

174 where

178 where

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

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

181+ eliminateDeadBranches [] = []

182+

183+ createIfBlock (JSTrue, e) =

184+ "{\n"

185+ ++ "return " ++ compileJS e

186+ ++ ";\n}"

175 createIfBlock (cond, e) =

187 createIfBlock (cond, e) =

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

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

177 ++ "return " ++ compileJS e

189 ++ "return " ++ compileJS e

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

233 )

245 )

234 ) [value]

246 ) [value]

235

247

248+

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

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

237jsSubst var new (JSVar old)

250jsSubst var new (JSVar old)

238 | var == translateVariableName old = new

251 | var == translateVariableName old = new

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

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

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

261 )]

274 )]

262

275

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

277+ | var `notElem` args =

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

279+ map (jsSubst var new) vals

280+ )

281+ | otherwise =

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

283+ map (jsSubst var new) vals

284+ )

285+

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

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

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

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

265

288

@@ -293,7 +316,38 @@ jsSubst var new (JSCond conds) =

293

316

294jsSubst _ _ js = js

317jsSubst _ _ js = js

295

318

319+

320+isJSConstant :: JS -> Bool

321+isJSConstant js

322+ | JSString _ <- js = True

323+ | JSChar _ <- js = True

324+ | JSNum _ <- js = True

325+ | JSType _ <- js = True

326+

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

328+ | otherwise = False

329+

296inlineJS :: JS -> JS

330inlineJS :: JS -> JS

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

332+ JSThis,JSProj (JSIdent var) "vars"

333+ ])

334+ | var /= "cse" =

335+ inlineApply args body 0

336+ where

337+ inlineApply [] body _ = body

338+ inlineApply (a:as) body n =

339+ inlineApply as (

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

341+ ) (n + 1)

342+

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

344+ | isJSConstant val = val

345+

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

347+ JSFunction [] (JSReturn val)

348+ ])

349+ | isJSConstant val = val

350+

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

351inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =

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

352 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []

299

353

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

365inlineJS (JSObject fields) =

419inlineJS (JSObject fields) =

366 JSObject (map (second inlineJS) fields)

420 JSObject (map (second inlineJS) fields)

367

421

422+inlineJS (JSOp op lhs rhs) =

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

424+

368inlineJS js = js

425inlineJS js = js

369

426

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

427reduceJS :: [JS] -> [JS]

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

536 reduceCall funs (JSProj obj field) =

593 reduceCall funs (JSProj obj field) =

537 JSProj (reduceCall funs obj) field

594 JSProj (reduceCall funs obj) field

538

595

596+ reduceCall funs (JSIndex obj idx) =

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

598+

599+ reduceCall funs (JSOp op rhs lhs) =

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

601+

539 reduceCall funs (JSCond conds) =

602 reduceCall funs (JSCond conds) =

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

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

541

604

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

606 mainFun = jsTailcall $ jsCall runMain []

669 mainFun = jsTailcall $ jsCall runMain []

607

670

608 runMain :: String

671 runMain :: String

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

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

610

673

611 invokeLoop :: String

674 invokeLoop :: String

612 invokeLoop = compileJS $ jsCall "main" []

675 invokeLoop = compileJS $ jsCall "main" []

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

671

734

672translateNamespace :: Name -> String

735translateNamespace :: Name -> String

673translateNamespace (UN _) = idrNamespace

736translateNamespace (UN _) = idrNamespace

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

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

675translateNamespace (MN _ _) = idrNamespace

738translateNamespace (MN _ _) = idrNamespace

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

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

677translateNamespace NErased = idrNamespace

740translateNamespace NErased = idrNamespace

678

741

679translateName :: Name -> String

742translateName :: Name -> String

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

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

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

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

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

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

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

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

684translateName NErased = "e"

747translateName NErased = "e"

685

748

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

688 | WhereN i m n <- name =

751 | WhereN i m n <- name =

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

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

690 | InstanceN n s <- name =

753 | InstanceN n s <- name =

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

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

692 | ParentN n s <- name =

755 | ParentN n s <- name =

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

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

694 | MethodN n <- name =

757 | MethodN n <- name =

695 'm' : translateName n

758 'm' : translateName n

696 | CaseN n <- name =

759 | CaseN n <- name =

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

699translateConstant :: Const -> JS

762translateConstant :: Const -> JS

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

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

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

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

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

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

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

702translateConstant (Ch c) = JSString [c]

768translateConstant (Ch c) = JSString [c]

703translateConstant (Str s) = JSString s

769translateConstant (Str s) = JSString s

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

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

@@ -714,9 +780,10 @@ translateConstant c =

714

780

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

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

716translateDeclaration (path, SFun name params stackSize body)

782translateDeclaration (path, SFun name params stackSize body)

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

783+ | (MN _ ap) <- name

718 , (SLet var val next) <- body

784 , (SLet var val next) <- body

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

785+ , (SChkCase cvar cases) <- next

786+ , ap == txt "APPLY" =

720 let lvar = translateVariableName var

787 let lvar = translateVariableName var

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

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

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

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

@@ -735,8 +802,9 @@ translateDeclaration (path, SFun name params stackSize body)

735 )

802 )

736 ]

803 ]

737

804

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

805+ | (MN _ ev) <- name

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

806+ , (SChkCase var cases) <- body

807+ , ev == txt "EVAL" =

740 JSSeq [ lookupTable [] var cases

808 JSSeq [ lookupTable [] var cases

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

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

742 JSTernary (

810 JSTernary (

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

798 JSFunction (p ++ map snd aux) (

866 JSFunction (p ++ map snd aux) (

799 JSSeq $

867 JSSeq $

800 zipWith assignVar [0..] p ++

868 zipWith assignVar [0..] p ++

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

802 map assignAux aux ++

869 map assignAux aux ++

803 [JSReturn body]

870 [JSReturn body]

804 )

871 )

805 where

872 where

806− numP :: Int

807− numP = length params

808−

809− allocVar :: Int -> JS

810− allocVar n = JSAlloc (jsVar n) Nothing

811−

812 assignVar :: Int -> String -> JS

873 assignVar :: Int -> String -> JS

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

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

814

875

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

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

816− assignAux (var, val) =

877+ assignAux (Loc var, val) =

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

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

818

879

819 p :: [String]

880 p :: [String]

820 p = map translateName params

881 p = map translateName params

src/IRTS/Compiler.hs+34−31

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

40 = do checkMVs

41 let tmnames = namesUsed (STerm tm)

42 usedIn <- mapM (allNames []) tmnames

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

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

44 defsIn <- mkDecls tm (concat used)

45 findUnusedArgs (concat used)

46 maindef <- irMain tm

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

49 flags <- getFlags codegen

50 hdrs <- getHdrs codegen

51 impdirs <- allImportDirs

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

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

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

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

55 let ctxtIn = addAlist tagged emptyContext

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

108

109irMain :: TT Name -> Idris LDecl

110irMain tm = do i <- ir tm

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

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

112

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

114mkDecls t used

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

137 = do i <- getIState

138 case lookup n (idris_scprims i) of

139 Just (ar, op) ->

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

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

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

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

143 _ -> do def <- mkLDecl n d

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

168instance ToIR (TT Name) where

169 ir tm = ir' [] tm where

170 ir' env tm@(App f a)

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

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

172+ m == txt "mkForeignPrim"

172 = doForeign env args

173 = doForeign env args

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

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

175+ u == txt "unsafePerformPrimIO"

174 = ir' env arg

176 = ir' env arg

175 -- TMP HACK - until we get inlining.

177 -- TMP HACK - until we get inlining.

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

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

179+ r == txt "replace"

177 = ir' env arg

180 = ir' env arg

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

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

182+ l == txt "lazy"

179 = do arg' <- ir' env arg

183 = do arg' <- ir' env arg

180 return $ LLazyExp arg'

184 return $ LLazyExp arg'

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

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

186+ a == txt "assert_smaller"

182 = ir' env arg

187 = ir' env arg

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

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

189+ p == txt "par"

184 = do arg' <- ir' env arg

190 = do arg' <- ir' env arg

185 return $ LOp LPar [LLazyExp arg']

191 return $ LOp LPar [LLazyExp arg']

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

192+ | (P _ (UN pf) _, [arg]) <- unApply tm,

193+ pf == txt "prim_fork"

187 = do arg' <- ir' env arg

194 = do arg' <- ir' env arg

188 return $ LOp LFork [LLazyExp arg']

195 return $ LOp LFork [LLazyExp arg']

189−-- | (P _ (UN "prim__IO") _, [v]) <- unApply tm

190−-- = do v' <- ir' env v

191−-- return v'

192−-- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm

193−-- = do v' <- ir' env v

194−-- sc' <- ir' (n:env) sc

195−-- return (LLet n (LForce v') sc')

196−-- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm

197−-- = do v' <- ir' env v

198−-- k' <- ir' env k

199−-- return (LApp False k' [LForce v'])

200− | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm

196+ | (P _ (UN m) _, [_,size,t]) <- unApply tm,

197+ m == txt "malloc"

201 = do size' <- ir' env size

198 = do size' <- ir' env size

202 t' <- ir' env t

199 t' <- ir' env t

203 return t' -- TODO $ malloc_ size' t'

200 return t' -- TODO $ malloc_ size' t'

204− | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm

201+ | (P _ (UN tm) _, [_,t]) <- unApply tm,

202+ tm == txt "trace_malloc"

205 = do t' <- ir' env t

203 = do t' <- ir' env t

206 return t' -- TODO

204 return t' -- TODO

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

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

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

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

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

273 return $ LLam extra sc'

271 return $ LLam extra sc'

274

272

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

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

276

274

277 buildApp env e [] = return e

275 buildApp env e [] = return e

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

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

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

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

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

301 _ -> Nothing

299 _ -> Nothing

302

300

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

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

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

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

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

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

304+mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

305+ | ff == txt "FFunction" && fa == txt "FAny" &&

306+ io == txt "IO"

307+ = FFunctionIO

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

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

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

307mkIty' _ = FAny

310mkIty' _ = FAny

308

311

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

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

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

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

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

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

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

339

342

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

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

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

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

342

345

343instance ToIR ([Name], SC) where

346instance ToIR ([Name], SC) where

344 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

347 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

src/IRTS/Defunctionalise.hs+14−14

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

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

144

145 chainAPPLY f [] = f

146− chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as

146+ chainAPPLY f (a : as) = chainAPPLY (DApp False (sMN 0 "APPLY") [f, a]) as

147

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

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

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

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

172 needsEval x _ = False

173

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

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

175

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

177 | ApplyCase a

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

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

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

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

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

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

202 : mkApplyCase fname (n + 1) ar

203

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

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

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

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

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

207 (mapMaybe evalCase xs ++

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

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

209 where

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

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

211 evalCase _ = Nothing

212

213mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

214−mkApply xs = (MN 0 "APPLY", DFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]

214+mkApply xs = (sMN 0 "APPLY", DFun (sMN 0 "APPLY") [sMN 0 "fn", sMN 0 "arg"]

215 (case mapMaybe applyCase xs of

216 [] -> DNothing

217 cases ->

218− mkBigCase (MN 0 "APPLY") 256

218+ mkBigCase (sMN 0 "APPLY") 256

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

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

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

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

221 (cases ++

222 [DDefaultCase DNothing])))

223 where

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

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

232

233

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

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

235

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

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

237mkUnderCon n 0 = n

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

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

239

240instance Show DExp where

241 show e = show' [] e where

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

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

26 where

27 prefixCallNamespacesExp :: Ident -> SExp -> SExp

28 prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =

29− SApp tail (NS n (name:ns)) args

29+ SApp tail (NS n (txt name:ns)) args

30 prefixCallNamespacesExp name (SLet var e1 e2) =

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

32 prefixCallNamespacesExp name (SUpdate var e) =

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

63 . parser ident

64 . (prefix ++)

65 . cleanNonLetter

66− $ cleanWs False name

66+ $ cleanWs False (str name)

67 where

68 cleanNonLetter (x:xs)

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

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

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

97 | otherwise = x : (cleanWs False xs)

98 cleanWs _ [] = []

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

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

100

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

102mangle = mangleWithPrefix "__IDRCG__"

src/IRTS/Lang.hs+1−1

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

102

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

104lname (UN n) i = MN i n

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

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

106

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

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

src/IRTS/Simplified.hs+2−1

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

3import IRTS.Defunctionalise

4import Idris.Core.TT

5+import Idris.Core.Typecheck

5import Data.Maybe

6import Data.Maybe

6import Control.Monad.State

7import Control.Monad.State

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

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

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

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

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

96 i <- hvar

97 i <- hvar

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

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

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

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

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

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

src/Idris/AbsSyntax.hs+270−122

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

19import System.IO

21import Control.Monad.State

22+import Control.Monad.Error(throwError)

23import Data.List

24import Data.List

24import Data.Char

25import Data.Char

26+import qualified Data.Text as T

25import Data.Either

27import Data.Either

26import Data.Maybe

28import Data.Maybe

27import Data.Word (Word)

29import Data.Word (Word)

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

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

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

181

183

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

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

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

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

184getNameHints i n =

186getNameHints i n =

185 case lookupCtxt n (idris_namehints i) of

187 case lookupCtxt n (idris_namehints i) of

186 [ns] -> ns

188 [ns] -> ns

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

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

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

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

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

202 putIState $ ist { idris_classes = cs }

204 putIState $ ist { idris_classes = cs }

203− _ -> do let cs = addDef n (CI (MN 0 "none") [] [] [] [] [i]) (idris_classes ist)

205+ _ -> do let cs = addDef n (CI (sMN 0 "none") [] [] [] [] [i]) (idris_classes ist)

204 putIState $ ist { idris_classes = cs }

206 putIState $ ist { idris_classes = cs }

205 where addI i ins | int = i : ins

207 where addI i ins | int = i : ins

206 | chaser n = ins ++ [i]

208 | chaser n = ins ++ [i]

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

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

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

210 | otherwise = n : insI i ns

212 | otherwise = n : insI i ns

211

213

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

214+ chaser (UN nm)

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

213 chaser (NS n _) = chaser n

216 chaser (NS n _) = chaser n

214 chaser _ = False

217 chaser _ = False

215

218

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

234clearIBC :: Idris ()

237clearIBC :: Idris ()

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

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

236

239

240+resetNameIdx :: Idris ()

241+resetNameIdx = do i <- getIState

242+ put (i { idris_nameIdx = (0, emptyContext) })

243+

244+-- Used to preserve sharing of names

245+addNameIdx :: Name -> Idris (Int, Name)

246+addNameIdx n = do i <- getIState

247+ let (i', x) = addNameIdx' i n

248+ return x

249+

250+addNameIdx' :: IState -> Name -> (IState, (Int, Name))

251+addNameIdx' i n

252+ = let idxs = snd (idris_nameIdx i) in

253+ case lookupCtxt n idxs of

254+ [x] -> (i, x)

255+ _ -> let i' = fst (idris_nameIdx i) + 1 in

256+ (i { idris_nameIdx = (i', addDef n (i', n) idxs) }, (i', n))

257+

237getHdrs :: Codegen -> Idris [String]

258getHdrs :: Codegen -> Idris [String]

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

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

239

260

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

284 Nothing -> return Placeholder

305 Nothing -> return Placeholder

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

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

286

307

308+-- Pattern definitions are only used for coverage checking, so erase them

309+-- when we're done

310+clearOrigPats :: Idris ()

311+clearOrigPats = do i <- get

312+ let ps = idris_patdefs i

313+ let ps' = mapCtxt (\ (_,miss) -> ([], miss)) ps

314+ put (i { idris_patdefs = ps' })

315+

316+-- Erase types from Ps in the context (basically ending up with what's in

317+-- the .ibc, which is all we need after all the analysis is done)

318+clearPTypes :: Idris ()

319+clearPTypes = do i <- get

320+ let ctxt = tt_ctxt i

321+ put (i { tt_ctxt = mapDefCtxt pErase ctxt })

322+ where pErase (CaseOp c t tys orig tot cds)

323+ = CaseOp c t tys orig [] (pErase' cds)

324+ pErase x = x

325+ pErase' (CaseDefs _ (cs, c) _ rs)

326+ = let c' = (cs, fmap pEraseType c) in

327+ CaseDefs c' c' c' rs

328+

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

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

288checkUndefined fc n

330checkUndefined fc n

289 = do i <- getContext

331 = do i <- getContext

290 case lookupTy n i of

332 case lookupTy n i of

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

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

292− show n ++ " already defined"

334+ show n ++ " already defined"

293 _ -> return ()

335 _ -> return ()

294

336

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

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

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

650

692

651bi = fileFC "builtin"

693bi = fileFC "builtin"

652

694

653−inferTy = MN 0 "__Infer"

695+inferTy = sMN 0 "__Infer"

654−inferCon = MN 0 "__infer"

696+inferCon = sMN 0 "__infer"

655inferDecl = PDatadecl inferTy

697inferDecl = PDatadecl inferTy

656 PType

698 PType

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

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

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

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

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

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

660inferOpts = []

702inferOpts = []

661

703

662−infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "iType") Placeholder True, pexp t]

704+infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

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

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

664

706

665getInferTerm, getInferType :: Term -> Term

707getInferTerm, getInferType :: Term -> Term

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

676 falseTy, pairTy, pairCon,

718 falseTy, pairTy, pairCon,

677 eqTy, eqCon, inferTy, inferCon]

719 eqTy, eqCon, inferTy, inferCon]

678

720

679−unitTy = MN 0 "__Unit"

721+unitTy = sMN 0 "__Unit"

680−unitCon = MN 0 "__II"

722+unitCon = sMN 0 "__II"

681unitDecl = PDatadecl unitTy PType

723unitDecl = PDatadecl unitTy PType

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

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

683unitOpts = [DefaultEliminator]

725unitOpts = [DefaultEliminator]

684

726

685−falseTy = MN 0 "__False"

727+falseTy = sMN 0 "__False"

686falseDecl = PDatadecl falseTy PType []

728falseDecl = PDatadecl falseTy PType []

687falseOpts = []

729falseOpts = []

688

730

689−pairTy = MN 0 "__Pair"

731+pairTy = sMN 0 "__Pair"

690−pairCon = MN 0 "__MkPair"

732+pairCon = sMN 0 "__MkPair"

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

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

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

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

693 PPi impl (n "B") PType (

735 PPi impl (n "B") PType (

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

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

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

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

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

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

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

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

698− where n a = MN 0 a

740+ where n a = sMN 0 a

699pairOpts = []

741pairOpts = []

700

742

701−eqTy = UN "="

743+eqTy = sUN "="

702−eqCon = UN "refl"

744+eqCon = sUN "refl"

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

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

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

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

705 PType)

747 PType)

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

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

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

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

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

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

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

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

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

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

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

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

712− where n a = MN 0 a

754+ where n a = sMN 0 a

713eqOpts = []

755eqOpts = []

714

756

715−elimName = UN "__Elim"

757+elimName = sUN "__Elim"

716−elimMethElimTy = UN "__elimTy"

758+elimMethElimTy = sUN "__elimTy"

717−elimMethElim = UN "elim"

759+elimMethElim = sUN "elim"

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

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

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

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

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

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

721

763

722-- Defined in builtins.idr

764-- Defined in builtins.idr

723−sigmaTy = UN "Exists"

765+sigmaTy = sUN "Exists"

724−existsCon = UN "Ex_intro"

766+existsCon = sUN "Ex_intro"

725

767

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

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

727piBind = piBindp expl

769piBind = piBindp expl

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

859 updateps yn nm [] = []

901 updateps yn nm [] = []

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

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

861 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

903 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

862− | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as

904+ | otherwise = (sMN i (show n ++ "_u"), t) : updateps yn nm as

863

905

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

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

865

907

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

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

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

880 (map econ cons)

922 (map econ cons)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

999 doAdd (UConstraint c args : cs) ns t

1041 doAdd (UConstraint c args : cs) ns t

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

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

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

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

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

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

1003 | otherwise = doAdd cs ns t

1045 | otherwise = doAdd cs ns t

1004

1046

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

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

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

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

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

1070 (decls , ns) <- get

1112 (decls , ns) <- get

1071− put (PImp (getPriority ist ty) True l n ty doc : decls,

1113+ put (PImp (getPriority ist ty) True l n Placeholder doc : decls,

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

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

1073 imps True (n:env) sc

1115 imps True (n:env) sc

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

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

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

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

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

1077 _ -> [])

1119 _ -> [])

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

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

1079− put (PExp (getPriority ist ty) l ty doc : decls,

1121+ put (PExp (getPriority ist ty) l Placeholder doc : decls,

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

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

1081 imps True (n:env) sc

1123 imps True (n:env) sc

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

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

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

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

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

1085 _ -> [])

1127 _ -> [])

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

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

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

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

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

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

1089 imps True (n:env) sc

1131 imps True (n:env) sc

1090 imps top env (PPi (TacImp l _ scr doc) n ty sc)

1132 imps top env (PPi (TacImp l _ scr doc) n ty sc)

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

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

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

1093 _ -> [])

1135 _ -> [])

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

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

1095− put (PTacImplicit 10 l n scr ty doc : decls,

1137+ put (PTacImplicit 10 l n scr Placeholder doc : decls,

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

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

1097 imps True (n:env) sc

1139 imps True (n:env) sc

1098 imps top env (PEq _ l r)

1140 imps top env (PEq _ l r)

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

1154-- and *not* inside a PHidden

1196-- and *not* inside a PHidden

1155

1197

1156addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

1198addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

1157−addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

1199+addImpl' inpat env infns ist ptm

1200+ = mkUniqueNames env (ai (zip env (repeat Nothing)) [] ptm)

1158 where

1201 where

1159− ai env (PRef fc f)

1202+ ai env ds (PRef fc f)

1160 | f `elem` infns = PInferRef fc f

1203 | f `elem` infns = PInferRef fc f

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

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

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

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

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

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

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

1207+ ai env ds (PEq fc l r)

1208+ = let l' = ai env ds l

1165− r' = ai env r in

1209+ r' = ai env ds r in

1166− PEq fc l' r'

1210+ PEq fc l' r'

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

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

1212+ = let l' = ai env ds l

1168− r' = ai env r

1213+ r' = ai env ds r

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

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

1170− PRewrite fc l' r' g'

1215+ PRewrite fc l' r' g'

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

1216+ ai env ds (PTyped l r)

1217+ = let l' = ai env ds l

1172− r' = ai env r in

1218+ r' = ai env ds r in

1173− PTyped l' r'

1219+ PTyped l' r'

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

1220+ ai env ds (PPair fc l r)

1221+ = let l' = ai env ds l

1175− r' = ai env r in

1222+ r' = ai env ds r in

1176− PPair fc l' r'

1223+ PPair fc l' r'

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

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

1225+ = let l' = ai env ds l

1178− t' = ai env t

1226+ t' = ai env ds t

1179− r' = ai env r in

1227+ r' = ai env ds r in

1180− PDPair fc l' t' r'

1228+ PDPair fc l' t' r'

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

1229+ ai env ds (PAlternative a as)

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

1182− PAlternative a as'

1231+ PAlternative a as'

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

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

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

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

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

1185 PApp fc (PInferRef fc f) as'

1235 PApp fc (PInferRef fc f) as'

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1193− arity = getPArity ty in

1243+ arity = getPArity ty in

1194− mkPApp fc arity ftm as'

1244+ mkPApp fc arity ftm as'

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

1245+ ai env ds (PApp fc f as)

1246+ = let f' = ai env ds f

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

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

1197− mkPApp fc 1 f' as'

1248+ mkPApp fc 1 f' as'

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

1249+ ai env ds (PCase fc c os)

1250+ = let c' = ai env ds c

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

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

1200− PCase fc c' os'

1252+ PCase fc c' os'

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

1253+ ai env ds (PLam n ty sc)

1254+ = let ty' = ai env ds ty

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

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

1203− PLam n ty' sc'

1256+ PLam n ty' sc'

1204− ai env (PLet n ty val sc)

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

1205− = let ty' = ai env ty

1258+ = let ty' = ai env ds ty

1206− val' = ai env val

1259+ val' = ai env ds val

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

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

1208− PLet n ty' val' sc'

1261+ PLet n ty' val' sc'

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

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

1263+ = let ty' = ai env ds ty

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

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

1211− PPi p n ty' sc'

1265+ PPi p n ty' sc'

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

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

1267+ = let r' = ai env ds r

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

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

1214− PGoal fc r' n sc'

1269+ PGoal fc r' n sc'

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

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

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

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

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

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

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

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

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

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

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

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

1221− ai env tm = tm

1276+ ai env ds tm = tm

1222

1277

1223 handleErr (Left err) = PElabError err

1278 handleErr (Left err) = PElabError err

1224 handleErr (Right x) = x

1279 handleErr (Right x) = x

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

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

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

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

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

1228

1283

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

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

1230−aiFn inpat True ist fc f []

1285+aiFn inpat True ist fc f ds []

1231 = case lookupDef f (tt_ctxt ist) of

1286 = case lookupDef f (tt_ctxt ist) of

1232 [] -> Right $ PPatvar fc f

1287 [] -> Right $ PPatvar fc f

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

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

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

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

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

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

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

1237-- any constructor alts || any allImp ialts))

1292-- any constructor alts || any allImp ialts))

1238− then aiFn inpat False ist fc f [] -- use it as a constructor

1293+ then aiFn inpat False ist fc f ds [] -- use it as a constructor

1239 else Right $ PPatvar fc f

1294 else Right $ PPatvar fc f

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

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

1241 imp _ = True

1296 imp _ = True

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

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

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

1250 vname _ = False

1305 vname _ = False

1251

1306

1252−aiFn inpat expat ist fc f as

1307+aiFn inpat expat ist fc f ds as

1253 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

1308 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

1254−aiFn inpat expat ist fc f as

1309+aiFn inpat expat ist fc f ds as

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

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

1256 = do let ns = lookupCtxtName f (idris_implicits ist)

1311 = do let ns = lookupCtxtName f (idris_implicits ist)

1257− let ns' = filter (\(n, _) -> notHidden n) ns

1312+ let nh = filter (\(n, _) -> notHidden n) ns

1313+ let ns' = case trimAlts ds nh of

1314+ [] -> nh

1315+ x -> x

1258 case ns' of

1316 case ns' of

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

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

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

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

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

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

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

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

1263 alts -> Right $

1321 alts -> Right $

1264− PAlternative True $

1322+ PAlternative True $

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

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

1266− (insertImpl ns as)) alts

1324+ (insertImpl ns as)) alts

1267 where

1325 where

1326+ trimAlts [] alts = alts

1327+ trimAlts ns alts

1328+ = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts

1329+

1330+ nspace (NS _ s) = s

1331+ nspace _ = []

1332+

1268 notHidden n = case getAccessibility n of

1333 notHidden n = case getAccessibility n of

1269 Hidden -> False

1334 Hidden -> False

1270 _ -> True

1335 _ -> True

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

1286 case find n given [] of

1351 case find n given [] of

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

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

1288 Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1353 Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1289− insertImpl (PTacImplicit p l n sc ty d : ps) given =

1354+ insertImpl (PTacImplicit p l n sc' ty d : ps) given =

1355+ let sc = addImpl ist sc' in

1290 case find n given [] of

1356 case find n given [] of

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

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

1292 Nothing -> if inpat

1358 Nothing -> if inpat

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

1422 fullApp x = x

1488 fullApp x = x

1423

1489

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1432 | length args == length args'

1500 | length args == length args'

1433 = do mf <- match' f f'

1501 = do mf <- match' f f'

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

1558shadow :: Name -> Name -> PTerm -> PTerm

1626shadow :: Name -> Name -> PTerm -> PTerm

1559shadow n n' t = sm t where

1627shadow n n' t = sm t where

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

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

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

1629+ sm (PLam x t sc) | n /= x = PLam x (sm t) (sm sc)

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

1630+ sm (PPi p x t sc) | n /=x = PPi p x (sm t) (sm sc)

1631+ sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc)

1563 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1632 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1633+ sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

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

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

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

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

1566 sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)

1636 sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)

@@ -1568,9 +1638,87 @@ shadow n n' t = sm t where

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

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

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

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

1570 sm (PAlternative a as) = PAlternative a (map sm as)

1640 sm (PAlternative a as) = PAlternative a (map sm as)

1641+ sm (PTactics ts) = PTactics (map (fmap sm) ts)

1642+ sm (PProof ts) = PProof (map (fmap sm) ts)

1571 sm (PHidden x) = PHidden (sm x)

1643 sm (PHidden x) = PHidden (sm x)

1572 sm (PUnifyLog x) = PUnifyLog (sm x)

1644 sm (PUnifyLog x) = PUnifyLog (sm x)

1573 sm (PNoImplicits x) = PNoImplicits (sm x)

1645 sm (PNoImplicits x) = PNoImplicits (sm x)

1574 sm x = x

1646 sm x = x

1575

1647

1648+-- Rename any binders which are repeated (so that we don't have to mess

1649+-- about with shadowing anywhere else).

1650+

1651+mkUniqueNames :: [Name] -> PTerm -> PTerm

1652+mkUniqueNames env tm = evalState (mkUniq tm) env where

1653+ inScope = boundNamesIn tm

1654+

1655+ mkUniqA arg = do t' <- mkUniq (getTm arg)

1656+ return (arg { getTm = t' })

1657+

1658+ -- FIXME: Probably ought to do this for completeness! It's fine as

1659+ -- long as there are no bindings inside tactics though.

1660+ mkUniqT tac = return tac

1661+

1662+ mkUniq :: PTerm -> State [Name] PTerm

1663+ mkUniq (PLam n ty sc)

1664+ = do env <- get

1665+ (n', sc') <-

1666+ if n `elem` env

1667+ then do let n' = uniqueName n (env ++ inScope)

1668+ return (n', shadow n n' sc)

1669+ else return (n, sc)

1670+ put (n' : env)

1671+ ty' <- mkUniq ty

1672+ sc'' <- mkUniq sc'

1673+ return $! PLam n' ty' sc''

1674+ mkUniq (PPi p n ty sc)

1675+ = do env <- get

1676+ (n', sc') <-

1677+ if n `elem` env

1678+ then do let n' = uniqueName n (env ++ inScope)

1679+ return (n', shadow n n' sc)

1680+ else return (n, sc)

1681+ put (n' : env)

1682+ ty' <- mkUniq ty

1683+ sc'' <- mkUniq sc'

1684+ return $! PPi p n' ty' sc''

1685+ mkUniq (PLet n ty val sc)

1686+ = do env <- get

1687+ (n', sc') <-

1688+ if n `elem` env

1689+ then do let n' = uniqueName n (env ++ inScope)

1690+ return (n', shadow n n' sc)

1691+ else return (n, sc)

1692+ put (n' : env)

1693+ ty' <- mkUniq ty; val' <- mkUniq val

1694+ sc'' <- mkUniq sc'

1695+ return $! PLet n' ty' val' sc''

1696+ mkUniq (PApp fc t args)

1697+ = do t' <- mkUniq t

1698+ args' <- mapM mkUniqA args

1699+ return $! PApp fc t' args'

1700+ mkUniq (PAppBind fc t args)

1701+ = do t' <- mkUniq t

1702+ args' <- mapM mkUniqA args

1703+ return $! PAppBind fc t' args'

1704+ mkUniq (PCase fc t alts)

1705+ = do t' <- mkUniq t

1706+ alts' <- mapM (\(x,y)-> do x' <- mkUniq x; y' <- mkUniq y

1707+ return (x', y')) alts

1708+ return $! PCase fc t' alts'

1709+ mkUniq (PPair fc l r)

1710+ = do l' <- mkUniq l; r' <- mkUniq r

1711+ return $! PPair fc l' r'

1712+ mkUniq (PDPair fc l t r)

1713+ = do l' <- mkUniq l; t' <- mkUniq t; r' <- mkUniq r

1714+ return $! PDPair fc l' t' r'

1715+ mkUniq (PAlternative b as)

1716+ = liftM (PAlternative b) (mapM mkUniq as)

1717+ mkUniq (PHidden t) = liftM PHidden (mkUniq t)

1718+ mkUniq (PUnifyLog t) = liftM PUnifyLog (mkUniq t)

1719+ mkUniq (PDisamb n t) = liftM (PDisamb n) (mkUniq t)

1720+ mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

1721+ mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

1722+ mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

1723+ mkUniq t = return t

1576

1724

src/Idris/AbsSyntaxTree.hs+62−27

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

25import Data.List

26import Data.Char

27+import qualified Data.Text as T

27import Data.Either

28import Data.Either

28import Data.Word (Word)

29import Data.Word (Word)

@@ -132,7 +133,8 @@ data IState = IState {

132 idris_colourRepl :: Bool,

133 idris_colourRepl :: Bool,

133 idris_colourTheme :: ColourTheme,

134 idris_colourTheme :: ColourTheme,

134 idris_outh :: Handle,

135 idris_outh :: Handle,

135− idris_errorhandlers :: [Name]

136+ idris_errorhandlers :: [Name],

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

136 }

138 }

137

139

138data SizeChange = Smaller | Same | Bigger | Unknown

140data SizeChange = Smaller | Same | Bigger | Unknown

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

155deriving instance NFData CGInfo

157deriving instance NFData CGInfo

156!-}

158!-}

157

159

158−primDefs = [UN "unsafePerformPrimIO",

160+primDefs = [sUN "unsafePerformPrimIO",

159− UN "mkLazyForeignPrim",

161+ sUN "mkLazyForeignPrim",

160− UN "mkForeignPrim",

162+ sUN "mkForeignPrim",

161− UN "FalseElim"]

163+ sUN "FalseElim"]

162

164

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

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

164data IBCWrite = IBCFix FixDecl

166data IBCWrite = IBCFix FixDecl

@@ -198,7 +200,7 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

198 emptyContext

200 emptyContext

199 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

201 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

200 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

202 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

201− True defaultTheme stdout []

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

202

204

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

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

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

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

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

293 | PkgBuild String

295 | PkgBuild String

294 | PkgInstall String

296 | PkgInstall String

295 | PkgClean String

297 | PkgClean String

298+ | PkgCheck String

296 | WarnOnly

299 | WarnOnly

297 | Pkg String

300 | Pkg String

298 | BCAsm String

301 | BCAsm String

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

475-- | Data declaration

478-- | Data declaration

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

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

477 d_tcon :: t, -- ^ Type constructor

480 d_tcon :: t, -- ^ Type constructor

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

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

479 }

482 }

480 -- ^ Data declaration

483 -- ^ Data declaration

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

508declared (PNamespace _ ds) = concatMap declared ds

511declared (PNamespace _ ds) = concatMap declared ds

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

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

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

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

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

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

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

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

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

526tldeclared (PParams _ _ ds) = []

529tldeclared (PParams _ _ ds) = []

527tldeclared (PMutual _ ds) = concatMap tldeclared ds

530tldeclared (PMutual _ ds) = concatMap tldeclared ds

528tldeclared (PNamespace _ ds) = concatMap tldeclared ds

531tldeclared (PNamespace _ ds) = concatMap tldeclared ds

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

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

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

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

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

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

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

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

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

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

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

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

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

543defined (PNamespace _ ds) = concatMap defined ds

546defined (PNamespace _ ds) = concatMap defined ds

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

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

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

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

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

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

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

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

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

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

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

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

612 deriving Eq

616 deriving Eq

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

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

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

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

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

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

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

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

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

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

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

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

642 mpt x = x

647 mpt x = x

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

843deriving instance NFData SSymbol

848deriving instance NFData SSymbol

844!-}

849!-}

845

850

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

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

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

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

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

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

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

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

850 Nothing

855 Nothing

851 Nothing

856 Nothing

852 Nothing

857 Nothing

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

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

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

883expandNS syn n = case syn_namespace syn of

888expandNS syn n = case syn_namespace syn of

884 [] -> n

889 [] -> n

885− xs -> NS n xs

890+ xs -> sNS n xs

886

891

887

892

888--- Pretty printing declarations and terms

893--- Pretty printing declarations and terms

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

940showDImp impl (PDatadecl n ty cons)

945showDImp impl (PDatadecl n ty cons)

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

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

942 ++ showSep "\n\t| "

947 ++ showSep "\n\t| "

943− (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

948+ (map (\ (_, n, t, _, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

944

949

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

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

946getImps [] = []

951getImps [] = []

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

979 prettyBasic n

984 prettyBasic n

980 where

985 where

981 prettyBasic n@(UN _) = pretty n

986 prettyBasic n@(UN _) = pretty n

982− prettyBasic (MN _ s) = text s

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

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

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

984 prettyBasic (SN sn) = text (show sn)

989 prettyBasic (SN sn) = text (show sn)

985 prettySe p (PLam n ty sc) =

990 prettySe p (PLam n ty sc) =

986 bracket p 2 $

991 bracket p 2 $

@@ -1051,8 +1056,9 @@ prettyImp impl = prettySe 10

1051 | not impl = pretty f

1056 | not impl = pretty f

1052 prettySe p (PAppBind _ (PRef _ f) [])

1057 prettySe p (PAppBind _ (PRef _ f) [])

1053 | not impl = text "!" <+> pretty f

1058 | not impl = text "!" <+> pretty f

1054− prettySe p (PApp _ (PRef _ op@(UN (f:_))) args)

1059+ prettySe p (PApp _ (PRef _ op@(UN nm)) args)

1060+ | not (tnull nm) &&

1055− | length (getExps args) == 2 && (not impl) && (not $ isAlpha f) =

1061+ length (getExps args) == 2 && (not impl) && (not $ isAlpha (thead nm)) =

1056 let [l, r] = getExps args in

1062 let [l, r] = getExps args in

1057 bracket p 1 $

1063 bracket p 1 $

1058 if size r > breakingSize then

1064 if size r > breakingSize then

@@ -1165,8 +1171,8 @@ showName ist bnd impl colour n = case ist of

1165 Nothing -> showbasic n

1171 Nothing -> showbasic n

1166 where name = if impl then show n else showbasic n

1172 where name = if impl then show n else showbasic n

1167 showbasic n@(UN _) = showCG n

1173 showbasic n@(UN _) = showCG n

1168− showbasic (MN _ s) = s

1174+ showbasic (MN _ s) = str s

1169− showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

1175+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

1170 showbasic (SN s) = show s

1176 showbasic (SN s) = show s

1171 fst3 (x, _, _) = x

1177 fst3 (x, _, _) = x

1172 colourise n t = let ctxt' = fmap tt_ctxt ist in

1178 colourise n t = let ctxt' = fmap tt_ctxt ist in

@@ -1240,8 +1246,9 @@ showImp ist impl colour tm = se 10 [] tm where

1240 | not impl = se p bnd hd

1246 | not impl = se p bnd hd

1241 se p bnd (PAppBind _ hd@(PRef _ f) [])

1247 se p bnd (PAppBind _ hd@(PRef _ f) [])

1242 | not impl = "!" ++ se p bnd hd

1248 | not impl = "!" ++ se p bnd hd

1243− se p bnd (PApp _ op@(PRef _ (UN (f:_))) args)

1249+ se p bnd (PApp _ op@(PRef _ (UN nm)) args)

1250+ | not (tnull nm) &&

1244− | length (getExps args) == 2 && not impl && not (isAlpha f)

1251+ length (getExps args) == 2 && not impl && not (isAlpha (thead nm))

1245 = let [l, r] = getExps args in

1252 = let [l, r] = getExps args in

1246 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

1253 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

1247 se p bnd (PApp _ f as)

1254 se p bnd (PApp _ f as)

@@ -1285,13 +1292,14 @@ showImp ist impl colour tm = se 10 [] tm where

1285 se p bnd (PElabError s) = show s

1292 se p bnd (PElabError s) = show s

1286 se p bnd (PCoerced t) = se p bnd t

1293 se p bnd (PCoerced t) = se p bnd t

1287 se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t

1294 se p bnd (PUnifyLog t) = "%unifyLog " ++ se p bnd t

1295+ se p bnd (PDisamb ns t) = "%disamb " ++ show ns ++ se p bnd t

1288 se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t

1296 se p bnd (PNoImplicits t) = "%noimplicit " ++ se p bnd t

1289-- se p bnd x = "Not implemented"

1297-- se p bnd x = "Not implemented"

1290

1298

1291 slist' p bnd (PApp _ (PRef _ nil) _)

1299 slist' p bnd (PApp _ (PRef _ nil) _)

1292− | not impl && nsroot nil == UN "Nil" = Just []

1300+ | not impl && nsroot nil == sUN "Nil" = Just []

1293 slist' p bnd (PApp _ (PRef _ cons) args)

1301 slist' p bnd (PApp _ (PRef _ cons) args)

1294− | nsroot cons == UN "::",

1302+ | nsroot cons == sUN "::",

1295 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1303 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1296 all isImp imps,

1304 all isImp imps,

1297 Just tl' <- slist' p bnd tl

1305 Just tl' <- slist' p bnd tl

@@ -1365,6 +1373,7 @@ instance Sized PTerm where

1365 size (PAlternative a alts) = 1 + size alts

1373 size (PAlternative a alts) = 1 + size alts

1366 size (PHidden hidden) = size hidden

1374 size (PHidden hidden) = size hidden

1367 size (PUnifyLog tm) = size tm

1375 size (PUnifyLog tm) = size tm

1376+ size (PDisamb _ tm) = size tm

1368 size (PNoImplicits tm) = size tm

1377 size (PNoImplicits tm) = size tm

1369 size PType = 1

1378 size PType = 1

1370 size (PConstant const) = 1 + size const

1379 size (PConstant const) = 1 + size const

@@ -1388,6 +1397,7 @@ allNamesIn tm = nub $ ni [] tm

1388 where

1397 where

1389 ni env (PRef _ n)

1398 ni env (PRef _ n)

1390 | not (n `elem` env) = [n]

1399 | not (n `elem` env) = [n]

1400+ ni env (PPatvar _ n) = [n]

1391 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1401 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1392 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1402 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1393 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1403 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

@@ -1402,11 +1412,34 @@ allNamesIn tm = nub $ ni [] tm

1402 ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r

1412 ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r

1403 ni env (PAlternative a ls) = concatMap (ni env) ls

1413 ni env (PAlternative a ls) = concatMap (ni env) ls

1404 ni env (PUnifyLog tm) = ni env tm

1414 ni env (PUnifyLog tm) = ni env tm

1415+ ni env (PDisamb _ tm) = ni env tm

1405 ni env (PNoImplicits tm) = ni env tm

1416 ni env (PNoImplicits tm) = ni env tm

1406 ni env _ = []

1417 ni env _ = []

1407

1418

1408−-- 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 _ = []

1409

1441

1442+-- Return names which are free in the given term.

1410namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1443namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1411namesIn uvars ist tm = nub $ ni [] tm

1444namesIn uvars ist tm = nub $ ni [] tm

1412 where

1445 where

@@ -1429,6 +1462,7 @@ namesIn uvars ist tm = nub $ ni [] tm

1429 ni env (PAlternative a as) = concatMap (ni env) as

1462 ni env (PAlternative a as) = concatMap (ni env) as

1430 ni env (PHidden tm) = ni env tm

1463 ni env (PHidden tm) = ni env tm

1431 ni env (PUnifyLog tm) = ni env tm

1464 ni env (PUnifyLog tm) = ni env tm

1465+ ni env (PDisamb _ tm) = ni env tm

1432 ni env (PNoImplicits tm) = ni env tm

1466 ni env (PNoImplicits tm) = ni env tm

1433 ni env _ = []

1467 ni env _ = []

1434

1468

@@ -1456,6 +1490,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

1456 ni env (PAlternative a as) = concatMap (ni env) as

1490 ni env (PAlternative a as) = concatMap (ni env) as

1457 ni env (PHidden tm) = ni env tm

1491 ni env (PHidden tm) = ni env tm

1458 ni env (PUnifyLog tm) = ni env tm

1492 ni env (PUnifyLog tm) = ni env tm

1493+ ni env (PDisamb _ tm) = ni env tm

1459 ni env (PNoImplicits tm) = ni env tm

1494 ni env (PNoImplicits tm) = ni env tm

1460 ni env _ = []

1495 ni env _ = []

1461

1496

src/Idris/CaseSplit.hs+13−12

@@ -91,7 +91,8 @@ inventName ist ty n =

91 Nothing -> []

92 Just t -> getNameHints ist t

93 let nsupp = case n of

94+ MN i n | not (tnull n) && thead n == '_'

94− MN i ('_':_) -> mkSupply (supp ++ varlist)

95+ -> mkSupply (supp ++ varlist)

95 MN i n -> mkSupply (UN n : supp ++ varlist)

96 MN i n -> mkSupply (UN n : supp ++ varlist)

96 x -> mkSupply (x : supp)

97 x -> mkSupply (x : supp)

97 let badnames = map snd (namemap ms) ++ map snd (invented ms) ++

98 let badnames = map snd (namemap ms) ++ map snd (invented ms) ++

@@ -106,7 +107,7 @@ inventName ist ty n =

106mkSupply ns = mkSupply' ns (map nextName ns)

107mkSupply ns = mkSupply' ns (map nextName ns)

107 where mkSupply' xs ns' = xs ++ mkSupply ns'

108 where mkSupply' xs ns' = xs ++ mkSupply ns'

108

109

109−varlist = map (UN . (:[])) "xyzwstuv" -- EB's personal preference :)

110+varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

110

111

111stripNS tm = mapPT dens tm where

112stripNS tm = mapPT dens tm where

112 dens (PRef fc n) = PRef fc (nsroot n)

113 dens (PRef fc n) = PRef fc (nsroot n)

@@ -164,7 +165,7 @@ argTys ist (PRef fc n)

164 = case lookupTy n (tt_ctxt ist) of

165 = case lookupTy n (tt_ctxt ist) of

165 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166 _ -> repeat Nothing

167 _ -> repeat Nothing

167− where tyName (Bind _ (Pi _) _) = Just (UN "->")

168+ where tyName (Bind _ (Pi _) _) = Just (sUN "->")

168 tyName t | (P _ n _, _) <- unApply t = Just n

169 tyName t | (P _ n _, _) <- unApply t = Just n

169 | otherwise = Nothing

170 | otherwise = Nothing

170argTys _ _ = repeat Nothing

171argTys _ _ = repeat Nothing

@@ -264,8 +265,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

264

265

265 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266 -- this isn't supported in a pattern, so special case here

267 -- this isn't supported in a pattern, so special case here

267− nshow (PRef _ (UN "Z")) = "Z"

268+ nshow (PRef _ (UN z)) | z == txt "Z" = "Z"

268− nshow (PApp _ (PRef _ (UN "S")) [x]) =

269+ nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" =

269 "S " ++ addBrackets (nshow (getTm x))

270 "S " ++ addBrackets (nshow (getTm x))

270 nshow t = show t

271 nshow t = show t

271

272

@@ -296,7 +297,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

296getUniq nm i

297getUniq nm i

297 = do ist <- getIState

298 = do ist <- getIState

298 let n = nameRoot [] nm ++ "_" ++ show i

299 let n = nameRoot [] nm ++ "_" ++ show i

299− case lookupTy (UN n) (tt_ctxt ist) of

300+ case lookupTy (sUN n) (tt_ctxt ist) of

300 [] -> return (n, i+1)

301 [] -> return (n, i+1)

301 _ -> getUniq nm (i+1)

302 _ -> getUniq nm (i+1)

302

303

@@ -324,14 +325,14 @@ getClause l fn fp = do ty <- getInternalApp fp l

324 mkApp i _ _ = ""

325 mkApp i _ _ = ""

325

326

326 getNameFrom i used (PPi _ _ _ _)

327 getNameFrom i used (PPi _ _ _ _)

327− = uniqueNameFrom (mkSupply [UN "f", UN "g"]) used

328+ = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

328 getNameFrom i used (PApp fc f as) = getNameFrom i used f

329 getNameFrom i used (PApp fc f as) = getNameFrom i used f

329− getNameFrom i used (PEq _ _ _) = uniqueNameFrom [UN "prf"] used

330+ getNameFrom i used (PEq _ _ _) = uniqueNameFrom [sUN "prf"] used

330 getNameFrom i used (PRef fc f)

331 getNameFrom i used (PRef fc f)

331 = case getNameHints i f of

332 = case getNameHints i f of

332− [] -> uniqueName (UN "x") used

333+ [] -> uniqueName (sUN "x") used

333 ns -> uniqueNameFrom (mkSupply ns) used

334 ns -> uniqueNameFrom (mkSupply ns) used

334− getNameFrom i used _ = uniqueName (UN "x") used

335+ getNameFrom i used _ = uniqueName (sUN "x") used

335

336

336getProofClause :: Int -- ^ line number that the type is declared

337getProofClause :: Int -- ^ line number that the type is declared

337 -> Name -- ^ Function name

338 -> Name -- ^ Function name

@@ -363,11 +364,11 @@ mkWith str n = let str' = replaceRHS str "with (_)"

363nameMissing :: [PTerm] -> Idris [PTerm]

364nameMissing :: [PTerm] -> Idris [PTerm]

364nameMissing ps = do ist <- get

365nameMissing ps = do ist <- get

365 newPats <- mapM nm ps

366 newPats <- mapM nm ps

366− let newPats' = mergeAllPats ist (UN "_") (base (head ps))

367+ let newPats' = mergeAllPats ist (sUN "_") (base (head ps))

367 newPats

368 newPats

368 return (map fst newPats')

369 return (map fst newPats')

369 where

370 where

370− base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (UN "_")))) args)

371+ base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (sUN "_")))) args)

371 base t = t

372 base t = t

372

373

373 nm ptm = do mptm <- elabNewPat ptm

374 nm ptm = do mptm <- elabNewPat ptm

src/Idris/Completion.hs+3−3

@@ -54,9 +54,9 @@ tactics = map fst tacticArgs

54-- | Convert a name into a string usable for completion. Filters out names

55-- that users probably don't want to see.

56nameString :: Name -> Maybe String

57−nameString (UN ('@':_)) = Nothing

57+nameString (UN nm)

58−nameString (UN ('#':_)) = Nothing

58+ | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing

59−nameString (UN n) = Just n

59+nameString (UN n) = Just (str n)

60nameString (NS n _) = nameString n

61nameString _ = Nothing

src/Idris/Core/CaseTree.hs+10−7

@@ -21,7 +21,8 @@ data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

21 | ImpossibleCase -- ^ already checked to be impossible

22 deriving (Eq, Ord, Functor)

23{-!

24−deriving instance Binary SC

24+deriving instance Binary SC'

25+deriving instance NFData SC'

25!-}

26!-}

27type SC = SC' Term

28type SC = SC' Term

@@ -33,7 +34,8 @@ data CaseAlt' t = ConCase Name Int [Name] !(SC' t)

33 | DefaultCase !(SC' t)

34 | DefaultCase !(SC' t)

34 deriving (Show, Eq, Ord, Functor)

35 deriving (Show, Eq, Ord, Functor)

35{-!

36{-!

36−deriving instance Binary CaseAlt

37+deriving instance Binary CaseAlt'

38+deriving instance NFData CaseAlt'

37!-}

39!-}

39type CaseAlt = CaseAlt' Term

41type CaseAlt = CaseAlt' Term

@@ -155,6 +157,7 @@ directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

155directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

157directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

156directUse fn@(App f a)

158directUse fn@(App f a)

157 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

159 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

160+ | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime

158 | otherwise = nub $ directUse f ++ directUse a

161 | otherwise = nub $ directUse f ++ directUse a

159directUse (Proj x i) = nub $ directUse x

162directUse (Proj x i) = nub $ directUse x

160directUse _ = []

163directUse _ = []

@@ -214,7 +217,7 @@ simpleCase tc cover reflect phase fc argtys cs

214 then return t

217 then return t

215 else Error (At fc (Msg "Typecase is not allowed"))

218 else Error (At fc (Msg "Typecase is not allowed"))

216 Error err -> Error (At fc err)

219 Error err -> Error (At fc err)

217− where args = map (\i -> MN i "e") [0..]

220+ where args = map (\i -> sMN i "e") [0..]

218 defaultCase True = STerm Erased

221 defaultCase True = STerm Erased

219 defaultCase False = UnmatchedCase "Error"

222 defaultCase False = UnmatchedCase "Error"

220 fstT (x, _, _) = x

223 fstT (x, _, _) = x

@@ -298,8 +301,8 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

298 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

301 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

299 return $ PCon n t args'

302 return $ PCon n t args'

300 -- n + 1

303 -- n + 1

301− toPat' (P _ (UN "prim__addBigInt") _)

304+ toPat' (P _ (UN pabi) _)

302− [p, Constant (BI 1)]

305+ [p, Constant (BI 1)] | pabi == txt "prim__addBigInt"

303 = do p' <- toPat' p []

306 = do p' <- toPat' p []

304 return $ PSuc p'

307 return $ PSuc p'

305 -- Typecase

308 -- Typecase

@@ -331,7 +334,7 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

331 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

334 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

332 = do t' <- toPat' t []

335 = do t' <- toPat' t []

333 sc' <- toPat' sc []

336 sc' <- toPat' sc []

334− return $ PReflected (UN "->") (t':sc':[])

337+ return $ PReflected (sUN "->") (t':sc':[])

335 toPat' (P _ n _) args | reflect

338 toPat' (P _ n _) args | reflect

336 = do args' <- mapM (\x -> toPat' x []) args

339 = do args' <- mapM (\x -> toPat' x []) args

337 return $ PReflected n args'

340 return $ PReflected n args'

@@ -488,7 +491,7 @@ argsToAlt rs@((r, m) : rest)

488 uniq i n = n

491 uniq i n = n

489

492

490getVar :: String -> State CS Name

493getVar :: String -> State CS Name

491−getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (MN v b)

494+getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (sMN v b)

492

495

493groupCons :: [Clause] -> State CS [Group]

496groupCons :: [Clause] -> State CS [Group]

494groupCons cs = gc [] cs

497groupCons cs = gc [] cs

src/Idris/Core/Constraints.hs+1

@@ -2,6 +2,7 @@

2module Idris.Core.Constraints(ucheck) where

4import Idris.Core.TT

5+import Idris.Core.Typecheck

6import Control.Applicative

7import Control.Applicative

7import Control.Arrow

8import Control.Arrow

src/Idris/Core/DeepSeq.hsnew file+114

@@ -0,0 +1,114 @@

1+module Idris.Core.DeepSeq where

3+import Idris.Core.TT

4+import Idris.Core.CaseTree

6+import Control.DeepSeq

8+instance NFData Name where

9+ rnf (UN x1) = rnf x1 `seq` ()

10+ rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

11+ rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

12+ rnf NErased = ()

13+ rnf (SN x1) = rnf x1 `seq` ()

14+

15+instance NFData SpecialName where

16+ rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

17+ rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

18+ rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19+ rnf (MethodN x1) = rnf x1 `seq` ()

20+ rnf (CaseN x1) = rnf x1 `seq` ()

21+ rnf (ElimN x1) = rnf x1 `seq` ()

22+

23+instance NFData Raw where

24+ rnf (Var x1) = rnf x1 `seq` ()

25+ rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

26+ rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

27+ rnf RType = ()

28+ rnf (RForce x1) = rnf x1 `seq` ()

29+ rnf (RConstant x1) = x1 `seq` ()

30+

31+instance NFData FC where

32+ rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

33+

34+instance NFData Err where

35+ rnf (Msg x1) = rnf x1 `seq` ()

36+ rnf (InternalMsg x1) = rnf x1 `seq` ()

37+ rnf (CantUnify x1 x2 x3 x4 x5 x6)

38+ = rnf x1 `seq`

39+ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

40+ rnf (InfiniteUnify x1 x2 x3)

41+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

42+ rnf (CantConvert x1 x2 x3)

43+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

44+ rnf (UnifyScope x1 x2 x3 x4)

45+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

46+ rnf (CantInferType x1) = rnf x1 `seq` ()

47+ rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

48+ rnf (CantIntroduce x1) = rnf x1 `seq` ()

49+ rnf (NoSuchVariable x1) = rnf x1 `seq` ()

50+ rnf (NoTypeDecl x1) = rnf x1 `seq` ()

51+ rnf (NotInjective x1 x2 x3)

52+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

53+ rnf (CantResolve x1) = rnf x1 `seq` ()

54+ rnf (CantResolveAlts x1) = rnf x1 `seq` ()

55+ rnf (IncompleteTerm x1) = rnf x1 `seq` ()

56+ rnf UniverseError = ()

57+ rnf ProgramLineComment = ()

58+ rnf (Inaccessible x1) = rnf x1 `seq` ()

59+ rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

60+ rnf (AlreadyDefined x1) = rnf x1 `seq` ()

61+ rnf (ProofSearchFail x1) = rnf x1 `seq` ()

62+ rnf (NoRewriting x1) = rnf x1 `seq` ()

63+ rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

64+ rnf (Elaborating x1 x2 x3)

65+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

66+ rnf (ProviderError x1) = rnf x1 `seq` ()

67+ rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

68+

69+instance (NFData b) => NFData (Binder b) where

70+ rnf (Lam x1) = rnf x1 `seq` ()

71+ rnf (Pi x1) = rnf x1 `seq` ()

72+ rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

73+ rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74+ rnf (Hole x1) = rnf x1 `seq` ()

75+ rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

76+ rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

77+ rnf (PVar x1) = rnf x1 `seq` ()

78+ rnf (PVTy x1) = rnf x1 `seq` ()

79+

80+instance NFData UExp where

81+ rnf (UVar x1) = rnf x1 `seq` ()

82+ rnf (UVal x1) = rnf x1 `seq` ()

83+

84+instance NFData NameType where

85+ rnf Bound = ()

86+ rnf Ref = ()

87+ rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

88+ rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

89+

90+instance (NFData n) => NFData (TT n) where

91+ rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92+ rnf (V x1) = rnf x1 `seq` ()

93+ rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

94+ rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

95+ rnf (Constant x1) = x1 `seq` ()

96+ rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

97+ rnf Erased = ()

98+ rnf Impossible = ()

99+ rnf (TType x1) = rnf x1 `seq` ()

100+

101+instance (NFData t) => NFData (SC' t) where

102+ rnf (Case x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103+ rnf (ProjCase x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

104+ rnf (STerm x1) = rnf x1 `seq` ()

105+ rnf (UnmatchedCase x1) = rnf x1 `seq` ()

106+ rnf ImpossibleCase = ()

107+

108+instance (NFData t) => NFData (CaseAlt' t) where

109+ rnf (ConCase x1 x2 x3 x4)

110+ = x1 `seq` x2 `seq` x3 `seq` rnf x4 `seq` ()

111+ rnf (FnCase x1 x2 x3) = x1 `seq` x2 `seq` rnf x3 `seq` ()

112+ rnf (ConstCase x1 x2) = x1 `seq` rnf x2 `seq` ()

113+ rnf (SucCase x1 x2) = x1 `seq` rnf x2 `seq` ()

114+ rnf (DefaultCase x1) = rnf x1 `seq` ()

src/Idris/Core/Elaborate.hs+98−64

@@ -16,8 +16,10 @@ import Idris.Core.TT

16import Idris.Core.Evaluate

17import Idris.Core.Typecheck

18import Idris.Core.Unify

19+import Idris.Core.DeepSeq

20−import Control.Monad.State

21+import Control.DeepSeq

22+import Control.Monad.State.Strict

21import Data.Char

23import Data.Char

22import Data.List

24import Data.List

23import Debug.Trace

25import Debug.Trace

@@ -46,7 +48,7 @@ proofFail :: Elab' aux a -> Elab' aux a

46proofFail e = do s <- get

48proofFail e = do s <- get

47 case runStateT e s of

49 case runStateT e s of

48 OK (a, s') -> do put s'

50 OK (a, s') -> do put s'

49− return a

51+ return $! a

50 Error err -> lift $ Error (ProofSearchFail err)

52 Error err -> lift $ Error (ProofSearchFail err)

52explicit :: Name -> Elab' aux ()

54explicit :: Name -> Elab' aux ()

@@ -64,11 +66,39 @@ loadState = do (ES p s e) <- get

64 Just st -> put st

66 Just st -> put st

65 _ -> fail "Nothing to undo"

67 _ -> fail "Nothing to undo"

69+getNameFrom :: Name -> Elab' aux Name

70+getNameFrom n = do (ES (p, a) s e) <- get

71+ let next = nextname p

72+ let p' = p { nextname = next + 1 }

73+ put (ES (p', a) s e)

74+ let n' = case n of

75+ UN x -> MN (next+100) x

76+ MN i x -> if i == 99999

77+ then MN (next+500) x

78+ else MN (next+100) x

79+ NS (UN x) s -> MN (next+100) x

80+ return $! n'

81+

82+setNextName :: Elab' aux ()

83+setNextName = do env <- get_env

84+ ES (p, a) s e <- get

85+ let pargs = map fst (getArgTys (ptype p))

86+ initNextNameFrom (pargs ++ map fst env)

87+

88+initNextNameFrom :: [Name] -> Elab' aux ()

89+initNextNameFrom ns = do ES (p, a) s e <- get

90+ let n' = maxName (nextname p) ns

91+ put (ES (p { nextname = n' }, a) s e)

92+ where

93+ maxName m ((MN i _) : xs) = maxName (max m i) xs

94+ maxName m (_ : xs) = maxName m xs

95+ maxName m [] = m + 1

96+

67errAt :: String -> Name -> Elab' aux a -> Elab' aux a

97errAt :: String -> Name -> Elab' aux a -> Elab' aux a

68errAt thing n elab = do s <- get

98errAt thing n elab = do s <- get

69 case runStateT elab s of

99 case runStateT elab s of

70 OK (a, s') -> do put s'

100 OK (a, s') -> do put s'

71− return a

101+ return $! a

72 Error (At f e) ->

102 Error (At f e) ->

73 lift $ Error (At f (Elaborating thing n e))

103 lift $ Error (At f (Elaborating thing n e))

74 Error e -> lift $ Error (Elaborating thing n e)

104 Error e -> lift $ Error (Elaborating thing n e)

@@ -77,7 +107,7 @@ erun :: FC -> Elab' aux a -> Elab' aux a

77erun f elab = do s <- get

107erun f elab = do s <- get

78 case runStateT elab s of

108 case runStateT elab s of

79 OK (a, s') -> do put s'

109 OK (a, s') -> do put s'

80− return a

110+ return $! a

81 Error (ProofSearchFail (At f e))

111 Error (ProofSearchFail (At f e))

82 -> lift $ Error (ProofSearchFail (At f e))

112 -> lift $ Error (ProofSearchFail (At f e))

83 Error (At f e) -> lift $ Error (At f e)

113 Error (At f e) -> lift $ Error (At f e)

@@ -95,7 +125,11 @@ initElaborator = newProof

95elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

125elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

96elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

126elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

97 (a, ES ps' str _) <- runElab d elab ps

127 (a, ES ps' str _) <- runElab d elab ps

98− return (a, str)

128+ return $! (a, str)

129+

130+force_term :: Elab' aux ()

131+force_term = do ES (ps, a) l p <- get

132+ put (ES (ps { pterm = force (pterm ps) }, a) l p)

133

100updateAux :: (aux -> aux) -> Elab' aux ()

134updateAux :: (aux -> aux) -> Elab' aux ()

101updateAux f = do ES (ps, a) l p <- get

135updateAux f = do ES (ps, a) l p <- get

@@ -103,23 +137,27 @@ updateAux f = do ES (ps, a) l p <- get

103

137

104getAux :: Elab' aux aux

138getAux :: Elab' aux aux

105getAux = do ES (ps, a) _ _ <- get

139getAux = do ES (ps, a) _ _ <- get

106− return a

140+ return $! a

107

141

108unifyLog :: Bool -> Elab' aux ()

142unifyLog :: Bool -> Elab' aux ()

109unifyLog log = do ES (ps, a) l p <- get

143unifyLog log = do ES (ps, a) l p <- get

110 put (ES (ps { unifylog = log }, a) l p)

144 put (ES (ps { unifylog = log }, a) l p)

111

145

146+getUnifyLog :: Elab' aux Bool

147+getUnifyLog = do ES (ps, a) l p <- get

148+ return (unifylog ps)

149+

112processTactic' t = do ES (p, a) logs prev <- get

150processTactic' t = do ES (p, a) logs prev <- get

113 (p', log) <- lift $ processTactic t p

151 (p', log) <- lift $ processTactic t p

114 put (ES (p', a) (logs ++ log) prev)

152 put (ES (p', a) (logs ++ log) prev)

115− return ()

153+ return $! ()

116

154

117-- Some handy gadgets for pulling out bits of state

155-- Some handy gadgets for pulling out bits of state

118

156

119-- get the global context

157-- get the global context

120get_context :: Elab' aux Context

158get_context :: Elab' aux Context

121get_context = do ES p _ _ <- get

159get_context = do ES p _ _ <- get

122− return (context (fst p))

160+ return $! (context (fst p))

123

161

124-- update the context

162-- update the context

125-- (should only be used for adding temporary definitions or all sorts of

163-- (should only be used for adding temporary definitions or all sorts of

@@ -131,7 +169,7 @@ set_context ctxt = do ES (p, a) logs prev <- get

131-- get the proof term

169-- get the proof term

132get_term :: Elab' aux Term

170get_term :: Elab' aux Term

133get_term = do ES p _ _ <- get

171get_term = do ES p _ _ <- get

134− return (pterm (fst p))

172+ return $! (pterm (fst p))

135

173

136-- get the proof term

174-- get the proof term

137update_term :: (Term -> Term) -> Elab' aux ()

175update_term :: (Term -> Term) -> Elab' aux ()

@@ -146,24 +184,24 @@ get_env = do ES p _ _ <- get

146

184

147get_holes :: Elab' aux [Name]

185get_holes :: Elab' aux [Name]

148get_holes = do ES p _ _ <- get

186get_holes = do ES p _ _ <- get

149− return (holes (fst p))

187+ return $! (holes (fst p))

150

188

151get_probs :: Elab' aux Fails

189get_probs :: Elab' aux Fails

152get_probs = do ES p _ _ <- get

190get_probs = do ES p _ _ <- get

153− return (problems (fst p))

191+ return $! (problems (fst p))

154

192

155-- get the current goal type

193-- get the current goal type

156goal :: Elab' aux Type

194goal :: Elab' aux Type

157goal = do ES p _ _ <- get

195goal = do ES p _ _ <- get

158 b <- lift $ goalAtFocus (fst p)

196 b <- lift $ goalAtFocus (fst p)

159− return (binderTy b)

197+ return $! (binderTy b)

160

198

161-- Get the guess at the current hole, if there is one

199-- Get the guess at the current hole, if there is one

162get_guess :: Elab' aux Type

200get_guess :: Elab' aux Type

163get_guess = do ES p _ _ <- get

201get_guess = do ES p _ _ <- get

164 b <- lift $ goalAtFocus (fst p)

202 b <- lift $ goalAtFocus (fst p)

165 case b of

203 case b of

166− Guess t v -> return v

204+ Guess t v -> return $! v

167 _ -> fail "Not a guess"

205 _ -> fail "Not a guess"

168

206

169-- typecheck locally

207-- typecheck locally

@@ -171,22 +209,22 @@ get_type :: Raw -> Elab' aux Type

171get_type tm = do ctxt <- get_context

209get_type tm = do ctxt <- get_context

172 env <- get_env

210 env <- get_env

173 (val, ty) <- lift $ check ctxt env tm

211 (val, ty) <- lift $ check ctxt env tm

174− return (finalise ty)

212+ return $! (finalise ty)

175

213

176get_type_val :: Raw -> Elab' aux (Term, Type)

214get_type_val :: Raw -> Elab' aux (Term, Type)

177get_type_val tm = do ctxt <- get_context

215get_type_val tm = do ctxt <- get_context

178 env <- get_env

216 env <- get_env

179 (val, ty) <- lift $ check ctxt env tm

217 (val, ty) <- lift $ check ctxt env tm

180− return (finalise val, finalise ty)

218+ return $! (finalise val, finalise ty)

181

219

182-- get holes we've deferred for later definition

220-- get holes we've deferred for later definition

183get_deferred :: Elab' aux [Name]

221get_deferred :: Elab' aux [Name]

184get_deferred = do ES p _ _ <- get

222get_deferred = do ES p _ _ <- get

185− return (deferred (fst p))

223+ return $! (deferred (fst p))

186

224

187checkInjective :: (Term, Term, Term) -> Elab' aux ()

225checkInjective :: (Term, Term, Term) -> Elab' aux ()

188checkInjective (tm, l, r) = do ctxt <- get_context

226checkInjective (tm, l, r) = do ctxt <- get_context

189− if isInj ctxt tm then return ()

227+ if isInj ctxt tm then return $! ()

190 else lift $ tfail (NotInjective tm l r)

228 else lift $ tfail (NotInjective tm l r)

191 where isInj ctxt (P _ n _)

229 where isInj ctxt (P _ n _)

192 | isConName n ctxt = True

230 | isConName n ctxt = True

@@ -199,7 +237,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

199-- get instance argument names

237-- get instance argument names

200get_instances :: Elab' aux [Name]

238get_instances :: Elab' aux [Name]

201get_instances = do ES p _ _ <- get

239get_instances = do ES p _ _ <- get

202− return (instances (fst p))

240+ return $! (instances (fst p))

203

241

204-- given a desired hole name, return a unique hole name

242-- given a desired hole name, return a unique hole name

205unique_hole = unique_hole' False

243unique_hole = unique_hole' False

@@ -209,13 +247,14 @@ unique_hole' reusable n

209 = do ES p _ _ <- get

247 = do ES p _ _ <- get

210 let bs = bound_in (pterm (fst p)) ++

248 let bs = bound_in (pterm (fst p)) ++

211 bound_in (ptype (fst p))

249 bound_in (ptype (fst p))

250+ let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p)

212− n' <- return $ uniqueNameCtxt (context (fst p)) n (holes (fst p)

251+ n' <- return $! uniqueNameCtxt (context (fst p)) n nouse

213− ++ bs ++ dontunify (fst p) ++ usedns (fst p))

214 ES (p, a) s u <- get

252 ES (p, a) s u <- get

215− -- Hmm: Do we need this level of uniqueness?

253+ case n' of

216− let p' = p -- if reusable then p else p { usedns = n' : usedns p }

254+ MN i _ -> when (i >= nextname p) $

217− put (ES (p', a) s u)

255+ put (ES (p { nextname = i + 1 }, a) s u)

256+ _ -> return $! ()

218− return n'

257+ return $! n'

219 where

258 where

220 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

259 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

221 where

260 where

@@ -231,7 +270,7 @@ elog str = do ES p logs prev <- get

231

270

232getLog :: Elab' aux String

271getLog :: Elab' aux String

233getLog = do ES p logs _ <- get

272getLog = do ES p logs _ <- get

234− return logs

273+ return $! logs

235

274

236-- The primitives, from ProofState

275-- The primitives, from ProofState

237

276

@@ -312,11 +351,12 @@ equiv tm = processTactic' (Equiv tm)

312

351

313patvar :: Name -> Elab' aux ()

352patvar :: Name -> Elab' aux ()

314patvar n = do env <- get_env

353patvar n = do env <- get_env

354+ hs <- get_holes

315 if (n `elem` map fst env) then do apply (Var n) []; solve

355 if (n `elem` map fst env) then do apply (Var n) []; solve

316 else do n' <- case n of

356 else do n' <- case n of

317− UN _ -> return n

357+ UN _ -> return $! n

318 MN _ _ -> unique_hole n

358 MN _ _ -> unique_hole n

319− NS _ _ -> return n

359+ NS _ _ -> return $! n

320 processTactic' (PatVar n')

360 processTactic' (PatVar n')

321

361

322patbind :: Name -> Elab' aux ()

362patbind :: Name -> Elab' aux ()

@@ -356,13 +396,13 @@ reorder_claims n = processTactic' (Reorder n)

356qed :: Elab' aux Term

396qed :: Elab' aux Term

357qed = do processTactic' QED

397qed = do processTactic' QED

358 ES p _ _ <- get

398 ES p _ _ <- get

359− return (pterm (fst p))

399+ return $! (pterm (fst p))

360

400

361undo :: Elab' aux ()

401undo :: Elab' aux ()

362undo = processTactic' Undo

402undo = processTactic' Undo

363

403

364prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

404prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

365−prepare_apply fn imps =

405+prepare_apply fn imps =

366 do ty <- get_type fn

406 do ty <- get_type fn

367 ctxt <- get_context

407 ctxt <- get_context

368 env <- get_env

408 env <- get_env

@@ -377,18 +417,18 @@ prepare_apply fn imps =

377-- case claims of

417-- case claims of

378-- [] -> return ()

418-- [] -> return ()

379-- (h : _) -> reorder_claims h

419-- (h : _) -> reorder_claims h

380− return claims

420+ return $! claims

381 where

421 where

382 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

422 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

383 do let t = rebind hs t_in

423 do let t = rebind hs t_in

384− n <- unique_hole (mkMN n')

424+ n <- getNameFrom (mkMN n')

385-- when (null claims) (start_unify n)

425-- when (null claims) (start_unify n)

386 let sc' = instantiate (P Bound n t) sc

426 let sc' = instantiate (P Bound n t) sc

387−-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show hs) $

427+-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $

388 claim n (forget t)

428 claim n (forget t)

389 when i (movelast n)

429 when i (movelast n)

390 mkClaims sc' is (n : claims) hs

430 mkClaims sc' is (n : claims) hs

391− mkClaims t [] claims _ = return (reverse claims)

431+ mkClaims t [] claims _ = return $! (reverse claims)

392 mkClaims _ _ _ _

432 mkClaims _ _ _ _

393 | Var n <- fn

433 | Var n <- fn

394 = do ctxt <- get_context

434 = do ctxt <- get_context

@@ -400,9 +440,9 @@ prepare_apply fn imps =

400 doClaim ((i, _), n, t) = do claim n t

440 doClaim ((i, _), n, t) = do claim n t

401 when i (movelast n)

441 when i (movelast n)

402

442

403− mkMN n@(MN _ _) = n

443+ mkMN n@(MN i _) = n

404− mkMN n@(UN x) = MN 1000 x

444+ mkMN n@(UN x) = MN 99999 x

405− mkMN n@(SN s) = MN 1000 (show s)

445+ mkMN n@(SN s) = sMN 99999 (show s)

406 mkMN (NS n xs) = NS (mkMN n) xs

446 mkMN (NS n xs) = NS (mkMN n) xs

407

447

408 rebind hs (Bind n t sc)

448 rebind hs (Bind n t sc)

@@ -419,16 +459,13 @@ match_apply = apply' match_fill

419apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

459apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

420apply' fillt fn imps =

460apply' fillt fn imps =

421 do args <- prepare_apply fn (map fst imps)

461 do args <- prepare_apply fn (map fst imps)

422− env <- get_env

423− g <- goal

424 -- _Don't_ solve the arguments we're specifying by hand.

462 -- _Don't_ solve the arguments we're specifying by hand.

425 -- (remove from unified list before calling end_unify)

463 -- (remove from unified list before calling end_unify)

426 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

464 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

427 -- so do nothing

465 -- so do nothing

428− ptm <- get_term

429 hs <- get_holes

466 hs <- get_holes

430 ES (p, a) s prev <- get

467 ES (p, a) s prev <- get

431− let dont = nub $ head hs : dontunify p ++

468+ let dont = head hs : dontunify p ++

432 if null imps then [] -- do all we can

469 if null imps then [] -- do all we can

433 else

470 else

434 map fst (filter (not.snd) (zip args (map fst imps)))

471 map fst (filter (not.snd) (zip args (map fst imps)))

@@ -441,13 +478,10 @@ apply' fillt fn imps =

441 put (ES (p { dontunify = dont, unified = (n, unify),

478 put (ES (p { dontunify = dont, unified = (n, unify),

442 notunified = notunify ++ notunified p }, a) s prev)

479 notunified = notunify ++ notunified p }, a) s prev)

443 fillt (raw_apply fn (map Var args))

480 fillt (raw_apply fn (map Var args))

444− ptm <- get_term

445− g <- goal

446-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

481-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

447 end_unify

482 end_unify

448− ptm <- get_term

449− return (map (updateUnify unify) args)

483+ return $! (map (updateUnify unify) args)

450− where updateUnify hs n = case lookup n hs of

484+ where updateUnify us n = case lookup n us of

451 Just (P _ t _) -> t

485 Just (P _ t _) -> t

452 _ -> n

486 _ -> n

453

487

@@ -460,7 +494,7 @@ apply2 fn elabs =

460 let (n, hs) = unified p

494 let (n, hs) = unified p

461 end_unify

495 end_unify

462 solve

496 solve

463− where elabArgs [] [] = return ()

497+ where elabArgs [] [] = return $! ()

464 elabArgs (n:ns) (Just e:es) = do focus n; e

498 elabArgs (n:ns) (Just e:es) = do focus n; e

465 elabArgs ns es

499 elabArgs ns es

466 elabArgs (n:ns) (_:es) = elabArgs ns es

500 elabArgs (n:ns) (_:es) = elabArgs ns es

@@ -491,18 +525,18 @@ apply_elab n args =

491 let sc' = instantiate (P Bound n t) sc

525 let sc' = instantiate (P Bound n t) sc

492 claim n (forget t)

526 claim n (forget t)

493 case i of

527 case i of

494− Nothing -> return ()

528+ Nothing -> return $! ()

495 Just _ -> -- don't solve by unification as there is an explicit value

529 Just _ -> -- don't solve by unification as there is an explicit value

496 do ES (p, a) s prev <- get

530 do ES (p, a) s prev <- get

497 put (ES (p { dontunify = n : dontunify p }, a) s prev)

531 put (ES (p { dontunify = n : dontunify p }, a) s prev)

498 doClaims sc' is ((n, i) : claims)

532 doClaims sc' is ((n, i) : claims)

499− doClaims t [] claims = return (reverse claims)

533+ doClaims t [] claims = return $! (reverse claims)

500 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

534 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

501

535

502 elabClaims failed r []

536 elabClaims failed r []

503− | null failed = return ()

537+ | null failed = return $! ()

504 | otherwise = if r then elabClaims [] False failed

538 | otherwise = if r then elabClaims [] False failed

505− else return ()

539+ else return $! ()

506 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

540 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

507 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

541 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

508 | r = try (do ES p _ _ <- get

542 | r = try (do ES p _ _ <- get

@@ -512,7 +546,7 @@ apply_elab n args =

512 focus n; elaboration; elabClaims failed r xs

546 focus n; elaboration; elabClaims failed r xs

513

547

514 mkMN n@(MN _ _) = n

548 mkMN n@(MN _ _) = n

515− mkMN n@(UN x) = MN 1000 x

549+ mkMN n@(UN x) = MN 0 x

516 mkMN (NS n ns) = NS (mkMN n) ns

550 mkMN (NS n ns) = NS (mkMN n) ns

517

551

518-- If the goal is not a Pi-type, invent some names and make it a pi type

552-- If the goal is not a Pi-type, invent some names and make it a pi type

@@ -521,9 +555,9 @@ checkPiGoal n

521 = do g <- goal

555 = do g <- goal

522 case g of

556 case g of

523 Bind _ (Pi _) _ -> return ()

557 Bind _ (Pi _) _ -> return ()

524− _ -> do a <- unique_hole (MN 0 "pargTy")

558+ _ -> do a <- getNameFrom (sMN 0 "pargTy")

525− b <- unique_hole (MN 0 "pretTy")

559+ b <- getNameFrom (sMN 0 "pretTy")

526− f <- unique_hole (MN 0 "pf")

560+ f <- getNameFrom (sMN 0 "pf")

527 claim a RType

561 claim a RType

528 claim b RType

562 claim b RType

529 claim f (RBind n (Pi (Var a)) (Var b))

563 claim f (RBind n (Pi (Var a)) (Var b))

@@ -535,13 +569,13 @@ checkPiGoal n

535

569

536simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

570simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

537simple_app fun arg appstr =

571simple_app fun arg appstr =

538− do a <- unique_hole (MN 0 "argTy")

572+ do a <- getNameFrom (sMN 0 "argTy")

539− b <- unique_hole (MN 0 "retTy")

573+ b <- getNameFrom (sMN 0 "retTy")

540− f <- unique_hole (MN 0 "f")

574+ f <- getNameFrom (sMN 0 "f")

541− s <- unique_hole (MN 0 "s")

575+ s <- getNameFrom (sMN 0 "s")

542 claim a RType

576 claim a RType

543 claim b RType

577 claim b RType

544− claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b))

578+ claim f (RBind (sMN 0 "aX") (Pi (Var a)) (Var b))

545 tm <- get_term

579 tm <- get_term

546 start_unify s

580 start_unify s

547 claim s (Var a)

581 claim s (Var a)

@@ -580,7 +614,7 @@ no_errors tac

580 ((x,y,env,err) : _) ->

614 ((x,y,env,err) : _) ->

581 let env' = map (\(x, b) -> (x, binderTy b)) env in

615 let env' = map (\(x, b) -> (x, binderTy b)) env in

582 lift $ tfail $ CantUnify False x y err env' 0

616 lift $ tfail $ CantUnify False x y err env' 0

583− else return ()

617+ else return $! ()

584

618

585-- Try a tactic, if it fails, try another

619-- Try a tactic, if it fails, try another

586try :: Elab' aux a -> Elab' aux a -> Elab' aux a

620try :: Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -592,10 +626,10 @@ try' t1 t2 proofSearch

592 ps <- get_probs

626 ps <- get_probs

593 case prunStateT 999999 False ps t1 s of

627 case prunStateT 999999 False ps t1 s of

594 OK ((v, _), s') -> do put s'

628 OK ((v, _), s') -> do put s'

595− return v

629+ return $! v

596 Error e1 -> if recoverableErr e1 then

630 Error e1 -> if recoverableErr e1 then

597 do case runStateT t2 s of

631 do case runStateT t2 s of

598− OK (v, s') -> do put s'; return v

632+ OK (v, s') -> do put s'; return $! v

599 Error e2 -> if score e1 >= score e2

633 Error e2 -> if score e1 >= score e2

600 then lift (tfail e1)

634 then lift (tfail e1)

601 else lift (tfail e2)

635 else lift (tfail e2)

@@ -632,8 +666,8 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

632 case prunStateT pmax True ps x s of

666 case prunStateT pmax True ps x s of

633 OK ((v, newps), s') ->

667 OK ((v, newps), s') ->

634 do let cs' = if (newps < pmax)

668 do let cs' = if (newps < pmax)

635− then [do put s'; return v]

669+ then [do put s'; return $! v]

636− else (do put s'; return v) : cs

670+ else (do put s'; return $! v) : cs

637 tryAll' cs' newps f xs

671 tryAll' cs' newps f xs

638 Error err -> do put s

672 Error err -> do put s

639 if (score err) < 100

673 if (score err) < 100

src/Idris/Core/Evaluate.hs+22−17

@@ -9,11 +9,12 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

9 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

10 addDatatype, addCasedef, simplifyCasedef, addOperator,

11 lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

12+ mapDefCtxt,

12 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

13 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

13 Value(..), Quote(..), initEval, uniqueNameCtxt) where

14 Value(..), Quote(..), initEval, uniqueNameCtxt) where

15import Debug.Trace

16import Debug.Trace

16−import Control.Monad.State

17+import Control.Monad.State -- not Strict!

17import qualified Data.Binary as B

18import qualified Data.Binary as B

18import Data.Binary hiding (get, put)

19import Data.Binary hiding (get, put)

@@ -98,11 +99,11 @@ specialise ctxt env limits t

99simplify :: Context -> Env -> TT Name -> TT Name

100simplify :: Context -> Env -> TT Name -> TT Name

100simplify ctxt env t

101simplify ctxt env t

101− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

102+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

102− (UN "assert_smaller", 0),

103+ (sUN "assert_smaller", 0),

103− (UN "par", 0),

104+ (sUN "par", 0),

104− (UN "prim__syntactic_eq", 0),

105+ (sUN "prim__syntactic_eq", 0),

105− (UN "fork", 0)]

106+ (sUN "fork", 0)]

106 (map finalEntry env) (finalise t)

107 (map finalEntry env) (finalise t)

107 [Simplify]

108 [Simplify]

108 quote 0 val) initEval

109 quote 0 val) initEval

@@ -110,11 +111,11 @@ simplify ctxt env t

110-- | Simplify for run-time (i.e. basic inlining)

111-- | Simplify for run-time (i.e. basic inlining)

111rt_simplify :: Context -> Env -> TT Name -> TT Name

112rt_simplify :: Context -> Env -> TT Name -> TT Name

112rt_simplify ctxt env t

113rt_simplify ctxt env t

113− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

114+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

114− (UN "assert_smaller", 0),

115+ (sUN "assert_smaller", 0),

115− (UN "par", 0),

116+ (sUN "par", 0),

116− (UN "prim__syntactic_eq", 0),

117+ (sUN "prim__syntactic_eq", 0),

117− (UN "prim_fork", 0)]

118+ (sUN "prim_fork", 0)]

118 (map finalEntry env) (finalise t)

119 (map finalEntry env) (finalise t)

119 [RunTT]

120 [RunTT]

120 quote 0 val) initEval

121 quote 0 val) initEval

@@ -189,7 +190,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

189 = not (inl || dict) || elem n stk

190 = not (inl || dict) || elem n stk

190 | Simplify `elem` opts

191 | Simplify `elem` opts

191 = (not (inl || dict) || elem n stk)

192 = (not (inl || dict) || elem n stk)

192− || (n == UN "prim__syntactic_eq")

193+ || (n == sUN "prim__syntactic_eq")

193 | otherwise = False

194 | otherwise = False

194

195

195 getCases cd | simpl = cases_totcheck cd

196 getCases cd | simpl = cases_totcheck cd

@@ -411,7 +412,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

411 chooseAlt env _ (VP _ n _, args) alts amap

412 chooseAlt env _ (VP _ n _, args) alts amap

412 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

413 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

413 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

414 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

414− | Just (ns, sc) <- findFn (UN "->") alts

415+ | Just (ns, sc) <- findFn (sUN "->") alts

415 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

416 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

416 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

417 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

417 chooseAlt _ _ _ alts amap

418 chooseAlt _ _ _ alts amap

@@ -491,7 +492,7 @@ instance Quote Value where

491 = do sc' <- quote i sc

492 = do sc' <- quote i sc

492 t' <- quote i t

493 t' <- quote i t

493 v' <- quote i v

494 v' <- quote i v

494− let sc'' = pToV (MN vd "vlet") (addBinder sc')

495+ let sc'' = pToV (sMN vd "vlet") (addBinder sc')

495 return (Bind n (Let t' v') sc'')

496 return (Bind n (Let t' v') sc'')

496 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

497 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

497 quote i (VType u) = return $ TType u

498 quote i (VType u) = return $ TType u

@@ -512,9 +513,9 @@ wknV i t = return t

512

513

513convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

514convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

514

515

515−convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

516+convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

516convEq ctxt = ceq [] where

517convEq ctxt = ceq [] where

517− ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool

518+ ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

518 ceq ps (P xt x _) (P yt y _)

519 ceq ps (P xt x _) (P yt y _)

519 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

520 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

520 | otherwise = sameDefs ps x y

521 | otherwise = sameDefs ps x y

@@ -696,6 +697,10 @@ data Context = MkContext {

696-- | The initial empty context

697-- | The initial empty context

697initContext = MkContext [] 0 emptyContext

698initContext = MkContext [] 0 emptyContext

698

699

700+mapDefCtxt :: (Def -> Def) -> Context -> Context

701+mapDefCtxt f (MkContext c t defs) = MkContext c t (mapCtxt f' defs)

702+ where f' (d, a, t, m) = f' (f d, a, t, m)

703+

699-- | Get the definitions from a context

704-- | Get the definitions from a context

700ctxtAlist :: Context -> [(Name, Def)]

705ctxtAlist :: Context -> [(Name, Def)]

701ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

706ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

@@ -886,7 +891,7 @@ lookupDefAcc :: Name -> Bool -> Context ->

886lookupDefAcc n mkpublic ctxt

891lookupDefAcc n mkpublic ctxt

887 = map mkp $ lookupCtxt n (definitions ctxt)

892 = map mkp $ lookupCtxt n (definitions ctxt)

888 -- io_bind a special case for REPL prettiness

893 -- io_bind a special case for REPL prettiness

889− where mkp (d, a, _, _) = if mkpublic && (not (n == UN "io_bind" || n == UN "io_return"))

894+ where mkp (d, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_return"))

890 then (d, Public) else (d, a)

895 then (d, Public) else (d, a)

891

896

892lookupTotal :: Name -> Context -> [Totality]

897lookupTotal :: Name -> Context -> [Totality]

src/Idris/Core/Execute.hs+65−41

@@ -96,7 +96,7 @@ toTT (EApp e1 e2) = do e1' <- toTT e1

96toTT (EType u) = return $ TType u

97toTT EErased = return Erased

98toTT (EConstant c) = return (Constant c)

99−toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT

99+toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT

100toTT (EHandle _) = return Erased

101

102unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -173,7 +173,7 @@ execute tm = do est <- initState

173 Right tm' -> return tm'

174

175ioWrap :: ExecVal -> ExecVal

176−ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]

176+ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]

177

178ioUnit :: ExecVal

179ioUnit = ioWrap (EP Ref unitCon EErased)

@@ -219,8 +219,9 @@ execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

219execApp env ctxt (f, args) = do newF <- doExec env ctxt f

220 laziness <- (++ repeat False) <$> (getLaziness newF)

221 newArgs <- mapM argExec (zip args laziness)

222− execApp' env ctxt newF newArgs

222+ res <- execApp' env ctxt newF newArgs

223+ return res

223− where getLaziness (EP _ (UN "lazy") _) = return [False, True]

224+ where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

224 getLaziness (EP _ n _) = do est <- getExecState

225 getLaziness (EP _ n _) = do est <- getExecState

225 let argInfo = exec_implicits est

226 let argInfo = exec_implicits est

226 case lookupCtxtName n argInfo of

227 case lookupCtxtName n argInfo of

@@ -235,28 +236,36 @@ execApp env ctxt (f, args) = do newF <- doExec env ctxt f

235

236

236execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

238execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

238−execApp' env ctxt (EP _ (UN "unsafePerformPrimIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =

239+execApp' env ctxt (EP _ fp _) (ty:action:rest)

240+ | fp == upio,

241+ (prim__IO, [_, v]) <- unApplyV action

239− execApp' env ctxt v rest

242+ = execApp' env ctxt v rest

240−

243+

241−execApp' env ctxt (EP _ (UN "prim_io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =

244+execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

245+ | fp == piobind,

246+ (prim__IO, [_, v']) <- unApplyV v =

242 do v'' <- tryForce v'

247 do v'' <- tryForce v'

243 res <- execApp' env ctxt k [v''] >>= tryForce

248 res <- execApp' env ctxt k [v''] >>= tryForce

244 execApp' env ctxt res rest

249 execApp' env ctxt res rest

245−execApp' env ctxt con@(EP _ (UN "prim_io_return") _) args@(tp:v:rest) =

250+execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

251+ | fp == pioret =

246 do v' <- tryForce v

252 do v' <- tryForce v

247 execApp' env ctxt (mkEApp con [tp, v']) rest

253 execApp' env ctxt (mkEApp con [tp, v']) rest

248

254

249-- Special cases arising from not having access to the C RTS in the interpreter

255-- Special cases arising from not having access to the C RTS in the interpreter

250−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest)

256+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

257+ | fp == mkfprim,

251− | Just (FFun "putStr" _ _) <- foreignFromTT fn

258+ Just (FFun "putStr" _ _) <- foreignFromTT fn

252 = do execIO (putStr arg)

259 = do execIO (putStr arg)

253 execApp' env ctxt ioUnit rest

260 execApp' env ctxt ioUnit rest

254−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

261+execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

262+ | fp == mkfprim,

255− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

263+ Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

256 = do contents <- execIO $ hGetLine h

264 = do contents <- execIO $ hGetLine h

257 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

265 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

258−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

266+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

267+ | fp == mkfprim,

259− | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

268+ Just (FFun "fileOpen" _ _) <- foreignFromTT fn

260 = do m <- case mode of

269 = do m <- case mode of

261 "r" -> return ReadMode

270 "r" -> return ReadMode

262 "w" -> return WriteMode

271 "w" -> return WriteMode

@@ -268,42 +277,46 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268 h <- execIO $ openFile f m

277 h <- execIO $ openFile f m

269 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

278 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

270

279

271−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

280+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

281+ | fp == mkfprim,

272− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

282+ Just (FFun "fileEOF" _ _) <- foreignFromTT fn

273 = do eofp <- execIO $ hIsEOF h

283 = do eofp <- execIO $ hIsEOF h

274 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

284 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

275 execApp' env ctxt res (tail rest)

285 execApp' env ctxt res (tail rest)

276

286

277−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

287+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

288+ | fp == mkfprim,

278− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

289+ Just (FFun "fileClose" _ _) <- foreignFromTT fn

279 = do execIO $ hClose h

290 = do execIO $ hClose h

280 execApp' env ctxt ioUnit (tail rest)

291 execApp' env ctxt ioUnit (tail rest)

281

292

282−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

293+execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

294+ | fp == mkfprim,

283− | Just (FFun "isNull" _ _) <- foreignFromTT fn

295+ Just (FFun "isNull" _ _) <- foreignFromTT fn

284 = let res = ioWrap . EConstant . I $

296 = let res = ioWrap . EConstant . I $

285 if p == nullPtr then 1 else 0

297 if p == nullPtr then 1 else 0

286 in execApp' env ctxt res (tail rest)

298 in execApp' env ctxt res (tail rest)

287

299

288-- A foreign-returned char* has to be tested for NULL sometimes

300-- A foreign-returned char* has to be tested for NULL sometimes

289−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str s):rest)

301+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

302+ | fp == mkfprim,

290− | Just (FFun "isNull" _ _) <- foreignFromTT fn

303+ Just (FFun "isNull" _ _) <- foreignFromTT fn

291 = let res = ioWrap . EConstant . I $ 0

304 = let res = ioWrap . EConstant . I $ 0

292 in execApp' env ctxt res (tail rest)

305 in execApp' env ctxt res (tail rest)

293

306

294-- Throw away the 'World' argument to the foreign function

307-- Throw away the 'World' argument to the foreign function

295

308

296−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

309+execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

297− | Just (FFun f argTs retT) <- foreignFromTT fn

310+ = case foreignFromTT fn of

298− , length xs >= length argTs =

311+ Just (FFun f argTs retT) | length xs >= length argTs ->

299− do let (args', xs') = (take (length argTs) xs, -- foreign args

312+ do let (args', xs') = (take (length argTs) xs, -- foreign args

300− drop (length argTs + 1) xs) -- rest

313+ drop (length argTs + 1) xs) -- rest

301− res <- stepForeign (ty:fn:args')

314+ res <- stepForeign (ty:fn:args')

302− case res of

315+ case res of

303− Nothing -> fail $ "Could not call foreign function \"" ++ f ++

316+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++

304− "\" with args " ++ show args

317+ "\" with args " ++ show args

305− Just r -> return (mkEApp r xs')

318+ Just r -> return (mkEApp r xs')

306− | otherwise = return (mkEApp f args)

319+ Nothing -> return (mkEApp f args)

307

320

308execApp' env ctxt c@(EP (DCon _ arity) n _) args =

321execApp' env ctxt c@(EP (DCon _ arity) n _) args =

309 do args' <- mapM tryForce (take arity args)

322 do args' <- mapM tryForce (take arity args)

@@ -343,13 +356,23 @@ execApp' env ctxt (EThunk i) args = do f <- force i

343execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

356execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

344execApp' env ctxt f args = return (mkEApp f args)

357execApp' env ctxt f args = return (mkEApp f args)

345

358

359+prs = sUN "prim__readString"

360+pbm = sUN "prim__believe_me"

361+pstd = sUN "prim__stdin"

362+mkfprim = sUN "mkForeignPrim"

363+pioret = sUN "prim_io_return"

364+piobind = sUN "prim_io_bind"

365+upio = sUN "unsafePerformPrimIO"

366+

346-- | Look up primitive operations in the global table and transform them into ExecVal functions

367-- | Look up primitive operations in the global table and transform them into ExecVal functions

347getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

368getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

348−getOp (UN "prim__believe_me") [_, _, x] = Just (return x)

369+getOp fn [_, _, x] | fn == pbm = Just (return x)

349−getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =

370+getOp fn [EP _ fn' _]

371+ | fn == prs && fn' == pstd =

350 Just $ do line <- execIO getLine

372 Just $ do line <- execIO getLine

351 return (EConstant (Str line))

373 return (EConstant (Str line))

352−getOp (UN "prim__readString") [EHandle h] =

374+getOp fn [EHandle h]

375+ | fn == prs =

353 Just $ do contents <- execIO $ hGetLine h

376 Just $ do contents <- execIO $ hGetLine h

354 return (EConstant (Str (contents ++ "\n")))

377 return (EConstant (Str (contents ++ "\n")))

355getOp n args = getPrim n primitives >>= flip applyPrim args

378getOp n args = getPrim n primitives >>= flip applyPrim args

@@ -478,11 +501,12 @@ foreignFromTT t = case (unApplyV t) of

478 argFTy <- sequence $ map getFTy argTy

501 argFTy <- sequence $ map getFTy argTy

479 retFTy <- getFTy ret

502 retFTy <- getFTy ret

480 return $ FFun name argFTy retFTy

503 return $ FFun name argFTy retFTy

481− _ -> trace "failed to construct ffun" Nothing

504+ _ -> trace ("failed to construct ffun") Nothing

482

505

483getFTy :: ExecVal -> Maybe FType

506getFTy :: ExecVal -> Maybe FType

484−getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

507+getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))

508+ | fi == txt "FIntT" =

485− case intTy of

509+ case str intTy of

486 "ITNative" -> Just (FArith (ATInt ITNative))

510 "ITNative" -> Just (FArith (ATInt ITNative))

487 "ITChar" -> Just (FArith (ATInt ITChar))

511 "ITChar" -> Just (FArith (ATInt ITChar))

488 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

512 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

@@ -491,7 +515,7 @@ getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

491 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

515 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

492 _ -> Nothing

516 _ -> Nothing

493getFTy (EP _ (UN t) _) =

517getFTy (EP _ (UN t) _) =

494− case t of

518+ case str t of

495 "FFloat" -> Just (FArith ATFloat)

519 "FFloat" -> Just (FArith ATFloat)

496 "FString" -> Just FString

520 "FString" -> Just FString

497 "FPtr" -> Just FPtr

521 "FPtr" -> Just FPtr

src/Idris/Core/ProofState.hs+33−31

@@ -13,7 +13,7 @@ import Idris.Core.Evaluate

13import Idris.Core.TT

14import Idris.Core.Unify

16−import Control.Monad.State

16+import Control.Monad.State.Strict

17import Control.Applicative hiding (empty)

18import Data.List

19import Debug.Trace

@@ -159,7 +159,7 @@ hole (Hole _) = True

159hole (Guess _ _) = True

160hole _ = False

161

162−holeName i = MN i "hole"

162+holeName i = sMN i "hole"

163

164qshow :: Fails -> String

165qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

@@ -209,7 +209,7 @@ getName :: Monad m => String -> StateT TState m Name

209getName tag = do ps <- get

210 let n = nextname ps

211 put (ps { nextname = n+1 })

212− return $ MN n tag

212+ return $ sMN n tag

213

214action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

215action a = do ps <- get

@@ -476,18 +476,12 @@ solve ctxt env (Bind x (Guess ty val) sc)

476 | True = do ps <- get

477 let (uh, uns) = unified ps

478 case lookup x (notunified ps) of

479− Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

480− -- return []

481− unify' ctxt env tm val

479+ Just tm -> unify' ctxt env tm val

482 _ -> return []

480 _ -> return []

483 action (\ps -> ps { holes = holes ps \\ [x],

481 action (\ps -> ps { holes = holes ps \\ [x],

484 solved = Just (x, val),

482 solved = Just (x, val),

485−-- problems = solveInProblems

486−-- x val (problems ps),

487− -- dontunify = dontunify ps \\ [x],

488− -- unified = (uh, uns ++ [(x, val)]),

489 instances = instances ps \\ [x] })

483 instances = instances ps \\ [x] })

490− let tm' = instantiate val (pToV x sc) in

484+ let tm' = subst x val sc in

491 return tm'

485 return tm'

492 | otherwise = lift $ tfail $ IncompleteTerm val

486 | otherwise = lift $ tfail $ IncompleteTerm val

493solve _ _ h@(Bind x t sc)

487solve _ _ h@(Bind x t sc)

@@ -513,7 +507,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

513 (tyv, tyt) <- lift $ check ctxt env ty

507 (tyv, tyt) <- lift $ check ctxt env ty

514-- ns <- lift $ unify ctxt env tyv t'

508-- ns <- lift $ unify ctxt env tyv t'

515 case t' of

509 case t' of

516− Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

510+ Bind y (Pi s) t -> let t' = subst y (P Bound n s) t in

517 do ns <- unify' ctxt env s tyv

511 do ns <- unify' ctxt env s tyv

518 ps <- get

512 ps <- get

519 let (uh, uns) = unified ps

513 let (uh, uns) = unified ps

@@ -532,7 +526,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

532 _ -> hnf ctxt env t

526 _ -> hnf ctxt env t

533 case t' of

527 case t' of

534 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

528 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

535− let t' = instantiate (P Bound n s) (pToV y t) in

529+ let t' = subst y (P Bound n s) t in

536 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

530 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

537 _ -> lift $ tfail $ CantIntroduce t'

531 _ -> lift $ tfail $ CantIntroduce t'

538intro n ctxt env _ = fail "Can't introduce here."

532intro n ctxt env _ = fail "Can't introduce here."

@@ -548,7 +542,7 @@ forall n ty ctxt env _ = fail "Can't pi bind here"

548patvar :: Name -> RunTactic

542patvar :: Name -> RunTactic

549patvar n ctxt env (Bind x (Hole t) sc) =

543patvar n ctxt env (Bind x (Hole t) sc) =

550 do action (\ps -> ps { holes = holes ps \\ [x] })

544 do action (\ps -> ps { holes = holes ps \\ [x] })

551− return $ Bind n (PVar t) (instantiate (P Bound n t) (pToV x sc))

545+ return $ Bind n (PVar t) (subst x (P Bound n t) sc)

552patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

546patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

553

547

554letbind :: Name -> Raw -> Raw -> RunTactic

548letbind :: Name -> Raw -> Raw -> RunTactic

@@ -568,16 +562,16 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

568 do (tmv, tmt) <- lift $ check ctxt env tm

562 do (tmv, tmt) <- lift $ check ctxt env tm

569 let tmt' = normalise ctxt env tmt

563 let tmt' = normalise ctxt env tmt

570 case unApply tmt' of

564 case unApply tmt' of

571− (P _ (UN "=") _, [lt,rt,l,r]) ->

565+ (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->

572 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

566 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

573 let newt = mkP l r l t

567 let newt = mkP l r l t

574 let sc = forget $ (Bind x (Hole newt)

568 let sc = forget $ (Bind x (Hole newt)

575− (mkApp (P Ref (UN "replace") (TType (UVal 0)))

569+ (mkApp (P Ref (sUN "replace") (TType (UVal 0)))

576 [lt, l, r, p, tmv, xp]))

570 [lt, l, r, p, tmv, xp]))

577 (scv, sct) <- lift $ check ctxt env sc

571 (scv, sct) <- lift $ check ctxt env sc

578 return scv

572 return scv

579 _ -> lift $ tfail (NotEquality tmv tmt')

573 _ -> lift $ tfail (NotEquality tmv tmt')

580− where rname = MN 0 "replaced"

574+ where rname = sMN 0 "replaced"

581rewrite _ _ _ _ = fail "Can't rewrite here"

575rewrite _ _ _ _ = fail "Can't rewrite here"

582

576

583-- To make the P for rewrite, replace syntactic occurrences of l in ty with

577-- To make the P for rewrite, replace syntactic occurrences of l in ty with

@@ -633,7 +627,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

633 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

627 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

634 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

628 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

635 _ -> fail "Unkown type for induction"

629 _ -> fail "Unkown type for induction"

636− where scname = MN 0 "scarg"

630+ where scname = sMN 0 "scarg"

637 makeConsArg (nm, ty) = P Bound nm ty

631 makeConsArg (nm, ty) = P Bound nm ty

638 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

632 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

639 bindConsArgs [] v = v

633 bindConsArgs [] v = v

@@ -642,7 +636,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

642 splitTyArgs param_pos tyargs =

636 splitTyArgs param_pos tyargs =

643 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

637 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

644 in (map snd params, map snd indicies)

638 in (map snd params, map snd indicies)

645− makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (MN 0 "idx") nms):nms) []

639+ makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []

646 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

640 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

647 let var = P Bound idnm idxt

641 let var = P Bound idnm idxt

648 return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs

642 return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs

@@ -662,7 +656,7 @@ patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

662 x@(Bind y (PVTy s) t) -> x

656 x@(Bind y (PVTy s) t) -> x

663 _ -> hnf ctxt env t

657 _ -> hnf ctxt env t

664 case t' of

658 case t' of

665− Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

659+ Bind y (PVTy s) t -> let t' = subst y (P Bound n s) t in

666 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

660 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

667 _ -> fail "Nothing to pattern bind"

661 _ -> fail "Nothing to pattern bind"

668patbind n ctxt env _ = fail "Can't pattern bind here"

662patbind n ctxt env _ = fail "Can't pattern bind here"

@@ -739,34 +733,42 @@ keepGiven du (u@(n, _) : us) hs

739 | n `elem` du = u : keepGiven du us hs

733 | n `elem` du = u : keepGiven du us hs

740keepGiven du (u : us) hs = keepGiven du us hs

734keepGiven du (u : us) hs = keepGiven du us hs

741

735

742−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

736+updateSolved xs x = updateSolved' xs x

743− updateSolved' xs x

737+updateSolved' [] x = x

744updateSolved' xs (Bind n (Hole ty) t)

738updateSolved' xs (Bind n (Hole ty) t)

745− | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t))

739+ | Just v <- lookup n xs

740+ = case xs of

741+ [_] -> psubst n v t

742+ _ -> psubst n v (updateSolved' xs t)

746updateSolved' xs (Bind n b t)

743updateSolved' xs (Bind n b t)

747 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

744 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

745+updateSolved' xs (App f a)

748−updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

746+ = App (updateSolved' xs f) (updateSolved' xs a)

749−updateSolved' xs (P _ n _)

747+updateSolved' xs (P _ n@(MN _ _) _)

750 | Just v <- lookup n xs = v

748 | Just v <- lookup n xs = v

751updateSolved' xs t = t

749updateSolved' xs t = t

752

750

751+updateEnv [] e = e

753updateEnv ns [] = []

752updateEnv ns [] = []

754updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

753updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

755

754

755+updateError [] err = err

756updateError ns (CantUnify b l r e xs sc)

757 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

758updateError ns e = e

759

760solveInProblems x val [] = []

761solveInProblems x val ((l, r, env, err) : ps)

762− = ((instantiate val (pToV x l), instantiate val (pToV x r),

762+ = ((psubst x val l, psubst x val r,

763 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

764

765+updateNotunified [] nu = nu

765updateNotunified ns nu = up nu where

766updateNotunified ns nu = up nu where

766 up [] = []

767 up [] = []

767− up ((n, t) : ns) = let t' = updateSolved ns t in

768+ up ((n, t) : nus) = let t' = updateSolved ns t in

768− ((n, t') : up ns)

769+ ((n, t') : up nus)

769

770

771+updateProblems ctxt [] ps inj holes = ([], ps)

770updateProblems ctxt ns ps inj holes = up ns ps where

772updateProblems ctxt ns ps inj holes = up ns ps where

771 up ns [] = (ns, [])

773 up ns [] = (ns, [])

772 up ns ((x, y, env, err) : ps) =

774 up ns ((x, y, env, err) : ps) =

@@ -811,12 +813,11 @@ processTactic EndUnify ps

811 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

813 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

812 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

814 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

813 (injective ps) (holes ps)

815 (injective ps) (holes ps)

814− tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

815− updateSolved ns'' (pterm ps) in

816+ tm' = updateSolved ns'' (pterm ps) in

816 return (ps { pterm = tm',

817 return (ps { pterm = tm',

817 unified = (h, []),

818 unified = (h, []),

818 problems = probs',

819 problems = probs',

819− notunified = updateNotunified ns (notunified ps),

820+ notunified = updateNotunified ns'' (notunified ps),

820 holes = holes ps \\ map fst ns'' }, "")

821 holes = holes ps \\ map fst ns'' }, "")

821processTactic (Reorder n) ps

822processTactic (Reorder n) ps

822 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

823 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

@@ -841,6 +842,7 @@ processTactic MatchProblems ps

841 pterm' = updateSolved ns' (pterm ps) in

842 pterm' = updateSolved ns' (pterm ps) in

842 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843 previous = Just ps, plog = "",

844 previous = Just ps, plog = "",

845+ notunified = updateNotunified ns' (notunified ps),

844 holes = holes ps \\ (map fst ns') }, plog ps)

846 holes = holes ps \\ (map fst ns') }, plog ps)

845processTactic t ps

847processTactic t ps

846 = case holes ps of

848 = case holes ps of

src/Idris/Core/TC.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE DeriveFunctor #-}

3+module Idris.Core.TC(TC'(..)) where

5+import Control.Monad

6+import Control.Monad.Trans.Error(Error(..))

8+data TC' e a = OK !a

9+ | Error e

10+ deriving (Eq, Functor)

11+

12+bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b

13+bindTC x k = case x of

14+ OK v -> k v

15+ Error e -> Error e

16+{-# INLINE bindTC #-}

17+

18+instance Error e => Monad (TC' e) where

19+ return x = OK x

20+ x >>= k = bindTC x k

21+ fail e = Error (strMsg e)

22+

23+instance Error e => MonadPlus (TC' e) where

24+ mzero = fail "Unknown error"

25+ (OK x) `mplus` _ = OK x

26+ _ `mplus` (OK y) = OK y

27+ err `mplus` _ = err

28+

src/Idris/Core/TT.hs+115−72

@@ -18,13 +18,16 @@

18 programs with implicit syntax into fully explicit terms.

19-}

21−module Idris.Core.TT where

21+module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where

23+import Idris.Core.TC

24+

23−import Control.Monad.State

25+import Control.Monad.State.Strict

24import Control.Monad.Trans.Error (Error(..))

26import Control.Monad.Trans.Error (Error(..))

25import Debug.Trace

27import Debug.Trace

26−import qualified Data.Map as Map

28+import qualified Data.Map.Strict as Map

27import Data.Char

29import Data.Char

30+import qualified Data.Text as T

28import Data.List

31import Data.List

29import Data.Vector.Unboxed (Vector)

32import Data.Vector.Unboxed (Vector)

30import qualified Data.Vector.Unboxed as V

33import qualified Data.Vector.Unboxed as V

@@ -162,7 +165,7 @@ instance Show Err where

162 ++ show e ++ " in " ++ show sc ++ " " ++ show i

165 ++ show e ++ " in " ++ show sc ++ " " ++ show i

163 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

166 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

164 show (ProviderError msg) = "Type provider error: " ++ msg

167 show (ProviderError msg) = "Type provider error: " ++ msg

165− show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ show e

168+ show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

166 show ProgramLineComment = "Program line next to comment"

169 show ProgramLineComment = "Program line next to comment"

167 show (At f e) = show f ++ ":" ++ show e

170 show (At f e) = show f ++ ":" ++ show e

168 show _ = "Error"

171 show _ = "Error"

@@ -182,13 +185,11 @@ instance Pretty Err where

182 pretty _ = text "Error"

185 pretty _ = text "Error"

183

186

184instance Error Err where

187instance Error Err where

185− strMsg = Msg

188+ strMsg = InternalMsg

186

189

187−data TC a = OK a

190+type TC = TC' Err

188− | Error Err

189− deriving (Eq, Functor)

190

191

191−instance Pretty a => Pretty (TC a) where

192+instance (Pretty a) => Pretty (TC a) where

192 pretty (OK ok) = pretty ok

193 pretty (OK ok) = pretty ok

193 pretty (Error err) =

194 pretty (Error err) =

194 if size err > breakingSize then

195 if size err > breakingSize then

@@ -200,29 +201,16 @@ instance Show a => Show (TC a) where

200 show (OK x) = show x

201 show (OK x) = show x

201 show (Error str) = "Error: " ++ show str

202 show (Error str) = "Error: " ++ show str

202

203

203−-- at some point, this instance should also carry type checking options

204−-- (e.g. Type:Type)

205−

206−instance Monad TC where

207− return = OK

208− x >>= k = case x of

209− OK v -> k v

210− Error e -> Error e

211− fail e = Error (InternalMsg e)

212−

213tfail :: Err -> TC a

204tfail :: Err -> TC a

214tfail e = Error e

205tfail e = Error e

215

206

207+failMsg :: String -> TC a

208+failMsg str = Error (Msg str)

209+

216trun :: FC -> TC a -> TC a

210trun :: FC -> TC a -> TC a

217trun fc (OK a) = OK a

211trun fc (OK a) = OK a

218trun fc (Error e) = Error (At fc e)

212trun fc (Error e) = Error (At fc e)

219

213

220−instance MonadPlus TC where

221− mzero = fail "Unknown error"

222− (OK x) `mplus` _ = OK x

223− _ `mplus` (OK y) = OK y

224− err `mplus` _ = err

225−

226discard :: Monad m => m a -> m ()

214discard :: Monad m => m a -> m ()

227discard f = f >> return ()

215discard f = f >> return ()

228

216

@@ -240,20 +228,44 @@ traceWhen False _ a = a

240

228

241-- | Names are hierarchies of strings, describing scope (so no danger of

229-- | Names are hierarchies of strings, describing scope (so no danger of

242-- duplicate names, but need to be careful on lookup).

230-- duplicate names, but need to be careful on lookup).

243−data Name = UN String -- ^ User-provided name

231+data Name = UN T.Text -- ^ User-provided name

244− | NS Name [String] -- ^ Root, namespaces

232+ | NS Name [T.Text] -- ^ Root, namespaces

245− | MN Int String -- ^ Machine chosen names

233+ | MN Int T.Text -- ^ Machine chosen names

246 | NErased -- ^ Name of somethng which is never used in scope

234 | NErased -- ^ Name of somethng which is never used in scope

247 | SN SpecialName -- ^ Decorated function names

235 | SN SpecialName -- ^ Decorated function names

236+ | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

248 deriving (Eq, Ord)

237 deriving (Eq, Ord)

238+

239+txt :: String -> T.Text

240+txt = T.pack

241+

242+str :: T.Text -> String

243+str = T.unpack

244+

245+tnull :: T.Text -> Bool

246+tnull = T.null

247+

248+thead :: T.Text -> Char

249+thead = T.head

250+

251+-- Smart constructors for names, using old String style

252+sUN :: String -> Name

253+sUN s = UN (txt s)

254+

255+sNS :: Name -> [String] -> Name

256+sNS n ss = NS n (map txt ss)

257+

258+sMN :: Int -> String -> Name

259+sMN i s = MN i (txt s)

260+

249{-!

261{-!

250deriving instance Binary Name

262deriving instance Binary Name

251deriving instance NFData Name

263deriving instance NFData Name

252!-}

264!-}

253

265

254data SpecialName = WhereN Int Name Name

266data SpecialName = WhereN Int Name Name

255− | InstanceN Name [String]

267+ | InstanceN Name [T.Text]

256− | ParentN Name String

268+ | ParentN Name T.Text

257 | MethodN Name

269 | MethodN Name

258 | CaseN Name

270 | CaseN Name

259 | ElimN Name

271 | ElimN Name

@@ -263,6 +275,12 @@ deriving instance Binary SpecialName

263deriving instance NFData SpecialName

275deriving instance NFData SpecialName

264!-}

276!-}

265

277

278+sInstanceN :: Name -> [String] -> SpecialName

279+sInstanceN n ss = InstanceN n (map T.pack ss)

280+

281+sParentN :: Name -> String -> SpecialName

282+sParentN n s = ParentN n (T.pack s)

283+

266instance Sized Name where

284instance Sized Name where

267 size (UN n) = 1

285 size (UN n) = 1

268 size (NS n els) = 1 + length els

286 size (NS n els) = 1 + length els

@@ -270,36 +288,36 @@ instance Sized Name where

270 size _ = 1

288 size _ = 1

271

289

272instance Pretty Name where

290instance Pretty Name where

273− pretty (UN n) = text n

291+ pretty (UN n) = text (T.unpack n)

274 pretty (NS n s) = pretty n

292 pretty (NS n s) = pretty n

275− pretty (MN i s) = lbrace <+> text s <+> (text . show $ i) <+> rbrace

293+ pretty (MN i s) = lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

276 pretty (SN s) = text (show s)

294 pretty (SN s) = text (show s)

277

295

278instance Show Name where

296instance Show Name where

279− show (UN n) = n

297+ show (UN n) = str n

280− show (NS n s) = showSep "." (reverse s) ++ "." ++ show n

298+ show (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ show n

281− show (MN _ "underscore") = "_"

299+ show (MN _ u) | u == txt "underscore" = "_"

282− show (MN i s) = "{" ++ s ++ show i ++ "}"

300+ show (MN i s) = "{" ++ str s ++ show i ++ "}"

283 show (SN s) = show s

301 show (SN s) = show s

284 show NErased = "_"

302 show NErased = "_"

285

303

286instance Show SpecialName where

304instance Show SpecialName where

287 show (WhereN i p c) = show p ++ ", " ++ show c

305 show (WhereN i p c) = show p ++ ", " ++ show c

288− show (InstanceN cl inst) = showSep ", " inst ++ " instance of " ++ show cl

306+ show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl

289 show (MethodN m) = "method " ++ show m

307 show (MethodN m) = "method " ++ show m

290− show (ParentN p c) = show p ++ "#" ++ c

308+ show (ParentN p c) = show p ++ "#" ++ T.unpack c

291 show (CaseN n) = "case block in " ++ show n

309 show (CaseN n) = "case block in " ++ show n

292 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

310 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

293

311

294-- Show a name in a way decorated for code generation, not human reading

312-- Show a name in a way decorated for code generation, not human reading

295showCG :: Name -> String

313showCG :: Name -> String

296−showCG (UN n) = n

314+showCG (UN n) = T.unpack n

297−showCG (NS n s) = showSep "." (reverse s) ++ "." ++ showCG n

315+showCG (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCG n

298−showCG (MN _ "underscore") = "_"

316+showCG (MN _ u) | u == txt "underscore" = "_"

299−showCG (MN i s) = "{" ++ s ++ show i ++ "}"

317+showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}"

300showCG (SN s) = showCG' s

318showCG (SN s) = showCG' s

301 where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i

319 where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i

302− showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" inst

320+ showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst)

303 showCG' (MethodN m) = '!':showCG m

321 showCG' (MethodN m) = '!':showCG m

304 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

322 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

305 showCG' (CaseN c) = showCG c ++ "_case"

323 showCG' (CaseN c) = showCG c ++ "_case"

@@ -312,7 +330,11 @@ showCG NErased = "_"

312type Ctxt a = Map.Map Name (Map.Map Name a)

330type Ctxt a = Map.Map Name (Map.Map Name a)

313emptyContext = Map.empty

331emptyContext = Map.empty

314

332

333+mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b

334+mapCtxt = fmap . fmap

335+

315−tcname (UN ('@':_)) = True

336+tcname (UN xs) | T.null xs = False

337+ | otherwise = T.head xs == '@'

316tcname (NS n _) = tcname n

338tcname (NS n _) = tcname n

317tcname (SN (InstanceN _ _)) = True

339tcname (SN (InstanceN _ _)) = True

318tcname (SN (MethodN _)) = True

340tcname (SN (MethodN _)) = True

@@ -320,7 +342,8 @@ tcname (SN (ParentN _ _)) = True

320tcname _ = False

342tcname _ = False

321

343

322implicitable (NS n _) = implicitable n

344implicitable (NS n _) = implicitable n

323−implicitable (UN (x:xs)) = isLower x

345+implicitable (UN xs) | T.null xs = False

346+ | otherwise = isLower (T.head xs)

324implicitable (MN _ _) = True

347implicitable (MN _ _) = True

325implicitable _ = False

348implicitable _ = False

326

349

@@ -480,19 +503,19 @@ deriving instance NFData Raw

480!-}

503!-}

481

504

482-- | All binding forms are represented in a unform fashion.

505-- | All binding forms are represented in a unform fashion.

483−data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

506+data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

484− | Pi { binderTy :: b }

507+ | Pi { binderTy :: !b }

485− | Let { binderTy :: b,

508+ | Let { binderTy :: !b,

486 binderVal :: b {-^ value for bound variable-}}

509 binderVal :: b {-^ value for bound variable-}}

487− | NLet { binderTy :: b,

510+ | NLet { binderTy :: !b,

488 binderVal :: b }

511 binderVal :: b }

489− | Hole { binderTy :: b}

512+ | Hole { binderTy :: !b}

490 | GHole { envlen :: Int,

513 | GHole { envlen :: Int,

491− binderTy :: b}

514+ binderTy :: !b}

492− | Guess { binderTy :: b,

515+ | Guess { binderTy :: !b,

493 binderVal :: b }

516 binderVal :: b }

494− | PVar { binderTy :: b }

517+ | PVar { binderTy :: !b }

495− | PVTy { binderTy :: b }

518+ | PVTy { binderTy :: !b }

496 deriving (Show, Eq, Ord, Functor)

519 deriving (Show, Eq, Ord, Functor)

497{-!

520{-!

498deriving instance Binary Binder

521deriving instance Binary Binder

@@ -593,12 +616,12 @@ instance Eq NameType where

593

616

594-- | Terms in the core language

617-- | Terms in the core language

595data TT n = P NameType n (TT n) -- ^ named references

618data TT n = P NameType n (TT n) -- ^ named references

596− | V Int -- ^ a resolved de Bruijn-indexed variable

619+ | V !Int -- ^ a resolved de Bruijn-indexed variable

597− | Bind n (Binder (TT n)) (TT n) -- ^ a binding

620+ | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

598− | App (TT n) (TT n) -- ^ function, function type, arg

621+ | App !(TT n) (TT n) -- ^ function, function type, arg

599 | Constant Const -- ^ constant

622 | Constant Const -- ^ constant

600− | Proj (TT n) Int -- ^ argument projection; runtime only

623+ | Proj (TT n) !Int -- ^ argument projection; runtime only

601− -- (-1) is a special case for 'subtract one from BI'

624+ -- (-1) is a special case for 'subtract one from BI'

602 | Erased -- ^ an erased term

625 | Erased -- ^ an erased term

603 | Impossible -- ^ special case for totality checking

626 | Impossible -- ^ special case for totality checking

604 | TType UExp -- ^ the type of types at some level

627 | TType UExp -- ^ the type of types at some level

@@ -621,10 +644,10 @@ instance TermSize (TT Name) where

621 | otherwise = 1

644 | otherwise = 1

622 termsize n (V _) = 1

645 termsize n (V _) = 1

623 termsize n (Bind n' (Let t v) sc)

646 termsize n (Bind n' (Let t v) sc)

624− = let rn = if n == n' then MN 0 "noname" else n in

647+ = let rn = if n == n' then sMN 0 "noname" else n in

625 termsize rn v + termsize rn sc

648 termsize rn v + termsize rn sc

626 termsize n (Bind n' b sc)

649 termsize n (Bind n' b sc)

627− = let rn = if n == n' then MN 0 "noname" else n in

650+ = let rn = if n == n' then sMN 0 "noname" else n in

628 termsize rn sc

651 termsize rn sc

629 termsize n (App f a) = termsize n f + termsize n a

652 termsize n (App f a) = termsize n f + termsize n a

630 termsize n (Proj t i) = termsize n t

653 termsize n (Proj t i) = termsize n t

@@ -653,8 +676,8 @@ data Datatype n = Data { d_typename :: n,

653instance Eq n => Eq (TT n) where

676instance Eq n => Eq (TT n) where

654 (==) (P xt x _) (P yt y _) = x == y

677 (==) (P xt x _) (P yt y _) = x == y

655 (==) (V x) (V y) = x == y

678 (==) (V x) (V y) = x == y

656− (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys

679+ (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

657− (==) (App fx ax) (App fy ay) = fx == fy && ax == ay

680+ (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

658 (==) (TType _) (TType _) = True -- deal with constraints later

681 (==) (TType _) (TType _) = True -- deal with constraints later

659 (==) (Constant x) (Constant y) = x == y

682 (==) (Constant x) (Constant y) = x == y

660 (==) (Proj x i) (Proj y j) = x == y && i == j

683 (==) (Proj x i) (Proj y j) = x == y && i == j

@@ -754,9 +777,28 @@ finalise (Bind x b sc) = Bind x (fmap finalise b) (pToV x (finalise sc))

754finalise (App f a) = App (finalise f) (finalise a)

777finalise (App f a) = App (finalise f) (finalise a)

755finalise t = t

778finalise t = t

756

779

780+-- Once we've finished checking everything about a term we no longer need

781+-- the type on the 'P' so erase it so save memory

782+

783+pEraseType :: TT n -> TT n

784+pEraseType (P nt t _) = P nt t Erased

785+pEraseType (App f a) = App (pEraseType f) (pEraseType a)

786+pEraseType (Bind n b sc) = Bind n (fmap pEraseType b) (pEraseType sc)

787+pEraseType t = t

788+

757subst :: Eq n => n -> TT n -> TT n -> TT n

789subst :: Eq n => n -> TT n -> TT n -> TT n

758subst n v tm = instantiate v (pToV n tm)

790subst n v tm = instantiate v (pToV n tm)

759

791

792+-- If there are no Vs in the term (i.e. in proof state)

793+psubst :: Eq n => n -> TT n -> TT n -> TT n

794+psubst n v tm = s' tm where

795+ s' (P _ x _) | n == x = v

796+ s' (Bind x b sc) | n == x = Bind x (fmap s' b) sc

797+ | otherwise = Bind x (fmap s' b) (s' sc)

798+ s' (App f a) = App (s' f) (s' a)

799+ s' (Proj t idx) = Proj (s' t) idx

800+ s' t = t

801+

760substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

802substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

761substNames [] t = t

803substNames [] t = t

762substNames ((n, tm) : xs) t = subst n tm (substNames xs t)

804substNames ((n, tm) : xs) t = subst n tm (substNames xs t)

@@ -821,8 +863,9 @@ forget tm = fe [] tm

821 where

863 where

822 fe env (P _ n _) = Var n

864 fe env (P _ n _) = Var n

823 fe env (V i) = Var (env !! i)

865 fe env (V i) = Var (env !! i)

866+ fe env (Bind n b sc) = let n' = uniqueName n env in

824− fe env (Bind n b sc) = RBind n (fmap (fe env) b)

867+ RBind n' (fmap (fe env) b)

825− (fe (n:env) sc)

868+ (fe (n':env) sc)

826 fe env (App f a) = RApp (fe env f) (fe env a)

869 fe env (App f a) = RApp (fe env f) (fe env a)

827 fe env (Constant c)

870 fe env (Constant c)

828 = RConstant c

871 = RConstant c

@@ -865,13 +908,13 @@ uniqueBinders ns t = t

865

908

866nextName (NS x s) = NS (nextName x) s

909nextName (NS x s) = NS (nextName x) s

867nextName (MN i n) = MN (i+1) n

910nextName (MN i n) = MN (i+1) n

868−nextName (UN x) = let (num', nm') = span isDigit (reverse x)

911+nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

869− nm = reverse nm'

912+ nm = T.reverse nm'

870− num = readN (reverse num') in

913+ num = readN (T.reverse num') in

871− UN (nm ++ show (num+1))

914+ UN (nm `T.append` txt (show (num+1)))

872 where

915 where

873− readN "" = 0

916+ readN x | not (T.null x) = read (T.unpack x)

874− readN x = read x

917+ readN x = 0

875nextName (SN x) = SN (nextName' x)

918nextName (SN x) = SN (nextName' x)

876 where

919 where

877 nextName' (WhereN i f x) = WhereN i f (nextName x)

920 nextName' (WhereN i f x) = WhereN i f (nextName x)

@@ -1016,7 +1059,7 @@ pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

1016 pureBinder (Let t v) = pureTerm t && pureTerm v

1059 pureBinder (Let t v) = pureTerm t && pureTerm v

1017 pureBinder t = pureTerm (binderTy t)

1060 pureBinder t = pureTerm (binderTy t)

1018

1061

1019− notClassName (MN _ "class") = False

1062+ notClassName (MN _ c) | c == txt "class" = False

1020 notClassName _ = True

1063 notClassName _ = True

1021

1064

1022pureTerm _ = True

1065pureTerm _ = True

src/Idris/Core/Typecheck.hs+1−1

@@ -88,7 +88,7 @@ check' holes ctxt env top = chk env top where

88 -- make sure bound names in function types are locally unique, machine

89 -- generated names, we'll be fine.

90 -- NOTE: now replaced with 'uniqueBinders' above

91− where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s)

91+ where renameBinders i (Bind x (Pi s) t) = Bind (sMN i "binder") (Pi s)

92 (renameBinders (i+1) t)

93 renameBinders i sc = sc

94 chk env RType

src/Idris/Core/Unify.hs+2−2

@@ -6,7 +6,7 @@ import Idris.Core.TT

6import Idris.Core.Evaluate

8import Control.Monad

9−import Control.Monad.State

9+import Control.Monad.State.Strict

10import Data.List

11import Debug.Trace

@@ -277,7 +277,7 @@ unify ctxt env topx topy dont holes =

277

278 un' fn bnames (App f x) (Bind n (Pi t) y)

279 | noOccurrence n y && x == y

280− = un' False bnames f (Bind (MN 0 "uv") (Lam (TType (UVar 0)))

280+ = un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0)))

281 (Bind n (Pi t) (V 1)))

282

283 un' fn bnames (Bind x bx sx) (Bind y by sy)

src/Idris/Coverage.hs+13−10

@@ -15,7 +15,7 @@ import Data.Either

15import Data.Maybe

16import Debug.Trace

18−import Control.Monad.State

18+import Control.Monad.State.Strict

20mkPatTm :: PTerm -> Idris Term

21mkPatTm t = do i <- getIState

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

31 return $ mkApp t' args'

32 toTT _ = do v <- get

33 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (sMN v "imp") Erased)

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -166,13 +166,13 @@ genAll i args

166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167 otherPats o@(PPair fc l r)

168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

169+ ([pimp (sUN "A") Placeholder True,

170− pimp (UN "B") Placeholder True] ++

170+ pimp (sUN "B") Placeholder True] ++

171 [pexp l, pexp r]) o

172 otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

173+ = ops fc (sUN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

174+ ([pimp (sUN "a") Placeholder True,

175− pimp (UN "P") Placeholder True] ++

175+ pimp (sUN "P") Placeholder True] ++

176 [pexp t,pexp v]) o

177 otherPats o@(PConstant c) = return o

178 otherPats arg = return Placeholder

@@ -191,7 +191,8 @@ genAll i args

191 getExpTm t = getTm t

192

193 -- put it back to its original form

194− resugar (PApp _ (PRef fc (UN "Ex_intro")) [_,_,t,v])

194+ resugar (PApp _ (PRef fc (UN ei)) [_,_,t,v])

195+ | ei == txt "Ex_intro"

195 = PDPair fc (getTm t) Placeholder (getTm v)

196 = PDPair fc (getTm t) Placeholder (getTm v)

196 resugar (PApp _ (PRef fc n) [_,_,l,r])

197 resugar (PApp _ (PRef fc n) [_,_,l,r])

197 | n == pairCon

198 | n == pairCon

@@ -258,7 +259,8 @@ calcProd i fc topn pats

258

259

259 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260 prod n done ok ap@(App _ _)

261 prod n done ok ap@(App _ _)

261− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg

262+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

263+ l == txt "lazy" = prod n done ok arg

262 | (P nt f _, args) <- unApply ap

264 | (P nt f _, args) <- unApply ap

263 = do recOK <- checkProdRec (n:done) f

265 = do recOK <- checkProdRec (n:done) f

264 let ctxt = tt_ctxt i

266 let ctxt = tt_ctxt i

@@ -405,7 +407,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

405 findCalls (dePat rhs) (patvars lhs) pargs

407 findCalls (dePat rhs) (patvars lhs) pargs

406

408

407 findCalls ap@(App f a) pvs pargs

409 findCalls ap@(App f a) pvs pargs

408− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

410+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

411+ l == txt "lazy"

409 = findCalls arg pvs pargs

412 = findCalls arg pvs pargs

410 | (P _ n _, args) <- unApply ap

413 | (P _ n _, args) <- unApply ap

411 = mkChange n args pargs ++

414 = mkChange n args pargs ++

src/Idris/DSL.hs+6−5

@@ -8,7 +8,7 @@ import Paths_idris

8import Idris.Core.TT

9import Idris.Core.Evaluate

11−import Control.Monad.State

11+import Control.Monad.State.Strict

12import Debug.Trace

14debindApp :: SyntaxInfo -> PTerm -> PTerm

@@ -44,6 +44,7 @@ expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

44expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

45expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)

46expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t)

47+expandDo dsl (PDisamb ns t) = PDisamb ns (expandDo dsl t)

47expandDo dsl (PReturn fc) = dsl_return dsl

48expandDo dsl (PReturn fc) = dsl_return dsl

48expandDo dsl (PRewrite fc r t ty)

49expandDo dsl (PRewrite fc r t ty)

49 = PRewrite fc r (expandDo dsl t) ty

50 = PRewrite fc r (expandDo dsl t) ty

@@ -57,8 +58,8 @@ expandDo dsl (PDoBlock ds)

57 block b (DoBind fc n tm : rest)

58 block b (DoBind fc n tm : rest)

58 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

59 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

59 block b (DoBindP fc p tm : rest)

60 block b (DoBindP fc p tm : rest)

60− = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

61+ = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

61− (PCase fc (PRef fc (MN 0 "bpat"))

62+ (PCase fc (PRef fc (sMN 0 "bpat"))

62 [(p, block b rest)]))]

63 [(p, block b rest)]))]

63 block b (DoLet fc n ty tm : rest)

64 block b (DoLet fc n ty tm : rest)

64 = PLet n ty tm (block b rest)

65 = PLet n ty tm (block b rest)

@@ -67,7 +68,7 @@ expandDo dsl (PDoBlock ds)

67 block b (DoExp fc tm : rest)

68 block b (DoExp fc tm : rest)

68 = PApp fc b

69 = PApp fc b

69 [pexp tm,

70 [pexp tm,

70− pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

71+ pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))]

71 block b _ = PElabError (Msg "Invalid statement in do block")

72 block b _ = PElabError (Msg "Invalid statement in do block")

73expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

74expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

@@ -131,7 +132,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

131 db' (PAppBind fc t args)

132 db' (PAppBind fc t args)

132 = do args' <- dbs args

133 = do args' <- dbs args

133 (bs, n) <- get

134 (bs, n) <- get

134− let nm = MN n ("bindApp" ++ show n)

135+ let nm = sUN ("_bindApp" ++ show n)

135 put ((nm, fc, PApp fc t args') : bs, n+1)

136 put ((nm, fc, PApp fc t args') : bs, n+1)

136 return (PRef fc nm)

137 return (PRef fc nm)

137 db' (PApp fc t args)

138 db' (PApp fc t args)

src/Idris/DataOpts.hs+40−20

@@ -18,14 +18,16 @@ type ForceMap = M.IntMap Forceability

19-- Calculate the forceable arguments to a constructor

20-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> Type -> Idris ()

21+forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22−forceArgs typeName n t = do

22+forceArgs typeName n expforce t = do

23 ist <- getIState

24 let fargs = getForcedArgs ist typeName t

25 copt = case lookupCtxt n (idris_optimisation ist) of

26 [] -> Optimise False False [] []

27 op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs }) (idris_optimisation ist)

28+ opts = addDef n (copt { forceable = M.toList fargs ++

29+ zip expforce (repeat Unconditional) })

30+ (idris_optimisation ist)

29 putIState (ist { idris_optimisation = opts })

31 putIState (ist { idris_optimisation = opts })

30 addIBC (IBCOpt n)

32 addIBC (IBCOpt n)

31 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

33 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

@@ -37,7 +39,7 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

38 -- Label all occurrences of the variable bound in Pi in the rest of

40 -- Label all occurrences of the variable bound in Pi in the rest of

39 -- the term with the number i so that we can recognize them anytime later.

41 -- the term with the number i so that we can recognize them anytime later.

40− label i = instantiate $ P Bound (MN i "ctor_arg") Erased

42+ label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

42 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

44 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

43 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

45 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

@@ -73,7 +75,8 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

73 guardedArgs t = bareArg t

75 guardedArgs t = bareArg t

75 bareArg :: Term -> ForceMap

77 bareArg :: Term -> ForceMap

76− bareArg (P _ (MN i "ctor_arg") _) = M.singleton i Unconditional

78+ bareArg (P _ (MN i ctor_arg) _)

79+ | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

77 bareArg _ = M.empty

80 bareArg _ = M.empty

79 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

82 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

@@ -196,8 +199,14 @@ instance Optimisable Raw where

196

199

197 stripCollapsed t = return t

200 stripCollapsed t = return t

198

201

202+-- Erase types (makes ibc smaller, and we don't need them)

199−instance Optimisable t => Optimisable (Binder t) where

203+instance Optimisable (Binder (TT Name)) where

200− applyOpts (Let t v) = Let <$> applyOpts t <*> applyOpts v

204+ applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

205+ applyOpts b = return (b { binderTy = Erased })

206+ stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207+ stripCollapsed b = return (b { binderTy = Erased })

208+

209+instance Optimisable (Binder Raw) where

201 applyOpts b = do t' <- applyOpts (binderTy b)

210 applyOpts b = do t' <- applyOpts (binderTy b)

202 return (b { binderTy = t' })

211 return (b { binderTy = t' })

203 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

212 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

@@ -221,17 +230,24 @@ applyDataOpt oi n args

221

230

222-- Run-time: do everything

231-- Run-time: do everything

223

232

233+prel = [txt "Nat", txt "Prelude"]

234+

224instance Optimisable (TT Name) where

235instance Optimisable (TT Name) where

225− applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _)

236+ applyOpts (P _ (NS (UN fn) mod) _)

237+ | fn == txt "plus" && mod == prel

226− = return (P Ref (UN "prim__addBigInt") Erased)

238+ = return (P Ref (sUN "prim__addBigInt") Erased)

227− applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _)

239+ applyOpts (P _ (NS (UN fn) mod) _)

240+ | fn == txt "mult" && mod == prel

228− = return (P Ref (UN "prim__mulBigInt") Erased)

241+ = return (P Ref (sUN "prim__mulBigInt") Erased)

229− applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x)

242+ applyOpts (App (P _ (NS (UN fn) mod) _) x)

243+ | fn == txt "fromIntegerNat" && mod == prel

230 = applyOpts x

244 = applyOpts x

231− applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _)

245+ applyOpts (P _ (NS (UN fn) mod) _)

246+ | fn == txt "fromIntegerNat" && mod == prel

232− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

247+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

233− applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _)

248+ applyOpts (P _ (NS (UN fn) mod) _)

249+ | fn == txt "toIntegerNat" && mod == prel

234− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

250+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

235 applyOpts c@(P (DCon t arity) n _)

251 applyOpts c@(P (DCon t arity) n _)

236 = do i <- getIState

252 = do i <- getIState

237 case lookupCtxt n (idris_optimisation i) of

253 case lookupCtxt n (idris_optimisation i) of

@@ -282,16 +298,19 @@ applyDataOptRT oi n tag arity args

282 (collapsible oi) (M.fromList $ forceable oi) in

298 (collapsible oi) (M.fromList $ forceable oi) in

283 bind extra tm

299 bind extra tm

284 where

300 where

285− satArgs n = map (\i -> MN i "sat") [1..n]

301+ satArgs n = map (\i -> sMN i "sat") [1..n]

286

302

287 bind [] tm = tm

303 bind [] tm = tm

288 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

304 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

289

305

290 -- Nat special cases

306 -- Nat special cases

291 -- TODO: Would be nice if this was configurable in idris source!

307 -- TODO: Would be nice if this was configurable in idris source!

308+ doOpts (NS (UN z) [nat, prelude]) [] _ _

309+ | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

292− doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

310+ = Constant (BI 0)

293− doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

311+ doOpts (NS (UN s) [nat, prelude]) [k] _ _

312+ | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

294− = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

313+ = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

295

314

296 doOpts n args True _ = Erased

315 doOpts n args True _ = Erased

297 doOpts n args _ forceMap

316 doOpts n args _ forceMap

@@ -302,3 +321,4 @@ applyDataOptRT oi n tag arity args

302 where

321 where

303 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

322 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

304 args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

323 args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324+

src/Idris/DeepSeq.hs+2−97

@@ -1,7 +1,7 @@

1−module Idris.DeepSeq where

1+module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where

3+import Idris.Core.DeepSeq

3import Idris.Core.TT

4import Idris.Core.TT

4−import Idris.AbsSyntax

5import Idris.AbsSyntaxTree

7import Control.DeepSeq

@@ -12,32 +12,6 @@ instance NFData Forceability where

12 rnf Conditional = ()

13 rnf Unconditional = ()

15−instance NFData Raw where

16− rnf (Var x1) = rnf x1 `seq` ()

17− rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

18− rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19− rnf RType = ()

20− rnf (RForce x1) = rnf x1 `seq` ()

21− rnf (RConstant x1) = x1 `seq` ()

22−

23−instance NFData FC where

24− rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

25−

26−instance NFData Name where

27− rnf (UN x1) = rnf x1 `seq` ()

28− rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

29− rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

30− rnf NErased = ()

31− rnf (SN x1) = rnf x1 `seq` ()

32−

33−instance NFData SpecialName where

34− rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

35− rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

36− rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

37− rnf (MethodN x1) = rnf x1 `seq` ()

38− rnf (CaseN x1) = rnf x1 `seq` ()

39− rnf (ElimN x1) = rnf x1 `seq` ()

40−

41instance NFData IntTy where

15instance NFData IntTy where

42 rnf (ITFixed x1) = rnf x1 `seq` ()

16 rnf (ITFixed x1) = rnf x1 `seq` ()

43 rnf ITNative = ()

17 rnf ITNative = ()

@@ -45,85 +19,16 @@ instance NFData IntTy where

45 rnf ITChar = ()

19 rnf ITChar = ()

46 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

20 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

48−

49instance NFData NativeTy where

22instance NFData NativeTy where

50 rnf IT8 = ()

23 rnf IT8 = ()

51 rnf IT16 = ()

24 rnf IT16 = ()

52 rnf IT32 = ()

25 rnf IT32 = ()

53 rnf IT64 = ()

26 rnf IT64 = ()

54−

56instance NFData ArithTy where

28instance NFData ArithTy where

57 rnf (ATInt x1) = rnf x1 `seq` ()

29 rnf (ATInt x1) = rnf x1 `seq` ()

58 rnf ATFloat = ()

30 rnf ATFloat = ()

60−instance NFData Err where

61− rnf (Msg x1) = rnf x1 `seq` ()

62− rnf (InternalMsg x1) = rnf x1 `seq` ()

63− rnf (CantUnify x1 x2 x3 x4 x5 x6)

64− = rnf x1 `seq`

65− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

66− rnf (InfiniteUnify x1 x2 x3)

67− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

68− rnf (CantConvert x1 x2 x3)

69− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

70− rnf (UnifyScope x1 x2 x3 x4)

71− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

72− rnf (CantInferType x1) = rnf x1 `seq` ()

73− rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74− rnf (CantIntroduce x1) = rnf x1 `seq` ()

75− rnf (NoSuchVariable x1) = rnf x1 `seq` ()

76− rnf (NoTypeDecl x1) = rnf x1 `seq` ()

77− rnf (NotInjective x1 x2 x3)

78− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

79− rnf (CantResolve x1) = rnf x1 `seq` ()

80− rnf (CantResolveAlts x1) = rnf x1 `seq` ()

81− rnf (IncompleteTerm x1) = rnf x1 `seq` ()

82− rnf UniverseError = ()

83− rnf ProgramLineComment = ()

84− rnf (Inaccessible x1) = rnf x1 `seq` ()

85− rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

86− rnf (AlreadyDefined x1) = rnf x1 `seq` ()

87− rnf (ProofSearchFail x1) = rnf x1 `seq` ()

88− rnf (NoRewriting x1) = rnf x1 `seq` ()

89− rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

90− rnf (Elaborating x1 x2 x3)

91− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92− rnf (ProviderError x1) = rnf x1 `seq` ()

93− rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

94−

95−instance (NFData b) => NFData (Binder b) where

96− rnf (Lam x1) = rnf x1 `seq` ()

97− rnf (Pi x1) = rnf x1 `seq` ()

98− rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

99− rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

100− rnf (Hole x1) = rnf x1 `seq` ()

101− rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

102− rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103− rnf (PVar x1) = rnf x1 `seq` ()

104− rnf (PVTy x1) = rnf x1 `seq` ()

105−

106−instance NFData UExp where

107− rnf (UVar x1) = rnf x1 `seq` ()

108− rnf (UVal x1) = rnf x1 `seq` ()

109−

110−instance NFData NameType where

111− rnf Bound = ()

112− rnf Ref = ()

113− rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

114− rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

115−

116−instance (NFData n) => NFData (TT n) where

117− rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

118− rnf (V x1) = rnf x1 `seq` ()

119− rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

120− rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

121− rnf (Constant x1) = x1 `seq` ()

122− rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

123− rnf Erased = ()

124− rnf Impossible = ()

125− rnf (TType x1) = rnf x1 `seq` ()

126−

127instance NFData SizeChange where

32instance NFData SizeChange where

128 rnf Smaller = ()

33 rnf Smaller = ()

129 rnf Same = ()

34 rnf Same = ()

src/Idris/Delaborate.hs+9−9

@@ -42,7 +42,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

43 de env _ (App f a) = deFn env f [a]

44 de env _ (V i) | i < length env = PRef un (snd (env!!i))

45− | otherwise = PRef un (UN ("v" ++ show i ++ ""))

45+ | otherwise = PRef un (sUN ("v" ++ show i ++ ""))

46 de env _ (P _ n _) | n == unitTy = PTrue un

47 | n == unitCon = PTrue un

48 | n == falseTy = PFalse un

@@ -63,8 +63,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

63 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

64 de env _ (Bind n (Let ty val) sc)

65 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

66− de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc

66+ de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

67− de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

67+ de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

68 de env _ (Bind n _ sc) = de ((n,n):env) [] sc

69 de env _ (Constant i) = PConstant i

70 de env _ Erased = Placeholder

@@ -82,16 +82,16 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

82 deFn env (P _ n _) [l,r]

83 | n == pairTy = PPair un (de env [] l) (de env [] r)

84 | n == eqCon = PRefl un (de env [] r)

85− | n == UN "lazy" = de env [] r

85+ | n == sUN "lazy" = de env [] r

86 deFn env (P _ n _) [ty, Bind x (Lam _) r]

87− | n == UN "Exists"

87+ | n == sUN "Exists"

88 = PDPair un (PRef un x) (de env [] ty)

89 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

90 deFn env (P _ n _) [_,_,l,r]

91 | n == pairCon = PPair un (de env [] l) (de env [] r)

92 | n == eqTy = PEq un (de env [] l) (de env [] r)

93− | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

93+ | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder

94− (de env [] r)

94+ (de env [] r)

95 deFn env (P _ n _) args | not mvs

96 = case lookup n (idris_metavars ist) of

97 Just (Just _, mi, _) ->

@@ -220,8 +220,8 @@ showqual i n = showName (Just i) [] False False (dens n)

220 dens n = n

221

222showbasic n@(UN _) = show n

223−showbasic (MN _ s) = s

223+showbasic (MN _ s) = str s

224−showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

224+showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

225showbasic (SN s) = show s

226

227

src/Idris/Docs.hs+1−1

@@ -107,7 +107,7 @@ docFun n

107

108 return (Doc n docstr args (delab i ty) f)

109 where funName :: Name -> String

110− funName (UN n) = n

110+ funName (UN n) = str n

111 funName (NS n _) = funName n

112

113

src/Idris/ElabDecls.hs+143−114

@@ -28,12 +28,13 @@ import Idris.Core.CaseTree

29import Control.DeepSeq

30import Control.Monad

31−import Control.Monad.State

31+import Control.Monad.State.Strict as State

32import Data.List

33import Data.Maybe

34import Debug.Trace

36import qualified Data.Map as Map

37+import qualified Data.Text as T

37import Data.Char(isLetter, toLower)

38import Data.Char(isLetter, toLower)

38import Data.List.Split (splitOn)

39import Data.List.Split (splitOn)

@@ -91,8 +92,10 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

91 let nty' = normalise ctxt [] nty

92 let nty' = normalise ctxt [] nty

93 -- Add normalised type to internals

94 -- Add normalised type to internals

95+ rep <- useREPL

96+ when rep $ do

94− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

97+ addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

95− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

98+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

97 let (t, _) = unApply (getRetTy nty')

100 let (t, _) = unApply (getRetTy nty')

98 let corec = case t of

101 let corec = case t of

@@ -137,14 +140,20 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

137 | otherwise = mergeTy sc sc'

140 | otherwise = mergeTy sc sc'

138 mergeTy _ sc = sc

141 mergeTy _ sc = sc

139

142

143+ err = txt "Err"

144+ maybe = txt "Maybe"

145+ lst = txt "List"

146+ errrep = txt "ErrorReportPart"

147+

140− tyIsHandler (Bind _ (Pi (P _ (NS (UN "Err") ns1) _))

148+ tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _))

141− (App (P _ (NS (UN "Maybe") ns2) _)

149+ (App (P _ (NS (UN m) ns2) _)

142− (App (P _ (NS (UN "List") ns3) _)

150+ (App (P _ (NS (UN l) ns3) _)

143− (P _ (NS (UN "ErrorReportPart") ns4) _))))

151+ (P _ (NS (UN r) ns4) _))))

152+ | e == err && m == maybe && l == lst && r == errrep

144− | ns1 == ["Errors","Reflection","Language"]

153+ , ns1 == map txt ["Errors","Reflection","Language"]

145− , ns2 == ["Maybe", "Prelude"]

154+ , ns2 == map txt ["Maybe", "Prelude"]

146− , ns3 == ["List", "Prelude"]

155+ , ns3 == map txt ["List", "Prelude"]

147− , ns4 == ["Errors","Reflection","Language"] = True

156+ , ns4 == map txt ["Errors","Reflection","Language"] = True

148 tyIsHandler _ = False

157 tyIsHandler _ = False

149

158

150

159

@@ -295,7 +304,8 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

295type EliminatorState = StateT (Map.Map String Int) Idris

304type EliminatorState = StateT (Map.Map String Int) Idris

296

305

297-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

306-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

298−elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC)] -> ElabInfo -> EliminatorState ()

307+elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] ->

308+ ElabInfo -> EliminatorState ()

299elabEliminator paramPos n ty cons info = do

309elabEliminator paramPos n ty cons info = do

300 elimLog $ "Elaborating eliminator"

310 elimLog $ "Elaborating eliminator"

301 let (cnstrs, _) = splitPi ty

311 let (cnstrs, _) = splitPi ty

@@ -303,7 +313,7 @@ elabEliminator paramPos n ty cons info = do

303 generalParams <- namePis False pms

313 generalParams <- namePis False pms

304 motiveIdxs <- namePis False idxs

314 motiveIdxs <- namePis False idxs

305 let motive = mkMotive n paramPos generalParams motiveIdxs

315 let motive = mkMotive n paramPos generalParams motiveIdxs

306− consTerms <- mapM (\(c@(_,cnm,_,_)) -> do

316+ consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

307 name <- freshName $ "elim_" ++ simpleName cnm

317 name <- freshName $ "elim_" ++ simpleName cnm

308 consTerm <- extractConsTerm c generalParams

318 consTerm <- extractConsTerm c generalParams

309 return (name, expl, consTerm)) cons

319 return (name, expl, consTerm)) cons

@@ -319,13 +329,13 @@ elabEliminator paramPos n ty cons info = do

319 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

329 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

320 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

330 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

321 elimLog $ "-- eliminator definition: " ++ showDeclImp True eliminatorDef

331 elimLog $ "-- eliminator definition: " ++ showDeclImp True eliminatorDef

322− Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

332+ State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

323 -- Do not elaborate clauses if there aren't any

333 -- Do not elaborate clauses if there aren't any

324 case eliminatorClauses of

334 case eliminatorClauses of

325 [] -> return ()

335 [] -> return ()

326− _ -> Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

336+ _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

327 where elimLog :: String -> EliminatorState ()

337 where elimLog :: String -> EliminatorState ()

328− elimLog s = Control.Monad.State.lift (logLvl 2 s)

338+ elimLog s = State.lift (logLvl 2 s)

329

339

330 elimFC :: FC

340 elimFC :: FC

331 elimFC = fileFC "(eliminator)"

341 elimFC = fileFC "(eliminator)"

@@ -335,7 +345,7 @@ elabEliminator paramPos n ty cons info = do

335

345

336 applyNS :: Name -> [String] -> Name

346 applyNS :: Name -> [String] -> Name

337 applyNS n [] = n

347 applyNS n [] = n

338− applyNS n ns = NS n ns

348+ applyNS n ns = sNS n ns

339

349

340 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

350 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

341 splitPi = splitPi' []

351 splitPi = splitPi' []

@@ -374,11 +384,11 @@ elabEliminator paramPos n ty cons info = do

374

384

375 simpleName :: Name -> String

385 simpleName :: Name -> String

376 simpleName (NS n _) = simpleName n

386 simpleName (NS n _) = simpleName n

377− simpleName (MN i n) = n ++ show i

387+ simpleName (MN i n) = str n ++ show i

378 simpleName n = show n

388 simpleName n = show n

379

389

380 nameSpaces :: Name -> [String]

390 nameSpaces :: Name -> [String]

381− nameSpaces (NS _ ns) = ns

391+ nameSpaces (NS _ ns) = map str ns

382 nameSpaces _ = []

392 nameSpaces _ = []

383

393

384 freshName :: String -> EliminatorState Name

394 freshName :: String -> EliminatorState Name

@@ -387,16 +397,16 @@ elabEliminator paramPos n ty cons info = do

387 let i = fromMaybe 0 (Map.lookup key nameMap)

397 let i = fromMaybe 0 (Map.lookup key nameMap)

388 let name = key ++ show i

398 let name = key ++ show i

389 put $ Map.insert key (i+1) nameMap

399 put $ Map.insert key (i+1) nameMap

390− return (UN name)

400+ return (sUN name)

391

401

392 scrutineeName :: Name

402 scrutineeName :: Name

393− scrutineeName = UN "scrutinee"

403+ scrutineeName = sUN "scrutinee"

394

404

395 scrutineeArgName :: Name

405 scrutineeArgName :: Name

396− scrutineeArgName = UN "scrutineeArg"

406+ scrutineeArgName = sUN "scrutineeArg"

397

407

398 motiveName :: Name

408 motiveName :: Name

399− motiveName = UN "prop"

409+ motiveName = sUN "prop"

400

410

401 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

411 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

402 mkMotive n paramPos params indicies =

412 mkMotive n paramPos params indicies =

@@ -460,9 +470,9 @@ elabEliminator paramPos n ty cons info = do

460 splitArgPms _ = ([],[])

470 splitArgPms _ = ([],[])

461

471

462

472

463− implicitIndexes :: (String, Name, PTerm, FC) -> EliminatorState [(Name, Plicity, PTerm)]

473+ implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

464− implicitIndexes (cns@(doc, cnm, ty, fc)) = do

474+ implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

465− i <- Control.Monad.State.lift getIState

475+ i <- State.lift getIState

466 implargs' <- case lookupCtxt cnm (idris_implicits i) of

476 implargs' <- case lookupCtxt cnm (idris_implicits i) of

467 [] -> do fail $ "Error while showing implicits for " ++ show cnm

477 [] -> do fail $ "Error while showing implicits for " ++ show cnm

468 [args] -> do return args

478 [args] -> do return args

@@ -475,18 +485,18 @@ elabEliminator paramPos n ty cons info = do

475 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

485 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

476 _ -> return implargs

486 _ -> return implargs

477

487

478− extractConsTerm :: (String, Name, PTerm, FC) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

488+ extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

479− extractConsTerm (doc, cnm, ty, fc) generalParameters = do

489+ extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

480 let cons' = replaceParams paramPos generalParameters ty

490 let cons' = replaceParams paramPos generalParameters ty

481 let (args, resTy) = splitPi cons'

491 let (args, resTy) = splitPi cons'

482− implidxs <- implicitIndexes (doc, cnm, ty, fc)

492+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

483 consArgs <- namePis True args

493 consArgs <- namePis True args

484 let recArgs = findRecArgs consArgs

494 let recArgs = findRecArgs consArgs

485 let recMotives = map applyRecMotive recArgs

495 let recMotives = map applyRecMotive recArgs

486 let (_, consIdxs) = splitArgPms resTy

496 let (_, consIdxs) = splitArgPms resTy

487 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

497 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

488 where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)

498 where applyRecMotive :: (Name, Plicity, PTerm) -> (Name, Plicity, PTerm)

489− 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))

490 where (_, idxs) = splitArgPms ty

500 where (_, idxs) = splitArgPms ty

491

501

492 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

502 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

@@ -511,12 +521,12 @@ elabEliminator paramPos n ty cons info = do

511 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

521 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

512 convertImplPi _ = Nothing

522 convertImplPi _ = Nothing

513

523

514− generateEliminatorClauses :: (String, Name, PTerm, FC) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

524+ generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

515− generateEliminatorClauses (doc, cnm, ty, fc) cnsElim generalArgs generalParameters = do

525+ generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

516 let cons' = replaceParams paramPos generalParameters ty

526 let cons' = replaceParams paramPos generalParameters ty

517 let (args, resTy) = splitPi cons'

527 let (args, resTy) = splitPi cons'

518− i <- Control.Monad.State.lift getIState

528+ i <- State.lift getIState

519− implidxs <- implicitIndexes (doc, cnm, ty, fc)

529+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

520 let (_, generalIdxs') = splitArgPms resTy

530 let (_, generalIdxs') = splitArgPms resTy

521 let generalIdxs = map pexp generalIdxs'

531 let generalIdxs = map pexp generalIdxs'

522 consArgs <- namePis True args

532 consArgs <- namePis True args

@@ -537,7 +547,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

537 (zip

547 (zip

538 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

548 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

539 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

549 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

540− addNameHint eqTy (UN "prf")

550+ addNameHint eqTy (sUN "prf")

541 elabDecl EAll toplevel elimDecl

551 elabDecl EAll toplevel elimDecl

542 mapM_ elabPrim primitives

552 mapM_ elabPrim primitives

543 -- Special case prim__believe_me because it doesn't work on just constants

553 -- Special case prim__believe_me because it doesn't work on just constants

@@ -560,11 +570,11 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

560

570

561 p_believeMe [_,_,x] = Just x

571 p_believeMe [_,_,x] = Just x

562 p_believeMe _ = Nothing

572 p_believeMe _ = Nothing

563− believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

573+ believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))))

564− (Bind (UN "b") (Pi (TType (UVar (-2))))

574+ (Bind (sUN "b") (Pi (TType (UVar (-2))))

565− (Bind (UN "x") (Pi (V 1)) (V 1)))

575+ (Bind (sUN "x") (Pi (V 1)) (V 1)))

566 elabBelieveMe

576 elabBelieveMe

567− = do let prim__believe_me = (UN "prim__believe_me")

577+ = do let prim__believe_me = sUN "prim__believe_me"

568 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

578 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

569 setTotality prim__believe_me (Partial NotCovering)

579 setTotality prim__believe_me (Partial NotCovering)

570 i <- getIState

580 i <- getIState

@@ -578,19 +588,19 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

578 | otherwise = Just (VApp vnNothing VErased)

588 | otherwise = Just (VApp vnNothing VErased)

579 p_synEq args = Nothing

589 p_synEq args = Nothing

580

590

581− nMaybe = P (TCon 0 2) (NS (UN "Maybe") ["Maybe", "Prelude"]) Erased

591+ nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased

582− vnJust = VP (DCon 1 2) (NS (UN "Just") ["Maybe", "Prelude"]) VErased

592+ vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased

583− vnNothing = VP (DCon 0 1) (NS (UN "Nothing") ["Maybe", "Prelude"]) VErased

593+ vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased

584 vnRefl = VP (DCon 0 2) eqCon VErased

594 vnRefl = VP (DCon 0 2) eqCon VErased

585

595

586− synEqTy = Bind (UN "a") (Pi (TType (UVar (-3))))

596+ synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))))

587− (Bind (UN "b") (Pi (TType (UVar (-3))))

597+ (Bind (sUN "b") (Pi (TType (UVar (-3))))

588− (Bind (UN "x") (Pi (V 1))

598+ (Bind (sUN "x") (Pi (V 1))

589− (Bind (UN "y") (Pi (V 1))

599+ (Bind (sUN "y") (Pi (V 1))

590 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

600 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

591 [V 3, V 2, V 1, V 0]]))))

601 [V 3, V 2, V 1, V 0]]))))

592 elabSynEq

602 elabSynEq

593− = do let synEq = UN "prim__syntactic_eq"

603+ = do let synEq = sUN "prim__syntactic_eq"

594

604

595 updateContext (addOperator synEq synEqTy 4 p_synEq)

605 updateContext (addOperator synEq synEqTy 4 p_synEq)

596 setTotality synEq (Total [])

606 setTotality synEq (Total [])

@@ -628,7 +638,7 @@ elabProvider info syn fc n ty tm

628 -- Execute the type provider and normalise the result

638 -- Execute the type provider and normalise the result

629 -- use 'run__provider' to convert to a primitive IO action

639 -- use 'run__provider' to convert to a primitive IO action

630

640

631− rhs <- execute (mkApp (P Ref (UN "run__provider") Erased)

641+ rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

632 [Erased, e])

642 [Erased, e])

633 let rhs' = normalise ctxt [] rhs

643 let rhs' = normalise ctxt [] rhs

634 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

644 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

@@ -646,9 +656,10 @@ elabProvider info syn fc n ty tm

646

656

647 isProviderOf :: TT Name -> TT Name -> Bool

657 isProviderOf :: TT Name -> TT Name -> Bool

648 isProviderOf tp prov

658 isProviderOf tp prov

649− | (P _ (UN "IO") _, [prov']) <- unApply prov

659+ | (P _ (UN io) _, [prov']) <- unApply prov

660+ , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'

661+ , tp == tp', io == txt "IO"

650− , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'

662+ , prov == txt "Provider" && provs == txt "Providers" = True

651− , tp == tp' = True

652 isProviderOf _ _ = False

663 isProviderOf _ _ = False

653

664

654-- | Elaborate a type provider

665-- | Elaborate a type provider

@@ -658,8 +669,8 @@ elabTransform info fc safe lhs_in rhs_in

658 i <- getIState

669 i <- getIState

659 let lhs = addImplPat i lhs_in

670 let lhs = addImplPat i lhs_in

660 ((lhs', dlhs, []), _) <-

671 ((lhs', dlhs, []), _) <-

661− tclift $ elaborate ctxt (MN 0 "transLHS") infP []

672+ tclift $ elaborate ctxt (sMN 0 "transLHS") infP []

662− (erun fc (buildTC i info True [] (UN "transform")

673+ (erun fc (buildTC i info True [] (sUN "transform")

663 (infTerm lhs)))

674 (infTerm lhs)))

664 let lhs_tm = orderPats (getInferTerm lhs')

675 let lhs_tm = orderPats (getInferTerm lhs')

665 let lhs_ty = getInferType lhs'

676 let lhs_ty = getInferType lhs'

@@ -669,13 +680,13 @@ elabTransform info fc safe lhs_in rhs_in

669 logLvl 3 ("Transform LHS " ++ show clhs_tm)

680 logLvl 3 ("Transform LHS " ++ show clhs_tm)

670 let rhs = addImplBound i (map fst newargs) rhs_in

681 let rhs = addImplBound i (map fst newargs) rhs_in

671 ((rhs', defer), _) <-

682 ((rhs', defer), _) <-

672− tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty []

683+ tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []

673 (do pbinds lhs_tm

684 (do pbinds lhs_tm

685+ setNextName

674− erun fc (build i info False [] (UN "transform") rhs)

686+ erun fc (build i info False [] (sUN "transform") rhs)

675 erun fc $ psolve lhs_tm

687 erun fc $ psolve lhs_tm

676 tt <- get_term

688 tt <- get_term

677− let (tm, ds) = runState (collectDeferred Nothing tt) []

689+ return (runState (collectDeferred Nothing tt) []))

678− return (tm, ds))

679 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

690 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

680 logLvl 3 ("Transform RHS " ++ show crhs_tm)

691 logLvl 3 ("Transform RHS " ++ show crhs_tm)

681 when safe $ case converts ctxt [] clhs_tm crhs_tm of

692 when safe $ case converts ctxt [] clhs_tm crhs_tm of

@@ -688,7 +699,7 @@ elabTransform info fc safe lhs_in rhs_in

688elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

699elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

689 PTerm -> String -> Name -> PTerm -> Idris ()

700 PTerm -> String -> Name -> PTerm -> Idris ()

690elabRecord info syn doc fc tyn ty cdoc cn cty

701elabRecord info syn doc fc tyn ty cdoc cn cty

691− = 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, [])])

692 cty' <- implicit syn cn cty

703 cty' <- implicit syn cn cty

693 i <- getIState

704 i <- getIState

694 cty <- case lookupTy cn (tt_ctxt i) of

705 cty <- case lookupTy cn (tt_ctxt i) of

@@ -742,18 +753,18 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

742 getRecTy (PPi _ n ty s) = getRecTy s

753 getRecTy (PPi _ n ty s) = getRecTy s

743 getRecTy t = t

754 getRecTy t = t

744

755

745− rec = MN 0 "rec"

756+ rec = sMN 0 "rec"

746

757

747− mkp (UN n) = MN 0 ("p_" ++ n)

758+ mkp (UN n) = sMN 0 ("p_" ++ str n)

748− mkp (MN i n) = MN i ("p_" ++ n)

759+ mkp (MN i n) = sMN i ("p_" ++ str n)

749 mkp (NS n s) = NS (mkp n) s

760 mkp (NS n s) = NS (mkp n) s

750

761

751− mkImp (UN n) = UN ("implicit_" ++ n)

762+ mkImp (UN n) = sUN ("implicit_" ++ str n)

752− mkImp (MN i n) = MN i ("implicit_" ++ n)

763+ mkImp (MN i n) = sMN i ("implicit_" ++ str n)

753 mkImp (NS n s) = NS (mkImp n) s

764 mkImp (NS n s) = NS (mkImp n) s

754

765

755− mkType (UN n) = UN ("set_" ++ n)

766+ mkType (UN n) = sUN ("set_" ++ str n)

756− mkType (MN i n) = MN i ("set_" ++ n)

767+ mkType (MN i n) = sMN i ("set_" ++ str n)

757 mkType (NS n s) = NS (mkType n) s

768 mkType (NS n s) = NS (mkType n) s

758

769

759 mkProj recty substs cimp ((pn_in, pty), pos)

770 mkProj recty substs cimp ((pn_in, pty), pos)

@@ -776,11 +787,11 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

776

787

777 mkUpdate recty k num ((pn, pty), pos)

788 mkUpdate recty k num ((pn, pty), pos)

778 = do let setname = expandNS syn $ mkType pn

789 = do let setname = expandNS syn $ mkType pn

779− let valname = MN 0 "updateval"

790+ let valname = sMN 0 "updateval"

780 let pt = k (PPi expl pn pty

791 let pt = k (PPi expl pn pty

781 (PPi expl rec recty recty))

792 (PPi expl rec recty recty))

782 let pfnTy = PTy "" defaultSyntax fc [] setname pt

793 let pfnTy = PTy "" defaultSyntax fc [] setname pt

783− 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]

784 let lhsArgs = pls

795 let lhsArgs = pls

785 let rhsArgs = take pos pls ++ (PRef fc valname) :

796 let rhsArgs = take pos pls ++ (PRef fc valname) :

786 drop (pos + 1) pls

797 drop (pos + 1) pls

@@ -795,8 +806,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

795 return (pn, pfnTy, PClauses fc [] setname [pclause])

806 return (pn, pfnTy, PClauses fc [] setname [pclause])

796

807

797elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

808elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

798− (String, Name, PTerm, FC) -> Idris (Name, Type)

809+ (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

799−elabCon info syn tn codata (doc, n, t_in, fc)

810+elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

800 = do checkUndefined fc n

811 = do checkUndefined fc n

801 ctxt <- getContext

812 ctxt <- getContext

802 i <- getIState

813 i <- getIState

@@ -819,7 +830,10 @@ elabCon info syn tn codata (doc, n, t_in, fc)

819 addIBC (IBCDef n)

830 addIBC (IBCDef n)

820 addDocStr n doc

831 addDocStr n doc

821 addIBC (IBCDoc n)

832 addIBC (IBCDoc n)

833+ let fs = map (getNamePos 0 t) forcenames

834+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

835+ -- erasing non-forceable things

822− forceArgs tn n cty'

836+ forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

823 return (n, cty')

837 return (n, cty')

824 where

838 where

825 tyIs (Bind n b sc) = tyIs sc

839 tyIs (Bind n b sc) = tyIs sc

@@ -831,6 +845,11 @@ elabCon info syn tn codata (doc, n, t_in, fc)

831 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

845 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

832 mkLazy t = t

846 mkLazy t = t

833

847

848+ getNamePos :: Int -> PTerm -> Name -> Maybe Int

849+ getNamePos i (PPi _ n _ sc) x | n == x = Just i

850+ | otherwise = getNamePos (i + 1) sc x

851+ getNamePos _ _ _ = Nothing

852+

834-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

853-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

835-- top-level definition.

854-- top-level definition.

836elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

855elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

@@ -1143,7 +1162,7 @@ elabPE info fc caller r =

1143 _ -> error "Can't happen (getSpecTy)"

1162 _ -> error "Can't happen (getSpecTy)"

1144

1163

1145 getSpecClause ist (n, args)

1164 getSpecClause ist (n, args)

1146− = let newnm = UN ("__"++show (nsroot n) ++ "_" ++

1165+ = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++

1147 showSep "_" (map showArg args)) in

1166 showSep "_" (map showArg args)) in

1148 -- UN (show n ++ show (map snd args)) in

1167 -- UN (show n ++ show (map snd args)) in

1149 (n, newnm, mkPE_TermDecl ist newnm n args)

1168 (n, newnm, mkPE_TermDecl ist newnm n args)

@@ -1168,8 +1187,8 @@ elabValBind info aspat tm_in

1168 ((tm', defer, is), _) <-

1187 ((tm', defer, is), _) <-

1169-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

1188-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

1170-- (build i info aspat (MN 0 "val") tm))

1189-- (build i info aspat (MN 0 "val") tm))

1171− tclift (elaborate ctxt (MN 0 "val") infP []

1190+ tclift (elaborate ctxt (sMN 0 "val") infP []

1172− (build i info aspat [Reflection] (MN 0 "val") (infTerm tm)))

1191+ (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

1173 let vtm = orderPats (getInferTerm tm')

1192 let vtm = orderPats (getInferTerm tm')

1174

1193

1175 def' <- checkDef (fileFC "(input)") defer

1194 def' <- checkDef (fileFC "(input)") defer

@@ -1199,7 +1218,7 @@ checkPossible info fc tcgen fname lhs_in

1199 i <- getIState

1218 i <- getIState

1200 let lhs = addImpl i lhs_in

1219 let lhs = addImpl i lhs_in

1201 -- if the LHS type checks, it is possible

1220 -- if the LHS type checks, it is possible

1202− case elaborate ctxt (MN 0 "patLHS") infP []

1221+ case elaborate ctxt (sMN 0 "patLHS") infP []

1203 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

1222 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

1204 OK ((lhs', _, _), _) ->

1223 OK ((lhs', _, _), _) ->

1205 do let lhs_tm = orderPats (getInferTerm lhs')

1224 do let lhs_tm = orderPats (getInferTerm lhs')

@@ -1254,7 +1273,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1254 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

1273 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

1255

1274

1256 ((lhs', dlhs, []), _) <-

1275 ((lhs', dlhs, []), _) <-

1257− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1276+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1258 (errAt "left hand side of " fname

1277 (errAt "left hand side of " fname

1259 (erun fc (buildTC i info True opts fname (infTerm lhs))))

1278 (erun fc (buildTC i info True opts fname (infTerm lhs))))

1260 let lhs_tm = orderPats (getInferTerm lhs')

1279 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1267,8 +1286,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1267

1286

1268 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

1287 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

1269

1288

1289+ rep <- useREPL

1290+ when rep $ do

1270− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1291+ addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1271− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1292+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1272

1293

1273 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1294 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1274 -- Elaborate where block

1295 -- Elaborate where block

@@ -1296,10 +1317,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1296 ctxt <- getContext -- new context with where block added

1317 ctxt <- getContext -- new context with where block added

1297 logLvl 5 "STARTING CHECK"

1318 logLvl 5 "STARTING CHECK"

1298 ((rhs', defer, is), _) <-

1319 ((rhs', defer, is), _) <-

1299− tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

1320+ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []

1300 (do pbinds lhs_tm

1321 (do pbinds lhs_tm

1322+ setNextName

1301 (_, _, is) <- errAt "right hand side of " fname

1323 (_, _, is) <- errAt "right hand side of " fname

1302− (erun fc (build i info False opts fname rhs))

1324+ (erun fc (build i info False opts fname rhs))

1303 errAt "right hand side of " fname

1325 errAt "right hand side of " fname

1304 (erun fc $ psolve lhs_tm)

1326 (erun fc $ psolve lhs_tm)

1305 hs <- get_holes

1327 hs <- get_holes

@@ -1326,6 +1348,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1326

1348

1327 ctxt <- getContext

1349 ctxt <- getContext

1328 logLvl 5 $ "Rechecking"

1350 logLvl 5 $ "Rechecking"

1351+ logLvl 6 $ " ==> " ++ show (forget rhs')

1329 (crhs, crhsty) <- recheckC fc [] rhs'

1352 (crhs, crhsty) <- recheckC fc [] rhs'

1330 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

1353 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

1331 case converts ctxt [] clhsty crhsty of

1354 case converts ctxt [] clhsty crhsty of

@@ -1431,7 +1454,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1431 let lhs = addImplPat i (stripLinear i lhs_in)

1454 let lhs = addImplPat i (stripLinear i lhs_in)

1432 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

1455 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

1433 ((lhs', dlhs, []), _) <-

1456 ((lhs', dlhs, []), _) <-

1434− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1457+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1435 (errAt "left hand side of with in " fname

1458 (errAt "left hand side of with in " fname

1436 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

1459 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

1437 let lhs_tm = orderPats (getInferTerm lhs')

1460 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1445,9 +1468,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1445 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

1468 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

1446 -- Elaborate wval in this context

1469 -- Elaborate wval in this context

1447 ((wval', defer, is), _) <-

1470 ((wval', defer, is), _) <-

1448− tclift $ elaborate ctxt (MN 0 "withRHS")

1471+ tclift $ elaborate ctxt (sMN 0 "withRHS")

1449 (bindTyArgs PVTy bargs infP) []

1472 (bindTyArgs PVTy bargs infP) []

1450 (do pbinds lhs_tm

1473 (do pbinds lhs_tm

1474+ setNextName

1451 -- TODO: may want where here - see winfo abpve

1475 -- TODO: may want where here - see winfo abpve

1452 (_', d, is) <- errAt "with value in " fname

1476 (_', d, is) <- errAt "with value in " fname

1453 (erun fc (build i info False opts fname (infTerm wval)))

1477 (erun fc (build i info False opts fname (infTerm wval)))

@@ -1477,11 +1501,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1477 let wargtype = getRetTy cwvaltyN

1501 let wargtype = getRetTy cwvaltyN

1478 logLvl 5 ("Abstract over " ++ show wargval)

1502 logLvl 5 ("Abstract over " ++ show wargval)

1479 let wtype = bindTyArgs Pi (bargs_pre ++

1503 let wtype = bindTyArgs Pi (bargs_pre ++

1480− (MN 0 "warg", wargtype) :

1504+ (sMN 0 "warg", wargtype) :

1481− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1505+ map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)

1482− (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

1506+ (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)

1483 logLvl 3 ("New function type " ++ show wtype)

1507 logLvl 3 ("New function type " ++ show wtype)

1484− let wname = MN windex (show fname)

1508+ let wname = sMN windex (show fname)

1485

1509

1486 let imps = getImps wtype -- add to implicits context

1510 let imps = getImps wtype -- add to implicits context

1487 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

1511 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

@@ -1509,8 +1533,9 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1509 ctxt <- getContext -- New context with block added

1533 ctxt <- getContext -- New context with block added

1510 i <- getIState

1534 i <- getIState

1511 ((rhs', defer, is), _) <-

1535 ((rhs', defer, is), _) <-

1512− tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty []

1536+ tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []

1513 (do pbinds lhs_tm

1537 (do pbinds lhs_tm

1538+ setNextName

1514 (_, d, is) <- erun fc (build i info False opts fname rhs)

1539 (_, d, is) <- erun fc (build i info False opts fname rhs)

1515 psolve lhs_tm

1540 psolve lhs_tm

1516 tt <- get_term

1541 tt <- get_term

@@ -1589,7 +1614,7 @@ elabClass :: ElabInfo -> SyntaxInfo -> String ->

1589 FC -> [PTerm] ->

1614 FC -> [PTerm] ->

1590 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1615 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1591elabClass info syn doc fc constraints tn ps ds

1616elabClass info syn doc fc constraints tn ps ds

1592− = 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)

1593 let tty = pibind ps PType

1618 let tty = pibind ps PType

1594 let constraint = PApp fc (PRef fc tn)

1619 let constraint = PApp fc (PRef fc tn)

1595 (map (pexp . PRef fc) (map fst ps))

1620 (map (pexp . PRef fc) (map fst ps))

@@ -1612,7 +1637,7 @@ elabClass info syn doc fc constraints tn ps ds

1612 let cty = impbind ps $ conbind constraints

1637 let cty = impbind ps $ conbind constraints

1613 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1638 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1614 constraint

1639 constraint

1615− let cons = [("", cn, cty, fc)]

1640+ let cons = [("", cn, cty, fc, [])]

1616 let ddecl = PDatadecl tn tty cons

1641 let ddecl = PDatadecl tn tty cons

1617 logLvl 5 $ "Class data " ++ showDImp True ddecl

1642 logLvl 5 $ "Class data " ++ showDImp True ddecl

1618 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

1643 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

@@ -1650,7 +1675,7 @@ elabClass info syn doc fc constraints tn ps ds

1650

1675

1651 impbind [] x = x

1676 impbind [] x = x

1652 impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1677 impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1653− 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)

1654 conbind [] x = x

1679 conbind [] x = x

1655

1680

1656 getMName (PTy _ _ _ _ n _) = nsroot n

1681 getMName (PTy _ _ _ _ n _) = nsroot n

@@ -1674,7 +1699,7 @@ elabClass info syn doc fc constraints tn ps ds

1674 _ -> ifail $ show n ++ " is not a method"

1699 _ -> ifail $ show n ++ " is not a method"

1675 defdecl _ _ _ = ifail "Can't happen (defdecl)"

1700 defdecl _ _ _ = ifail "Can't happen (defdecl)"

1676

1701

1677− defaultdec (UN n) = UN ("default#" ++ n)

1702+ defaultdec (UN n) = sUN ("default#" ++ str n)

1678 defaultdec (NS n ns) = NS (defaultdec n) ns

1703 defaultdec (NS n ns) = NS (defaultdec n) ns

1679

1704

1680 tydecl (PTy _ _ _ _ _ _) = True

1705 tydecl (PTy _ _ _ _ _ _) = True

@@ -1686,13 +1711,13 @@ elabClass info syn doc fc constraints tn ps ds

1686

1711

1687 -- Generate a function for chasing a dictionary constraint

1712 -- Generate a function for chasing a dictionary constraint

1688 cfun cn c syn all con

1713 cfun cn c syn all con

1689− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1714+ = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con)

1690 -- SN (ParentN cn (show con))

1715 -- SN (ParentN cn (show con))

1691− let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1716+ let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

1692 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1717 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1693 let lhs = PApp fc (PRef fc cfn) [pconst capp]

1718 let lhs = PApp fc (PRef fc cfn) [pconst capp]

1694 let rhs = PResolveTC (fileFC "HACK")

1719 let rhs = PResolveTC (fileFC "HACK")

1695− let ty = PPi constraint (MN 0 "pc") c con

1720+ let ty = PPi constraint (sMN 0 "pc") c con

1696 iLOG (showImp Nothing True False ty)

1721 iLOG (showImp Nothing True False ty)

1697 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

1722 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

1698 i <- getIState

1723 i <- getIState

@@ -1712,10 +1737,10 @@ elabClass info syn doc fc constraints tn ps ds

1712 -- dictionary (this is inlinable, always)

1737 -- dictionary (this is inlinable, always)

1713 tfun cn c syn all (m, (doc, o, ty))

1738 tfun cn c syn all (m, (doc, o, ty))

1714 = do let ty' = insertConstraint c ty

1739 = do let ty' = insertConstraint c ty

1715− let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1740+ let mnames = take (length all) $ map (\x -> sMN x "meth") [0..]

1716 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1741 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

1717 let margs = getMArgs ty

1742 let margs = getMArgs ty

1718− let anames = map (\x -> MN x "arg") [0..]

1743+ let anames = map (\x -> sMN x "arg") [0..]

1719 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

1744 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

1720 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

1745 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

1721 iLOG (showImp Nothing True False ty)

1746 iLOG (showImp Nothing True False ty)

@@ -1744,7 +1769,7 @@ elabClass info syn doc fc constraints tn ps ds

1744

1769

1745 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

1770 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

1746 = PPi p n ty (insertConstraint c sc)

1771 = PPi p n ty (insertConstraint c sc)

1747− insertConstraint c sc = PPi constraint (MN 0 "class") c sc

1772+ insertConstraint c sc = PPi constraint (sMN 0 "class") c sc

1748

1773

1749 -- make arguments explicit and don't bind class parameters

1774 -- make arguments explicit and don't bind class parameters

1750 toExp ns e (PPi (Imp l s _ p) n ty sc)

1775 toExp ns e (PPi (Imp l s _ p) n ty sc)

@@ -1754,19 +1779,21 @@ elabClass info syn doc fc constraints tn ps ds

1754 toExp ns e sc = sc

1779 toExp ns e sc = sc

1755

1780

1756elabInstance :: ElabInfo -> SyntaxInfo ->

1781elabInstance :: ElabInfo -> SyntaxInfo ->

1782+ ElabWhat -> -- phase

1757 FC -> [PTerm] -> -- constraints

1783 FC -> [PTerm] -> -- constraints

1758 Name -> -- the class

1784 Name -> -- the class

1759 [PTerm] -> -- class parameters (i.e. instance)

1785 [PTerm] -> -- class parameters (i.e. instance)

1760 PTerm -> -- full instance type

1786 PTerm -> -- full instance type

1761 Maybe Name -> -- explicit name

1787 Maybe Name -> -- explicit name

1762 [PDecl] -> Idris ()

1788 [PDecl] -> Idris ()

1763−elabInstance info syn fc cs n ps t expn ds

1789+elabInstance info syn what fc cs n ps t expn ds = do

1764− = do i <- getIState

1790+ i <- getIState

1765− (n, ci) <- case lookupCtxtName n (idris_classes i) of

1791+ (n, ci) <- case lookupCtxtName n (idris_classes i) of

1766− [c] -> return c

1792+ [c] -> return c

1767− _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1793+ _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1768− let constraint = PApp fc (PRef fc n) (map pexp ps)

1794+ let constraint = PApp fc (PRef fc n) (map pexp ps)

1769− let iname = mkiname n ps expn

1795+ let iname = mkiname n ps expn

1796+ when (what /= EDefns) $ do

1770 nty <- elabType' True info syn "" fc [] iname t

1797 nty <- elabType' True info syn "" fc [] iname t

1771 -- if the instance type matches any of the instances we have already,

1798 -- if the instance type matches any of the instances we have already,

1772 -- and it's not a named instance, then it's overlapping, so report an error

1799 -- and it's not a named instance, then it's overlapping, so report an error

@@ -1775,6 +1802,7 @@ elabInstance info syn fc cs n ps t expn ds

1775 (class_instances ci)

1802 (class_instances ci)

1776 addInstance intInst n iname

1803 addInstance intInst n iname

1777 Just _ -> addInstance intInst n iname

1804 Just _ -> addInstance intInst n iname

1805+ when (what /= ETypes) $ do

1778 let ips = zip (class_params ci) ps

1806 let ips = zip (class_params ci) ps

1779 let ns = case n of

1807 let ns = case n of

1780 NS n ns' -> ns'

1808 NS n ns' -> ns'

@@ -1827,7 +1855,7 @@ elabInstance info syn fc cs n ps t expn ds

1827

1855

1828 mkiname n' ps' expn' =

1856 mkiname n' ps' expn' =

1829 case expn' of

1857 case expn' of

1830− Nothing -> SN (InstanceN n' (map show ps'))

1858+ Nothing -> SN (sInstanceN n' (map show ps'))

1831 Just nm -> nm

1859 Just nm -> nm

1832

1860

1833 substInstance ips pnames (PInstance syn _ cs n ps t expn ds)

1861 substInstance ips pnames (PInstance syn _ cs n ps t expn ds)

@@ -1875,14 +1903,14 @@ elabInstance info syn fc cs n ps t expn ds

1875 mkMethApp (n, _, _, ty)

1903 mkMethApp (n, _, _, ty)

1876 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

1904 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

1877 lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1905 lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1878− = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1906+ = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

1879 lamBind i (PPi _ n ty sc) sc'

1907 lamBind i (PPi _ n ty sc) sc'

1880− = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1908+ = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

1881 lamBind i _ sc = sc

1909 lamBind i _ sc = sc

1882 methArgs i (PPi (Imp _ _ _ _) n ty sc)

1910 methArgs i (PPi (Imp _ _ _ _) n ty sc)

1883− = 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

1884 methArgs i (PPi (Exp _ _ _ _) n ty sc)

1912 methArgs i (PPi (Exp _ _ _ _) n ty sc)

1885− = 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

1886 methArgs i (PPi (Constraint _ _ _) n ty sc)

1914 methArgs i (PPi (Constraint _ _ _) n ty sc)

1887 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

1915 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

1888 methArgs i _ = []

1916 methArgs i _ = []

@@ -1905,14 +1933,14 @@ elabInstance info syn fc cs n ps t expn ds

1905

1933

1906 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

1934 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

1907

1935

1908− 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)

1909 conbind [] x = x

1937 conbind [] x = x

1910

1938

1911 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

1939 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

1912 coninsert cs sc = conbind cs sc

1940 coninsert cs sc = conbind cs sc

1913

1941

1914 insertDefaults :: IState -> Name ->

1942 insertDefaults :: IState -> Name ->

1915− [(Name, (Name, PDecl))] -> [String] ->

1943+ [(Name, (Name, PDecl))] -> [T.Text] ->

1916 [PDecl] -> [PDecl]

1944 [PDecl] -> [PDecl]

1917 insertDefaults i iname [] ns ds = ds

1945 insertDefaults i iname [] ns ds = ds

1918 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

1946 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

@@ -2034,8 +2062,10 @@ elabDecl' what info d@(PClauses f o n ps)

2034 [] -> []

2062 [] -> []

2035 elabClauses info f (o ++ o') n ps

2063 elabClauses info f (o ++ o') n ps

2036elabDecl' what info (PMutual f ps)

2064elabDecl' what info (PMutual f ps)

2065+ = do case ps of

2066+ [p] -> elabDecl what info p

2037− = do mapM_ (elabDecl ETypes info) ps

2067+ _ -> do mapM_ (elabDecl ETypes info) ps

2038− mapM_ (elabDecl EDefns info) ps

2068+ mapM_ (elabDecl EDefns info) ps

2039 -- Do totality checking after entire mutual block

2069 -- Do totality checking after entire mutual block

2040 i <- get

2070 i <- get

2041 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

2071 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2071,9 +2101,8 @@ elabDecl' what info (PClass doc s f cs n ps ds)

2071 = do iLOG $ "Elaborating class " ++ show n

2101 = do iLOG $ "Elaborating class " ++ show n

2072 elabClass info (s { syn_params = [] }) doc f cs n ps ds

2102 elabClass info (s { syn_params = [] }) doc f cs n ps ds

2073elabDecl' what info (PInstance s f cs n ps t expn ds)

2103elabDecl' what info (PInstance s f cs n ps t expn ds)

2074− | what /= ETypes

2075 = do iLOG $ "Elaborating instance " ++ show n

2104 = do iLOG $ "Elaborating instance " ++ show n

2076− elabInstance info s f cs n ps t expn ds

2105+ elabInstance info s what f cs n ps t expn ds

2077elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

2106elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

2078 | what /= ETypes

2107 | what /= ETypes

2079 = do iLOG $ "Elaborating record " ++ show tyn

2108 = do iLOG $ "Elaborating record " ++ show tyn

src/Idris/ElabTerm.hs+139−186

@@ -14,7 +14,7 @@ import Idris.Core.Evaluate

14import Idris.Core.Typecheck (check)

16import Control.Monad

17−import Control.Monad.State

17+import Control.Monad.State.Strict

18import Data.List

19import Data.Maybe (mapMaybe)

@@ -81,7 +81,10 @@ build ist info pattern opts fn tm

81buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->

82 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

83buildTC ist info pattern opts fn tm

84+ = do -- set name supply to begin after highest index in tm

85+ let ns = allNamesIn tm

86+ initNextNameFrom ns

84− = do elab ist info pattern opts fn tm

87+ elab ist info pattern opts fn tm

85 probs <- get_probs

88 probs <- get_probs

86 tm <- get_term

89 tm <- get_term

87 case probs of

90 case probs of

@@ -107,7 +110,6 @@ elab ist info pattern opts fn tm

107 end_unify

110 end_unify

108 when pattern -- convert remaining holes to pattern vars

111 when pattern -- convert remaining holes to pattern vars

109 (do update_term orderPats

112 (do update_term orderPats

110− tm <- get_term

111 mkPat)

113 mkPat)

112 where

114 where

113 tcgen = Dictionary `elem` opts

115 tcgen = Dictionary `elem` opts

@@ -171,18 +173,18 @@ elab ist info pattern opts fn tm

171 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

173 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

172 = do g <- goal; resolveTC 5 g fn ist

174 = do g <- goal; resolveTC 5 g fn ist

173 elab' ina (PResolveTC fc)

175 elab' ina (PResolveTC fc)

174− | True = do c <- unique_hole (MN 0 "class")

176+ | True = do c <- getNameFrom (sMN 0 "class")

175 instanceArg c

177 instanceArg c

176 | otherwise = do g <- goal

178 | otherwise = do g <- goal

177 try (resolveTC 2 g fn ist)

179 try (resolveTC 2 g fn ist)

178− (do c <- unique_hole (MN 0 "class")

180+ (do c <- getNameFrom (sMN 0 "class")

179 instanceArg c)

181 instanceArg c)

180 elab' ina (PRefl fc t)

182 elab' ina (PRefl fc t)

181− = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

183+ = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,

182− pimp (MN 0 "x") t False])

184+ pimp (sMN 0 "x") t False])

183 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

185 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

184− [pimp (MN 0 "a") Placeholder True,

186+ [pimp (sMN 0 "A") Placeholder True,

185− pimp (MN 0 "b") Placeholder False,

187+ pimp (sMN 0 "B") Placeholder False,

186 pexp l, pexp r])

188 pexp l, pexp r])

187 elab' ina@(_, a, inty) (PPair fc l r)

189 elab' ina@(_, a, inty) (PPair fc l r)

188 = do hnf_compute

190 = do hnf_compute

@@ -191,8 +193,8 @@ elab ist info pattern opts fn tm

191 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

193 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

192 [pexp l,pexp r])

194 [pexp l,pexp r])

193 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

195 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

194− [pimp (MN 0 "A") Placeholder True,

196+ [pimp (sMN 0 "A") Placeholder True,

195− pimp (MN 0 "B") Placeholder True,

197+ pimp (sMN 0 "B") Placeholder True,

196 pexp l, pexp r])

198 pexp l, pexp r])

197 elab' ina (PDPair fc l@(PRef _ n) t r)

199 elab' ina (PDPair fc l@(PRef _ n) t r)

198 = case t of

200 = case t of

@@ -207,12 +209,12 @@ elab ist info pattern opts fn tm

207 [pexp t,

209 [pexp t,

208 pexp (PLam n Placeholder r)])

210 pexp (PLam n Placeholder r)])

209 asValue = elab' ina (PApp fc (PRef fc existsCon)

211 asValue = elab' ina (PApp fc (PRef fc existsCon)

210− [pimp (MN 0 "a") t False,

212+ [pimp (sMN 0 "a") t False,

211− pimp (MN 0 "P") Placeholder True,

213+ pimp (sMN 0 "P") Placeholder True,

212 pexp l, pexp r])

214 pexp l, pexp r])

213 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

215 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

214− [pimp (MN 0 "a") t False,

216+ [pimp (sMN 0 "a") t False,

215− pimp (MN 0 "P") Placeholder True,

217+ pimp (sMN 0 "P") Placeholder True,

216 pexp l, pexp r])

218 pexp l, pexp r])

217 elab' ina (PAlternative True as)

219 elab' ina (PAlternative True as)

218 = do hnf_compute

220 = do hnf_compute

@@ -259,38 +261,35 @@ elab ist info pattern opts fn tm

259 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

261 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

260 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

262 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

261 elab' ina@(_, a, inty) (PLam n Placeholder sc)

263 elab' ina@(_, a, inty) (PLam n Placeholder sc)

262− = do -- n' <- unique_hole n

264+ = do -- if n is a type constructor name, this makes no sense...

263− -- let sc' = mapPT (repN n n') sc

265+ ctxt <- get_context

264− ptm <- get_term

266+ when (isTConName n ctxt) $

265− g <- goal

267+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

266 checkPiGoal n

268 checkPiGoal n

267 attack; intro (Just n);

269 attack; intro (Just n);

268 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

270 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

269 elabE (True, a, inty) sc; solve

271 elabE (True, a, inty) sc; solve

270− where repN n n' (PRef fc x) | x == n' = PRef fc n'

271− repN _ _ t = t

272 elab' ina@(_, a, inty) (PLam n ty sc)

273− = do hsin <- get_holes

273+ = do tyn <- getNameFrom (sMN 0 "lamty")

274− ptmin <- get_term

274+ -- if n is a type constructor name, this makes no sense...

275− tyn <- unique_hole (MN 0 "lamty")

275+ ctxt <- get_context

276+ when (isTConName n ctxt) $

277+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

276 checkPiGoal n

278 checkPiGoal n

277 claim tyn RType

279 claim tyn RType

278 explicit tyn

280 explicit tyn

279 attack

281 attack

280 ptm <- get_term

282 ptm <- get_term

281 hs <- get_holes

283 hs <- get_holes

282− -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

283− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

284 introTy (Var tyn) (Just n)

285− -- end_unify

286 focus tyn

285 focus tyn

287 elabE (True, a, True) ty

286 elabE (True, a, True) ty

288 elabE (True, a, inty) sc

287 elabE (True, a, inty) sc

289 solve

288 solve

290 elab' ina@(_, a, _) (PPi _ n Placeholder sc)

289 elab' ina@(_, a, _) (PPi _ n Placeholder sc)

291− = 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

292 elab' ina@(_, a, _) (PPi _ n ty sc)

291 elab' ina@(_, a, _) (PPi _ n ty sc)

293− = do attack; tyn <- unique_hole (MN 0 "ty")

292+ = do attack; tyn <- getNameFrom (sMN 0 "ty")

294 claim tyn RType

293 claim tyn RType

295 n' <- case n of

294 n' <- case n of

296 MN _ _ -> unique_hole n

295 MN _ _ -> unique_hole n

@@ -302,9 +301,9 @@ elab ist info pattern opts fn tm

302 solve

301 solve

303 elab' ina@(_, a, inty) (PLet n ty val sc)

302 elab' ina@(_, a, inty) (PLet n ty val sc)

304 = do attack;

303 = do attack;

305− tyn <- unique_hole (MN 0 "letty")

304+ tyn <- getNameFrom (sMN 0 "letty")

306 claim tyn RType

305 claim tyn RType

307− valn <- unique_hole (MN 0 "letval")

306+ valn <- getNameFrom (sMN 0 "letval")

308 claim valn (Var tyn)

307 claim valn (Var tyn)

309 explicit valn

308 explicit valn

310 letbind n (Var tyn) (Var valn)

309 letbind n (Var tyn) (Var valn)

@@ -325,9 +324,9 @@ elab ist info pattern opts fn tm

325 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

324 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

326 rty <- goal

325 rty <- goal

327 attack

326 attack

328− tyn <- unique_hole (MN 0 "letty")

327+ tyn <- getNameFrom (sMN 0 "letty")

329 claim tyn RType

328 claim tyn RType

330− valn <- unique_hole (MN 0 "letval")

329+ valn <- getNameFrom (sMN 0 "letval")

331 claim valn (Var tyn)

330 claim valn (Var tyn)

332 letbind n (Var tyn) (Var valn)

331 letbind n (Var tyn) (Var valn)

333 focus valn

332 focus valn

@@ -346,7 +345,7 @@ elab ist info pattern opts fn tm

346 -- new function name

345 -- new function name

347 env <- get_env

346 env <- get_env

348 argTys <- claimArgTys env args

347 argTys <- claimArgTys env args

349− fn <- unique_hole (MN 0 "inf_fn")

348+ fn <- getNameFrom (sMN 0 "inf_fn")

350 let fty = fnTy argTys rty

349 let fty = fnTy argTys rty

351-- trace (show (ptm, map fst argTys)) $ focus fn

350-- trace (show (ptm, map fst argTys)) $ focus fn

352 -- build and defer the function application

351 -- build and defer the function application

@@ -360,8 +359,8 @@ elab ist info pattern opts fn tm

360 ans <- claimArgTys env xs

359 ans <- claimArgTys env xs

361 return ((n, (False, forget nty)) : ans)

360 return ((n, (False, forget nty)) : ans)

362 claimArgTys env (_ : xs)

361 claimArgTys env (_ : xs)

363− = do an <- unique_hole (MN 0 "inf_argTy")

362+ = do an <- getNameFrom (sMN 0 "inf_argTy")

364− aval <- unique_hole (MN 0 "inf_arg")

363+ aval <- getNameFrom (sMN 0 "inf_arg")

365 claim an RType

364 claim an RType

366 claim aval (Var an)

365 claim aval (Var an)

367 ans <- claimArgTys env xs

366 ans <- claimArgTys env xs

@@ -381,7 +380,7 @@ elab ist info pattern opts fn tm

381 mkN n@(NS _ _) = n

380 mkN n@(NS _ _) = n

382 mkN n@(SN _) = n

381 mkN n@(SN _) = n

383 mkN n = case namespace info of

382 mkN n = case namespace info of

384− Just xs@(_:_) -> NS n xs

383+ Just xs@(_:_) -> sNS n xs

385 _ -> n

384 _ -> n

386

385

387 elab' ina (PMatchApp fc fn)

386 elab' ina (PMatchApp fc fn)

@@ -394,16 +393,12 @@ elab ist info pattern opts fn tm

394 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

393 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

395 = lift $ tfail (Msg "Typecase is not allowed")

394 = lift $ tfail (Msg "Typecase is not allowed")

396 -- if f is local, just do a simple_app

395 -- if f is local, just do a simple_app

397− elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args')

396+ elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args)

398− = do let args = {- case lookupCtxt f (inblock info) of

399− Just ps -> (map (pexp . (PRef fc)) ps ++ args')

400− _ -> -} args'

401−-- newtm <- mkSpecialised ist fc f (map getTm args') tm

402− env <- get_env

397+ = do env <- get_env

403− if (f `elem` map fst env && length args' == 1)

398+ if (f `elem` map fst env && length args == 1)

404 then -- simple app, as below

399 then -- simple app, as below

405 do simple_app (elabE (ina, g, inty) (PRef fc f))

400 do simple_app (elabE (ina, g, inty) (PRef fc f))

406− (elabE (True, g, inty) (getTm (head args')))

401+ (elabE (True, g, inty) (getTm (head args)))

407 (show tm)

402 (show tm)

408 solve

403 solve

409 else

404 else

@@ -416,24 +411,17 @@ elab ist info pattern opts fn tm

416 -- we can unify with them

411 -- we can unify with them

417 case lookupCtxt f (idris_classes ist) of

412 case lookupCtxt f (idris_classes ist) of

418 [] -> return ()

413 [] -> return ()

419− _ -> mapM_ setInjective (map getTm args')

414+ _ -> mapM_ setInjective (map getTm args)

420 ctxt <- get_context

415 ctxt <- get_context

421 let guarded = isConName f ctxt

416 let guarded = isConName f ctxt

422 ns <- apply (Var f) (map isph args)

417 ns <- apply (Var f) (map isph args)

423− ptm <- get_term

424− g <- goal

425− -- Sort so that the implicit tactics go last

418+ -- Sort so that the implicit tactics and alternatives go last

426 let (ns', eargs) = unzip $

419 let (ns', eargs) = unzip $

427− sortBy (\(_,x) (_,y) ->

428− compare (priority x) (priority y))

429− (zip ns args)

420+ sortBy cmpArg (zip ns args)

430 elabArgs (ina || not isinf, guarded, inty)

421 elabArgs (ina || not isinf, guarded, inty)

431 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

422 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

432− mkSpecialised ist fc f (map getTm args') tm

433 solve

423 solve

434− ptm <- get_term

435 ivs' <- get_instances

424 ivs' <- get_instances

436− ps' <- get_probs

437 -- Attempt to resolve any type classes which have 'complete' types,

425 -- Attempt to resolve any type classes which have 'complete' types,

438 -- i.e. no holes in them

426 -- i.e. no holes in them

439 when (not pattern || (ina && not tcgen && not guarded)) $

427 when (not pattern || (ina && not tcgen && not guarded)) $

@@ -449,6 +437,13 @@ elab ist info pattern opts fn tm

449 (ivs' \\ ivs)

437 (ivs' \\ ivs)

450 where tcArg (n, PConstraint _ _ Placeholder _) = True

438 where tcArg (n, PConstraint _ _ Placeholder _) = True

451 tcArg _ = False

439 tcArg _ = False

440+

441+ -- normal < tactic < default tactic

442+ cmpArg (_, x) (_, y)

443+ = compare (priority x + alt x) (priority y + alt y)

444+ where alt t = case getTm t of

445+ PAlternative False _ -> 5

446+ _ -> 0

452

447

453 tacTm (PTactics _) = True

448 tacTm (PTactics _) = True

454 tacTm (PProof _) = True

449 tacTm (PProof _) = True

@@ -469,7 +464,7 @@ elab ist info pattern opts fn tm

469 do attack; defer n'; solve

464 do attack; defer n'; solve

470 where mkN n@(NS _ _) = n

465 where mkN n@(NS _ _) = n

471 mkN n = case namespace info of

466 mkN n = case namespace info of

472− Just xs@(_:_) -> NS n xs

467+ Just xs@(_:_) -> sNS n xs

473 _ -> n

468 _ -> n

474 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

469 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

475 elab' ina (PTactics ts)

470 elab' ina (PTactics ts)

@@ -478,11 +473,11 @@ elab ist info pattern opts fn tm

478 elab' ina (PElabError e) = fail (pshow ist e)

473 elab' ina (PElabError e) = fail (pshow ist e)

479 elab' ina (PRewrite fc r sc newg)

474 elab' ina (PRewrite fc r sc newg)

480 = do attack

475 = do attack

481− tyn <- unique_hole (MN 0 "rty")

476+ tyn <- getNameFrom (sMN 0 "rty")

482 claim tyn RType

477 claim tyn RType

483− valn <- unique_hole (MN 0 "rval")

478+ valn <- getNameFrom (sMN 0 "rval")

484 claim valn (Var tyn)

479 claim valn (Var tyn)

485− letn <- unique_hole (MN 0 "rewrite_rule")

480+ letn <- getNameFrom (sMN 0 "rewrite_rule")

486 letbind letn (Var tyn) (Var valn)

481 letbind letn (Var tyn) (Var valn)

487 focus valn

482 focus valn

488 elab' ina r

483 elab' ina r

@@ -497,11 +492,11 @@ elab ist info pattern opts fn tm

497 solve

492 solve

498 where doEquiv t sc =

493 where doEquiv t sc =

499 do attack

494 do attack

500− tyn <- unique_hole (MN 0 "ety")

495+ tyn <- getNameFrom (sMN 0 "ety")

501 claim tyn RType

496 claim tyn RType

502− valn <- unique_hole (MN 0 "eqval")

497+ valn <- getNameFrom (sMN 0 "eqval")

503 claim valn (Var tyn)

498 claim valn (Var tyn)

504− letn <- unique_hole (MN 0 "equiv_val")

499+ letn <- getNameFrom (sMN 0 "equiv_val")

505 letbind letn (Var tyn) (Var valn)

500 letbind letn (Var tyn) (Var valn)

506 focus tyn

501 focus tyn

507 elab' ina t

502 elab' ina t

@@ -511,10 +506,10 @@ elab ist info pattern opts fn tm

511 solve

506 solve

512 elab' ina@(_, a, inty) c@(PCase fc scr opts)

507 elab' ina@(_, a, inty) c@(PCase fc scr opts)

513 = do attack

508 = do attack

514− tyn <- unique_hole (MN 0 "scty")

509+ tyn <- getNameFrom (sMN 0 "scty")

515 claim tyn RType

510 claim tyn RType

516− valn <- unique_hole (MN 0 "scval")

511+ valn <- getNameFrom (sMN 0 "scval")

517− scvn <- unique_hole (MN 0 "scvar")

512+ scvn <- getNameFrom (sMN 0 "scvar")

518 claim valn (Var tyn)

513 claim valn (Var tyn)

519 letbind scvn (Var tyn) (Var valn)

514 letbind scvn (Var tyn) (Var valn)

520 focus valn

515 focus valn

@@ -540,7 +535,7 @@ elab ist info pattern opts fn tm

540-- mkCaseName (MN i x) = MN i (x ++ "_case")

535-- mkCaseName (MN i x) = MN i (x ++ "_case")

541 mkN n@(NS _ _) = n

536 mkN n@(NS _ _) = n

542 mkN n = case namespace info of

537 mkN n = case namespace info of

543− Just xs@(_:_) -> NS n xs

538+ Just xs@(_:_) -> sNS n xs

544 _ -> n

539 _ -> n

545 elab' ina (PUnifyLog t) = do unifyLog True

540 elab' ina (PUnifyLog t) = do unifyLog True

546 elab' ina t

541 elab' ina t

@@ -620,8 +615,8 @@ elab ist info pattern opts fn tm

620 = elabArgs ina failed fc r ns args

615 = elabArgs ina failed fc r ns args

621 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

616 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

622 | lazy && not pattern

617 | lazy && not pattern

623− = do elabArg n (PApp bi (PRef bi (UN "lazy"))

618+ = do elabArg n (PApp bi (PRef bi (sUN "lazy"))

624− [pimp (UN "a") Placeholder True,

619+ [pimp (sUN "a") Placeholder True,

625 pexp t]);

620 pexp t]);

626 | otherwise = elabArg n t

621 | otherwise = elabArg n t

627 where elabArg n t

622 where elabArg n t

@@ -701,9 +696,9 @@ findInstances ist t

701 | otherwise = []

696 | otherwise = []

702

697

703trivial' ist

698trivial' ist

704− = trivial (elab ist toplevel False [] (MN 0 "tac")) ist

699+ = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

705proofSearch' ist top n hints

700proofSearch' ist top n hints

706− = 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

707

702

708

703

709resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

704resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

@@ -713,9 +708,10 @@ resolveTC depth topg fn ist

713 = do hnf_compute

708 = do hnf_compute

714 g <- goal

709 g <- goal

715 ptm <- get_term

710 ptm <- get_term

711+ ulog <- getUnifyLog

716 hs <- get_holes

712 hs <- get_holes

717− if True -- all (\n -> not (n `elem` hs)) (freeNames g)

713+ traceWhen ulog ("Resolving class " ++ show g) $

718− then try' (trivial' ist)

714+ try' (trivial' ist)

719 (do t <- goal

715 (do t <- goal

720 let (tc, ttypes) = unApply t

716 let (tc, ttypes) = unApply t

721 scopeOnly <- needsDefault t tc ttypes

717 scopeOnly <- needsDefault t tc ttypes

@@ -723,28 +719,23 @@ resolveTC depth topg fn ist

723 let insts = if scopeOnly then filter chaser insts_in

719 let insts = if scopeOnly then filter chaser insts_in

724 else insts_in

720 else insts_in

725 tm <- get_term

721 tm <- get_term

726−-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $

727−-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))

728−-- if scopeOnly then fail "Can't resolve" else

729 let depth' = if scopeOnly then 2 else depth

722 let depth' = if scopeOnly then 2 else depth

730 blunderbuss t depth' insts) True

723 blunderbuss t depth' insts) True

731− else do try' (trivial' ist)

732− (do g <- goal

733− fail $ "Can't resolve " ++ show g) True

734−-- tm <- get_term

735−-- fail $ "Can't resolve yet in " ++ show tm

736 where

724 where

737 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

725 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

738 | otherwise = (fail "Can't resolve", show n)

726 | otherwise = (fail "Can't resolve", show n)

739

727

740 -- HACK! Rather than giving a special name, better to have some kind

728 -- HACK! Rather than giving a special name, better to have some kind

741 -- of flag in ClassInfo structure

729 -- of flag in ClassInfo structure

730+ chaser (UN nm)

742− chaser (UN ('@':'@':_)) = True -- old way

731+ | ('@':'@':_) <- str nm = True -- old way

743 chaser (SN (ParentN _ _)) = True

732 chaser (SN (ParentN _ _)) = True

744 chaser (NS n _) = chaser n

733 chaser (NS n _) = chaser n

745 chaser _ = False

734 chaser _ = False

746

735

736+ numclass = sNS (sUN "Num") ["Classes","Prelude"]

737+

747− needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _]

738+ needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass

748 = do focus a

739 = do focus a

749 fill (RConstant (AType (ATInt ITBig))) -- default Integer

740 fill (RConstant (AType (ATInt ITBig))) -- default Integer

750 solve

741 solve

@@ -777,8 +768,8 @@ resolveTC depth topg fn ist

777 [args] -> map isImp (snd args) -- won't be overloaded!

768 [args] -> map isImp (snd args) -- won't be overloaded!

778 ps <- get_probs

769 ps <- get_probs

779 tm <- get_term

770 tm <- get_term

780− args <- try' (match_apply (Var n) imps)

771+ args <- try' (apply (Var n) imps)

781− (apply (Var n) imps) True

772+ (match_apply (Var n) imps) True

782 ps' <- get_probs

773 ps' <- get_probs

783 when (length ps < length ps') $ fail "Can't apply type class"

774 when (length ps < length ps') $ fail "Can't apply type class"

784-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

775-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

@@ -790,7 +781,9 @@ resolveTC depth topg fn ist

790 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

781 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

791 -- if there's any arguments left, we've failed to resolve

782 -- if there's any arguments left, we've failed to resolve

792 hs <- get_holes

783 hs <- get_holes

784+ ulog <- getUnifyLog

793− solve

785+ solve

786+ traceWhen ulog ("Got " ++ show n) $ return ()

794 where isImp (PImp p _ _ _ _ _) = (True, p)

787 where isImp (PImp p _ _ _ _ _) = (True, p)

795 isImp arg = (False, priority arg)

788 isImp arg = (False, priority arg)

796

789

@@ -832,7 +825,7 @@ runTac autoSolve ist tac

832 where

825 where

833 bname (Bind n _ _) = Just n

826 bname (Bind n _ _) = Just n

834 bname _ = Nothing

827 bname _ = Nothing

835− runT (Exact tm) = do elab ist toplevel False [] (MN 0 "tac") tm

828+ runT (Exact tm) = do elab ist toplevel False [] (sMN 0 "tac") tm

836 when autoSolve solveAll

829 when autoSolve solveAll

837 runT (MatchRefine fn)

830 runT (MatchRefine fn)

838 = do fnimps <-

831 = do fnimps <-

@@ -872,27 +865,27 @@ runTac autoSolve ist tac

872 when autoSolve solveAll

865 when autoSolve solveAll

873 runT (Equiv tm) -- let bind tm, then

866 runT (Equiv tm) -- let bind tm, then

874 = do attack

867 = do attack

875− tyn <- unique_hole (MN 0 "ety")

868+ tyn <- getNameFrom (sMN 0 "ety")

876 claim tyn RType

869 claim tyn RType

877− valn <- unique_hole (MN 0 "eqval")

870+ valn <- getNameFrom (sMN 0 "eqval")

878 claim valn (Var tyn)

871 claim valn (Var tyn)

879− letn <- unique_hole (MN 0 "equiv_val")

872+ letn <- getNameFrom (sMN 0 "equiv_val")

880 letbind letn (Var tyn) (Var valn)

873 letbind letn (Var tyn) (Var valn)

881 focus tyn

874 focus tyn

882− elab ist toplevel False [] (MN 0 "tac") tm

875+ elab ist toplevel False [] (sMN 0 "tac") tm

883 focus valn

876 focus valn

884 when autoSolve solveAll

877 when autoSolve solveAll

885 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

878 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

886 = do attack; -- (h:_) <- get_holes

879 = do attack; -- (h:_) <- get_holes

887− tyn <- unique_hole (MN 0 "rty")

880+ tyn <- getNameFrom (sMN 0 "rty")

888 -- start_unify h

881 -- start_unify h

889 claim tyn RType

882 claim tyn RType

890− valn <- unique_hole (MN 0 "rval")

883+ valn <- getNameFrom (sMN 0 "rval")

891 claim valn (Var tyn)

884 claim valn (Var tyn)

892− letn <- unique_hole (MN 0 "rewrite_rule")

885+ letn <- getNameFrom (sMN 0 "rewrite_rule")

893 letbind letn (Var tyn) (Var valn)

886 letbind letn (Var tyn) (Var valn)

894 focus valn

887 focus valn

895− elab ist toplevel False [] (MN 0 "tac") tm

888+ elab ist toplevel False [] (sMN 0 "tac") tm

896 rewrite (Var letn)

889 rewrite (Var letn)

897 when autoSolve solveAll

890 when autoSolve solveAll

898 runT (Induction nm)

891 runT (Induction nm)

@@ -900,27 +893,27 @@ runTac autoSolve ist tac

900 when autoSolve solveAll

893 when autoSolve solveAll

901 runT (LetTac n tm)

894 runT (LetTac n tm)

902 = do attack

895 = do attack

903− tyn <- unique_hole (MN 0 "letty")

896+ tyn <- getNameFrom (sMN 0 "letty")

904 claim tyn RType

897 claim tyn RType

905− valn <- unique_hole (MN 0 "letval")

898+ valn <- getNameFrom (sMN 0 "letval")

906 claim valn (Var tyn)

899 claim valn (Var tyn)

907 letn <- unique_hole n

900 letn <- unique_hole n

908 letbind letn (Var tyn) (Var valn)

901 letbind letn (Var tyn) (Var valn)

909 focus valn

902 focus valn

910− elab ist toplevel False [] (MN 0 "tac") tm

903+ elab ist toplevel False [] (sMN 0 "tac") tm

911 when autoSolve solveAll

904 when autoSolve solveAll

912 runT (LetTacTy n ty tm)

905 runT (LetTacTy n ty tm)

913 = do attack

906 = do attack

914− tyn <- unique_hole (MN 0 "letty")

907+ tyn <- getNameFrom (sMN 0 "letty")

915 claim tyn RType

908 claim tyn RType

916− valn <- unique_hole (MN 0 "letval")

909+ valn <- getNameFrom (sMN 0 "letval")

917 claim valn (Var tyn)

910 claim valn (Var tyn)

918 letn <- unique_hole n

911 letn <- unique_hole n

919 letbind letn (Var tyn) (Var valn)

912 letbind letn (Var tyn) (Var valn)

920 focus tyn

913 focus tyn

921− elab ist toplevel False [] (MN 0 "tac") ty

914+ elab ist toplevel False [] (sMN 0 "tac") ty

922 focus valn

915 focus valn

923− elab ist toplevel False [] (MN 0 "tac") tm

916+ elab ist toplevel False [] (sMN 0 "tac") tm

924 when autoSolve solveAll

917 when autoSolve solveAll

925 runT Compute = compute

918 runT Compute = compute

926 runT Trivial = do trivial' ist; when autoSolve solveAll

919 runT Trivial = do trivial' ist; when autoSolve solveAll

@@ -933,16 +926,16 @@ runTac autoSolve ist tac

933 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

926 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

934 tgoal <- goal -- store the goal

927 tgoal <- goal -- store the goal

935 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

928 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

936− script <- unique_hole (MN 0 "script")

929+ script <- getNameFrom (sMN 0 "script")

937 claim script scriptTy

930 claim script scriptTy

938− scriptvar <- unique_hole (MN 0 "scriptvar" )

931+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

939 letbind scriptvar scriptTy (Var script)

932 letbind scriptvar scriptTy (Var script)

940 focus script

933 focus script

941− elab ist toplevel False [] (MN 0 "tac") tm

934+ elab ist toplevel False [] (sMN 0 "tac") tm

942 (script', _) <- get_type_val (Var scriptvar)

935 (script', _) <- get_type_val (Var scriptvar)

943 -- now that we have the script apply

936 -- now that we have the script apply

944 -- it to the reflected goal and context

937 -- it to the reflected goal and context

945− restac <- unique_hole (MN 0 "restac")

938+ restac <- getNameFrom (sMN 0 "restac")

946 claim restac tacticTy

939 claim restac tacticTy

947 focus restac

940 focus restac

948 fill (raw_apply (forget script')

941 fill (raw_apply (forget script')

@@ -956,27 +949,27 @@ runTac autoSolve ist tac

956 let tactic = normalise ctxt env restac'

949 let tactic = normalise ctxt env restac'

957 runReflected tactic

950 runReflected tactic

958 where tacticTy = Var (reflm "Tactic")

951 where tacticTy = Var (reflm "Tactic")

959− listTy = Var (NS (UN "List") ["List", "Prelude"])

952+ listTy = Var (sNS (sUN "List") ["List", "Prelude"])

960− scriptTy = (RBind (UN "__pi_arg")

953+ scriptTy = (RBind (sUN "__pi_arg")

961 (Pi (RApp listTy envTupleType))

954 (Pi (RApp listTy envTupleType))

962− (RBind (UN "__pi_arg1")

955+ (RBind (sUN "__pi_arg1")

963 (Pi (Var $ reflm "TT")) tacticTy))

956 (Pi (Var $ reflm "TT")) tacticTy))

964 runT (ByReflection tm) -- run the reflection function 'tm' on the

957 runT (ByReflection tm) -- run the reflection function 'tm' on the

965 -- goal, then apply the resulting reflected Tactic

958 -- goal, then apply the resulting reflected Tactic

966 = do tgoal <- goal

959 = do tgoal <- goal

967 attack

960 attack

968− script <- unique_hole (MN 0 "script")

961+ script <- getNameFrom (sMN 0 "script")

969 claim script scriptTy

962 claim script scriptTy

970− scriptvar <- unique_hole (MN 0 "scriptvar" )

963+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

971 letbind scriptvar scriptTy (Var script)

964 letbind scriptvar scriptTy (Var script)

972 focus script

965 focus script

973 ptm <- get_term

966 ptm <- get_term

974− elab ist toplevel False [] (MN 0 "tac")

967+ elab ist toplevel False [] (sMN 0 "tac")

975 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

968 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

976 (script', _) <- get_type_val (Var scriptvar)

969 (script', _) <- get_type_val (Var scriptvar)

977 -- now that we have the script apply

970 -- now that we have the script apply

978 -- it to the reflected goal

971 -- it to the reflected goal

979− restac <- unique_hole (MN 0 "restac")

972+ restac <- getNameFrom (sMN 0 "restac")

980 claim restac tacticTy

973 claim restac tacticTy

981 focus restac

974 focus restac

982 fill (forget script')

975 fill (forget script')

@@ -992,28 +985,28 @@ runTac autoSolve ist tac

992 scriptTy = tacticTy

985 scriptTy = tacticTy

993

986

994 runT (Reflect v) = do attack -- let x = reflect v in ...

987 runT (Reflect v) = do attack -- let x = reflect v in ...

995− tyn <- unique_hole (MN 0 "letty")

988+ tyn <- getNameFrom (sMN 0 "letty")

996 claim tyn RType

989 claim tyn RType

997− valn <- unique_hole (MN 0 "letval")

990+ valn <- getNameFrom (sMN 0 "letval")

998 claim valn (Var tyn)

991 claim valn (Var tyn)

999− letn <- unique_hole (MN 0 "letvar")

992+ letn <- getNameFrom (sMN 0 "letvar")

1000 letbind letn (Var tyn) (Var valn)

993 letbind letn (Var tyn) (Var valn)

1001 focus valn

994 focus valn

1002− elab ist toplevel False [] (MN 0 "tac") v

995+ elab ist toplevel False [] (sMN 0 "tac") v

1003 (value, _) <- get_type_val (Var letn)

996 (value, _) <- get_type_val (Var letn)

1004 ctxt <- get_context

997 ctxt <- get_context

1005 env <- get_env

998 env <- get_env

1006 let value' = hnf ctxt env value

999 let value' = hnf ctxt env value

1007 runTac autoSolve ist (Exact $ PQuote (reflect value'))

1000 runTac autoSolve ist (Exact $ PQuote (reflect value'))

1008 runT (Fill v) = do attack -- let x = fill x in ...

1001 runT (Fill v) = do attack -- let x = fill x in ...

1009− tyn <- unique_hole (MN 0 "letty")

1002+ tyn <- getNameFrom (sMN 0 "letty")

1010 claim tyn RType

1003 claim tyn RType

1011− valn <- unique_hole (MN 0 "letval")

1004+ valn <- getNameFrom (sMN 0 "letval")

1012 claim valn (Var tyn)

1005 claim valn (Var tyn)

1013− letn <- unique_hole (MN 0 "letvar")

1006+ letn <- getNameFrom (sMN 0 "letvar")

1014 letbind letn (Var tyn) (Var valn)

1007 letbind letn (Var tyn) (Var valn)

1015 focus valn

1008 focus valn

1016− elab ist toplevel False [] (MN 0 "tac") v

1009+ elab ist toplevel False [] (sMN 0 "tac") v

1017 (value, _) <- get_type_val (Var letn)

1010 (value, _) <- get_type_val (Var letn)

1018 ctxt <- get_context

1011 ctxt <- get_context

1019 env <- get_env

1012 env <- get_env

@@ -1023,12 +1016,12 @@ runTac autoSolve ist tac

1023 runT (GoalType n tac) = do g <- goal

1016 runT (GoalType n tac) = do g <- goal

1024 case unApply g of

1017 case unApply g of

1025 (P _ n' _, _) ->

1018 (P _ n' _, _) ->

1026− if nsroot n' == UN n

1019+ if nsroot n' == sUN n

1027 then runT tac

1020 then runT tac

1028 else fail "Wrong goal type"

1021 else fail "Wrong goal type"

1029 _ -> fail "Wrong goal type"

1022 _ -> fail "Wrong goal type"

1030 runT ProofState = do g <- goal

1023 runT ProofState = do g <- goal

1031− trace (show g) $ return ()

1024+ return ()

1032 runT x = fail $ "Not implemented " ++ show x

1025 runT x = fail $ "Not implemented " ++ show x

1033

1026

1034 runReflected t = do t' <- reify ist t

1027 runReflected t = do t' <- reify ist t

@@ -1036,7 +1029,7 @@ runTac autoSolve ist tac

1036

1029

1037-- | Prefix a name with the "Language.Reflection" namespace

1030-- | Prefix a name with the "Language.Reflection" namespace

1038reflm :: String -> Name

1031reflm :: String -> Name

1039−reflm n = NS (UN n) ["Reflection", "Language"]

1032+reflm n = sNS (sUN n) ["Reflection", "Language"]

1040

1033

1041

1034

1042-- | Reify tactics from their reflected representation

1035-- | Reify tactics from their reflected representation

@@ -1058,7 +1051,7 @@ reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist

1058reifyApp ist t [Constant (Str n), x]

1051reifyApp ist t [Constant (Str n), x]

1059 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1052 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1060reifyApp _ t [Constant (Str n)]

1053reifyApp _ t [Constant (Str n)]

1061− | t == reflm "Intro" = return $ Intro [UN n]

1054+ | t == reflm "Intro" = return $ Intro [sUN n]

1062reifyApp ist t [t']

1055reifyApp ist t [t']

1063 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1056 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1064reifyApp ist t [t']

1057reifyApp ist t [t']

@@ -1149,13 +1142,13 @@ reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

1149

1142

1150reifyTTNameApp :: Name -> [Term] -> ElabD Name

1143reifyTTNameApp :: Name -> [Term] -> ElabD Name

1151reifyTTNameApp t [Constant (Str n)]

1144reifyTTNameApp t [Constant (Str n)]

1152− | t == reflm "UN" = return $ UN n

1145+ | t == reflm "UN" = return $ sUN n

1153reifyTTNameApp t [n, ns]

1146reifyTTNameApp t [n, ns]

1154 | t == reflm "NS" = do n' <- reifyTTName n

1147 | t == reflm "NS" = do n' <- reifyTTName n

1155 ns' <- reifyTTNamespace ns

1148 ns' <- reifyTTNamespace ns

1156− return $ NS n' ns'

1149+ return $ sNS n' ns'

1157reifyTTNameApp t [Constant (I i), Constant (Str n)]

1150reifyTTNameApp t [Constant (I i), Constant (Str n)]

1158− | t == reflm "MN" = return $ MN i n

1151+ | t == reflm "MN" = return $ sMN i n

1159reifyTTNameApp t []

1152reifyTTNameApp t []

1160 | t == reflm "NErased" = return NErased

1153 | t == reflm "NErased" = return NErased

1161reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

1154reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

@@ -1164,9 +1157,9 @@ reifyTTNamespace :: Term -> ElabD [String]

1164reifyTTNamespace t@(App _ _)

1157reifyTTNamespace t@(App _ _)

1165 = case unApply t of

1158 = case unApply t of

1166 (P _ f _, [Constant StrType])

1159 (P _ f _, [Constant StrType])

1167− | f == NS (UN "Nil") ["List", "Prelude"] -> return []

1160+ | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

1168 (P _ f _, [Constant StrType, Constant (Str n), ns])

1161 (P _ f _, [Constant StrType, Constant (Str n), ns])

1169− | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

1162+ | f == sNS (sUN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

1170 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

1163 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

1171reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

1164reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

1172

1165

@@ -1288,19 +1281,19 @@ reflectNameType (TCon x y)

1288 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

1281 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

1289

1282

1290reflectName :: Name -> Raw

1283reflectName :: Name -> Raw

1291−reflectName (UN str)

1284+reflectName (UN s)

1292− = reflCall "UN" [RConstant (Str str)]

1285+ = reflCall "UN" [RConstant (Str (str s))]

1293reflectName (NS n ns)

1286reflectName (NS n ns)

1294 = reflCall "NS" [ reflectName n

1287 = reflCall "NS" [ reflectName n

1295 , foldr (\ n s ->

1288 , foldr (\ n s ->

1296− raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

1289+ raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

1297 [ RConstant StrType, RConstant (Str n), s ])

1290 [ RConstant StrType, RConstant (Str n), s ])

1298− ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

1291+ ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

1299 [ RConstant StrType ])

1292 [ RConstant StrType ])

1300− ns

1293+ (map str ns)

1301 ]

1294 ]

1302reflectName (MN i n)

1295reflectName (MN i n)

1303− = reflCall "MN" [RConstant (I i), RConstant (Str n)]

1296+ = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

1304reflectName (NErased) = Var (reflm "NErased")

1297reflectName (NErased) = Var (reflm "NErased")

1305reflectName n = Var (reflm "NErased") -- special name, not yet implemented

1298reflectName n = Var (reflm "NErased") -- special name, not yet implemented

1306

1299

@@ -1357,7 +1350,7 @@ reflectEnv = foldr consToEnvList emptyEnvList

1357 where

1350 where

1358 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

1351 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

1359 consToEnvList (n, b) l

1352 consToEnvList (n, b) l

1360− = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

1353+ = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

1361 [ envTupleType

1354 [ envTupleType

1362 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1355 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1363 , (RApp (Var $ reflm "Binder")

1356 , (RApp (Var $ reflm "Binder")

@@ -1369,19 +1362,19 @@ reflectEnv = foldr consToEnvList emptyEnvList

1369 ]

1362 ]

1370

1363

1371 emptyEnvList :: Raw

1364 emptyEnvList :: Raw

1372− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1365+ emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

1373 [envTupleType]

1366 [envTupleType]

1374

1367

1375-- | Reflect an error into the internal datatype of Idris -- TODO

1368-- | Reflect an error into the internal datatype of Idris -- TODO

1376rawBool :: Bool -> Raw

1369rawBool :: Bool -> Raw

1377−rawBool True = Var (NS (UN "True") ["Bool", "Prelude"])

1370+rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"])

1378−rawBool False = Var (NS (UN "False") ["Bool", "Prelude"])

1371+rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"])

1379

1372

1380rawNil :: Raw -> Raw

1373rawNil :: Raw -> Raw

1381−rawNil ty = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"])) [ty]

1374+rawNil ty = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"])) [ty]

1382

1375

1383rawCons :: Raw -> Raw -> Raw -> Raw

1376rawCons :: Raw -> Raw -> Raw -> Raw

1384−rawCons ty hd tl = raw_apply (Var (NS (UN "::") ["List", "Prelude"])) [ty, hd, tl]

1377+rawCons ty hd tl = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"])) [ty, hd, tl]

1385

1378

1386rawList :: Raw -> [Raw] -> Raw

1379rawList :: Raw -> [Raw] -> Raw

1387rawList ty = foldr (rawCons ty) (rawNil ty)

1380rawList ty = foldr (rawCons ty) (rawNil ty)

@@ -1447,7 +1440,7 @@ reflectErr (NotInjective t1 t2 t3) =

1447reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

1440reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

1448reflectErr (CantResolveAlts ss) =

1441reflectErr (CantResolveAlts ss) =

1449 raw_apply (Var $ reflErrName "CantResolve")

1442 raw_apply (Var $ reflErrName "CantResolve")

1450− [rawList (Var $ (UN "String")) (map (RConstant . Str) ss)]

1443+ [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)]

1451reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

1444reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

1452reflectErr UniverseError = Var $ reflErrName "UniverseError"

1445reflectErr UniverseError = Var $ reflErrName "UniverseError"

1453reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

1446reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

@@ -1472,7 +1465,7 @@ reflectErr (ProviderError str) =

1472 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1465 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1473reflectErr (LoadingFailed str err) =

1466reflectErr (LoadingFailed str err) =

1474 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1467 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1475−reflectErr x = raw_apply (Var (NS (UN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1468+reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1476

1469

1477withErrorReflection :: Idris a -> Idris a

1470withErrorReflection :: Idris a -> Idris a

1478withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1471withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1506,11 +1499,12 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1506 parts -> ReflectionError errorparts e

1499 parts -> ReflectionError errorparts e

1507

1500

1508 fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1501 fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1509− fromTTMaybe (App (App (P (DCon _ _) (NS (UN "Just") _) _) ty) tm) = Just tm

1502+ fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

1503+ | just == txt "Just" = Just tm

1510 fromTTMaybe x = Nothing

1504 fromTTMaybe x = Nothing

1511

1505

1512reflErrName :: String -> Name

1506reflErrName :: String -> Name

1513−reflErrName n = NS (UN n) ["Errors", "Reflection", "Language"]

1507+reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"]

1514

1508

1515reifyReportPart :: Term -> Idris ErrorReportPart

1509reifyReportPart :: Term -> Idris ErrorReportPart

1516reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflErrName "TextPart" =

1510reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflErrName "TextPart" =

@@ -1548,44 +1542,3 @@ envTupleType

1548

1542

1549solveAll = try (do solve; solveAll) (return ())

1543solveAll = try (do solve; solveAll) (return ())

1550

1544

1551−-- If the function application is specialisable, make a new

1552−-- top level function by normalising the application

1553−-- and elaborating the new expression.

1554−

1555−mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm

1556−mkSpecialised i fc n args def

1557− = do let tm' = def

1558− case lookupCtxt n (idris_statics i) of

1559− [as] -> if (not (or as)) then return tm' else

1560− mkSpecDecl i n (zip args as) tm'

1561− _ -> return tm'

1562−

1563−mkSpecDecl :: IState -> Name -> [(PTerm, Bool)] -> PTerm -> ElabD PTerm

1564−mkSpecDecl i n pargs tm'

1565− = do t <- goal

1566− g <- get_guess

1567− let (f, args) = unApply g

1568− let sargs = zip args (map snd pargs)

1569− let staticArgs = map fst (filter (\ (_,x) -> x) sargs)

1570− let ns = group (sort (concatMap staticFnNames staticArgs))

1571− let ntimes = map (\xs -> (head xs, length xs - 1)) ns

1572− if (not (null ns)) then

1573− do env <- get_env

1574− let g' = g -- specialise ctxt env ntimes g

1575− return tm'

1576−-- trace (show t ++ "\n" ++

1577−-- show ntimes ++ "\n" ++

1578−-- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO

1579− else return tm'

1580− where

1581− ctxt = tt_ctxt i

1582− cg = idris_callgraph i

1583−

1584− staticFnNames tm | (P _ f _, as) <- unApply tm

1585− = if not (isFnName f ctxt) then []

1586− else case lookupCtxt f cg of

1587− [ns] -> f : f : [] --(ns \\ [f])

1588− [] -> [f,f]

1589− _ -> []

1590− staticFnNames _ = []

1591−

src/Idris/Error.hs+1−1

@@ -12,7 +12,7 @@ import Idris.Core.Constraints

13import System.Console.Haskeline

14import System.Console.Haskeline.MonadException

15−import Control.Monad.State

15+import Control.Monad.State.Strict

16import Control.Monad.Error (throwError, catchError)

17import System.IO.Error(isUserError, ioeGetErrorString)

18import Data.Char

src/Idris/IBC.hs+146−50

@@ -8,25 +8,31 @@ import Idris.Core.CaseTree

8import Idris.AbsSyntax

9import Idris.Imports

10import Idris.Error

11+import Idris.Delaborate

12import Data.Binary

13import Data.Binary

13import Data.Vector.Binary

14import Data.Vector.Binary

14import Data.List

15import Data.List

15−import Data.ByteString.Lazy as B hiding (length, elem)

16+import Data.ByteString.Lazy as B hiding (length, elem, map)

17+import qualified Data.Text as T

18+

16import Control.Monad

19import Control.Monad

17−import Control.Monad.State hiding (get, put)

20+import Control.Monad.State.Strict hiding (get, put)

21+import qualified Control.Monad.State.Strict as ST

18import System.FilePath

22import System.FilePath

19import System.Directory

23import System.Directory

24+import Codec.Compression.Zlib

21import Debug.Trace

26import Debug.Trace

23import Paths_idris

28import Paths_idris

25ibcVersion :: Word8

30ibcVersion :: Word8

26−ibcVersion = 50

31+ibcVersion = 54

28data IBCFile = IBCFile { ver :: Word8,

33data IBCFile = IBCFile { ver :: Word8,

29 sourcefile :: FilePath,

34 sourcefile :: FilePath,

35+ symbols :: [Name],

30 ibc_imports :: [FilePath],

36 ibc_imports :: [FilePath],

31 ibc_implicits :: [(Name, [PArg])],

37 ibc_implicits :: [(Name, [PArg])],

32 ibc_fixes :: [FixDecl],

38 ibc_fixes :: [FixDecl],

@@ -61,13 +67,17 @@ deriving instance Binary IBCFile

61!-}

67!-}

63initIBC :: IBCFile

69initIBC :: IBCFile

64−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

70+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

66loadIBC :: FilePath -> Idris ()

72loadIBC :: FilePath -> Idris ()

67loadIBC fp = do iLOG $ "Loading ibc " ++ fp

73loadIBC fp = do iLOG $ "Loading ibc " ++ fp

68− ibcf <- runIO $ (decodeFile fp :: IO IBCFile)

74+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

69 process ibcf fp

75 process ibcf fp

77+bencode f d = B.writeFile f (compress (encode d))

78+bdecode f = do d' <- B.readFile f

79+ return (decode (decompress d'))

80+

71writeIBC :: FilePath -> FilePath -> Idris ()

81writeIBC :: FilePath -> FilePath -> Idris ()

72writeIBC src f

82writeIBC src f

73 = do iLOG $ "Writing ibc " ++ show f

83 = do iLOG $ "Writing ibc " ++ show f

@@ -75,11 +85,12 @@ writeIBC src f

75 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

85 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

76 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

86 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

77 [] -> return ()

87 [] -> return ()

88+ resetNameIdx

78 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

89 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

79 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

90 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

80− runIO $ encodeFile f ibcf

91+ runIO $ bencode f ibcf

81 iLOG "Written")

92 iLOG "Written")

82− (\c -> do iLOG $ "Failed " ++ show c)

93+ (\c -> do iLOG $ "Failed " ++ pshow i c)

83 return ()

94 return ()

85mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

96mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

@@ -124,8 +135,64 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

124ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

135ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

125ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

136ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

126ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

137ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

138+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

127− [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

139+ return f' { ibc_defs = (n,v) : ibc_defs f' }

128 _ -> ifail "IBC write failed"

140 _ -> ifail "IBC write failed"

141+ where

142+ updateDef :: Def -> StateT (IBCFile, Int) Idris Def

143+ updateDef (CaseOp c t args o s cd)

144+ = do o' <- mapM updateOrig o

145+ cd' <- updateCD cd

146+ return (CaseOp c t args o' s cd')

147+ updateDef t = return t

148+

149+ updateOrig (Left t) = do t' <- update t

150+ return (Left t')

151+ updateOrig (Right (l,r)) = do l' <- update l

152+ r' <- update r

153+ return (Right (l', r'))

154+

155+ updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

156+ = do c' <- updateSC c; r' <- updateSC r

157+ return (CaseDefs (ts, t) (cs, c') (is, i) (rs, r'))

158+

159+ updateSC (Case n alts) = do alts' <- mapM updateAlt alts

160+ return (Case n alts')

161+ updateSC (ProjCase t alts) = do t' <- update t

162+ alts' <- mapM updateAlt alts

163+ return (ProjCase t' alts')

164+ updateSC (STerm t) = do t' <- update t

165+ return (STerm t')

166+ updateSC t = return t

167+

168+ updateAlt (ConCase n i a sc) = do sc' <- updateSC sc

169+ return (ConCase n i a sc')

170+ updateAlt (FnCase n a sc) = do sc' <- updateSC sc

171+ return (FnCase n a sc')

172+ updateAlt (ConstCase i sc) = do sc' <- updateSC sc

173+ return (ConstCase i sc')

174+ updateAlt (SucCase n sc) = do sc' <- updateSC sc

175+ return (SucCase n sc')

176+ updateAlt (DefaultCase sc) = do sc' <- updateSC sc

177+ return (DefaultCase sc')

178+

179+ update (P t n@(MN _ _) ty) = return (P t n ty)

180+ update (P t n@(UN _) ty) = return (P t n ty)

181+ update (P t n ty) = do (f, len) <- ST.get

182+ (i, _) <- lift (addNameIdx n)

183+ when (i >= len) $

184+ ST.put (f { symbols = symbols f ++ [n] }, len+1)

185+ return (P t (SymRef i) ty)

186+ update (App f a) = do f' <- update f; a' <- update a

187+ return (App f' a')

188+ update (Bind n b sc) = do b' <- fmapMB update b

189+ sc' <- update sc

190+ return (Bind n b' sc')

191+ update (Proj t i) = do t' <- update t

192+ return (Proj t' i)

193+ update t = return t

194+

195+

129ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

196ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

130 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

197 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

131 _ -> ifail "IBC write failed"

198 _ -> ifail "IBC write failed"

@@ -169,7 +236,7 @@ process i fn

169 pCGFlags (ibc_cgflags i)

236 pCGFlags (ibc_cgflags i)

170 pDyLibs (ibc_dynamic_libs i)

237 pDyLibs (ibc_dynamic_libs i)

171 pHdrs (ibc_hdrs i)

238 pHdrs (ibc_hdrs i)

172− pDefs (ibc_defs i)

239+ pDefs (symbols i) (ibc_defs i)

173 pAccess (ibc_access i)

240 pAccess (ibc_access i)

174 pTotal (ibc_total i)

241 pTotal (ibc_total i)

175 pCG (ibc_cg i)

242 pCG (ibc_cg i)

@@ -207,7 +274,9 @@ pImports fs

207pImps :: [(Name, [PArg])] -> Idris ()

274pImps :: [(Name, [PArg])] -> Idris ()

208pImps imps = mapM_ (\ (n, imp) ->

275pImps imps = mapM_ (\ (n, imp) ->

209 do i <- getIState

276 do i <- getIState

277+ case lookupDefAcc n False (tt_ctxt i) of

278+ [(n, Hidden)] -> return ()

210− putIState (i { idris_implicits

279+ _ -> putIState (i { idris_implicits

211 = addDef n imp (idris_implicits i) }))

280 = addDef n imp (idris_implicits i) }))

212 imps

281 imps

213

282

@@ -289,12 +358,32 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

289pHdrs :: [(Codegen, String)] -> Idris ()

358pHdrs :: [(Codegen, String)] -> Idris ()

290pHdrs hs = mapM_ (uncurry addHdr) hs

359pHdrs hs = mapM_ (uncurry addHdr) hs

291

360

292−pDefs :: [(Name, Def)] -> Idris ()

361+pDefs :: [Name] -> [(Name, Def)] -> Idris ()

362+pDefs syms ds

293−pDefs ds = mapM_ (\ (n, d) ->

363+ = mapM_ (\ (n, d) ->

294− do i <- getIState

364+ do i <- getIState

365+ let d' = updateDef d

295− logLvl 5 $ "Added " ++ show (n, d)

366+ logLvl 5 $ "Added " ++ show (n, d')

296− putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

367+ putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds

297− ds

368+ where

369+ updateDef (CaseOp c t args o s cd)

370+ = CaseOp c t args (map updateOrig o) s (updateCD cd)

371+ updateDef t = t

372+

373+ updateOrig (Left t) = Left (update t)

374+ updateOrig (Right (l, r)) = Right (update l, update r)

375+

376+ updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

377+ = CaseDefs (ts, fmap update t)

378+ (cs, fmap update c)

379+ (is, fmap update i)

380+ (rs, fmap update r)

381+

382+ update (P t (SymRef i) ty) = P t (syms!!i) ty

383+ update (App f a) = App (update f) (update a)

384+ update (Bind n b sc) = Bind n (fmap update b) (update sc)

385+ update (Proj t i) = Proj (update t) i

386+ update t = t

298

387

299pDocs :: [(Name, String)] -> Idris ()

388pDocs :: [(Name, String)] -> Idris ()

300pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

389pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -357,27 +446,24 @@ instance Binary CGInfo where

357 put (CGInfo x1 x2 x3 x4 x5)

446 put (CGInfo x1 x2 x3 x4 x5)

358 = do put x1

447 = do put x1

359 put x2

448 put x2

360− put x3

449+-- put x3 -- Already used SCG info for totality check

361 put x4

450 put x4

362 put x5

451 put x5

363 get

452 get

364 = do x1 <- get

453 = do x1 <- get

365 x2 <- get

454 x2 <- get

366− x3 <- get

367 x4 <- get

455 x4 <- get

368 x5 <- get

456 x5 <- get

369− return (CGInfo x1 x2 x3 x4 x5)

457+ return (CGInfo x1 x2 [] x4 x5)

370

458

371instance Binary FC where

459instance Binary FC where

372 put (FC x1 x2 x3)

460 put (FC x1 x2 x3)

373 = do put x1

461 = do put x1

374− put x2

462+ put (x2 * 65536 + x3)

375− put x3

376 get

463 get

377 = do x1 <- get

464 = do x1 <- get

378− x2 <- get

379− x3 <- get

465+ x2x3 <- get

380− return (FC x1 x2 x3)

466+ return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

381

467

382

468

383instance Binary Name where

469instance Binary Name where

@@ -394,6 +480,8 @@ instance Binary Name where

394 NErased -> putWord8 3

480 NErased -> putWord8 3

395 SN x1 -> do putWord8 4

481 SN x1 -> do putWord8 4

396 put x1

482 put x1

483+ SymRef x1 -> do putWord8 5

484+ put x1

397 get

485 get

398 = do i <- getWord8

486 = do i <- getWord8

399 case i of

487 case i of

@@ -408,8 +496,15 @@ instance Binary Name where

408 3 -> return NErased

496 3 -> return NErased

409 4 -> do x1 <- get

497 4 -> do x1 <- get

410 return (SN x1)

498 return (SN x1)

499+ 5 -> do x1 <- get

500+ return (SymRef x1)

411 _ -> error "Corrupted binary data for Name"

501 _ -> error "Corrupted binary data for Name"

412

502

503+instance Binary T.Text where

504+ put x = put (str x)

505+ get = do x <- get

506+ return (txt x)

507+

413instance Binary SpecialName where

508instance Binary SpecialName where

414 put x

509 put x

415 = case x of

510 = case x of

@@ -624,22 +719,18 @@ instance Binary NameType where

624 Bound -> putWord8 0

719 Bound -> putWord8 0

625 Ref -> putWord8 1

720 Ref -> putWord8 1

626 DCon x1 x2 -> do putWord8 2

721 DCon x1 x2 -> do putWord8 2

627− put x1

722+ put (x1 * 65536 + x2)

628− put x2

629 TCon x1 x2 -> do putWord8 3

723 TCon x1 x2 -> do putWord8 3

630− put x1

724+ put (x1 * 65536 + x2)

631− put x2

632 get

725 get

633 = do i <- getWord8

726 = do i <- getWord8

634 case i of

727 case i of

635 0 -> return Bound

728 0 -> return Bound

636 1 -> return Ref

729 1 -> return Ref

637− 2 -> do x1 <- get

638− x2 <- get

730+ 2 -> do x1x2 <- get

639− return (DCon x1 x2)

731+ return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

640− 3 -> do x1 <- get

641− x2 <- get

732+ 3 -> do x1x2 <- get

642− return (TCon x1 x2)

733+ return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

643 _ -> error "Corrupted binary data for NameType"

734 _ -> error "Corrupted binary data for NameType"

644

735

645

736

@@ -650,9 +741,12 @@ instance {- (Binary n) => -} Binary (TT Name) where

650 P x1 x2 x3 -> do putWord8 0

741 P x1 x2 x3 -> do putWord8 0

651 put x1

742 put x1

652 put x2

743 put x2

653− put x3

744+-- put x3

745+ V x1 -> if (x1 >= 0 && x1 < 256)

654− V x1 -> do putWord8 1

746+ then do putWord8 1

747+ putWord8 (toEnum (x1 + 1))

748+ else do putWord8 9

655− put x1

749+ put x1

656 Bind x1 x2 x3 -> do putWord8 2

750 Bind x1 x2 x3 -> do putWord8 2

657 put x1

751 put x1

658 put x2

752 put x2

@@ -664,7 +758,7 @@ instance {- (Binary n) => -} Binary (TT Name) where

664 put x1

758 put x1

665 Proj x1 x2 -> do putWord8 5

759 Proj x1 x2 -> do putWord8 5

666 put x1

760 put x1

667− put x2

761+ putWord8 (toEnum (x2 + 1))

668 Erased -> putWord8 6

762 Erased -> putWord8 6

669 TType x1 -> do putWord8 7

763 TType x1 -> do putWord8 7

670 put x1

764 put x1

@@ -674,10 +768,10 @@ instance {- (Binary n) => -} Binary (TT Name) where

674 case i of

768 case i of

675 0 -> do x1 <- get

769 0 -> do x1 <- get

676 x2 <- get

770 x2 <- get

677− x3 <- get

771+-- x3 <- get

678− return (P x1 x2 x3)

772+ return (P x1 x2 Erased)

679− 1 -> do x1 <- get

773+ 1 -> do x1 <- getWord8

680− return (V x1)

774+ return (V ((fromEnum x1) - 1))

681 2 -> do x1 <- get

775 2 -> do x1 <- get

682 x2 <- get

776 x2 <- get

683 x3 <- get

777 x3 <- get

@@ -688,12 +782,14 @@ instance {- (Binary n) => -} Binary (TT Name) where

688 4 -> do x1 <- get

782 4 -> do x1 <- get

689 return (Constant x1)

783 return (Constant x1)

690 5 -> do x1 <- get

784 5 -> do x1 <- get

691− x2 <- get

785+ x2 <- getWord8

692− return (Proj x1 x2)

786+ return (Proj x1 ((fromEnum x2)-1))

693 6 -> return Erased

787 6 -> return Erased

694 7 -> do x1 <- get

788 7 -> do x1 <- get

695 return (TType x1)

789 return (TType x1)

696 8 -> return Impossible

790 8 -> return Impossible

791+ 9 -> do x1 <- get

792+ return (V x1)

697 _ -> error "Corrupted binary data for TT"

793 _ -> error "Corrupted binary data for TT"

698

794

699instance Binary SC where

795instance Binary SC where

@@ -772,15 +868,13 @@ instance Binary CaseAlt where

772

868

773instance Binary CaseDefs where

869instance Binary CaseDefs where

774 put (CaseDefs x1 x2 x3 x4)

870 put (CaseDefs x1 x2 x3 x4)

775− = do -- don't need totality checked version

871+ = do -- don't need totality checked or inlined versions

776 put x2

872 put x2

777− put x3

778 put x4

873 put x4

779 get

874 get

780 = do x2 <- get

875 = do x2 <- get

781− x3 <- get -- use for totality checked version

782 x4 <- get

876 x4 <- get

783− return (CaseDefs x3 x2 x3 x4)

877+ return (CaseDefs x2 x2 x2 x4)

784

878

785instance Binary CaseInfo where

879instance Binary CaseInfo where

786 put x@(CaseInfo x1 x2) = do put x1

880 put x@(CaseInfo x1 x2) = do put x1

@@ -914,7 +1008,7 @@ instance Binary MetaInformation where

914 return (DataMI x1)

1008 return (DataMI x1)

915

1009

916instance Binary IBCFile where

1010instance 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)

1011+ put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30)

918 = {-# SCC "putIBCFile" #-}

1012 = {-# SCC "putIBCFile" #-}

919 do put x1

1013 do put x1

920 put x2

1014 put x2

@@ -945,6 +1039,7 @@ instance Binary IBCFile where

945 put x27

1039 put x27

946 put x28

1040 put x28

947 put x29

1041 put x29

1042+ put x30

948 get

1043 get

949 = do x1 <- get

1044 = do x1 <- get

950 if x1 == ibcVersion then

1045 if x1 == ibcVersion then

@@ -976,7 +1071,8 @@ instance Binary IBCFile where

976 x27 <- get

1071 x27 <- get

977 x28 <- get

1072 x28 <- get

978 x29 <- get

1073 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)

1074+ x30 <- get

1075+ return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30)

980 else return (initIBC { ver = x1 })

1076 else return (initIBC { ver = x1 })

981

1077

982instance Binary DataOpt where

1078instance Binary DataOpt where

src/Idris/Imports.hs+1−1

@@ -7,7 +7,7 @@ import Paths_idris

8import System.FilePath

9import System.Directory

10−import Control.Monad.State

10+import Control.Monad.State.Strict

12data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

13 deriving (Show, Eq)

src/Idris/ParseData.hs+14−10

@@ -49,7 +49,7 @@ record syn = do (doc, acc) <- try (do

49 ty <- typeExpr (allowImp syn)

50 let tyn = expandNS syn tyn_in

51 reserved "where"

52− (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)

52+ (cdoc, cn, cty, _, _) <- indentedBlockS (constructor syn)

53 accData acc tyn [cn]

54 let rsyn = syn { syn_namespace = show (nsroot tyn) :

55 syn_namespace syn }

@@ -113,7 +113,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

113 option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do

114 reserved "where"

115 cons <- indentedBlock (constructor syn)

116− accData acc tyn (map (\ (_, n, _, _) -> n) cons)

116+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons)

117 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

118 args <- many name

119 let ty = bindArgs (map (const PType) args) PType

@@ -133,10 +133,10 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

133 cons <- sepBy1 (simpleConstructor syn) (lchar '|')

134 terminator

135 let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)

136− cons' <- mapM (\ (doc, x, cargs, cfc) ->

136+ cons' <- mapM (\ (doc, x, cargs, cfc, fs) ->

137 do let cty = bindArgs cargs conty

138− return (doc, x, cty, cfc)) cons

138+ return (doc, x, cty, cfc, fs)) cons

139− accData acc tyn (map (\ (_, n, _, _) -> n) cons')

139+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons')

140 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons')))

141 <?> "data type declaration"

142 where

@@ -144,7 +144,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

144 mkPApp fc t [] = t

145 mkPApp fc t xs = PApp fc t (map pexp xs)

146 bindArgs :: [PTerm] -> PTerm -> PTerm

147− bindArgs xs t = foldr (PPi expl (MN 0 "_t")) t xs

147+ bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs

148 combineDataOpts :: DataOpts -> DataOpts

149 combineDataOpts opts = if Codata `elem` opts then delete DefaultEliminator opts else opts

150

@@ -152,20 +152,24 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

152{- | Parses a type constructor declaration

153 Constructor ::= DocComment? FnName TypeSig;

154-}

155−constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)

155+constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC, [Name])

156constructor syn

157 = do doc <- option "" (docComment '|')

158 cn_in <- fnName; fc <- getFC

159 let cn = expandNS syn cn_in

160 lchar ':'

161+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

162+ -- erasing non-forceable things

163+ fs <- option [] (do lchar '%'; reserved "erase"

164+ sepBy1 name (lchar ','))

161 ty <- typeExpr (allowImp syn)

165 ty <- typeExpr (allowImp syn)

162− return (doc, cn, ty, fc)

166+ return (doc, cn, ty, fc, fs)

163 <?> "constructor"

167 <?> "constructor"

164

168

165{- | Parses a constructor for simple discriminative union data types

169{- | Parses a constructor for simple discriminative union data types

166 SimpleConstructor ::= FnName SimpleExpr* DocComment?

170 SimpleConstructor ::= FnName SimpleExpr* DocComment?

167-}

171-}

168−simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)

172+simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC, [Name])

169simpleConstructor syn

173simpleConstructor syn

170 = do cn_in <- fnName

174 = do cn_in <- fnName

171 let cn = expandNS syn cn_in

175 let cn = expandNS syn cn_in

@@ -173,7 +177,7 @@ simpleConstructor syn

173 args <- many (do notEndApp

177 args <- many (do notEndApp

174 simpleExpr syn)

178 simpleExpr syn)

175 doc <- option "" (docComment '^')

179 doc <- option "" (docComment '^')

176− return (doc, cn, args, fc)

180+ return (doc, cn, args, fc, [])

177 <?> "constructor"

181 <?> "constructor"

178

182

179{- | Parses a dsl block declaration

183{- | Parses a dsl block declaration

src/Idris/ParseExpr.hs+41−27

@@ -190,6 +190,7 @@ internalExpr syn =

190 try (app syn)

191 <|> try (matchApp syn)

192 <|> try (unifyLog syn)

193+ <|> try (disamb syn)

193 <|> try (noImplicits syn)

194 <|> try (noImplicits syn)

194 <|> recordType syn

195 <|> recordType syn

195 <|> lambda syn

196 <|> lambda syn

@@ -295,7 +296,7 @@ simpleExpr syn =

295 fc <- getFC

296 fc <- getFC

296 return (modifyConst syn fc (PConstant c)))

297 return (modifyConst syn fc (PConstant c)))

297 <|> try (do symbol "'"; fc <- getFC; str <- name

298 <|> try (do symbol "'"; fc <- getFC; str <- name

298− return (PApp fc (PRef fc (UN "Symbol_"))

299+ return (PApp fc (PRef fc (sUN "Symbol_"))

299 [pexp (PConstant (Str (show str)))]))

300 [pexp (PConstant (Str (show str)))]))

300 <|> do fc <- getFC

301 <|> do fc <- getFC

301 x <- fnName

302 x <- fnName

@@ -360,12 +361,12 @@ bracketed syn =

360 l <- expr' syn

361 l <- expr' syn

361 o <- operator

362 o <- operator

362 lchar ')'

363 lchar ')'

363− return $ PLam (MN 1000 "ARG") Placeholder

364+ return $ PLam (sMN 1000 "ARG") Placeholder

364− (PApp fc0 (PRef fc0 (UN o)) [pexp l,

365+ (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

365− pexp (PRef fc0 (MN 1000 "ARG"))]))

366+ pexp (PRef fc0 (sMN 1000 "ARG"))]))

366 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

367 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

367− return $ PLam (MN 1000 "ARG") Placeholder

368+ return $ PLam (sMN 1000 "ARG") Placeholder

368− (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),

369+ (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

369 pexp e]))

370 pexp e]))

370 <|> try (do ln <- name; lchar ':'

371 <|> try (do ln <- name; lchar ':'

371 lty <- expr syn

372 lty <- expr syn

@@ -388,7 +389,7 @@ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

388modifyConst syn fc (PConstant (BI x))

389modifyConst syn fc (PConstant (BI x))

389 | not (inPattern syn)

390 | not (inPattern syn)

390 = PAlternative False

391 = PAlternative False

391− (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]

392+ (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI (fromInteger x)))]

392 : consts)

393 : consts)

393 | otherwise = PAlternative False consts

394 | otherwise = PAlternative False consts

394 where

395 where

@@ -420,8 +421,8 @@ listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lc

420 <?> "list expression"

421 <?> "list expression"

421 where

422 where

422 mkList :: FC -> [PTerm] -> PTerm

423 mkList :: FC -> [PTerm] -> PTerm

423− mkList fc [] = PRef fc (UN "Nil")

424+ mkList fc [] = PRef fc (sUN "Nil")

424− mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]

425+ mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

425

426

427

427{- | Parses an alternative expression

428{- | Parses an alternative expression

@@ -466,10 +467,10 @@ matchApp syn = do ty <- simpleExpr syn

466 symbol "<=="

467 symbol "<=="

467 fc <- getFC

468 fc <- getFC

468 f <- fnName

469 f <- fnName

469− return (PLet (MN 0 "match")

470+ return (PLet (sMN 0 "match")

470 ty

471 ty

471 (PMatchApp fc f)

472 (PMatchApp fc f)

472− (PRef fc (MN 0 "match")))

473+ (PRef fc (sMN 0 "match")))

473 <?> "matching application expression"

474 <?> "matching application expression"

474

475

475{- | Parses a unification log expression

476{- | Parses a unification log expression

@@ -483,6 +484,19 @@ unifyLog syn = do lchar '%'; reserved "unifyLog";

483 return (PUnifyLog tm)

484 return (PUnifyLog tm)

484 <?> "unification log expression"

485 <?> "unification log expression"

485

486

487+{- | Parses a disambiguation expression

488+Disamb ::=

489+ '%' 'disamb' NameList Expr

490+ ;

491+-}

492+disamb :: SyntaxInfo -> IdrisParser PTerm

493+disamb syn = do reserved "with";

494+ ns <- sepBy1 name (lchar ',')

495+ tm <- expr' syn

496+ return (PDisamb (map tons ns) tm)

497+ <?> "unification log expression"

498+ where tons (NS n s) = txt (show n) : s

499+ tons n = [txt (show n)]

486{- | Parses a no implicits expression

500{- | Parses a no implicits expression

487@

501@

488NoImplicits ::=

502NoImplicits ::=

@@ -512,12 +526,12 @@ app syn = do f <- reserved "mkForeign"

512 i <- get

526 i <- get

513 -- mkForeign f args ==>

527 -- mkForeign f args ==>

514 -- liftPrimIO (\w => mkForeignPrim f args w)

528 -- liftPrimIO (\w => mkForeignPrim f args w)

515− let ap = PApp fc (PRef fc (UN "liftPrimIO"))

529+ let ap = PApp fc (PRef fc (sUN "liftPrimIO"))

516− [pexp (PLam (MN 0 "w")

530+ [pexp (PLam (sMN 0 "w")

517 Placeholder

531 Placeholder

518− (PApp fc (PRef fc (UN "mkForeignPrim"))

532+ (PApp fc (PRef fc (sUN "mkForeignPrim"))

519 (fn : args ++

533 (fn : args ++

520− [pexp (PRef fc (MN 0 "w"))])))]

534+ [pexp (PRef fc (sMN 0 "w"))])))]

521 return (dslify i ap)

535 return (dslify i ap)

522

536

523 <|> do f <- simpleExpr syn

537 <|> do f <- simpleExpr syn

@@ -566,7 +580,7 @@ implicitArg syn = do lchar '{'

566 v <- option (PRef fc n) (do lchar '='

580 v <- option (PRef fc n) (do lchar '='

567 expr syn)

581 expr syn)

568 lchar '}'

582 lchar '}'

569− return (pimp n v False)

583+ return (pimp n v True)

570 <?> "implicit function argument"

584 <?> "implicit function argument"

571

585

572{-| Parses a constraint argument (for selecting a named type class instance)

586{-| Parses a constraint argument (for selecting a named type class instance)

@@ -611,8 +625,8 @@ recordType syn

611 rec <- optional (simpleExpr syn)

625 rec <- optional (simpleExpr syn)

612 case rec of

626 case rec of

613 Nothing ->

627 Nothing ->

614− return (PLam (MN 0 "fldx") Placeholder

628+ return (PLam (sMN 0 "fldx") Placeholder

615− (applyAll fc fields (PRef fc (MN 0 "fldx"))))

629+ (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

616 Just v -> return (applyAll fc fields v)

630 Just v -> return (applyAll fc fields v)

617 <?> "record setting expression"

631 <?> "record setting expression"

618 where fieldType :: IdrisParser (Name, PTerm)

632 where fieldType :: IdrisParser (Name, PTerm)

@@ -628,8 +642,8 @@ recordType syn

628

642

629-- | Creates setters for record types on necessary functions

643-- | Creates setters for record types on necessary functions

630mkType :: Name -> Name

644mkType :: Name -> Name

631−mkType (UN n) = UN ("set_" ++ n)

645+mkType (UN n) = sUN ("set_" ++ str n)

632−mkType (MN 0 n) = MN 0 ("set_" ++ n)

646+mkType (MN 0 n) = sMN 0 ("set_" ++ str n)

633mkType (NS n s) = NS (mkType n) s

647mkType (NS n s) = NS (mkType n) s

634

648

635{- | Parses a type signature

649{- | Parses a type signature

@@ -645,7 +659,7 @@ TypeExpr ::= ConstraintList? Expr;

645typeExpr :: SyntaxInfo -> IdrisParser PTerm

659typeExpr :: SyntaxInfo -> IdrisParser PTerm

646typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

660typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

647 sc <- expr syn

661 sc <- expr syn

648− 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)

649 <?> "type signature"

663 <?> "type signature"

650

664

651{- | Parses a lambda expression

665{- | Parses a lambda expression

@@ -678,8 +692,8 @@ lambda syn = do lchar '\\'

678 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

692 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

679 pmList [] sc = sc

693 pmList [] sc = sc

680 pmList ((i, (fc, x)) : xs) sc

694 pmList ((i, (fc, x)) : xs) sc

681− = PLam (MN i "lamp") Placeholder

695+ = PLam (sMN i "lamp") Placeholder

682− (PCase fc (PRef fc (MN i "lamp"))

696+ (PCase fc (PRef fc (sMN i "lamp"))

683 [(x, pmList xs sc)])

697 [(x, pmList xs sc)])

684

698

685{- | Parses a term rewrite expression

699{- | Parses a term rewrite expression

@@ -696,7 +710,7 @@ rewriteTerm syn = do reserved "rewrite"

696 giving <- optional (do symbol "==>"; expr' syn)

710 giving <- optional (do symbol "==>"; expr' syn)

697 reserved "in"; sc <- expr syn

711 reserved "in"; sc <- expr syn

698 return (PRewrite fc

712 return (PRewrite fc

699− (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc

713+ (PApp fc (PRef fc (sUN "sym")) [pexp prf]) sc

700 giving)

714 giving)

701 <?> "term rewrite expression"

715 <?> "term rewrite expression"

702

716

@@ -861,7 +875,7 @@ tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

861 where nameOrPlaceholder :: IdrisParser Name

875 where nameOrPlaceholder :: IdrisParser Name

862 nameOrPlaceholder = fnName

876 nameOrPlaceholder = fnName

863 <|> do symbol "_"

877 <|> do symbol "_"

864− return (MN 0 "underscore")

878+ return (sMN 0 "underscore")

865 <?> "name or placeholder"

879 <?> "name or placeholder"

866

880

867{- | Parses a list comprehension

881{- | Parses a list comprehension

@@ -885,11 +899,11 @@ comprehension syn

885 qs <- sepBy1 (do_ syn) (lchar ',')

899 qs <- sepBy1 (do_ syn) (lchar ',')

886 lchar ']'

900 lchar ']'

887 return (PDoBlock (map addGuard qs ++

901 return (PDoBlock (map addGuard qs ++

888− [DoExp fc (PApp fc (PRef fc (UN "return"))

902+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

889 [pexp pat])]))

903 [pexp pat])]))

890 <?> "list comprehension"

904 <?> "list comprehension"

891 where addGuard :: PDo -> PDo

905 where addGuard :: PDo -> PDo

892− 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"))

893 [pexp e])

907 [pexp e])

894 addGuard x = x

908 addGuard x = x

895

909

src/Idris/ParseHelpers.hs+2−2

@@ -230,8 +230,8 @@ initsEndAt p (x:xs) | p x = [] : x_inits_xs

230 namespace.

231-}

232mkName :: (String, String) -> Name

233−mkName (n, "") = UN n

233+mkName (n, "") = sUN n

234−mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

234+mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))

235 where parseNS x = case span (/= '.') x of

236 (x, "") -> [x]

237 (x, '.':y) -> x : parseNS y

src/Idris/ParseOps.hs+6−5

@@ -33,21 +33,22 @@ import qualified Data.ByteString.UTF8 as UTF8

33-- using pre-build and user-defined operator/fixity declarations

34table :: [FixDecl] -> OperatorTable IdrisParser PTerm

35table fixes

36− = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))

36+ = [[prefix "-" (\fc x -> PApp fc (PRef fc (sUN "-"))

37− [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

37+ [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

38 ++ toTable (reverse fixes) ++

39 [[backtick],

40+ [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

40 [binary "=" PEq AssocLeft],

41 [binary "=" PEq AssocLeft],

41− [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]]

42+ [binary "->" (\fc x y -> PPi expl (sMN 42 "__pi_arg") x y) AssocRight]]

43-- | Calculates table for fixtiy declarations

44-- | Calculates table for fixtiy declarations

44toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

45toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

45toTable fs = map (map toBin)

46toTable fs = map (map toBin)

46 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

47 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

47 where toBin (Fix (PrefixN _) op) = prefix op

48 where toBin (Fix (PrefixN _) op) = prefix op

48− (\fc x -> PApp fc (PRef fc (UN op)) [pexp x])

49+ (\fc x -> PApp fc (PRef fc (sUN op)) [pexp x])

49 toBin (Fix f op)

50 toBin (Fix f op)

50− = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f)

51+ = binary op (\fc x y -> PApp fc (PRef fc (sUN op)) [pexp x,pexp y]) (assoc f)

51 assoc (Infixl _) = AssocLeft

52 assoc (Infixl _) = AssocLeft

52 assoc (Infixr _) = AssocRight

53 assoc (Infixr _) = AssocRight

53 assoc (InfixN _) = AssocNone

54 assoc (InfixN _) = AssocNone

src/Idris/Parser.hs+22−13

@@ -21,6 +21,7 @@ import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

21import Idris.AbsSyntax

22import Idris.DSL

23import Idris.Imports

24+import Idris.Delaborate

24import Idris.Error

25import Idris.Error

25import Idris.ElabDecls

26import Idris.ElabDecls

26import Idris.ElabTerm hiding (namespace, params)

27import Idris.ElabTerm hiding (namespace, params)

@@ -43,6 +44,7 @@ import Idris.Core.Evaluate

44import Control.Applicative

45import Control.Applicative

45import Control.Monad

46import Control.Monad

47+import Control.Monad.Error (throwError, catchError)

46import Control.Monad.State.Strict

48import Control.Monad.State.Strict

48import Data.Maybe

50import Data.Maybe

@@ -79,7 +81,9 @@ moduleHeader = try (do reserved "module"

79 i <- identifier

81 i <- identifier

80 option ';' (lchar ';')

82 option ';' (lchar ';')

81 return (moduleName i))

83 return (moduleName i))

82− <|> return []

84+ <|> try (do lchar '%'; reserved "unqualified"

85+ return [])

86+ <|> return (moduleName "Main")

83 where moduleName x = case span (/='.') x of

87 where moduleName x = case span (/='.') x of

84 (x, "") -> [x]

88 (x, "") -> [x]

85 (x, '.':y) -> x : moduleName y

89 (x, '.':y) -> x : moduleName y

@@ -298,9 +302,9 @@ fnDecl' syn = checkFixity $

298 getName (PTy _ _ _ _ n _) = Just n

302 getName (PTy _ _ _ _ n _) = Just n

299 getName _ = Nothing

303 getName _ = Nothing

300 fixityOK (NS n _) = fixityOK n

304 fixityOK (NS n _) = fixityOK n

301− fixityOK (UN n) | all (flip elem opChars) n =

305+ fixityOK (UN n) | all (flip elem opChars) (str n) =

302 do fixities <- fmap idris_infixes get

306 do fixities <- fmap idris_infixes get

303− return . elem n . map (\ (Fix _ op) -> op) $ fixities

307+ return . elem (str n) . map (\ (Fix _ op) -> op) $ fixities

304 | otherwise = return True

308 | otherwise = return True

305 fixityOK _ = return True

309 fixityOK _ = return True

306

310

@@ -515,7 +519,7 @@ instance_ syn = do reserved "instance"; fc <- getFC

515 cn <- name

519 cn <- name

516 args <- many (simpleExpr syn)

520 args <- many (simpleExpr syn)

517 let sc = PApp fc (PRef fc cn) (map pexp args)

521 let sc = PApp fc (PRef fc cn) (map pexp args)

518− 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

519 ds <- option [] (instanceBlock syn)

523 ds <- option [] (instanceBlock syn)

520 return [PInstance syn fc cs cn args t en ds]

524 return [PInstance syn fc cs cn args t en ds]

521 <?> "instance declaration"

525 <?> "instance declaration"

@@ -573,7 +577,7 @@ Pattern ::= Clause;

573pattern :: SyntaxInfo -> IdrisParser PDecl

577pattern :: SyntaxInfo -> IdrisParser PDecl

574pattern syn = do fc <- getFC

578pattern syn = do fc <- getFC

575 clause <- clause syn

579 clause <- clause syn

576− return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later

580+ return (PClauses fc [] (sMN 2 "_") [clause]) -- collect together later

577 <?> "pattern"

581 <?> "pattern"

578

582

579{- | Parse a constant applicative form declaration

583{- | Parse a constant applicative form declaration

@@ -615,7 +619,7 @@ rhs syn n = do lchar '='; expr syn

615 <|> do reserved "impossible"; return PImpossible

619 <|> do reserved "impossible"; return PImpossible

616 <?> "function right hand side"

620 <?> "function right hand side"

617 where mkN :: Name -> Name

621 where mkN :: Name -> Name

618− mkN (UN x) = UN (x++"_lemma_1")

622+ mkN (UN x) = sUN (str x++"_lemma_1")

619 mkN (NS x n) = NS (mkN x) n

623 mkN (NS x n) = NS (mkN x) n

620 n' :: Name

624 n' :: Name

621 n' = mkN n

625 n' = mkN n

@@ -623,7 +627,7 @@ rhs syn n = do lchar '='; expr syn

623 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

627 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

624 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

628 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

625 where addLetC (l, r) = (l, addLet nm r)

629 where addLetC (l, r) = (l, addLet nm r)

626− addLet nm r = (PLet (UN "value") Placeholder r (PMetavar nm))

630+ addLet nm r = (PLet (sUN "value") Placeholder r (PMetavar nm))

627

631

628{- |Parses a function clause

632{- |Parses a function clause

629RHSOrWithBlock ::= RHS WhereOrTerminator

633RHSOrWithBlock ::= RHS WhereOrTerminator

@@ -677,10 +681,10 @@ clause syn

677 return x,

681 return x,

678 do terminator

682 do terminator

679 return ([], [])]

683 return ([], [])]

680− let capp = PLet (MN 0 "match")

684+ let capp = PLet (sMN 0 "match")

681 ty

685 ty

682 (PMatchApp fc n)

686 (PMatchApp fc n)

683− (PRef fc (MN 0 "match"))

687+ (PRef fc (sMN 0 "match"))

684 ist <- get

688 ist <- get

685 put (ist { lastParse = Just n })

689 put (ist { lastParse = Just n })

686 return $ PClause fc n capp [] r wheres

690 return $ PClause fc n capp [] r wheres

@@ -691,7 +695,7 @@ clause syn

691 when (op == "=" || op == "?=" ) $

695 when (op == "=" || op == "?=" ) $

692 fail "infix clause definition with \"=\" and \"?=\" not supported "

696 fail "infix clause definition with \"=\" and \"?=\" not supported "

693 return (l, op))

697 return (l, op))

694− let n = expandNS syn (UN op)

698+ let n = expandNS syn (sUN op)

695 r <- argExpr syn

699 r <- argExpr syn

696 fc <- getFC

700 fc <- getFC

697 wargs <- many (wExpr syn)

701 wargs <- many (wExpr syn)

@@ -866,8 +870,13 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

866 ty <- iName []

870 ty <- iName []

867 ns <- sepBy1 name (lchar ',')

871 ns <- sepBy1 name (lchar ',')

868 return [PDirective

872 return [PDirective

869− (do mapM_ (addNameHint ty) ns

873+ (do i <- getIState

870− mapM_ (\n -> addIBC (IBCNameHint (ty, n))) ns)]

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)]

871 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

880 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

872 return [PDirective (addLangExt ext)]

881 return [PDirective (addLangExt ext)]

873 <?> "directive"

882 <?> "directive"

@@ -1004,7 +1013,7 @@ loadModule' outh f

1004 LIDR fn -> loadSource outh True fn

1013 LIDR fn -> loadSource outh True fn

1005 IBC fn src ->

1014 IBC fn src ->

1006 idrisCatch (loadIBC fn)

1015 idrisCatch (loadIBC fn)

1007− (\c -> do iLOG $ fn ++ " failed " ++ show c

1016+ (\c -> do iLOG $ fn ++ " failed " ++ pshow i c

1008 case src of

1017 case src of

1009 IDR sfn -> loadSource outh False sfn

1018 IDR sfn -> loadSource outh False sfn

1010 LIDR sfn -> loadSource outh True sfn)

1019 LIDR sfn -> loadSource outh True sfn)

src/Idris/PartialEval.hs+2−2

@@ -54,7 +54,7 @@ specType args ty = let (t, args') = runState (unifyEq args ty) [] in

54 sc' <- unifyEq xs sc

55 return (Bind n (Pi t) sc')

56 unifyEq xs t = do args <- get

57− put (args ++ (zip xs (repeat (UN "_"))))

57+ put (args ++ (zip xs (repeat (sUN "_"))))

58 return t

60mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

@@ -122,7 +122,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

122 | x && imparg imp = (ImplicitS, tm)

123 | x = (ExplicitS, tm)

124 | imparg imp = (ImplicitD, tm)

125− | otherwise = (ExplicitD, (P Ref (UN (show n ++ "arg")) Erased))

125+ | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126

127 imparg (PExp _ _ _ _) = False

128 imparg _ = True

src/Idris/Primitives.hs+50−50

@@ -26,7 +26,7 @@ data Prim = Prim { p_name :: Name,

27ty :: [Const] -> Const -> Type

28ty [] x = Constant x

29−ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x)

29+ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x)

31total, partial :: Totality

32total = Total []

@@ -94,83 +94,83 @@ primitives =

94 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,

95 iCoerce ITBig ITChar "trunc" trunc LTrunc,

97− Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

97+ Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

98 (2, LPlus ATFloat) total,

99− Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

99+ Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

100 (2, LMinus ATFloat) total,

101− Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

101+ Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

102 (2, LTimes ATFloat) total,

103− Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

103+ Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

104 (2, LSDiv ATFloat) total,

105− Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

105+ Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

106 (2, LEq ATFloat) total,

107− Prim (UN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

107+ Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

108 (2, LSLt ATFloat) total,

109− Prim (UN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

109+ Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

110 (2, LSLe ATFloat) total,

111− Prim (UN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

111+ Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

112 (2, LSGt ATFloat) total,

113− Prim (UN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

113+ Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

114 (2, LSGe ATFloat) total,

115− Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

115+ Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

116 (2, LStrConcat) total,

117− Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

117+ Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

118 (2, LStrEq) total,

119− Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

119+ Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

120 (2, LStrLt) total,

121− Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

121+ Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

122 (1, LStrLen) total,

123 -- Conversions

124− Prim (UN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

124+ Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

125 (1, LChInt ITNative) total,

126− Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

126+ Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

127 (1, LIntCh ITNative) total,

128− Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

128+ Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

129 (1, LStrFloat) total,

130− Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

130+ Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

131 (1, LFloatStr) total,

132

133− Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

133+ Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

134 (1, LFExp) total,

135− Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

135+ Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

136 (1, LFLog) total,

137− Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

137+ Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

138 (1, LFSin) total,

139− Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

139+ Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

140 (1, LFCos) total,

141− Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

141+ Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

142 (1, LFTan) total,

143− Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

143+ Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

144 (1, LFASin) total,

145− Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

145+ Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

146 (1, LFACos) total,

147− Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

147+ Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

148 (1, LFATan) total,

149− Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

149+ Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

150 (1, LFSqrt) total,

151− Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

151+ Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

152 (1, LFFloor) total,

153− Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

153+ Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

154 (1, LFCeil) total,

155

156− Prim (UN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

156+ Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

157 (1, LStrHead) partial,

158− Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

158+ Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

159 (1, LStrTail) partial,

160− Prim (UN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

160+ Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

161 (2, LStrCons) total,

162− Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

162+ Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

163 (2, LStrIndex) partial,

164− Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

164+ Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

165 (1, LStrRev) total,

166− Prim (UN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

166+ Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

167 (1, LReadStr) partial,

168− Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

168+ Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

169 (0, LVMPtr) total,

170 -- Streams

171− Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

171+ Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

172 (0, LStdIn) partial,

173− Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

173+ Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

174 (0, LNullPtr) total

175 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]

176 ++ concatMap vecOps vecTypes

@@ -221,13 +221,13 @@ intArith ity =

221

222intConv :: IntTy -> [Prim]

223intConv ity =

224− [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

224+ [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

225 (1, LIntStr ity) total

226− , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

226+ , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

227 (1, LStrInt ity) total

228− , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

228+ , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

229 (1, LIntFloat ity) total

230− , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

230+ , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

231 (1, LFloatInt ity) total

232 ]

233

@@ -246,13 +246,13 @@ vecCmps ity =

246

247vecOps :: IntTy -> [Prim]

248vecOps ity@(ITVec elem count) =

249− [ Prim (UN $ "prim__mk" ++ intTyName ity)

249+ [ Prim (sUN $ "prim__mk" ++ intTyName ity)

250 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))

251 count (mkVecCon elem count) (count, LMkVec elem count) total

252− , Prim (UN $ "prim__index" ++ intTyName ity)

252+ , Prim (sUN $ "prim__index" ++ intTyName ity)

253 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))

254 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces

255− , Prim (UN $ "prim__update" ++ intTyName ity)

255+ , Prim (sUN $ "prim__update" ++ intTyName ity)

256 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]

257 (AType . ATInt $ ity))

258 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces

@@ -260,7 +260,7 @@ vecOps ity@(ITVec elem count) =

260

261bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim

262bitcastPrim from to impl prim =

263− Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

263+ Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

264 (1, prim) total

265

266vecBitcasts :: [IntTy] -> [Prim]

@@ -377,23 +377,23 @@ intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show cou

377

378iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

379iCmp ity op self impl irop totality

380− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

380+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

381 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))

382 2 impl (2, irop ity) totality

383

384iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

385iBinOp ity op impl irop totality

386− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

386+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

387 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))

388 2 impl (2, irop ity) totality

389iUnOp ity op impl irop totality

390− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

390+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

391 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))

392 1 impl (1, irop ity) totality

393

394iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

395iCoerce from to op impl irop =

396− Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

396+ Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

397 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total

398

399fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const

src/Idris/Prover.hs+3−2

@@ -20,7 +20,7 @@ import Text.Trifecta.Result(Result(..))

21import System.Console.Haskeline

22import System.Console.Haskeline.History

23−import Control.Monad.State

23+import Control.Monad.State.Strict

25import Util.Pretty

26import Debug.Trace

@@ -102,7 +102,8 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

102 tPretty t = pretty $ delab ist t

103

104 prettyPs [] = empty

105− prettyPs ((MN _ "rewrite_rule", _) : bs) = prettyPs bs

105+ prettyPs ((MN _ r, _) : bs)

106+ | r == txt "rewrite_rule" = prettyPs bs

106 prettyPs ((n, Let t v) : bs) =

107 prettyPs ((n, Let t v) : bs) =

107 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108 tPretty t $$ prettyPs bs)

109 tPretty t $$ prettyPs bs)

src/Idris/Providers.hs+14−7

@@ -11,17 +11,24 @@ import Debug.Trace

12-- | Wrap a type provider in the type of type providers

13providerTy :: FC -> PTerm -> PTerm

14−providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

14+providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 False tm ""]

15+

16+ioret = sUN "prim_io_return"

17+ermod = sNS (sUN "Error") ["Providers"]

18+prmod = sNS (sUN "Provide") ["Providers"]

16-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

20-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

17getProvided :: TT Name -> Idris (TT Name)

21getProvided :: TT Name -> Idris (TT Name)

18−getProvided tm | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

22+getProvided tm | (P _ pioret _, [tp, result]) <- unApply tm

19− , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =

23+ , (P _ nm _, [_, err]) <- unApply result

20− case err of

24+ , pioret == ioret && nm == ermod

25+ = case err of

21 Constant (Str msg) -> ierror . ProviderError $ msg

26 Constant (Str msg) -> ierror . ProviderError $ msg

22 _ -> ifail "Internal error in type provider, non-normalised error"

27 _ -> ifail "Internal error in type provider, non-normalised error"

23− | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

28+ | (P _ pioret _, [tp, result]) <- unApply tm

24− , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =

29+ , (P _ nm _, [_, res]) <- unApply result

25− return res

30+ , pioret == ioret && nm == prmod

31+ = return res

26 | otherwise = ifail $ "Internal type provider error: result was not " ++

32 | otherwise = ifail $ "Internal type provider error: result was not " ++

27 "IO (Provider a), or perhaps missing normalisation."

33 "IO (Provider a), or perhaps missing normalisation."

34+

src/Idris/REPL.hs+56−44

@@ -80,31 +80,33 @@ repl :: IState -- ^ The initial state

80 -> [FilePath] -- ^ The loaded modules

81 -> InputT Idris ()

82repl orig mods

83− = H.catch

83+ = -- H.catch

84− (do let quiet = opt_quiet (idris_options orig)

84+ do let quiet = opt_quiet (idris_options orig)

85− i <- lift getIState

85+ i <- lift getIState

86− let colour = idris_colourRepl i

86+ let colour = idris_colourRepl i

87− let theme = idris_colourTheme i

87+ let theme = idris_colourTheme i

88− let mvs = idris_metavars i

88+ let mvs = idris_metavars i

89− let prompt = if quiet

89+ let prompt = if quiet

90− then ""

90+ then ""

91− else showMVs colour theme mvs ++

91+ else showMVs colour theme mvs ++

92− let str = mkPrompt mods ++ ">" in

92+ let str = mkPrompt mods ++ ">" in

93− (if colour then colourisePrompt theme str else str) ++ " "

93+ (if colour then colourisePrompt theme str else str) ++ " "

94− x <- getInputLine prompt

94+ x <- H.catch (getInputLine prompt)

95− case x of

95+ (ctrlC (return Nothing))

96− Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

96+ case x of

97− return ()

97+ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

98− Just input -> H.catch

98+ return ()

99− (do ms <- lift $ processInput input orig mods

99+ Just input -> -- H.catch

100− case ms of

100+ do ms <- H.catch (lift $ processInput input orig mods)

101− Just mods -> repl orig mods

101+ (ctrlC (return (Just mods)))

102− Nothing -> return ())

102+ case ms of

103− ctrlC)

103+ Just mods -> repl orig mods

104− ctrlC

104+ Nothing -> return ()

105− where ctrlC :: SomeException -> InputT Idris ()

105+-- ctrlC)

106− ctrlC e = do lift $ iputStrLn (show e)

106+-- ctrlC

107− repl orig mods

107+ where ctrlC :: InputT Idris a -> SomeException -> InputT Idris a

108+ ctrlC act e = do lift $ iputStrLn (show e)

109+ act -- repl orig mods

108

110

109 showMVs c thm [] = ""

111 showMVs c thm [] = ""

110 showMVs c thm ms = "Metavariables: " ++

112 showMVs c thm ms = "Metavariables: " ++

@@ -245,19 +247,19 @@ ideslave orig mods

245 Just x -> iPrintError $ "didn't load " ++ filename

247 Just x -> iPrintError $ "didn't load " ++ filename

246 ideslave orig [filename]

248 ideslave orig [filename]

247 Just (IdeSlave.TypeOf name) ->

249 Just (IdeSlave.TypeOf name) ->

248− process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (UN name)))

250+ process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (sUN name)))

249 Just (IdeSlave.CaseSplit line name) ->

251 Just (IdeSlave.CaseSplit line name) ->

250− process stdout fn (CaseSplitAt False line (UN name))

252+ process stdout fn (CaseSplitAt False line (sUN name))

251 Just (IdeSlave.AddClause line name) ->

253 Just (IdeSlave.AddClause line name) ->

252− process stdout fn (AddClauseFrom False line (UN name))

254+ process stdout fn (AddClauseFrom False line (sUN name))

253 Just (IdeSlave.AddProofClause line name) ->

255 Just (IdeSlave.AddProofClause line name) ->

254− process stdout fn (AddProofClauseFrom False line (UN name))

256+ process stdout fn (AddProofClauseFrom False line (sUN name))

255 Just (IdeSlave.AddMissing line name) ->

257 Just (IdeSlave.AddMissing line name) ->

256− process stdout fn (AddMissing False line (UN name))

258+ process stdout fn (AddMissing False line (sUN name))

257 Just (IdeSlave.MakeWithBlock line name) ->

259 Just (IdeSlave.MakeWithBlock line name) ->

258− process stdout fn (MakeWith False line (UN name))

260+ process stdout fn (MakeWith False line (sUN name))

259 Just (IdeSlave.ProofSearch line name hints) ->

261 Just (IdeSlave.ProofSearch line name hints) ->

260− process stdout fn (DoProofSearch False line (UN name) (map UN hints))

262+ process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

261 Nothing -> do iPrintError "did not understand")

263 Nothing -> do iPrintError "did not understand")

262 (\e -> do iPrintError $ show e))

264 (\e -> do iPrintError $ show e))

263 (\e -> do iPrintError $ show e)

265 (\e -> do iPrintError $ show e)

@@ -406,6 +408,7 @@ edit f orig

406 , idris_colourTheme = idris_colourTheme i

408 , idris_colourTheme = idris_colourTheme i

407 }

409 }

408 loadInputs stdout [f]

410 loadInputs stdout [f]

411+-- clearOrigPats

409 iucheck

412 iucheck

410 return ()

413 return ()

411 where getEditor env | Just ed <- lookup "EDITOR" env = ed

414 where getEditor env | Just ed <- lookup "EDITOR" env = ed

@@ -441,7 +444,7 @@ process h fn (Eval t)

441 let tm' = force (normaliseAll ctxt [] tm)

444 let tm' = force (normaliseAll ctxt [] tm)

442 let ty' = force (normaliseAll ctxt [] ty)

445 let ty' = force (normaliseAll ctxt [] ty)

443 -- Add value to context, call it "it"

446 -- Add value to context, call it "it"

444− updateContext (addCtxtDef (UN "it") (Function ty' tm'))

447+ updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

445 ist <- getIState

448 ist <- getIState

446 logLvl 3 $ "Raw: " ++ show (tm', ty')

449 logLvl 3 $ "Raw: " ++ show (tm', ty')

447 logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

450 logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

@@ -482,7 +485,7 @@ process h fn (Check (PRef _ n))

482 = let current = " " ++

485 = let current = " " ++

483 (case n of

486 (case n of

484 MN _ _ -> "_"

487 MN _ _ -> "_"

485− UN ('_':'_':_) -> "_"

488+ UN nm | ('_':'_':_) <- str nm -> "_"

486 _ -> showName (Just ist) [] False c n) ++

489 _ -> showName (Just ist) [] False c n) ++

487 " : " ++ showImp (Just ist) imp c t ++ "\n"

490 " : " ++ showImp (Just ist) imp c t ++ "\n"

488 in

491 in

@@ -849,8 +852,8 @@ process h fn (TestInline t)

849process h fn Execute

852process h fn Execute

850 = do (m, _) <- elabVal toplevel False

853 = do (m, _) <- elabVal toplevel False

851 (PApp fc

854 (PApp fc

852− (PRef fc (UN "run__IO"))

855+ (PRef fc (sUN "run__IO"))

853− [pexp $ PRef fc (NS (UN "main") ["Main"])])

856+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

854-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

857-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

855 (tmpn, tmph) <- runIO tempfile

858 (tmpn, tmph) <- runIO tempfile

856 runIO $ hClose tmph

859 runIO $ hClose tmph

@@ -861,8 +864,8 @@ process h fn Execute

861 where fc = fileFC "main"

864 where fc = fileFC "main"

862process h fn (Compile codegen f)

865process h fn (Compile codegen f)

863 = do (m, _) <- elabVal toplevel False

866 = do (m, _) <- elabVal toplevel False

864− (PApp fc (PRef fc (UN "run__IO"))

867+ (PApp fc (PRef fc (sUN "run__IO"))

865− [pexp $ PRef fc (NS (UN "main") ["Main"])])

868+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

866 compile codegen f m

869 compile codegen f m

867 where fc = fileFC "main"

870 where fc = fileFC "main"

868process h fn (LogLvl i) = setLogLevel i

871process h fn (LogLvl i) = setLogLevel i

@@ -1005,11 +1008,14 @@ parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)

1005parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

1008parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

1006parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

1009parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

1007parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1010parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1011+-- Package Related options

1008parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

1012parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

1009parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

1013parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

1010parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

1014parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

1011parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

1015parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

1012parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1016parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1017+parseArgs ("--checkpkg":n:ns) = PkgCheck n : (parseArgs ns)

1018+-- Misc Options

1013parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

1019parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

1014parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

1020parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

1015parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

1021parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

@@ -1101,12 +1107,13 @@ loadInputs h inputs

1101 when (not loadCode) $ tryLoad $ nub (concat ifiles)

1107 when (not loadCode) $ tryLoad $ nub (concat ifiles)

1102 _ -> return ()

1108 _ -> return ()

1103 putIState inew)

1109 putIState inew)

1104− (\e -> do case e of

1110+ (\e -> do i <- getIState

1111+ case e of

1105 At f _ -> do setErrLine (fc_line f)

1112 At f _ -> do setErrLine (fc_line f)

1106 iputStrLn (show e)

1113 iputStrLn (show e)

1107 ProgramLineComment -> return () -- fail elsewhere

1114 ProgramLineComment -> return () -- fail elsewhere

1108 _ -> do setErrLine 3 -- FIXME! Propagate it

1115 _ -> do setErrLine 3 -- FIXME! Propagate it

1109− iputStrLn (show e))

1116+ iputStrLn (pshow i e))

1110 where -- load all files, stop if any fail

1117 where -- load all files, stop if any fail

1111 tryLoad :: [IFileType] -> Idris ()

1118 tryLoad :: [IFileType] -> Idris ()

1112 tryLoad [] = return ()

1119 tryLoad [] = return ()

@@ -1192,8 +1199,8 @@ idrisMain opts =

1192 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

1199 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

1193 return ()

1200 return ()

1194 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1201 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1195− ist <- getIState

1196

1202

1203+ orig <- getIState

1197 loadInputs stdout inputs

1204 loadInputs stdout inputs

1198

1205

1199 runIO $ hSetBuffering stdout LineBuffering

1206 runIO $ hSetBuffering stdout LineBuffering

@@ -1217,10 +1224,11 @@ idrisMain opts =

1217 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

1224 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

1218

1225

1219 when (runrepl && not idesl) $ do

1226 when (runrepl && not idesl) $ do

1227+-- clearOrigPats

1220 initScript

1228 initScript

1221− startServer ist inputs

1229+ startServer orig inputs

1222− runInputT (replSettings (Just historyFile)) $ repl ist inputs

1230+ runInputT (replSettings (Just historyFile)) $ repl orig inputs

1223− when (idesl) $ ideslaveStart ist inputs

1231+ when (idesl) $ ideslaveStart orig inputs

1224 ok <- noErrors

1232 ok <- noErrors

1225 when (not ok) $ runIO (exitWith (ExitFailure 1))

1233 when (not ok) $ runIO (exitWith (ExitFailure 1))

1226 where

1234 where

@@ -1322,6 +1330,10 @@ getPkgClean :: Opt -> Maybe String

1322getPkgClean (PkgClean str) = Just str

1330getPkgClean (PkgClean str) = Just str

1323getPkgClean _ = Nothing

1331getPkgClean _ = Nothing

1324

1332

1333+getPkgCheck :: Opt -> Maybe String

1334+getPkgCheck (PkgCheck str) = Just str

1335+getPkgCheck _ = Nothing

1336+

1325getCodegen :: Opt -> Maybe Codegen

1337getCodegen :: Opt -> Maybe Codegen

1326getCodegen (UseCodegen x) = Just x

1338getCodegen (UseCodegen x) = Just x

1327getCodegen _ = Nothing

1339getCodegen _ = Nothing

src/Idris/Transforms.hs+3−3

@@ -39,8 +39,8 @@ instance Transform CaseAlt where

40natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

42−zname = NS (UN "Z") ["Nat","Prelude"]

42+zname = sNS (sUN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

43+sname = sNS (sUN "S") ["Nat","Prelude"]

45zero :: TT Name -> TT Name

46zero (P _ n _) | n == zname

@@ -49,7 +49,7 @@ zero x = x

50suc :: TT Name -> TT Name

51suc (App (P _ s _) a) | s == sname

52− = mkApp (P Ref (UN "prim__addBigInt") Erased) [Constant (BI 1), a]

52+ = mkApp (P Ref (sUN "prim__addBigInt") Erased) [Constant (BI 1), a]

53suc x = x

55natcase :: SC -> SC

src/Idris/UnusedArgs.hs+2−1

@@ -23,6 +23,7 @@ traceUnused n

23 recused <- mapM (\ (argn, i, (g, j)) ->

24 do u <- used [(n, i)] g j

25 return (argn, u)) fargs

26+ logLvl 4 $ show n ++ " recused TRACE: " ++ show recused

26 let fused = nub $ usedns ++ map fst (filter snd recused)

27 let fused = nub $ usedns ++ map fst (filter snd recused)

27 logLvl 1 $ show n ++ " used args: " ++ show fused

28 logLvl 1 $ show n ++ " used args: " ++ show fused

28 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

29 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

@@ -50,7 +51,7 @@ used path g j

50 recused <- mapM (\ (argn, j, (g', j')) ->

51 recused <- mapM (\ (argn, j, (g', j')) ->

51 used ((g,j):path) g' j') garg

52 used ((g,j):path) g' j') garg

52 -- used on any route from here, or not used recursively

53 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

54+ return (directuse || or recused)

54 _ -> return True -- no definition, assume used

55 _ -> return True -- no definition, assume used

56getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

57getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+1−1

@@ -27,7 +27,7 @@ data PkgDesc = PkgDesc { pkgname :: String,

27 }

28 deriving Show

30−defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (UN "") Nothing

30+defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing

32parseDesc :: FilePath -> IO PkgDesc

33parseDesc fp = do p <- readFile fp

src/Pkg/Package.hs+44−5

@@ -24,13 +24,14 @@ import Pkg.PParser

25import Paths_idris (getDataDir)

27+-- | Run the package through the idris compiler.

28+--

27-- To build a package:

29-- To build a package:

28-- * read the package description

30-- * read the package description

29-- * check all the library dependencies exist

31-- * check all the library dependencies exist

30-- * invoke the makefile if there is one

32-- * invoke the makefile if there is one

31-- * invoke idris on each module, with idris_opts

33-- * invoke idris on each module, with idris_opts

32-- * install everything into datadir/pname, if install flag is set

34-- * install everything into datadir/pname, if install flag is set

33−

34buildPkg :: Bool -> (Bool, FilePath) -> IO ()

35buildPkg :: Bool -> (Bool, FilePath) -> IO ()

35buildPkg warnonly (install, fp)

36buildPkg warnonly (install, fp)

36 = do pkgdesc <- parseDesc fp

37 = do pkgdesc <- parseDesc fp

@@ -63,7 +64,33 @@ buildPkg warnonly (install, fp)

63 putStrLn $ "\t" ++ show ms

64 putStrLn $ "\t" ++ show ms

64 exitWith (ExitFailure 1)

65 exitWith (ExitFailure 1)

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 ()

67cleanPkg fp

94cleanPkg fp

68 = do pkgdesc <- parseDesc fp

95 = do pkgdesc <- parseDesc fp

69 dir <- getCurrentDirectory

96 dir <- getCurrentDirectory

@@ -74,6 +101,7 @@ cleanPkg fp

74 Nothing -> return ()

101 Nothing -> return ()

75 Just s -> rmFile $ dir </> s

102 Just s -> rmFile $ dir </> s

103

104+-- | Install package

77installPkg :: PkgDesc -> IO ()

105installPkg :: PkgDesc -> IO ()

78installPkg pkgdesc

106installPkg pkgdesc

79 = do dir <- getCurrentDirectory

107 = do dir <- getCurrentDirectory

@@ -83,6 +111,11 @@ installPkg pkgdesc

83 Just o -> return () -- do nothing, keep executable locally, for noe

111 Just o -> return () -- do nothing, keep executable locally, for noe

84 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

112 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

113

114+

115+-- ---------------------------------------------------------- [ Helper Methods ]

116+-- Methods for building, testing, installing, and removal of idris

117+-- packages.

118+

86buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

119buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

87buildMods opts ns = do let f = map (toPath . showCG) ns

120buildMods opts ns = do let f = map (toPath . showCG) ns

88-- putStrLn $ "MODULE: " ++ show f

121-- putStrLn $ "MODULE: " ++ show f

@@ -108,8 +141,8 @@ testLib warn p f

108rmIBC :: Name -> IO ()

141rmIBC :: Name -> IO ()

109rmIBC m = rmFile $ toIBCFile m

142rmIBC m = rmFile $ toIBCFile m

110

143

111−toIBCFile (UN n) = n ++ ".ibc"

144+toIBCFile (UN n) = str n ++ ".ibc"

112−toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

145+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))

113

146

114installIBC :: String -> Name -> IO ()

147installIBC :: String -> Name -> IO ()

115installIBC p m = do let f = toIBCFile m

148installIBC p m = do let f = toIBCFile m

@@ -120,7 +153,8 @@ installIBC p m = do let f = toIBCFile m

120 copyFile f (destdir </> takeFileName f)

153 copyFile f (destdir </> takeFileName f)

121 return ()

154 return ()

122 where getDest (UN n) = ""

155 where getDest (UN n) = ""

123− getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))

156+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns))

157+

124

158

125installObj :: String -> String -> IO ()

159installObj :: String -> String -> IO ()

126installObj p o = do d <- getTargetDir

160installObj p o = do d <- getTargetDir

@@ -136,12 +170,17 @@ mkDirCmd = "mkdir "

136mkDirCmd = "mkdir -p "

170mkDirCmd = "mkdir -p "

137#endif

171#endif

138

172

173+-- ------------------------------------------------------- [ Makefile Commands ]

174+-- | Invoke a Makefile's default target.

139make :: Maybe String -> IO ()

175make :: Maybe String -> IO ()

140make Nothing = return ()

176make Nothing = return ()

141make (Just s) = do system $ "make -f " ++ s

177make (Just s) = do system $ "make -f " ++ s

142 return ()

178 return ()

143

179

180+-- | Invoke a Makefile's clean target.

144clean :: Maybe String -> IO ()

181clean :: Maybe String -> IO ()

145clean Nothing = return ()

182clean Nothing = return ()

146clean (Just s) = do system $ "make -f " ++ s ++ " clean"

183clean (Just s) = do system $ "make -f " ++ s ++ " clean"

147 return ()

184 return ()

185+

186+-- --------------------------------------------------------------------- [ EOF ]

test/Makefile+2−1

@@ -1,3 +1,5 @@

1+.PHONY: test test_java test_js update diff distclean $(TESTS)

1TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

3TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

3test: $(TESTS)

5test: $(TESTS)

@@ -105,4 +107,3 @@ distclean:

105 rm -f *~

107 rm -f *~

106 rm -f */output

108 rm -f */output

107

109

108−.PHONY: test test_java test_js update diff distclean $(TESTS)

test/reg001/reg001.idr−3

@@ -1,6 +1,3 @@

1−apply : (a -> b) -> a -> b

2−apply f x = f x

3−

4class Functor f => VerifiedFunctor (f : Type -> Type) where

1class Functor f => VerifiedFunctor (f : Type -> Type) where

5 identity : (fa : f a) -> map id fa = fa

2 identity : (fa : f a) -> map id fa = fa

test/reg003/expected+1−6

@@ -1,7 +1,2 @@

1−reg003a.idr:4:20:When elaborating constructor ECons:

1+reg003a.idr:4:20:When elaborating constructor Main.ECons:

2No such variable OddList

3−reg003a.idr:7:20:When elaborating constructor OCons:

4−No such variable EvenList

5−reg003a.idr:9:8:When elaborating type of test:

6−No such variable EvenList

7−reg003a.idr:10:1:No type declaration for test

test/reg030/expectednew file

No changes to the content.

test/reg030/reg030.idrnew file+15

@@ -0,0 +1,15 @@

1+import Control.Isomorphism

3+class Set univ where

4+ member : univ -> univ -> Type

6+isSubsetOf : Set univ => univ -> univ -> Type

7+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

9+class Set univ => HasPower univ where

10+ Powerset : (a : univ) ->

11+ Exists univ (\Pa => (c : univ) ->

12+ (isSubsetOf c a) -> member c Pa)

13+

14+powerset : HasPower univ => univ -> univ

15+powerset {univ} a = getWitness (Powerset a)

test/reg030/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ reg030.idr --check

3+rm -f *.ibc

test/reg031/expectednew file+1

@@ -0,0 +1 @@

1+[10, -128, -55, -1, 10, 51, 10, 52]

test/reg031/reg031.idrnew file+4

@@ -0,0 +1,4 @@

1+module Main

3+main : IO ()

4+main = print . map ord . unpack $ "\x0a\x80\xC9\xFF\n3\n4"

test/reg031/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+idris $@ reg031.idr -o reg031

3+./reg031

4+rm -f *.ibc reg031

test/test010/expected+1−1

@@ -1,3 +1,3 @@

1−test010.idr:13:1:foo is possibly not total due to: MkBad

1+test010.idr:13:1:Main.foo is possibly not total due to: Main.MkBad

2test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad

3test010b.idr:9:1:main.bar is possibly not total due to: main.MkBad

test/test037/expected+1−1

@@ -1,6 +1,6 @@

1In file ErrorReflection.idr line 78 column 5

2 When elaborating right hand side of Main.bad :

3− DSL type error: (t'(1000) => t'(1000)) doesn't match ()

3+ DSL type error: (t'(504) => t'(504)) doesn't match ()

5Original error: