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

CHANGELOG+6−1

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

11New in 0.9.11:

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

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

33

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

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

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

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

99 same name.

1010

11+Internal changes

12+

13+* Faster elaboration

14+* Smaller .ibc files

15+

1116New in 0.9.10:

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

1318

idris.cabal+6−3

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

1414 Dependent types allow types to be predicated on values,

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

1616 specified precisely in the type. The language is closely

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

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

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

1919 Features include:

2020 .

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

341341 Exposed-modules:

342342 Idris.Core.CaseTree

343343 , Idris.Core.Constraints

344+ , Idris.Core.DeepSeq

344345 , Idris.Core.Elaborate

345346 , Idris.Core.Evaluate

346347 , Idris.Core.Execute

347348 , Idris.Core.ProofState

349+ , Idris.Core.TC

348350 , Idris.Core.TT

349351 , Idris.Core.Typecheck

350352 , Idris.Core.Unify

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

445447 , network

446448 , xml

447449 , deepseq

450+ , zlib

448451 Extensions: MultiParamTypeClasses

449452 , FunctionalDependencies

450453 , FlexibleInstances

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

459462 if os(freebsd)

460463 cpp-options: -DFREEBSD

461464 build-depends: unix

462− if os(dragonfly)

465+ if os(dragonfly)

463466 cpp-options: -DDRAGONFLY

464467 build-depends: unix

465468 if os(darwin)

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

493496 , transformers

494497

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

496− ghc-options: -threaded -rtsopts

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

497500

498501

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

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

66-- Typeclass for decidable n-ary Relations

77--------------------------------------------------------------------------------

88

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−

149using (t : Type)

1510 class Rel (p : t) where

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

1712

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

19− total decide : liftRel Dec

14+ total decide : liftRel {p} Dec

2015

2116using (P : Type, p : P)

2217 data Given : Dec P -> Type where

2318 always : Given (Yes p)

24−-}

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

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

11module Decidable.Order

22

3−%access public

4−

5−{-

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

7−

83import Decidable.Decidable

94import Decidable.Equality

105

6+%access public

7+

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

129-- Utility Lemmas

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

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

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

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

8582

86−-}

87−

libs/prelude/Builtins.idr+2

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

1+%unqualified

2+

13%access public

24%default total

35

libs/prelude/IO.idr+2

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

1+%unqualified

2+

13import Prelude.List

24

35%access public

libs/prelude/Prelude.idr+5−5

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

275275instance Applicative (Vect k) where

276276 pure = replicate _

277277

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

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

279279

280280instance Applicative Stream where

281281 pure = repeat

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

282+ (<$>) = zipWith apply

283283

284284---- Alternative instances

285285

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

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

335335

336336---- some mathematical operations

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

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

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

339339pow x Z = 1

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

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

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

377377 enumFromTo n m = if n <= m

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

379− else []

379+ else []

380380 where go : List Nat -> List Integer

381381 go [] = []

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

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

392392 toNat n = cast n

393393 fromNat n = cast n

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

395− enumFromTo n m = if n <= m

395+ enumFromTo n m = if n <= m

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

397397 else []

398398 where go : List Nat -> List Int

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

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

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

3434flip f x y = f y x

3535

36−infixr 1 $

37−

3836-- | Function application.

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

40−f $ a = f a

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

38+apply f a = f a

4139

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

4341cong refl = refl

main/Main.hs+57−30

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

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

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

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

56+ case opt getPkgCheck opts of

57+ [] -> return ()

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

59+ runIO $ exitWith ExitSuccess

5660 case opt getPkgClean opts of

5761 [] -> return ()

5862 fs -> do runIO $ mapM_ cleanPkg fs

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

7983 putStrLn incFlags

8084 exitWith ExitSuccess

8185

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

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

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

85− "Options:\n" ++

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

111−

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

87+

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

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

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

91+ "Common flags:\n" ++

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

112139

src/IRTS/CodegenC.hs+19−2

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

1010import Paths_idris

1111import Util.System

1212

13+import Numeric

1314import Data.Char

1415import Data.List (intercalate)

1516import System.Process

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

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

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

106107

108+showCStr :: String -> String

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

110+ where

111+ showChar :: Char -> String

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

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

114+ showChar c

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

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

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

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

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

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

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

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

123+

107124bcc :: Int -> BC -> String

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

109126bcc i (ASSIGNCONST l c)

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

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

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

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

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

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

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

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

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

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

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

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

446463

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

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

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

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

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

src/IRTS/CodegenJava.hs+5−5

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

369369 | otherwise = decls

370370 where

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

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

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

373373 findMain (_:decls) = findMain decls

374374 findMain [] = False

375375

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

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

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

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

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

379379 findMainMethod (_:decls) = findMainMethod decls

380380 findMainMethod [] = False

381381

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

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

391391 , jConst "args"

392392 ]

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

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

394394 ]

395395

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

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

749749

750750mkThread :: LVar -> CodeGeneration Exp

751751mkThread arg =

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

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

753753

754754

src/IRTS/CodegenJavaScript.hs+81−20

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

6464 | JSArray [JS]

6565 | JSObject [(String, JS)]

6666 | JSString String

67+ | JSChar String

6768 | JSNum JSNum

6869 | JSAssign JS JS

6970 | JSAlloc String (Maybe JS)

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

153154compileJS (JSString str) =

154155 show str

155156

157+compileJS (JSChar chr) =

158+ chr

159+

156160compileJS (JSNum num)

157161 | JSInt i <- num = show i

158162 | JSFloat f <- num = show f

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

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

171175

172176compileJS (JSCond branches) =

173− intercalate " else " $ map createIfBlock branches

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

174178 where

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

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

181+ eliminateDeadBranches [] = []

182+

183+ createIfBlock (JSTrue, e) =

184+ "{\n"

185+ ++ "return " ++ compileJS e

186+ ++ ";\n}"

175187 createIfBlock (cond, e) =

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

177189 ++ "return " ++ compileJS e

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

233245 )

234246 ) [value]

235247

248+

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

237250jsSubst var new (JSVar old)

238251 | var == translateVariableName old = new

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

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

261274 )]

262275

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

277+ | var `notElem` args =

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

279+ map (jsSubst var new) vals

280+ )

281+ | otherwise =

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

283+ map (jsSubst var new) vals

284+ )

285+

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

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

265288

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

293316

294317jsSubst _ _ js = js

295318

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+

296330inlineJS :: 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+

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

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

299353

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

365419inlineJS (JSObject fields) =

366420 JSObject (map (second inlineJS) fields)

367421

422+inlineJS (JSOp op lhs rhs) =

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

424+

368425inlineJS js = js

369426

370427reduceJS :: [JS] -> [JS]

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

536593 reduceCall funs (JSProj obj field) =

537594 JSProj (reduceCall funs obj) field

538595

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+

539602 reduceCall funs (JSCond conds) =

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

541604

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

606669 mainFun = jsTailcall $ jsCall runMain []

607670

608671 runMain :: String

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

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

610673

611674 invokeLoop :: String

612675 invokeLoop = compileJS $ jsCall "main" []

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

671734

672735translateNamespace :: Name -> String

673736translateNamespace (UN _) = idrNamespace

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

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

675738translateNamespace (MN _ _) = idrNamespace

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

677740translateNamespace NErased = idrNamespace

678741

679742translateName :: Name -> String

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

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

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

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

684747translateName NErased = "e"

685748

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

688751 | WhereN i m n <- name =

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

690753 | InstanceN n s <- name =

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

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

692755 | ParentN n s <- name =

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

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

694757 | MethodN n <- name =

695758 'm' : translateName n

696759 | CaseN n <- name =

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

699762translateConstant :: Const -> JS

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

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

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

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

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

702768translateConstant (Ch c) = JSString [c]

703769translateConstant (Str s) = JSString s

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

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

714780

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

716782translateDeclaration (path, SFun name params stackSize body)

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

783+ | (MN _ ap) <- name

718784 , (SLet var val next) <- body

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

785+ , (SChkCase cvar cases) <- next

786+ , ap == txt "APPLY" =

720787 let lvar = translateVariableName var

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

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

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

735802 )

736803 ]

737804

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

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

805+ | (MN _ ev) <- name

806+ , (SChkCase var cases) <- body

807+ , ev == txt "EVAL" =

740808 JSSeq [ lookupTable [] var cases

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

742810 JSTernary (

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

798866 JSFunction (p ++ map snd aux) (

799867 JSSeq $

800868 zipWith assignVar [0..] p ++

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

802869 map assignAux aux ++

803870 [JSReturn body]

804871 )

805872 where

806− numP :: Int

807− numP = length params

808−

809− allocVar :: Int -> JS

810− allocVar n = JSAlloc (jsVar n) Nothing

811−

812873 assignVar :: Int -> String -> JS

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

814875

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

816− assignAux (var, val) =

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

877+ assignAux (Loc var, val) =

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

818879

819880 p :: [String]

820881 p = map translateName params

src/IRTS/Compiler.hs+34−31

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

4040 = do checkMVs

4141 let tmnames = namesUsed (STerm tm)

4242 usedIn <- mapM (allNames []) tmnames

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

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

4444 defsIn <- mkDecls tm (concat used)

4545 findUnusedArgs (concat used)

4646 maindef <- irMain tm

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

4949 flags <- getFlags codegen

5050 hdrs <- getHdrs codegen

5151 impdirs <- allImportDirs

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

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

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

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

5555 let ctxtIn = addAlist tagged emptyContext

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

108108

109109irMain :: TT Name -> Idris LDecl

110110irMain tm = do i <- ir tm

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

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

112112

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

114114mkDecls t used

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

137137 = do i <- getIState

138138 case lookup n (idris_scprims i) of

139139 Just (ar, op) ->

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

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

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

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

143143 _ -> do def <- mkLDecl n d

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

168168instance ToIR (TT Name) where

169169 ir tm = ir' [] tm where

170170 ir' env tm@(App f a)

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

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

172+ m == txt "mkForeignPrim"

172173 = doForeign env args

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

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

175+ u == txt "unsafePerformPrimIO"

174176 = ir' env arg

175177 -- TMP HACK - until we get inlining.

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

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

179+ r == txt "replace"

177180 = ir' env arg

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

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

182+ l == txt "lazy"

179183 = do arg' <- ir' env arg

180184 return $ LLazyExp arg'

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

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

186+ a == txt "assert_smaller"

182187 = ir' env arg

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

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

189+ p == txt "par"

184190 = do arg' <- ir' env arg

185191 return $ LOp LPar [LLazyExp arg']

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

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

193+ pf == txt "prim_fork"

187194 = do arg' <- ir' env arg

188195 return $ LOp LFork [LLazyExp arg']

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

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

191−-- return v'

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

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

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

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

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

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

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

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

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

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

197+ m == txt "malloc"

201198 = do size' <- ir' env size

202199 t' <- ir' env t

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

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

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

202+ tm == txt "trace_malloc"

205203 = do t' <- ir' env t

206204 return t' -- TODO

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

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

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

273271 return $ LLam extra sc'

274272

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

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

276274

277275 buildApp env e [] = return e

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

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

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

301299 _ -> Nothing

302300

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

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

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

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

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

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

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

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

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

306+ io == txt "IO"

307+ = FFunctionIO

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

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

307310mkIty' _ = FAny

308311

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

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

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

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

339342

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

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

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

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

342345

343346instance ToIR ([Name], SC) where

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

src/IRTS/Defunctionalise.hs+14−14

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

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

144144

145145 chainAPPLY f [] = f

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

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

147147

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

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

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

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

172172 needsEval x _ = False

173173

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

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

175175

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

177177 | ApplyCase a

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

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

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

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

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

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

202202 : mkApplyCase fname (n + 1) ar

203203

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

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

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

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

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

207207 (mapMaybe evalCase xs ++

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

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

209209 where

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

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

211211 evalCase _ = Nothing

212212

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

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

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

215215 (case mapMaybe applyCase xs of

216216 [] -> DNothing

217217 cases ->

218− mkBigCase (MN 0 "APPLY") 256

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

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

218+ mkBigCase (sMN 0 "APPLY") 256

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

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

221221 (cases ++

222222 [DDefaultCase DNothing])))

223223 where

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

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

232232

233233

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

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

235235

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

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

237237mkUnderCon n 0 = n

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

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

239239

240240instance Show DExp where

241241 show e = show' [] e where

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

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

2626 where

2727 prefixCallNamespacesExp :: Ident -> SExp -> SExp

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

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

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

3030 prefixCallNamespacesExp name (SLet var e1 e2) =

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

3232 prefixCallNamespacesExp name (SUpdate var e) =

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

6363 . parser ident

6464 . (prefix ++)

6565 . cleanNonLetter

66− $ cleanWs False name

66+ $ cleanWs False (str name)

6767 where

6868 cleanNonLetter (x:xs)

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

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

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

9797 | otherwise = x : (cleanWs False xs)

9898 cleanWs _ [] = []

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

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

100100

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

102102mangle = mangleWithPrefix "__IDRCG__"

src/IRTS/Lang.hs+1−1

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

102102

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

104104lname (UN n) i = MN i n

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

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

106106

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

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

src/IRTS/Simplified.hs+2−1

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

22

33import IRTS.Defunctionalise

44import Idris.Core.TT

5+import Idris.Core.Typecheck

56import Data.Maybe

67import Control.Monad.State

78

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

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

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

9697 i <- hvar

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

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

9899

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

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

src/Idris/AbsSyntax.hs+270−122

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

1919import System.IO

2020

2121import Control.Monad.State

22+import Control.Monad.Error(throwError)

2223

2324import Data.List

2425import Data.Char

26+import qualified Data.Text as T

2527import Data.Either

2628import Data.Maybe

2729import Data.Word (Word)

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

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

181183

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

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

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

184186getNameHints i n =

185187 case lookupCtxt n (idris_namehints i) of

186188 [ns] -> ns

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

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

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

202204 putIState $ ist { idris_classes = cs }

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

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

204206 putIState $ ist { idris_classes = cs }

205207 where addI i ins | int = i : ins

206208 | chaser n = ins ++ [i]

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

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

210212 | otherwise = n : insI i ns

211213

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

214+ chaser (UN nm)

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

213216 chaser (NS n _) = chaser n

214217 chaser _ = False

215218

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

234237clearIBC :: Idris ()

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

236239

240+resetNameIdx :: Idris ()

241+resetNameIdx = do i <- getIState

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

243+

244+-- Used to preserve sharing of names

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

246+addNameIdx n = do i <- getIState

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

248+ return x

249+

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

251+addNameIdx' i n

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

253+ case lookupCtxt n idxs of

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

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

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

257+

237258getHdrs :: Codegen -> Idris [String]

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

239260

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

284305 Nothing -> return Placeholder

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

286307

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

309+-- when we're done

310+clearOrigPats :: Idris ()

311+clearOrigPats = do i <- get

312+ let ps = idris_patdefs i

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

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

315+

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

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

318+clearPTypes :: Idris ()

319+clearPTypes = do i <- get

320+ let ctxt = tt_ctxt i

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

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

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

324+ pErase x = x

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

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

327+ CaseDefs c' c' c' rs

328+

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

288330checkUndefined fc n

289331 = do i <- getContext

290332 case lookupTy n i of

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

292− show n ++ " already defined"

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

334+ show n ++ " already defined"

293335 _ -> return ()

294336

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

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

650692

651693bi = fileFC "builtin"

652694

653−inferTy = MN 0 "__Infer"

654−inferCon = MN 0 "__infer"

695+inferTy = sMN 0 "__Infer"

696+inferCon = sMN 0 "__infer"

655697inferDecl = PDatadecl inferTy

656698 PType

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

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

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

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

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

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

660702inferOpts = []

661703

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

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

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

664706

665707getInferTerm, getInferType :: Term -> Term

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

676718 falseTy, pairTy, pairCon,

677719 eqTy, eqCon, inferTy, inferCon]

678720

679−unitTy = MN 0 "__Unit"

680−unitCon = MN 0 "__II"

721+unitTy = sMN 0 "__Unit"

722+unitCon = sMN 0 "__II"

681723unitDecl = PDatadecl unitTy PType

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

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

683725unitOpts = [DefaultEliminator]

684726

685−falseTy = MN 0 "__False"

727+falseTy = sMN 0 "__False"

686728falseDecl = PDatadecl falseTy PType []

687729falseOpts = []

688730

689−pairTy = MN 0 "__Pair"

690−pairCon = MN 0 "__MkPair"

731+pairTy = sMN 0 "__Pair"

732+pairCon = sMN 0 "__MkPair"

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

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

693735 PPi impl (n "B") PType (

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

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

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

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

698− where n a = MN 0 a

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

740+ where n a = sMN 0 a

699741pairOpts = []

700742

701−eqTy = UN "="

702−eqCon = UN "refl"

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

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

743+eqTy = sUN "="

744+eqCon = sUN "refl"

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

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

705747 PType)

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

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

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

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

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

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

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

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

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

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

712− where n a = MN 0 a

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

754+ where n a = sMN 0 a

713755eqOpts = []

714756

715−elimName = UN "__Elim"

716−elimMethElimTy = UN "__elimTy"

717−elimMethElim = UN "elim"

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

757+elimName = sUN "__Elim"

758+elimMethElimTy = sUN "__elimTy"

759+elimMethElim = sUN "elim"

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

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

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

721763

722764-- Defined in builtins.idr

723−sigmaTy = UN "Exists"

724−existsCon = UN "Ex_intro"

765+sigmaTy = sUN "Exists"

766+existsCon = sUN "Ex_intro"

725767

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

727769piBind = piBindp expl

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

859901 updateps yn nm [] = []

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

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

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

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

863905

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

865907

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

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

880922 (map econ cons)

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

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

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

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

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

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

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

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

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

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

9991041 doAdd (UConstraint c args : cs) ns t

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

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

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

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

10031045 | otherwise = doAdd cs ns t

10041046

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

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

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

10701112 (decls , ns) <- get

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

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

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

10731115 imps True (n:env) sc

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

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

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

10771119 _ -> [])

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

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

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

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

10811123 imps True (n:env) sc

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

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

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

10851127 _ -> [])

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

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

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

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

10891131 imps True (n:env) sc

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

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

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

10931135 _ -> [])

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

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

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

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

10971139 imps True (n:env) sc

10981140 imps top env (PEq _ l r)

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

11541196-- and *not* inside a PHidden

11551197

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

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

1199+addImpl' inpat env infns ist ptm

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

11581201 where

1159− ai env (PRef fc f)

1202+ ai env ds (PRef fc f)

11601203 | f `elem` infns = PInferRef fc f

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

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

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

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

1165− r' = ai env r in

1166− PEq fc l' r'

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

1168− r' = ai env r

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

1170− PRewrite fc l' r' g'

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

1172− r' = ai env r in

1173− PTyped l' r'

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

1175− r' = ai env r in

1176− PPair fc l' r'

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

1178− t' = ai env t

1179− r' = ai env r in

1180− PDPair fc l' t' r'

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

1182− PAlternative a as'

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

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

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

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

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

1207+ ai env ds (PEq fc l r)

1208+ = let l' = ai env ds l

1209+ r' = ai env ds r in

1210+ PEq fc l' r'

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

1212+ = let l' = ai env ds l

1213+ r' = ai env ds r

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

1215+ PRewrite fc l' r' g'

1216+ ai env ds (PTyped l r)

1217+ = let l' = ai env ds l

1218+ r' = ai env ds r in

1219+ PTyped l' r'

1220+ ai env ds (PPair fc l r)

1221+ = let l' = ai env ds l

1222+ r' = ai env ds r in

1223+ PPair fc l' r'

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

1225+ = let l' = ai env ds l

1226+ t' = ai env ds t

1227+ r' = ai env ds r in

1228+ PDPair fc l' t' r'

1229+ ai env ds (PAlternative a as)

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

1231+ PAlternative a as'

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

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

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

11851235 PApp fc (PInferRef fc f) as'

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

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

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

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

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

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

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

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

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

1193− arity = getPArity ty in

1194− mkPApp fc arity ftm as'

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

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

1197− mkPApp fc 1 f' as'

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

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

1200− PCase fc c' os'

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

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

1203− PLam n ty' sc'

1204− ai env (PLet n ty val sc)

1205− = let ty' = ai env ty

1206− val' = ai env val

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

1208− PLet n ty' val' sc'

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

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

1211− PPi p n ty' sc'

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

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

1214− PGoal fc r' n sc'

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

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

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

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

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

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

1221− ai env tm = tm

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

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

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

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

1243+ arity = getPArity ty in

1244+ mkPApp fc arity ftm as'

1245+ ai env ds (PApp fc f as)

1246+ = let f' = ai env ds f

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

1248+ mkPApp fc 1 f' as'

1249+ ai env ds (PCase fc c os)

1250+ = let c' = ai env ds c

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

1252+ PCase fc c' os'

1253+ ai env ds (PLam n ty sc)

1254+ = let ty' = ai env ds ty

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

1256+ PLam n ty' sc'

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

1258+ = let ty' = ai env ds ty

1259+ val' = ai env ds val

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

1261+ PLet n ty' val' sc'

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

1263+ = let ty' = ai env ds ty

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

1265+ PPi p n ty' sc'

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

1267+ = let r' = ai env ds r

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

1269+ PGoal fc r' n sc'

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

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

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

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

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

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

1276+ ai env ds tm = tm

12221277

12231278 handleErr (Left err) = PElabError err

12241279 handleErr (Right x) = x

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

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

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

12281283

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

1230−aiFn inpat True ist fc f []

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

1285+aiFn inpat True ist fc f ds []

12311286 = case lookupDef f (tt_ctxt ist) of

12321287 [] -> Right $ PPatvar fc f

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

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

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

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

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

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

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

12391294 else Right $ PPatvar fc f

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

12411296 imp _ = True

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

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

12501305 vname _ = False

12511306

1252−aiFn inpat expat ist fc f as

1307+aiFn inpat expat ist fc f ds as

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

1254−aiFn inpat expat ist fc f as

1309+aiFn inpat expat ist fc f ds as

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

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

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

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

1313+ let ns' = case trimAlts ds nh of

1314+ [] -> nh

1315+ x -> x

12581316 case ns' of

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

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

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

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

12631321 alts -> Right $

1264− PAlternative True $

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

1266− (insertImpl ns as)) alts

1322+ PAlternative True $

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

1324+ (insertImpl ns as)) alts

12671325 where

1326+ trimAlts [] alts = alts

1327+ trimAlts ns alts

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

1329+

1330+ nspace (NS _ s) = s

1331+ nspace _ = []

1332+

12681333 notHidden n = case getAccessibility n of

12691334 Hidden -> False

12701335 _ -> True

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

12861351 case find n given [] of

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

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

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

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

1355+ let sc = addImpl ist sc' in

12901356 case find n given [] of

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

12921358 Nothing -> if inpat

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

14221488 fullApp x = x

14231489

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

14321500 | length args == length args'

14331501 = do mf <- match' f f'

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

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

15591627shadow n n' t = sm t where

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

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

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

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

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

1631+ sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc)

15631632 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1633+ sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

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

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

15661636 sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)

@@ -1568,9 +1638,87 @@ shadow n n' t = sm t where

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

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

15701640 sm (PAlternative a as) = PAlternative a (map sm as)

1641+ sm (PTactics ts) = PTactics (map (fmap sm) ts)

1642+ sm (PProof ts) = PProof (map (fmap sm) ts)

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

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

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

15741646 sm x = x

15751647

1648+-- Rename any binders which are repeated (so that we don't have to mess

1649+-- about with shadowing anywhere else).

1650+

1651+mkUniqueNames :: [Name] -> PTerm -> PTerm

1652+mkUniqueNames env tm = evalState (mkUniq tm) env where

1653+ inScope = boundNamesIn tm

1654+

1655+ mkUniqA arg = do t' <- mkUniq (getTm arg)

1656+ return (arg { getTm = t' })

1657+

1658+ -- FIXME: Probably ought to do this for completeness! It's fine as

1659+ -- long as there are no bindings inside tactics though.

1660+ mkUniqT tac = return tac

1661+

1662+ mkUniq :: PTerm -> State [Name] PTerm

1663+ mkUniq (PLam n ty sc)

1664+ = do env <- get

1665+ (n', sc') <-

1666+ if n `elem` env

1667+ then do let n' = uniqueName n (env ++ inScope)

1668+ return (n', shadow n n' sc)

1669+ else return (n, sc)

1670+ put (n' : env)

1671+ ty' <- mkUniq ty

1672+ sc'' <- mkUniq sc'

1673+ return $! PLam n' ty' sc''

1674+ mkUniq (PPi p n ty sc)

1675+ = do env <- get

1676+ (n', sc') <-

1677+ if n `elem` env

1678+ then do let n' = uniqueName n (env ++ inScope)

1679+ return (n', shadow n n' sc)

1680+ else return (n, sc)

1681+ put (n' : env)

1682+ ty' <- mkUniq ty

1683+ sc'' <- mkUniq sc'

1684+ return $! PPi p n' ty' sc''

1685+ mkUniq (PLet n ty val sc)

1686+ = do env <- get

1687+ (n', sc') <-

1688+ if n `elem` env

1689+ then do let n' = uniqueName n (env ++ inScope)

1690+ return (n', shadow n n' sc)

1691+ else return (n, sc)

1692+ put (n' : env)

1693+ ty' <- mkUniq ty; val' <- mkUniq val

1694+ sc'' <- mkUniq sc'

1695+ return $! PLet n' ty' val' sc''

1696+ mkUniq (PApp fc t args)

1697+ = do t' <- mkUniq t

1698+ args' <- mapM mkUniqA args

1699+ return $! PApp fc t' args'

1700+ mkUniq (PAppBind fc t args)

1701+ = do t' <- mkUniq t

1702+ args' <- mapM mkUniqA args

1703+ return $! PAppBind fc t' args'

1704+ mkUniq (PCase fc t alts)

1705+ = do t' <- mkUniq t

1706+ alts' <- mapM (\(x,y)-> do x' <- mkUniq x; y' <- mkUniq y

1707+ return (x', y')) alts

1708+ return $! PCase fc t' alts'

1709+ mkUniq (PPair fc l r)

1710+ = do l' <- mkUniq l; r' <- mkUniq r

1711+ return $! PPair fc l' r'

1712+ mkUniq (PDPair fc l t r)

1713+ = do l' <- mkUniq l; t' <- mkUniq t; r' <- mkUniq r

1714+ return $! PDPair fc l' t' r'

1715+ mkUniq (PAlternative b as)

1716+ = liftM (PAlternative b) (mapM mkUniq as)

1717+ mkUniq (PHidden t) = liftM PHidden (mkUniq t)

1718+ mkUniq (PUnifyLog t) = liftM PUnifyLog (mkUniq t)

1719+ mkUniq (PDisamb n t) = liftM (PDisamb n) (mkUniq t)

1720+ mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

1721+ mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

1722+ mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

1723+ mkUniq t = return t

15761724

src/Idris/AbsSyntaxTree.hs+62−27

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

2424

2525import Data.List

2626import Data.Char

27+import qualified Data.Text as T

2728import Data.Either

2829import Data.Word (Word)

2930

@@ -132,7 +133,8 @@ data IState = IState {

132133 idris_colourRepl :: Bool,

133134 idris_colourTheme :: ColourTheme,

134135 idris_outh :: Handle,

135− idris_errorhandlers :: [Name]

136+ idris_errorhandlers :: [Name],

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

136138 }

137139

138140data SizeChange = Smaller | Same | Bigger | Unknown

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

155157deriving instance NFData CGInfo

156158!-}

157159

158−primDefs = [UN "unsafePerformPrimIO",

159− UN "mkLazyForeignPrim",

160− UN "mkForeignPrim",

161− UN "FalseElim"]

160+primDefs = [sUN "unsafePerformPrimIO",

161+ sUN "mkLazyForeignPrim",

162+ sUN "mkForeignPrim",

163+ sUN "FalseElim"]

162164

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

164166data IBCWrite = IBCFix FixDecl

@@ -198,7 +200,7 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

198200 emptyContext

199201 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

200202 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

201− True defaultTheme stdout []

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

202204

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

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

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

293295 | PkgBuild String

294296 | PkgInstall String

295297 | PkgClean String

298+ | PkgCheck String

296299 | WarnOnly

297300 | Pkg String

298301 | BCAsm String

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

475478-- | Data declaration

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

477480 d_tcon :: t, -- ^ Type constructor

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

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

479482 }

480483 -- ^ Data declaration

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

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

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

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

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

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

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

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

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

508511declared (PNamespace _ ds) = concatMap declared ds

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

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

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

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

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

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

526529tldeclared (PParams _ _ ds) = []

527530tldeclared (PMutual _ ds) = concatMap tldeclared ds

528531tldeclared (PNamespace _ ds) = concatMap tldeclared ds

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

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

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

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

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

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

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

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

543546defined (PNamespace _ ds) = concatMap defined ds

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

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

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

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

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

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

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

612616 deriving Eq

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

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

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

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

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

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

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

642647 mpt x = x

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

843848deriving instance NFData SSymbol

844849!-}

845850

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

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

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

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

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

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

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

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

850855 Nothing

851856 Nothing

852857 Nothing

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

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

883888expandNS syn n = case syn_namespace syn of

884889 [] -> n

885− xs -> NS n xs

890+ xs -> sNS n xs

886891

887892

888893--- Pretty printing declarations and terms

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

940945showDImp impl (PDatadecl n ty cons)

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

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

944949

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

946951getImps [] = []

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

979984 prettyBasic n

980985 where

981986 prettyBasic n@(UN _) = pretty n

982− prettyBasic (MN _ s) = text s

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

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

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

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

985990 prettySe p (PLam n ty sc) =

986991 bracket p 2 $

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

10511056 | not impl = pretty f

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

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

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

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

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

1060+ | not (tnull nm) &&

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

10561062 let [l, r] = getExps args in

10571063 bracket p 1 $

10581064 if size r > breakingSize then

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

11651171 Nothing -> showbasic n

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

11671173 showbasic n@(UN _) = showCG n

1168− showbasic (MN _ s) = s

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

1174+ showbasic (MN _ s) = str s

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

11701176 showbasic (SN s) = show s

11711177 fst3 (x, _, _) = x

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

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

12401246 | not impl = se p bnd hd

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

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

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

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

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

1250+ | not (tnull nm) &&

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

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

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

12471254 se p bnd (PApp _ f as)

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

12851292 se p bnd (PElabError s) = show s

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

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

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

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

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

12901298

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

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

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

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

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

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

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

12961304 all isImp imps,

12971305 Just tl' <- slist' p bnd tl

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

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

13661374 size (PHidden hidden) = size hidden

13671375 size (PUnifyLog tm) = size tm

1376+ size (PDisamb _ tm) = size tm

13681377 size (PNoImplicits tm) = size tm

13691378 size PType = 1

13701379 size (PConstant const) = 1 + size const

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

13881397 where

13891398 ni env (PRef _ n)

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

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

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

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

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

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

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

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

14041414 ni env (PUnifyLog tm) = ni env tm

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

14051416 ni env (PNoImplicits tm) = ni env tm

14061417 ni env _ = []

14071418

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

14091441

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

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

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

14121445 where

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

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

14301463 ni env (PHidden tm) = ni env tm

14311464 ni env (PUnifyLog tm) = ni env tm

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

14321466 ni env (PNoImplicits tm) = ni env tm

14331467 ni env _ = []

14341468

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

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

14571491 ni env (PHidden tm) = ni env tm

14581492 ni env (PUnifyLog tm) = ni env tm

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

14591494 ni env (PNoImplicits tm) = ni env tm

14601495 ni env _ = []

14611496

src/Idris/CaseSplit.hs+13−12

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

9191 Nothing -> []

9292 Just t -> getNameHints ist t

9393 let nsupp = case n of

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

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

95+ -> mkSupply (supp ++ varlist)

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

9697 x -> mkSupply (x : supp)

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

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

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

107108 where mkSupply' xs ns' = xs ++ mkSupply ns'

108109

109−varlist = map (UN . (:[])) "xyzwstuv" -- EB's personal preference :)

110+varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

110111

111112stripNS tm = mapPT dens tm where

112113 dens (PRef fc n) = PRef fc (nsroot n)

@@ -164,7 +165,7 @@ argTys ist (PRef fc n)

164165 = case lookupTy n (tt_ctxt ist) of

165166 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

166167 _ -> repeat Nothing

167− where tyName (Bind _ (Pi _) _) = Just (UN "->")

168+ where tyName (Bind _ (Pi _) _) = Just (sUN "->")

168169 tyName t | (P _ n _, _) <- unApply t = Just n

169170 | otherwise = Nothing

170171argTys _ _ = repeat Nothing

@@ -264,8 +265,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

264265

265266 -- TMP HACK: If there are Nats, we don't want to show as numerals since

266267 -- this isn't supported in a pattern, so special case here

267− nshow (PRef _ (UN "Z")) = "Z"

268− nshow (PApp _ (PRef _ (UN "S")) [x]) =

268+ nshow (PRef _ (UN z)) | z == txt "Z" = "Z"

269+ nshow (PApp _ (PRef _ (UN s)) [x]) | s == txt "S" =

269270 "S " ++ addBrackets (nshow (getTm x))

270271 nshow t = show t

271272

@@ -296,7 +297,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

296297getUniq nm i

297298 = do ist <- getIState

298299 let n = nameRoot [] nm ++ "_" ++ show i

299− case lookupTy (UN n) (tt_ctxt ist) of

300+ case lookupTy (sUN n) (tt_ctxt ist) of

300301 [] -> return (n, i+1)

301302 _ -> getUniq nm (i+1)

302303

@@ -324,14 +325,14 @@ getClause l fn fp = do ty <- getInternalApp fp l

324325 mkApp i _ _ = ""

325326

326327 getNameFrom i used (PPi _ _ _ _)

327− = uniqueNameFrom (mkSupply [UN "f", UN "g"]) used

328+ = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used

328329 getNameFrom i used (PApp fc f as) = getNameFrom i used f

329− getNameFrom i used (PEq _ _ _) = uniqueNameFrom [UN "prf"] used

330+ getNameFrom i used (PEq _ _ _) = uniqueNameFrom [sUN "prf"] used

330331 getNameFrom i used (PRef fc f)

331332 = case getNameHints i f of

332− [] -> uniqueName (UN "x") used

333+ [] -> uniqueName (sUN "x") used

333334 ns -> uniqueNameFrom (mkSupply ns) used

334− getNameFrom i used _ = uniqueName (UN "x") used

335+ getNameFrom i used _ = uniqueName (sUN "x") used

335336

336337getProofClause :: Int -- ^ line number that the type is declared

337338 -> Name -- ^ Function name

@@ -363,11 +364,11 @@ mkWith str n = let str' = replaceRHS str "with (_)"

363364nameMissing :: [PTerm] -> Idris [PTerm]

364365nameMissing ps = do ist <- get

365366 newPats <- mapM nm ps

366− let newPats' = mergeAllPats ist (UN "_") (base (head ps))

367+ let newPats' = mergeAllPats ist (sUN "_") (base (head ps))

367368 newPats

368369 return (map fst newPats')

369370 where

370− base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (UN "_")))) args)

371+ base (PApp fc f args) = PApp fc f (map (fmap (const (PRef fc (sUN "_")))) args)

371372 base t = t

372373

373374 nm ptm = do mptm <- elabNewPat ptm

src/Idris/Completion.hs+3−3

@@ -54,9 +54,9 @@ tactics = map fst tacticArgs

5454-- | Convert a name into a string usable for completion. Filters out names

5555-- that users probably don't want to see.

5656nameString :: Name -> Maybe String

57−nameString (UN ('@':_)) = Nothing

58−nameString (UN ('#':_)) = Nothing

59−nameString (UN n) = Just n

57+nameString (UN nm)

58+ | not (tnull nm) && (thead nm == '@' || thead nm == '#') = Nothing

59+nameString (UN n) = Just (str n)

6060nameString (NS n _) = nameString n

6161nameString _ = Nothing

6262

src/Idris/Core/CaseTree.hs+10−7

@@ -21,7 +21,8 @@ data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

2121 | ImpossibleCase -- ^ already checked to be impossible

2222 deriving (Eq, Ord, Functor)

2323{-!

24−deriving instance Binary SC

24+deriving instance Binary SC'

25+deriving instance NFData SC'

2526!-}

2627

2728type SC = SC' Term

@@ -33,7 +34,8 @@ data CaseAlt' t = ConCase Name Int [Name] !(SC' t)

3334 | DefaultCase !(SC' t)

3435 deriving (Show, Eq, Ord, Functor)

3536{-!

36−deriving instance Binary CaseAlt

37+deriving instance Binary CaseAlt'

38+deriving instance NFData CaseAlt'

3739!-}

3840

3941type CaseAlt = CaseAlt' Term

@@ -155,6 +157,7 @@ directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

155157directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

156158directUse fn@(App f a)

157159 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

160+ | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime

158161 | otherwise = nub $ directUse f ++ directUse a

159162directUse (Proj x i) = nub $ directUse x

160163directUse _ = []

@@ -214,7 +217,7 @@ simpleCase tc cover reflect phase fc argtys cs

214217 then return t

215218 else Error (At fc (Msg "Typecase is not allowed"))

216219 Error err -> Error (At fc err)

217− where args = map (\i -> MN i "e") [0..]

220+ where args = map (\i -> sMN i "e") [0..]

218221 defaultCase True = STerm Erased

219222 defaultCase False = UnmatchedCase "Error"

220223 fstT (x, _, _) = x

@@ -298,8 +301,8 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

298301 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

299302 return $ PCon n t args'

300303 -- n + 1

301− toPat' (P _ (UN "prim__addBigInt") _)

302− [p, Constant (BI 1)]

304+ toPat' (P _ (UN pabi) _)

305+ [p, Constant (BI 1)] | pabi == txt "prim__addBigInt"

303306 = do p' <- toPat' p []

304307 return $ PSuc p'

305308 -- Typecase

@@ -331,7 +334,7 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

331334 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

332335 = do t' <- toPat' t []

333336 sc' <- toPat' sc []

334− return $ PReflected (UN "->") (t':sc':[])

337+ return $ PReflected (sUN "->") (t':sc':[])

335338 toPat' (P _ n _) args | reflect

336339 = do args' <- mapM (\x -> toPat' x []) args

337340 return $ PReflected n args'

@@ -488,7 +491,7 @@ argsToAlt rs@((r, m) : rest)

488491 uniq i n = n

489492

490493getVar :: String -> State CS Name

491−getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (MN v b)

494+getVar b = do (t, v, ntys) <- get; put (t, v+1, ntys); return (sMN v b)

492495

493496groupCons :: [Clause] -> State CS [Group]

494497groupCons cs = gc [] cs

src/Idris/Core/Constraints.hs+1

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

22module Idris.Core.Constraints(ucheck) where

33

44import Idris.Core.TT

5+import Idris.Core.Typecheck

56

67import Control.Applicative

78import Control.Arrow

src/Idris/Core/DeepSeq.hsnew file+114

@@ -0,0 +1,114 @@

1+module Idris.Core.DeepSeq where

2+

3+import Idris.Core.TT

4+import Idris.Core.CaseTree

5+

6+import Control.DeepSeq

7+

8+instance NFData Name where

9+ rnf (UN x1) = rnf x1 `seq` ()

10+ rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

11+ rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

12+ rnf NErased = ()

13+ rnf (SN x1) = rnf x1 `seq` ()

14+

15+instance NFData SpecialName where

16+ rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

17+ rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

18+ rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19+ rnf (MethodN x1) = rnf x1 `seq` ()

20+ rnf (CaseN x1) = rnf x1 `seq` ()

21+ rnf (ElimN x1) = rnf x1 `seq` ()

22+

23+instance NFData Raw where

24+ rnf (Var x1) = rnf x1 `seq` ()

25+ rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

26+ rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

27+ rnf RType = ()

28+ rnf (RForce x1) = rnf x1 `seq` ()

29+ rnf (RConstant x1) = x1 `seq` ()

30+

31+instance NFData FC where

32+ rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

33+

34+instance NFData Err where

35+ rnf (Msg x1) = rnf x1 `seq` ()

36+ rnf (InternalMsg x1) = rnf x1 `seq` ()

37+ rnf (CantUnify x1 x2 x3 x4 x5 x6)

38+ = rnf x1 `seq`

39+ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

40+ rnf (InfiniteUnify x1 x2 x3)

41+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

42+ rnf (CantConvert x1 x2 x3)

43+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

44+ rnf (UnifyScope x1 x2 x3 x4)

45+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

46+ rnf (CantInferType x1) = rnf x1 `seq` ()

47+ rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

48+ rnf (CantIntroduce x1) = rnf x1 `seq` ()

49+ rnf (NoSuchVariable x1) = rnf x1 `seq` ()

50+ rnf (NoTypeDecl x1) = rnf x1 `seq` ()

51+ rnf (NotInjective x1 x2 x3)

52+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

53+ rnf (CantResolve x1) = rnf x1 `seq` ()

54+ rnf (CantResolveAlts x1) = rnf x1 `seq` ()

55+ rnf (IncompleteTerm x1) = rnf x1 `seq` ()

56+ rnf UniverseError = ()

57+ rnf ProgramLineComment = ()

58+ rnf (Inaccessible x1) = rnf x1 `seq` ()

59+ rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

60+ rnf (AlreadyDefined x1) = rnf x1 `seq` ()

61+ rnf (ProofSearchFail x1) = rnf x1 `seq` ()

62+ rnf (NoRewriting x1) = rnf x1 `seq` ()

63+ rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

64+ rnf (Elaborating x1 x2 x3)

65+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

66+ rnf (ProviderError x1) = rnf x1 `seq` ()

67+ rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

68+

69+instance (NFData b) => NFData (Binder b) where

70+ rnf (Lam x1) = rnf x1 `seq` ()

71+ rnf (Pi x1) = rnf x1 `seq` ()

72+ rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

73+ rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74+ rnf (Hole x1) = rnf x1 `seq` ()

75+ rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

76+ rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

77+ rnf (PVar x1) = rnf x1 `seq` ()

78+ rnf (PVTy x1) = rnf x1 `seq` ()

79+

80+instance NFData UExp where

81+ rnf (UVar x1) = rnf x1 `seq` ()

82+ rnf (UVal x1) = rnf x1 `seq` ()

83+

84+instance NFData NameType where

85+ rnf Bound = ()

86+ rnf Ref = ()

87+ rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

88+ rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

89+

90+instance (NFData n) => NFData (TT n) where

91+ rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92+ rnf (V x1) = rnf x1 `seq` ()

93+ rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

94+ rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

95+ rnf (Constant x1) = x1 `seq` ()

96+ rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

97+ rnf Erased = ()

98+ rnf Impossible = ()

99+ rnf (TType x1) = rnf x1 `seq` ()

100+

101+instance (NFData t) => NFData (SC' t) where

102+ rnf (Case x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103+ rnf (ProjCase x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

104+ rnf (STerm x1) = rnf x1 `seq` ()

105+ rnf (UnmatchedCase x1) = rnf x1 `seq` ()

106+ rnf ImpossibleCase = ()

107+

108+instance (NFData t) => NFData (CaseAlt' t) where

109+ rnf (ConCase x1 x2 x3 x4)

110+ = x1 `seq` x2 `seq` x3 `seq` rnf x4 `seq` ()

111+ rnf (FnCase x1 x2 x3) = x1 `seq` x2 `seq` rnf x3 `seq` ()

112+ rnf (ConstCase x1 x2) = x1 `seq` rnf x2 `seq` ()

113+ rnf (SucCase x1 x2) = x1 `seq` rnf x2 `seq` ()

114+ rnf (DefaultCase x1) = rnf x1 `seq` ()

src/Idris/Core/Elaborate.hs+98−64

@@ -16,8 +16,10 @@ import Idris.Core.TT

1616import Idris.Core.Evaluate

1717import Idris.Core.Typecheck

1818import Idris.Core.Unify

19+import Idris.Core.DeepSeq

1920

20−import Control.Monad.State

21+import Control.DeepSeq

22+import Control.Monad.State.Strict

2123import Data.Char

2224import Data.List

2325import Debug.Trace

@@ -46,7 +48,7 @@ proofFail :: Elab' aux a -> Elab' aux a

4648proofFail e = do s <- get

4749 case runStateT e s of

4850 OK (a, s') -> do put s'

49− return a

51+ return $! a

5052 Error err -> lift $ Error (ProofSearchFail err)

5153

5254explicit :: Name -> Elab' aux ()

@@ -64,11 +66,39 @@ loadState = do (ES p s e) <- get

6466 Just st -> put st

6567 _ -> fail "Nothing to undo"

6668

69+getNameFrom :: Name -> Elab' aux Name

70+getNameFrom n = do (ES (p, a) s e) <- get

71+ let next = nextname p

72+ let p' = p { nextname = next + 1 }

73+ put (ES (p', a) s e)

74+ let n' = case n of

75+ UN x -> MN (next+100) x

76+ MN i x -> if i == 99999

77+ then MN (next+500) x

78+ else MN (next+100) x

79+ NS (UN x) s -> MN (next+100) x

80+ return $! n'

81+

82+setNextName :: Elab' aux ()

83+setNextName = do env <- get_env

84+ ES (p, a) s e <- get

85+ let pargs = map fst (getArgTys (ptype p))

86+ initNextNameFrom (pargs ++ map fst env)

87+

88+initNextNameFrom :: [Name] -> Elab' aux ()

89+initNextNameFrom ns = do ES (p, a) s e <- get

90+ let n' = maxName (nextname p) ns

91+ put (ES (p { nextname = n' }, a) s e)

92+ where

93+ maxName m ((MN i _) : xs) = maxName (max m i) xs

94+ maxName m (_ : xs) = maxName m xs

95+ maxName m [] = m + 1

96+

6797errAt :: String -> Name -> Elab' aux a -> Elab' aux a

6898errAt thing n elab = do s <- get

6999 case runStateT elab s of

70100 OK (a, s') -> do put s'

71− return a

101+ return $! a

72102 Error (At f e) ->

73103 lift $ Error (At f (Elaborating thing n e))

74104 Error e -> lift $ Error (Elaborating thing n e)

@@ -77,7 +107,7 @@ erun :: FC -> Elab' aux a -> Elab' aux a

77107erun f elab = do s <- get

78108 case runStateT elab s of

79109 OK (a, s') -> do put s'

80− return a

110+ return $! a

81111 Error (ProofSearchFail (At f e))

82112 -> lift $ Error (ProofSearchFail (At f e))

83113 Error (At f e) -> lift $ Error (At f e)

@@ -95,7 +125,11 @@ initElaborator = newProof

95125elaborate :: Context -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

96126elaborate ctxt n ty d elab = do let ps = initElaborator n ctxt ty

97127 (a, ES ps' str _) <- runElab d elab ps

98− return (a, str)

128+ return $! (a, str)

129+

130+force_term :: Elab' aux ()

131+force_term = do ES (ps, a) l p <- get

132+ put (ES (ps { pterm = force (pterm ps) }, a) l p)

99133

100134updateAux :: (aux -> aux) -> Elab' aux ()

101135updateAux f = do ES (ps, a) l p <- get

@@ -103,23 +137,27 @@ updateAux f = do ES (ps, a) l p <- get

103137

104138getAux :: Elab' aux aux

105139getAux = do ES (ps, a) _ _ <- get

106− return a

140+ return $! a

107141

108142unifyLog :: Bool -> Elab' aux ()

109143unifyLog log = do ES (ps, a) l p <- get

110144 put (ES (ps { unifylog = log }, a) l p)

111145

146+getUnifyLog :: Elab' aux Bool

147+getUnifyLog = do ES (ps, a) l p <- get

148+ return (unifylog ps)

149+

112150processTactic' t = do ES (p, a) logs prev <- get

113151 (p', log) <- lift $ processTactic t p

114152 put (ES (p', a) (logs ++ log) prev)

115− return ()

153+ return $! ()

116154

117155-- Some handy gadgets for pulling out bits of state

118156

119157-- get the global context

120158get_context :: Elab' aux Context

121159get_context = do ES p _ _ <- get

122− return (context (fst p))

160+ return $! (context (fst p))

123161

124162-- update the context

125163-- (should only be used for adding temporary definitions or all sorts of

@@ -131,7 +169,7 @@ set_context ctxt = do ES (p, a) logs prev <- get

131169-- get the proof term

132170get_term :: Elab' aux Term

133171get_term = do ES p _ _ <- get

134− return (pterm (fst p))

172+ return $! (pterm (fst p))

135173

136174-- get the proof term

137175update_term :: (Term -> Term) -> Elab' aux ()

@@ -146,24 +184,24 @@ get_env = do ES p _ _ <- get

146184

147185get_holes :: Elab' aux [Name]

148186get_holes = do ES p _ _ <- get

149− return (holes (fst p))

187+ return $! (holes (fst p))

150188

151189get_probs :: Elab' aux Fails

152190get_probs = do ES p _ _ <- get

153− return (problems (fst p))

191+ return $! (problems (fst p))

154192

155193-- get the current goal type

156194goal :: Elab' aux Type

157195goal = do ES p _ _ <- get

158196 b <- lift $ goalAtFocus (fst p)

159− return (binderTy b)

197+ return $! (binderTy b)

160198

161199-- Get the guess at the current hole, if there is one

162200get_guess :: Elab' aux Type

163201get_guess = do ES p _ _ <- get

164202 b <- lift $ goalAtFocus (fst p)

165203 case b of

166− Guess t v -> return v

204+ Guess t v -> return $! v

167205 _ -> fail "Not a guess"

168206

169207-- typecheck locally

@@ -171,22 +209,22 @@ get_type :: Raw -> Elab' aux Type

171209get_type tm = do ctxt <- get_context

172210 env <- get_env

173211 (val, ty) <- lift $ check ctxt env tm

174− return (finalise ty)

212+ return $! (finalise ty)

175213

176214get_type_val :: Raw -> Elab' aux (Term, Type)

177215get_type_val tm = do ctxt <- get_context

178216 env <- get_env

179217 (val, ty) <- lift $ check ctxt env tm

180− return (finalise val, finalise ty)

218+ return $! (finalise val, finalise ty)

181219

182220-- get holes we've deferred for later definition

183221get_deferred :: Elab' aux [Name]

184222get_deferred = do ES p _ _ <- get

185− return (deferred (fst p))

223+ return $! (deferred (fst p))

186224

187225checkInjective :: (Term, Term, Term) -> Elab' aux ()

188226checkInjective (tm, l, r) = do ctxt <- get_context

189− if isInj ctxt tm then return ()

227+ if isInj ctxt tm then return $! ()

190228 else lift $ tfail (NotInjective tm l r)

191229 where isInj ctxt (P _ n _)

192230 | isConName n ctxt = True

@@ -199,7 +237,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

199237-- get instance argument names

200238get_instances :: Elab' aux [Name]

201239get_instances = do ES p _ _ <- get

202− return (instances (fst p))

240+ return $! (instances (fst p))

203241

204242-- given a desired hole name, return a unique hole name

205243unique_hole = unique_hole' False

@@ -209,13 +247,14 @@ unique_hole' reusable n

209247 = do ES p _ _ <- get

210248 let bs = bound_in (pterm (fst p)) ++

211249 bound_in (ptype (fst p))

212− n' <- return $ uniqueNameCtxt (context (fst p)) n (holes (fst p)

213− ++ bs ++ dontunify (fst p) ++ usedns (fst p))

250+ let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p)

251+ n' <- return $! uniqueNameCtxt (context (fst p)) n nouse

214252 ES (p, a) s u <- get

215− -- Hmm: Do we need this level of uniqueness?

216− let p' = p -- if reusable then p else p { usedns = n' : usedns p }

217− put (ES (p', a) s u)

218− return n'

253+ case n' of

254+ MN i _ -> when (i >= nextname p) $

255+ put (ES (p { nextname = i + 1 }, a) s u)

256+ _ -> return $! ()

257+ return $! n'

219258 where

220259 bound_in (Bind n b sc) = n : bi b ++ bound_in sc

221260 where

@@ -231,7 +270,7 @@ elog str = do ES p logs prev <- get

231270

232271getLog :: Elab' aux String

233272getLog = do ES p logs _ <- get

234− return logs

273+ return $! logs

235274

236275-- The primitives, from ProofState

237276

@@ -312,11 +351,12 @@ equiv tm = processTactic' (Equiv tm)

312351

313352patvar :: Name -> Elab' aux ()

314353patvar n = do env <- get_env

354+ hs <- get_holes

315355 if (n `elem` map fst env) then do apply (Var n) []; solve

316356 else do n' <- case n of

317− UN _ -> return n

357+ UN _ -> return $! n

318358 MN _ _ -> unique_hole n

319− NS _ _ -> return n

359+ NS _ _ -> return $! n

320360 processTactic' (PatVar n')

321361

322362patbind :: Name -> Elab' aux ()

@@ -356,13 +396,13 @@ reorder_claims n = processTactic' (Reorder n)

356396qed :: Elab' aux Term

357397qed = do processTactic' QED

358398 ES p _ _ <- get

359− return (pterm (fst p))

399+ return $! (pterm (fst p))

360400

361401undo :: Elab' aux ()

362402undo = processTactic' Undo

363403

364404prepare_apply :: Raw -> [Bool] -> Elab' aux [Name]

365−prepare_apply fn imps =

405+prepare_apply fn imps =

366406 do ty <- get_type fn

367407 ctxt <- get_context

368408 env <- get_env

@@ -377,18 +417,18 @@ prepare_apply fn imps =

377417-- case claims of

378418-- [] -> return ()

379419-- (h : _) -> reorder_claims h

380− return claims

420+ return $! claims

381421 where

382422 mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =

383423 do let t = rebind hs t_in

384− n <- unique_hole (mkMN n')

424+ n <- getNameFrom (mkMN n')

385425-- when (null claims) (start_unify n)

386426 let sc' = instantiate (P Bound n t) sc

387−-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show hs) $

427+-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $

388428 claim n (forget t)

389429 when i (movelast n)

390430 mkClaims sc' is (n : claims) hs

391− mkClaims t [] claims _ = return (reverse claims)

431+ mkClaims t [] claims _ = return $! (reverse claims)

392432 mkClaims _ _ _ _

393433 | Var n <- fn

394434 = do ctxt <- get_context

@@ -400,9 +440,9 @@ prepare_apply fn imps =

400440 doClaim ((i, _), n, t) = do claim n t

401441 when i (movelast n)

402442

403− mkMN n@(MN _ _) = n

404− mkMN n@(UN x) = MN 1000 x

405− mkMN n@(SN s) = MN 1000 (show s)

443+ mkMN n@(MN i _) = n

444+ mkMN n@(UN x) = MN 99999 x

445+ mkMN n@(SN s) = sMN 99999 (show s)

406446 mkMN (NS n xs) = NS (mkMN n) xs

407447

408448 rebind hs (Bind n t sc)

@@ -419,16 +459,13 @@ match_apply = apply' match_fill

419459apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

420460apply' fillt fn imps =

421461 do args <- prepare_apply fn (map fst imps)

422− env <- get_env

423− g <- goal

424462 -- _Don't_ solve the arguments we're specifying by hand.

425463 -- (remove from unified list before calling end_unify)

426464 -- HMMM: Actually, if we get it wrong, the typechecker will complain!

427465 -- so do nothing

428− ptm <- get_term

429466 hs <- get_holes

430467 ES (p, a) s prev <- get

431− let dont = nub $ head hs : dontunify p ++

468+ let dont = head hs : dontunify p ++

432469 if null imps then [] -- do all we can

433470 else

434471 map fst (filter (not.snd) (zip args (map fst imps)))

@@ -441,13 +478,10 @@ apply' fillt fn imps =

441478 put (ES (p { dontunify = dont, unified = (n, unify),

442479 notunified = notunify ++ notunified p }, a) s prev)

443480 fillt (raw_apply fn (map Var args))

444− ptm <- get_term

445− g <- goal

446481-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

447482 end_unify

448− ptm <- get_term

449− return (map (updateUnify unify) args)

450− where updateUnify hs n = case lookup n hs of

483+ return $! (map (updateUnify unify) args)

484+ where updateUnify us n = case lookup n us of

451485 Just (P _ t _) -> t

452486 _ -> n

453487

@@ -460,7 +494,7 @@ apply2 fn elabs =

460494 let (n, hs) = unified p

461495 end_unify

462496 solve

463− where elabArgs [] [] = return ()

497+ where elabArgs [] [] = return $! ()

464498 elabArgs (n:ns) (Just e:es) = do focus n; e

465499 elabArgs ns es

466500 elabArgs (n:ns) (_:es) = elabArgs ns es

@@ -491,18 +525,18 @@ apply_elab n args =

491525 let sc' = instantiate (P Bound n t) sc

492526 claim n (forget t)

493527 case i of

494− Nothing -> return ()

528+ Nothing -> return $! ()

495529 Just _ -> -- don't solve by unification as there is an explicit value

496530 do ES (p, a) s prev <- get

497531 put (ES (p { dontunify = n : dontunify p }, a) s prev)

498532 doClaims sc' is ((n, i) : claims)

499− doClaims t [] claims = return (reverse claims)

533+ doClaims t [] claims = return $! (reverse claims)

500534 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

501535

502536 elabClaims failed r []

503− | null failed = return ()

537+ | null failed = return $! ()

504538 | otherwise = if r then elabClaims [] False failed

505− else return ()

539+ else return $! ()

506540 elabClaims failed r ((n, Nothing) : xs) = elabClaims failed r xs

507541 elabClaims failed r (e@(n, Just (_, elaboration)) : xs)

508542 | r = try (do ES p _ _ <- get

@@ -512,7 +546,7 @@ apply_elab n args =

512546 focus n; elaboration; elabClaims failed r xs

513547

514548 mkMN n@(MN _ _) = n

515− mkMN n@(UN x) = MN 1000 x

549+ mkMN n@(UN x) = MN 0 x

516550 mkMN (NS n ns) = NS (mkMN n) ns

517551

518552-- If the goal is not a Pi-type, invent some names and make it a pi type

@@ -521,9 +555,9 @@ checkPiGoal n

521555 = do g <- goal

522556 case g of

523557 Bind _ (Pi _) _ -> return ()

524− _ -> do a <- unique_hole (MN 0 "pargTy")

525− b <- unique_hole (MN 0 "pretTy")

526− f <- unique_hole (MN 0 "pf")

558+ _ -> do a <- getNameFrom (sMN 0 "pargTy")

559+ b <- getNameFrom (sMN 0 "pretTy")

560+ f <- getNameFrom (sMN 0 "pf")

527561 claim a RType

528562 claim b RType

529563 claim f (RBind n (Pi (Var a)) (Var b))

@@ -535,13 +569,13 @@ checkPiGoal n

535569

536570simple_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

537571simple_app fun arg appstr =

538− do a <- unique_hole (MN 0 "argTy")

539− b <- unique_hole (MN 0 "retTy")

540− f <- unique_hole (MN 0 "f")

541− s <- unique_hole (MN 0 "s")

572+ do a <- getNameFrom (sMN 0 "argTy")

573+ b <- getNameFrom (sMN 0 "retTy")

574+ f <- getNameFrom (sMN 0 "f")

575+ s <- getNameFrom (sMN 0 "s")

542576 claim a RType

543577 claim b RType

544− claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b))

578+ claim f (RBind (sMN 0 "aX") (Pi (Var a)) (Var b))

545579 tm <- get_term

546580 start_unify s

547581 claim s (Var a)

@@ -580,7 +614,7 @@ no_errors tac

580614 ((x,y,env,err) : _) ->

581615 let env' = map (\(x, b) -> (x, binderTy b)) env in

582616 lift $ tfail $ CantUnify False x y err env' 0

583− else return ()

617+ else return $! ()

584618

585619-- Try a tactic, if it fails, try another

586620try :: Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -592,10 +626,10 @@ try' t1 t2 proofSearch

592626 ps <- get_probs

593627 case prunStateT 999999 False ps t1 s of

594628 OK ((v, _), s') -> do put s'

595− return v

629+ return $! v

596630 Error e1 -> if recoverableErr e1 then

597631 do case runStateT t2 s of

598− OK (v, s') -> do put s'; return v

632+ OK (v, s') -> do put s'; return $! v

599633 Error e2 -> if score e1 >= score e2

600634 then lift (tfail e1)

601635 else lift (tfail e2)

@@ -632,8 +666,8 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

632666 case prunStateT pmax True ps x s of

633667 OK ((v, newps), s') ->

634668 do let cs' = if (newps < pmax)

635− then [do put s'; return v]

636− else (do put s'; return v) : cs

669+ then [do put s'; return $! v]

670+ else (do put s'; return $! v) : cs

637671 tryAll' cs' newps f xs

638672 Error err -> do put s

639673 if (score err) < 100

src/Idris/Core/Evaluate.hs+22−17

@@ -9,11 +9,12 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

99 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

1010 addDatatype, addCasedef, simplifyCasedef, addOperator,

1111 lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

12+ mapDefCtxt,

1213 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

1314 Value(..), Quote(..), initEval, uniqueNameCtxt) where

1415

1516import Debug.Trace

16−import Control.Monad.State

17+import Control.Monad.State -- not Strict!

1718import qualified Data.Binary as B

1819import Data.Binary hiding (get, put)

1920

@@ -98,11 +99,11 @@ specialise ctxt env limits t

9899

99100simplify :: Context -> Env -> TT Name -> TT Name

100101simplify ctxt env t

101− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

102− (UN "assert_smaller", 0),

103− (UN "par", 0),

104− (UN "prim__syntactic_eq", 0),

105− (UN "fork", 0)]

102+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

103+ (sUN "assert_smaller", 0),

104+ (sUN "par", 0),

105+ (sUN "prim__syntactic_eq", 0),

106+ (sUN "fork", 0)]

106107 (map finalEntry env) (finalise t)

107108 [Simplify]

108109 quote 0 val) initEval

@@ -110,11 +111,11 @@ simplify ctxt env t

110111-- | Simplify for run-time (i.e. basic inlining)

111112rt_simplify :: Context -> Env -> TT Name -> TT Name

112113rt_simplify ctxt env t

113− = evalState (do val <- eval False ctxt [(UN "lazy", 0),

114− (UN "assert_smaller", 0),

115− (UN "par", 0),

116− (UN "prim__syntactic_eq", 0),

117− (UN "prim_fork", 0)]

114+ = evalState (do val <- eval False ctxt [(sUN "lazy", 0),

115+ (sUN "assert_smaller", 0),

116+ (sUN "par", 0),

117+ (sUN "prim__syntactic_eq", 0),

118+ (sUN "prim_fork", 0)]

118119 (map finalEntry env) (finalise t)

119120 [RunTT]

120121 quote 0 val) initEval

@@ -189,7 +190,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

189190 = not (inl || dict) || elem n stk

190191 | Simplify `elem` opts

191192 = (not (inl || dict) || elem n stk)

192− || (n == UN "prim__syntactic_eq")

193+ || (n == sUN "prim__syntactic_eq")

193194 | otherwise = False

194195

195196 getCases cd | simpl = cases_totcheck cd

@@ -411,7 +412,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

411412 chooseAlt env _ (VP _ n _, args) alts amap

412413 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)

413414 chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap

414− | Just (ns, sc) <- findFn (UN "->") alts

415+ | Just (ns, sc) <- findFn (sUN "->") alts

415416 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

416417 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

417418 chooseAlt _ _ _ alts amap

@@ -491,7 +492,7 @@ instance Quote Value where

491492 = do sc' <- quote i sc

492493 t' <- quote i t

493494 v' <- quote i v

494− let sc'' = pToV (MN vd "vlet") (addBinder sc')

495+ let sc'' = pToV (sMN vd "vlet") (addBinder sc')

495496 return (Bind n (Let t' v') sc'')

496497 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

497498 quote i (VType u) = return $ TType u

@@ -512,9 +513,9 @@ wknV i t = return t

512513

513514convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

514515

515−convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

516+convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

516517convEq 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

518519 ceq ps (P xt x _) (P yt y _)

519520 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

520521 | otherwise = sameDefs ps x y

@@ -696,6 +697,10 @@ data Context = MkContext {

696697-- | The initial empty context

697698initContext = MkContext [] 0 emptyContext

698699

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+

699704-- | Get the definitions from a context

700705ctxtAlist :: Context -> [(Name, Def)]

701706ctxtAlist ctxt = map (\(n, (d, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)

@@ -886,7 +891,7 @@ lookupDefAcc :: Name -> Bool -> Context ->

886891lookupDefAcc n mkpublic ctxt

887892 = map mkp $ lookupCtxt n (definitions ctxt)

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

890895 then (d, Public) else (d, a)

891896

892897lookupTotal :: Name -> Context -> [Totality]

src/Idris/Core/Execute.hs+65−41

@@ -96,7 +96,7 @@ toTT (EApp e1 e2) = do e1' <- toTT e1

9696toTT (EType u) = return $ TType u

9797toTT EErased = return Erased

9898toTT (EConstant c) = return (Constant c)

99−toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT

99+toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT

100100toTT (EHandle _) = return Erased

101101

102102unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -173,7 +173,7 @@ execute tm = do est <- initState

173173 Right tm' -> return tm'

174174

175175ioWrap :: ExecVal -> ExecVal

176−ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]

176+ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]

177177

178178ioUnit :: ExecVal

179179ioUnit = ioWrap (EP Ref unitCon EErased)

@@ -219,8 +219,9 @@ execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

219219execApp env ctxt (f, args) = do newF <- doExec env ctxt f

220220 laziness <- (++ repeat False) <$> (getLaziness newF)

221221 newArgs <- mapM argExec (zip args laziness)

222− execApp' env ctxt newF newArgs

223− where getLaziness (EP _ (UN "lazy") _) = return [False, True]

222+ res <- execApp' env ctxt newF newArgs

223+ return res

224+ where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

224225 getLaziness (EP _ n _) = do est <- getExecState

225226 let argInfo = exec_implicits est

226227 case lookupCtxtName n argInfo of

@@ -235,28 +236,36 @@ execApp env ctxt (f, args) = do newF <- doExec env ctxt f

235236

236237execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

237238execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

238−execApp' env ctxt (EP _ (UN "unsafePerformPrimIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =

239− execApp' env ctxt v rest

240−

241−execApp' env ctxt (EP _ (UN "prim_io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =

239+execApp' env ctxt (EP _ fp _) (ty:action:rest)

240+ | fp == upio,

241+ (prim__IO, [_, v]) <- unApplyV action

242+ = execApp' env ctxt v rest

243+

244+execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

245+ | fp == piobind,

246+ (prim__IO, [_, v']) <- unApplyV v =

242247 do v'' <- tryForce v'

243248 res <- execApp' env ctxt k [v''] >>= tryForce

244249 execApp' env ctxt res rest

245−execApp' env ctxt con@(EP _ (UN "prim_io_return") _) args@(tp:v:rest) =

250+execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

251+ | fp == pioret =

246252 do v' <- tryForce v

247253 execApp' env ctxt (mkEApp con [tp, v']) rest

248254

249255-- Special cases arising from not having access to the C RTS in the interpreter

250−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest)

251− | Just (FFun "putStr" _ _) <- foreignFromTT fn

256+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

257+ | fp == mkfprim,

258+ Just (FFun "putStr" _ _) <- foreignFromTT fn

252259 = do execIO (putStr arg)

253260 execApp' env ctxt ioUnit rest

254−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

255− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

261+execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

262+ | fp == mkfprim,

263+ Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

256264 = do contents <- execIO $ hGetLine h

257265 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

258−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

259− | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

266+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

267+ | fp == mkfprim,

268+ Just (FFun "fileOpen" _ _) <- foreignFromTT fn

260269 = do m <- case mode of

261270 "r" -> return ReadMode

262271 "w" -> return WriteMode

@@ -268,42 +277,46 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268277 h <- execIO $ openFile f m

269278 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

270279

271−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

272− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

280+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

281+ | fp == mkfprim,

282+ Just (FFun "fileEOF" _ _) <- foreignFromTT fn

273283 = do eofp <- execIO $ hIsEOF h

274284 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

275285 execApp' env ctxt res (tail rest)

276286

277−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

278− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

287+execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

288+ | fp == mkfprim,

289+ Just (FFun "fileClose" _ _) <- foreignFromTT fn

279290 = do execIO $ hClose h

280291 execApp' env ctxt ioUnit (tail rest)

281292

282−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

283− | Just (FFun "isNull" _ _) <- foreignFromTT fn

293+execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

294+ | fp == mkfprim,

295+ Just (FFun "isNull" _ _) <- foreignFromTT fn

284296 = let res = ioWrap . EConstant . I $

285297 if p == nullPtr then 1 else 0

286298 in execApp' env ctxt res (tail rest)

287299

288300-- A foreign-returned char* has to be tested for NULL sometimes

289−execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str s):rest)

290− | Just (FFun "isNull" _ _) <- foreignFromTT fn

301+execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

302+ | fp == mkfprim,

303+ Just (FFun "isNull" _ _) <- foreignFromTT fn

291304 = let res = ioWrap . EConstant . I $ 0

292305 in execApp' env ctxt res (tail rest)

293306

294307-- Throw away the 'World' argument to the foreign function

295308

296−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

297− | Just (FFun f argTs retT) <- foreignFromTT fn

298− , length xs >= length argTs =

299− do let (args', xs') = (take (length argTs) xs, -- foreign args

300− drop (length argTs + 1) xs) -- rest

301− res <- stepForeign (ty:fn:args')

302− case res of

303− Nothing -> fail $ "Could not call foreign function \"" ++ f ++

304− "\" with args " ++ show args

305− Just r -> return (mkEApp r xs')

306− | otherwise = return (mkEApp f args)

309+execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

310+ = case foreignFromTT fn of

311+ Just (FFun f argTs retT) | length xs >= length argTs ->

312+ do let (args', xs') = (take (length argTs) xs, -- foreign args

313+ drop (length argTs + 1) xs) -- rest

314+ res <- stepForeign (ty:fn:args')

315+ case res of

316+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++

317+ "\" with args " ++ show args

318+ Just r -> return (mkEApp r xs')

319+ Nothing -> return (mkEApp f args)

307320

308321execApp' env ctxt c@(EP (DCon _ arity) n _) args =

309322 do args' <- mapM tryForce (take arity args)

@@ -343,13 +356,23 @@ execApp' env ctxt (EThunk i) args = do f <- force i

343356execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

344357execApp' env ctxt f args = return (mkEApp f args)

345358

359+prs = sUN "prim__readString"

360+pbm = sUN "prim__believe_me"

361+pstd = sUN "prim__stdin"

362+mkfprim = sUN "mkForeignPrim"

363+pioret = sUN "prim_io_return"

364+piobind = sUN "prim_io_bind"

365+upio = sUN "unsafePerformPrimIO"

366+

346367-- | Look up primitive operations in the global table and transform them into ExecVal functions

347368getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

348−getOp (UN "prim__believe_me") [_, _, x] = Just (return x)

349−getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =

369+getOp fn [_, _, x] | fn == pbm = Just (return x)

370+getOp fn [EP _ fn' _]

371+ | fn == prs && fn' == pstd =

350372 Just $ do line <- execIO getLine

351373 return (EConstant (Str line))

352−getOp (UN "prim__readString") [EHandle h] =

374+getOp fn [EHandle h]

375+ | fn == prs =

353376 Just $ do contents <- execIO $ hGetLine h

354377 return (EConstant (Str (contents ++ "\n")))

355378getOp n args = getPrim n primitives >>= flip applyPrim args

@@ -478,11 +501,12 @@ foreignFromTT t = case (unApplyV t) of

478501 argFTy <- sequence $ map getFTy argTy

479502 retFTy <- getFTy ret

480503 return $ FFun name argFTy retFTy

481− _ -> trace "failed to construct ffun" Nothing

504+ _ -> trace ("failed to construct ffun") Nothing

482505

483506getFTy :: ExecVal -> Maybe FType

484−getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

485− case intTy of

507+getFTy (EApp (EP _ (UN fi) _) (EP _ (UN intTy) _))

508+ | fi == txt "FIntT" =

509+ case str intTy of

486510 "ITNative" -> Just (FArith (ATInt ITNative))

487511 "ITChar" -> Just (FArith (ATInt ITChar))

488512 "IT8" -> Just (FArith (ATInt (ITFixed IT8)))

@@ -491,7 +515,7 @@ getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

491515 "IT64" -> Just (FArith (ATInt (ITFixed IT64)))

492516 _ -> Nothing

493517getFTy (EP _ (UN t) _) =

494− case t of

518+ case str t of

495519 "FFloat" -> Just (FArith ATFloat)

496520 "FString" -> Just FString

497521 "FPtr" -> Just FPtr

src/Idris/Core/ProofState.hs+33−31

@@ -13,7 +13,7 @@ import Idris.Core.Evaluate

1313import Idris.Core.TT

1414import Idris.Core.Unify

1515

16−import Control.Monad.State

16+import Control.Monad.State.Strict

1717import Control.Applicative hiding (empty)

1818import Data.List

1919import Debug.Trace

@@ -159,7 +159,7 @@ hole (Hole _) = True

159159hole (Guess _ _) = True

160160hole _ = False

161161

162−holeName i = MN i "hole"

162+holeName i = sMN i "hole"

163163

164164qshow :: Fails -> String

165165qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

@@ -209,7 +209,7 @@ getName :: Monad m => String -> StateT TState m Name

209209getName tag = do ps <- get

210210 let n = nextname ps

211211 put (ps { nextname = n+1 })

212− return $ MN n tag

212+ return $ sMN n tag

213213

214214action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

215215action a = do ps <- get

@@ -476,18 +476,12 @@ solve ctxt env (Bind x (Guess ty val) sc)

476476 | True = do ps <- get

477477 let (uh, uns) = unified ps

478478 case lookup x (notunified ps) of

479− Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

480− -- return []

481− unify' ctxt env tm val

479+ Just tm -> unify' ctxt env tm val

482480 _ -> return []

483481 action (\ps -> ps { holes = holes ps \\ [x],

484482 solved = Just (x, val),

485−-- problems = solveInProblems

486−-- x val (problems ps),

487− -- dontunify = dontunify ps \\ [x],

488− -- unified = (uh, uns ++ [(x, val)]),

489483 instances = instances ps \\ [x] })

490− let tm' = instantiate val (pToV x sc) in

484+ let tm' = subst x val sc in

491485 return tm'

492486 | otherwise = lift $ tfail $ IncompleteTerm val

493487solve _ _ h@(Bind x t sc)

@@ -513,7 +507,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

513507 (tyv, tyt) <- lift $ check ctxt env ty

514508-- ns <- lift $ unify ctxt env tyv t'

515509 case t' of

516− Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

510+ Bind y (Pi s) t -> let t' = subst y (P Bound n s) t in

517511 do ns <- unify' ctxt env s tyv

518512 ps <- get

519513 let (uh, uns) = unified ps

@@ -532,7 +526,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

532526 _ -> hnf ctxt env t

533527 case t' of

534528 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

535− let t' = instantiate (P Bound n s) (pToV y t) in

529+ let t' = subst y (P Bound n s) t in

536530 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

537531 _ -> lift $ tfail $ CantIntroduce t'

538532intro n ctxt env _ = fail "Can't introduce here."

@@ -548,7 +542,7 @@ forall n ty ctxt env _ = fail "Can't pi bind here"

548542patvar :: Name -> RunTactic

549543patvar n ctxt env (Bind x (Hole t) sc) =

550544 do action (\ps -> ps { holes = holes ps \\ [x] })

551− return $ Bind n (PVar t) (instantiate (P Bound n t) (pToV x sc))

545+ return $ Bind n (PVar t) (subst x (P Bound n t) sc)

552546patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm

553547

554548letbind :: Name -> Raw -> Raw -> RunTactic

@@ -568,16 +562,16 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

568562 do (tmv, tmt) <- lift $ check ctxt env tm

569563 let tmt' = normalise ctxt env tmt

570564 case unApply tmt' of

571− (P _ (UN "=") _, [lt,rt,l,r]) ->

565+ (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->

572566 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

573567 let newt = mkP l r l t

574568 let sc = forget $ (Bind x (Hole newt)

575− (mkApp (P Ref (UN "replace") (TType (UVal 0)))

569+ (mkApp (P Ref (sUN "replace") (TType (UVal 0)))

576570 [lt, l, r, p, tmv, xp]))

577571 (scv, sct) <- lift $ check ctxt env sc

578572 return scv

579573 _ -> lift $ tfail (NotEquality tmv tmt')

580− where rname = MN 0 "replaced"

574+ where rname = sMN 0 "replaced"

581575rewrite _ _ _ _ = fail "Can't rewrite here"

582576

583577-- To make the P for rewrite, replace syntactic occurrences of l in ty with

@@ -633,7 +627,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

633627 [] -> fail $ "Induction needs an eliminator for " ++ show tnm

634628 xs -> fail $ "Multiple definitions found when searching for the eliminator of " ++ show tnm

635629 _ -> fail "Unkown type for induction"

636− where scname = MN 0 "scarg"

630+ where scname = sMN 0 "scarg"

637631 makeConsArg (nm, ty) = P Bound nm ty

638632 bindConsArgs ((nm, ty):args) v = Bind nm (Hole ty) $ bindConsArgs args v

639633 bindConsArgs [] v = v

@@ -642,7 +636,7 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

642636 splitTyArgs param_pos tyargs =

643637 let (params, indicies) = partition (flip elem param_pos . fst) . zip [0..] $ tyargs

644638 in (map snd params, map snd indicies)

645− makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (MN 0 "idx") nms):nms) []

639+ makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []

646640 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)

647641 let var = P Bound idnm idxt

648642 return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs

@@ -662,7 +656,7 @@ patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

662656 x@(Bind y (PVTy s) t) -> x

663657 _ -> hnf ctxt env t

664658 case t' of

665− Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in

659+ Bind y (PVTy s) t -> let t' = subst y (P Bound n s) t in

666660 return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))

667661 _ -> fail "Nothing to pattern bind"

668662patbind n ctxt env _ = fail "Can't pattern bind here"

@@ -739,34 +733,42 @@ keepGiven du (u@(n, _) : us) hs

739733 | n `elem` du = u : keepGiven du us hs

740734keepGiven du (u : us) hs = keepGiven du us hs

741735

742−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

743− updateSolved' xs x

736+updateSolved xs x = updateSolved' xs x

737+updateSolved' [] x = x

744738updateSolved' xs (Bind n (Hole ty) t)

745− | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t))

739+ | Just v <- lookup n xs

740+ = case xs of

741+ [_] -> psubst n v t

742+ _ -> psubst n v (updateSolved' xs t)

746743updateSolved' xs (Bind n b t)

747744 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

748−updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

749−updateSolved' xs (P _ n _)

745+updateSolved' xs (App f a)

746+ = App (updateSolved' xs f) (updateSolved' xs a)

747+updateSolved' xs (P _ n@(MN _ _) _)

750748 | Just v <- lookup n xs = v

751749updateSolved' xs t = t

752750

751+updateEnv [] e = e

753752updateEnv ns [] = []

754753updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

755754

755+updateError [] err = err

756756updateError ns (CantUnify b l r e xs sc)

757757 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

758758updateError ns e = e

759759

760760solveInProblems x val [] = []

761761solveInProblems x val ((l, r, env, err) : ps)

762− = ((instantiate val (pToV x l), instantiate val (pToV x r),

762+ = ((psubst x val l, psubst x val r,

763763 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

764764

765+updateNotunified [] nu = nu

765766updateNotunified ns nu = up nu where

766767 up [] = []

767− up ((n, t) : ns) = let t' = updateSolved ns t in

768− ((n, t') : up ns)

768+ up ((n, t) : nus) = let t' = updateSolved ns t in

769+ ((n, t') : up nus)

769770

771+updateProblems ctxt [] ps inj holes = ([], ps)

770772updateProblems ctxt ns ps inj holes = up ns ps where

771773 up ns [] = (ns, [])

772774 up ns ((x, y, env, err) : ps) =

@@ -811,12 +813,11 @@ processTactic EndUnify ps

811813 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

812814 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

813815 (injective ps) (holes ps)

814− tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

815− updateSolved ns'' (pterm ps) in

816+ tm' = updateSolved ns'' (pterm ps) in

816817 return (ps { pterm = tm',

817818 unified = (h, []),

818819 problems = probs',

819− notunified = updateNotunified ns (notunified ps),

820+ notunified = updateNotunified ns'' (notunified ps),

820821 holes = holes ps \\ map fst ns'' }, "")

821822processTactic (Reorder n) ps

822823 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

@@ -841,6 +842,7 @@ processTactic MatchProblems ps

841842 pterm' = updateSolved ns' (pterm ps) in

842843 return (ps { pterm = pterm', solved = Nothing, problems = probs',

843844 previous = Just ps, plog = "",

845+ notunified = updateNotunified ns' (notunified ps),

844846 holes = holes ps \\ (map fst ns') }, plog ps)

845847processTactic t ps

846848 = case holes ps of

src/Idris/Core/TC.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+

3+module Idris.Core.TC(TC'(..)) where

4+

5+import Control.Monad

6+import Control.Monad.Trans.Error(Error(..))

7+

8+data TC' e a = OK !a

9+ | Error e

10+ deriving (Eq, Functor)

11+

12+bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b

13+bindTC x k = case x of

14+ OK v -> k v

15+ Error e -> Error e

16+{-# INLINE bindTC #-}

17+

18+instance Error e => Monad (TC' e) where

19+ return x = OK x

20+ x >>= k = bindTC x k

21+ fail e = Error (strMsg e)

22+

23+instance Error e => MonadPlus (TC' e) where

24+ mzero = fail "Unknown error"

25+ (OK x) `mplus` _ = OK x

26+ _ `mplus` (OK y) = OK y

27+ err `mplus` _ = err

28+

src/Idris/Core/TT.hs+115−72

@@ -18,13 +18,16 @@

1818 programs with implicit syntax into fully explicit terms.

1919-}

2020

21−module Idris.Core.TT where

21+module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where

2222

23−import Control.Monad.State

23+import Idris.Core.TC

24+

25+import Control.Monad.State.Strict

2426import Control.Monad.Trans.Error (Error(..))

2527import Debug.Trace

26−import qualified Data.Map as Map

28+import qualified Data.Map.Strict as Map

2729import Data.Char

30+import qualified Data.Text as T

2831import Data.List

2932import Data.Vector.Unboxed (Vector)

3033import qualified Data.Vector.Unboxed as V

@@ -162,7 +165,7 @@ instance Show Err where

162165 ++ show e ++ " in " ++ show sc ++ " " ++ show i

163166 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

164167 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

166169 show ProgramLineComment = "Program line next to comment"

167170 show (At f e) = show f ++ ":" ++ show e

168171 show _ = "Error"

@@ -182,13 +185,11 @@ instance Pretty Err where

182185 pretty _ = text "Error"

183186

184187instance Error Err where

185− strMsg = Msg

188+ strMsg = InternalMsg

186189

187−data TC a = OK a

188− | Error Err

189− deriving (Eq, Functor)

190+type TC = TC' Err

190191

191−instance Pretty a => Pretty (TC a) where

192+instance (Pretty a) => Pretty (TC a) where

192193 pretty (OK ok) = pretty ok

193194 pretty (Error err) =

194195 if size err > breakingSize then

@@ -200,29 +201,16 @@ instance Show a => Show (TC a) where

200201 show (OK x) = show x

201202 show (Error str) = "Error: " ++ show str

202203

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−

213204tfail :: Err -> TC a

214205tfail e = Error e

215206

207+failMsg :: String -> TC a

208+failMsg str = Error (Msg str)

209+

216210trun :: FC -> TC a -> TC a

217211trun fc (OK a) = OK a

218212trun fc (Error e) = Error (At fc e)

219213

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−

226214discard :: Monad m => m a -> m ()

227215discard f = f >> return ()

228216

@@ -240,20 +228,44 @@ traceWhen False _ a = a

240228

241229-- | Names are hierarchies of strings, describing scope (so no danger of

242230-- duplicate names, but need to be careful on lookup).

243−data Name = UN String -- ^ User-provided name

244− | NS Name [String] -- ^ Root, namespaces

245− | MN Int String -- ^ Machine chosen names

231+data Name = UN T.Text -- ^ User-provided name

232+ | NS Name [T.Text] -- ^ Root, namespaces

233+ | MN Int T.Text -- ^ Machine chosen names

246234 | NErased -- ^ Name of somethng which is never used in scope

247235 | SN SpecialName -- ^ Decorated function names

236+ | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

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

249261{-!

250262deriving instance Binary Name

251263deriving instance NFData Name

252264!-}

253265

254266data SpecialName = WhereN Int Name Name

255− | InstanceN Name [String]

256− | ParentN Name String

267+ | InstanceN Name [T.Text]

268+ | ParentN Name T.Text

257269 | MethodN Name

258270 | CaseN Name

259271 | ElimN Name

@@ -263,6 +275,12 @@ deriving instance Binary SpecialName

263275deriving instance NFData SpecialName

264276!-}

265277

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+

266284instance Sized Name where

267285 size (UN n) = 1

268286 size (NS n els) = 1 + length els

@@ -270,36 +288,36 @@ instance Sized Name where

270288 size _ = 1

271289

272290instance Pretty Name where

273− pretty (UN n) = text n

291+ pretty (UN n) = text (T.unpack n)

274292 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

276294 pretty (SN s) = text (show s)

277295

278296instance Show Name where

279− show (UN n) = n

280− show (NS n s) = showSep "." (reverse s) ++ "." ++ show n

281− show (MN _ "underscore") = "_"

282− show (MN i s) = "{" ++ s ++ show i ++ "}"

297+ show (UN n) = str n

298+ show (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ show n

299+ show (MN _ u) | u == txt "underscore" = "_"

300+ show (MN i s) = "{" ++ str s ++ show i ++ "}"

283301 show (SN s) = show s

284302 show NErased = "_"

285303

286304instance Show SpecialName where

287305 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

289307 show (MethodN m) = "method " ++ show m

290− show (ParentN p c) = show p ++ "#" ++ c

308+ show (ParentN p c) = show p ++ "#" ++ T.unpack c

291309 show (CaseN n) = "case block in " ++ show n

292310 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

293311

294312-- Show a name in a way decorated for code generation, not human reading

295313showCG :: Name -> String

296−showCG (UN n) = n

297−showCG (NS n s) = showSep "." (reverse s) ++ "." ++ showCG n

298−showCG (MN _ "underscore") = "_"

299−showCG (MN i s) = "{" ++ s ++ show i ++ "}"

314+showCG (UN n) = T.unpack n

315+showCG (NS n s) = showSep "." (map T.unpack (reverse s)) ++ "." ++ showCG n

316+showCG (MN _ u) | u == txt "underscore" = "_"

317+showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}"

300318showCG (SN s) = showCG' s

301319 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)

303321 showCG' (MethodN m) = '!':showCG m

304322 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

305323 showCG' (CaseN c) = showCG c ++ "_case"

@@ -312,7 +330,11 @@ showCG NErased = "_"

312330type Ctxt a = Map.Map Name (Map.Map Name a)

313331emptyContext = Map.empty

314332

315−tcname (UN ('@':_)) = True

333+mapCtxt :: (a -> b) -> Ctxt a -> Ctxt b

334+mapCtxt = fmap . fmap

335+

336+tcname (UN xs) | T.null xs = False

337+ | otherwise = T.head xs == '@'

316338tcname (NS n _) = tcname n

317339tcname (SN (InstanceN _ _)) = True

318340tcname (SN (MethodN _)) = True

@@ -320,7 +342,8 @@ tcname (SN (ParentN _ _)) = True

320342tcname _ = False

321343

322344implicitable (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)

324347implicitable (MN _ _) = True

325348implicitable _ = False

326349

@@ -480,19 +503,19 @@ deriving instance NFData Raw

480503!-}

481504

482505-- | All binding forms are represented in a unform fashion.

483−data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

484− | Pi { binderTy :: b }

485− | Let { binderTy :: b,

506+data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

507+ | Pi { binderTy :: !b }

508+ | Let { binderTy :: !b,

486509 binderVal :: b {-^ value for bound variable-}}

487− | NLet { binderTy :: b,

510+ | NLet { binderTy :: !b,

488511 binderVal :: b }

489− | Hole { binderTy :: b}

512+ | Hole { binderTy :: !b}

490513 | GHole { envlen :: Int,

491− binderTy :: b}

492− | Guess { binderTy :: b,

514+ binderTy :: !b}

515+ | Guess { binderTy :: !b,

493516 binderVal :: b }

494− | PVar { binderTy :: b }

495− | PVTy { binderTy :: b }

517+ | PVar { binderTy :: !b }

518+ | PVTy { binderTy :: !b }

496519 deriving (Show, Eq, Ord, Functor)

497520{-!

498521deriving instance Binary Binder

@@ -593,12 +616,12 @@ instance Eq NameType where

593616

594617-- | Terms in the core language

595618data TT n = P NameType n (TT n) -- ^ named references

596− | V Int -- ^ a resolved de Bruijn-indexed variable

597− | Bind n (Binder (TT n)) (TT n) -- ^ a binding

598− | App (TT n) (TT n) -- ^ function, function type, arg

619+ | V !Int -- ^ a resolved de Bruijn-indexed variable

620+ | Bind n !(Binder (TT n)) (TT n) -- ^ a binding

621+ | App !(TT n) (TT n) -- ^ function, function type, arg

599622 | Constant Const -- ^ constant

600− | Proj (TT n) Int -- ^ argument projection; runtime only

601− -- (-1) is a special case for 'subtract one from BI'

623+ | Proj (TT n) !Int -- ^ argument projection; runtime only

624+ -- (-1) is a special case for 'subtract one from BI'

602625 | Erased -- ^ an erased term

603626 | Impossible -- ^ special case for totality checking

604627 | TType UExp -- ^ the type of types at some level

@@ -621,10 +644,10 @@ instance TermSize (TT Name) where

621644 | otherwise = 1

622645 termsize n (V _) = 1

623646 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

625648 termsize rn v + termsize rn sc

626649 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

628651 termsize rn sc

629652 termsize n (App f a) = termsize n f + termsize n a

630653 termsize n (Proj t i) = termsize n t

@@ -653,8 +676,8 @@ data Datatype n = Data { d_typename :: n,

653676instance Eq n => Eq (TT n) where

654677 (==) (P xt x _) (P yt y _) = x == y

655678 (==) (V x) (V y) = x == y

656− (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys

657− (==) (App fx ax) (App fy ay) = fx == fy && ax == ay

679+ (==) (Bind _ xb xs) (Bind _ yb ys) = xs == ys && xb == yb

680+ (==) (App fx ax) (App fy ay) = ax == ay && fx == fy

658681 (==) (TType _) (TType _) = True -- deal with constraints later

659682 (==) (Constant x) (Constant y) = x == y

660683 (==) (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))

754777finalise (App f a) = App (finalise f) (finalise a)

755778finalise t = t

756779

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+

757789subst :: Eq n => n -> TT n -> TT n -> TT n

758790subst n v tm = instantiate v (pToV n tm)

759791

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+

760802substNames :: Eq n => [(n, TT n)] -> TT n -> TT n

761803substNames [] t = t

762804substNames ((n, tm) : xs) t = subst n tm (substNames xs t)

@@ -821,8 +863,9 @@ forget tm = fe [] tm

821863 where

822864 fe env (P _ n _) = Var n

823865 fe env (V i) = Var (env !! i)

824− fe env (Bind n b sc) = RBind n (fmap (fe env) b)

825− (fe (n:env) sc)

866+ fe env (Bind n b sc) = let n' = uniqueName n env in

867+ RBind n' (fmap (fe env) b)

868+ (fe (n':env) sc)

826869 fe env (App f a) = RApp (fe env f) (fe env a)

827870 fe env (Constant c)

828871 = RConstant c

@@ -865,13 +908,13 @@ uniqueBinders ns t = t

865908

866909nextName (NS x s) = NS (nextName x) s

867910nextName (MN i n) = MN (i+1) n

868−nextName (UN x) = let (num', nm') = span isDigit (reverse x)

869− nm = reverse nm'

870− num = readN (reverse num') in

871− UN (nm ++ show (num+1))

911+nextName (UN x) = let (num', nm') = T.span isDigit (T.reverse x)

912+ nm = T.reverse nm'

913+ num = readN (T.reverse num') in

914+ UN (nm `T.append` txt (show (num+1)))

872915 where

873− readN "" = 0

874− readN x = read x

916+ readN x | not (T.null x) = read (T.unpack x)

917+ readN x = 0

875918nextName (SN x) = SN (nextName' x)

876919 where

877920 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

10161059 pureBinder (Let t v) = pureTerm t && pureTerm v

10171060 pureBinder t = pureTerm (binderTy t)

10181061

1019− notClassName (MN _ "class") = False

1062+ notClassName (MN _ c) | c == txt "class" = False

10201063 notClassName _ = True

10211064

10221065pureTerm _ = True

src/Idris/Core/Typecheck.hs+1−1

@@ -88,7 +88,7 @@ check' holes ctxt env top = chk env top where

8888 -- make sure bound names in function types are locally unique, machine

8989 -- generated names, we'll be fine.

9090 -- NOTE: now replaced with 'uniqueBinders' above

91− where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s)

91+ where renameBinders i (Bind x (Pi s) t) = Bind (sMN i "binder") (Pi s)

9292 (renameBinders (i+1) t)

9393 renameBinders i sc = sc

9494 chk env RType

src/Idris/Core/Unify.hs+2−2

@@ -6,7 +6,7 @@ import Idris.Core.TT

66import Idris.Core.Evaluate

77

88import Control.Monad

9−import Control.Monad.State

9+import Control.Monad.State.Strict

1010import Data.List

1111import Debug.Trace

1212

@@ -277,7 +277,7 @@ unify ctxt env topx topy dont holes =

277277

278278 un' fn bnames (App f x) (Bind n (Pi t) y)

279279 | 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)))

281281 (Bind n (Pi t) (V 1)))

282282

283283 un' fn bnames (Bind x bx sx) (Bind y by sy)

src/Idris/Coverage.hs+13−10

@@ -15,7 +15,7 @@ import Data.Either

1515import Data.Maybe

1616import Debug.Trace

1717

18−import Control.Monad.State

18+import Control.Monad.State.Strict

1919

2020mkPatTm :: PTerm -> Idris Term

2121mkPatTm t = do i <- getIState

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

3131 return $ mkApp t' args'

3232 toTT _ = do v <- get

3333 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (sMN v "imp") Erased)

3535

3636-- Given a list of LHSs, generate a extra clauses which cover the remaining

3737-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -166,13 +166,13 @@ genAll i args

166166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167167 otherPats o@(PPair fc l r)

168168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

170− pimp (UN "B") Placeholder True] ++

169+ ([pimp (sUN "A") Placeholder True,

170+ pimp (sUN "B") Placeholder True] ++

171171 [pexp l, pexp r]) o

172172 otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

175− pimp (UN "P") Placeholder True] ++

173+ = ops fc (sUN "Ex_intro")

174+ ([pimp (sUN "a") Placeholder True,

175+ pimp (sUN "P") Placeholder True] ++

176176 [pexp t,pexp v]) o

177177 otherPats o@(PConstant c) = return o

178178 otherPats arg = return Placeholder

@@ -191,7 +191,8 @@ genAll i args

191191 getExpTm t = getTm t

192192

193193 -- put it back to its original form

194− resugar (PApp _ (PRef fc (UN "Ex_intro")) [_,_,t,v])

194+ resugar (PApp _ (PRef fc (UN ei)) [_,_,t,v])

195+ | ei == txt "Ex_intro"

195196 = PDPair fc (getTm t) Placeholder (getTm v)

196197 resugar (PApp _ (PRef fc n) [_,_,l,r])

197198 | n == pairCon

@@ -258,7 +259,8 @@ calcProd i fc topn pats

258259

259260 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

260261 prod n done ok ap@(App _ _)

261− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg

262+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

263+ l == txt "lazy" = prod n done ok arg

262264 | (P nt f _, args) <- unApply ap

263265 = do recOK <- checkProdRec (n:done) f

264266 let ctxt = tt_ctxt i

@@ -405,7 +407,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

405407 findCalls (dePat rhs) (patvars lhs) pargs

406408

407409 findCalls ap@(App f a) pvs pargs

408− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

410+ | (P _ (UN l) _, [_, arg]) <- unApply ap,

411+ l == txt "lazy"

409412 = findCalls arg pvs pargs

410413 | (P _ n _, args) <- unApply ap

411414 = mkChange n args pargs ++

src/Idris/DSL.hs+6−5

@@ -8,7 +8,7 @@ import Paths_idris

88import Idris.Core.TT

99import Idris.Core.Evaluate

1010

11−import Control.Monad.State

11+import Control.Monad.State.Strict

1212import Debug.Trace

1313

1414debindApp :: SyntaxInfo -> PTerm -> PTerm

@@ -44,6 +44,7 @@ expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

4444expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

4545expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)

4646expandDo dsl (PUnifyLog t) = PUnifyLog (expandDo dsl t)

47+expandDo dsl (PDisamb ns t) = PDisamb ns (expandDo dsl t)

4748expandDo dsl (PReturn fc) = dsl_return dsl

4849expandDo dsl (PRewrite fc r t ty)

4950 = PRewrite fc r (expandDo dsl t) ty

@@ -57,8 +58,8 @@ expandDo dsl (PDoBlock ds)

5758 block b (DoBind fc n tm : rest)

5859 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

5960 block b (DoBindP fc p tm : rest)

60− = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

61− (PCase fc (PRef fc (MN 0 "bpat"))

61+ = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

62+ (PCase fc (PRef fc (sMN 0 "bpat"))

6263 [(p, block b rest)]))]

6364 block b (DoLet fc n ty tm : rest)

6465 = PLet n ty tm (block b rest)

@@ -67,7 +68,7 @@ expandDo dsl (PDoBlock ds)

6768 block b (DoExp fc tm : rest)

6869 = PApp fc b

6970 [pexp tm,

70− pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

71+ pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))]

7172 block b _ = PElabError (Msg "Invalid statement in do block")

7273

7374expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

@@ -131,7 +132,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

131132 db' (PAppBind fc t args)

132133 = do args' <- dbs args

133134 (bs, n) <- get

134− let nm = MN n ("bindApp" ++ show n)

135+ let nm = sUN ("_bindApp" ++ show n)

135136 put ((nm, fc, PApp fc t args') : bs, n+1)

136137 return (PRef fc nm)

137138 db' (PApp fc t args)

src/Idris/DataOpts.hs+40−20

@@ -18,14 +18,16 @@ type ForceMap = M.IntMap Forceability

1818

1919-- Calculate the forceable arguments to a constructor

2020-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> Type -> Idris ()

22−forceArgs typeName n t = do

21+forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22+forceArgs typeName n expforce t = do

2323 ist <- getIState

2424 let fargs = getForcedArgs ist typeName t

2525 copt = case lookupCtxt n (idris_optimisation ist) of

2626 [] -> Optimise False False [] []

2727 op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs }) (idris_optimisation ist)

28+ opts = addDef n (copt { forceable = M.toList fargs ++

29+ zip expforce (repeat Unconditional) })

30+ (idris_optimisation ist)

2931 putIState (ist { idris_optimisation = opts })

3032 addIBC (IBCOpt n)

3133 iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

@@ -37,7 +39,7 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

3739

3840 -- Label all occurrences of the variable bound in Pi in the rest of

3941 -- the term with the number i so that we can recognize them anytime later.

40− label i = instantiate $ P Bound (MN i "ctor_arg") Erased

42+ label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

4143

4244 addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

4345 addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

@@ -73,7 +75,8 @@ getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

7375 guardedArgs t = bareArg t

7476

7577 bareArg :: Term -> ForceMap

76− bareArg (P _ (MN i "ctor_arg") _) = M.singleton i Unconditional

78+ bareArg (P _ (MN i ctor_arg) _)

79+ | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

7780 bareArg _ = M.empty

7881

7982 unionMap :: (a -> ForceMap) -> [a] -> ForceMap

@@ -196,8 +199,14 @@ instance Optimisable Raw where

196199

197200 stripCollapsed t = return t

198201

199−instance Optimisable t => Optimisable (Binder t) where

200− applyOpts (Let t v) = Let <$> applyOpts t <*> applyOpts v

202+-- Erase types (makes ibc smaller, and we don't need them)

203+instance Optimisable (Binder (TT Name)) where

204+ applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

205+ applyOpts b = return (b { binderTy = Erased })

206+ stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207+ stripCollapsed b = return (b { binderTy = Erased })

208+

209+instance Optimisable (Binder Raw) where

201210 applyOpts b = do t' <- applyOpts (binderTy b)

202211 return (b { binderTy = t' })

203212 stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

@@ -221,17 +230,24 @@ applyDataOpt oi n args

221230

222231-- Run-time: do everything

223232

233+prel = [txt "Nat", txt "Prelude"]

234+

224235instance Optimisable (TT Name) where

225− applyOpts (P _ (NS (UN "plus") ["Nat","Prelude"]) _)

226− = return (P Ref (UN "prim__addBigInt") Erased)

227− applyOpts (P _ (NS (UN "mult") ["Nat","Prelude"]) _)

228− = return (P Ref (UN "prim__mulBigInt") Erased)

229− applyOpts (App (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _) x)

236+ applyOpts (P _ (NS (UN fn) mod) _)

237+ | fn == txt "plus" && mod == prel

238+ = return (P Ref (sUN "prim__addBigInt") Erased)

239+ applyOpts (P _ (NS (UN fn) mod) _)

240+ | fn == txt "mult" && mod == prel

241+ = return (P Ref (sUN "prim__mulBigInt") Erased)

242+ applyOpts (App (P _ (NS (UN fn) mod) _) x)

243+ | fn == txt "fromIntegerNat" && mod == prel

230244 = applyOpts x

231− applyOpts (P _ (NS (UN "fromIntegerNat") ["Nat","Prelude"]) _)

232− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

233− applyOpts (P _ (NS (UN "toIntegerNat") ["Nat","Prelude"]) _)

234− = return (App (P Ref (NS (UN "id") ["Basics","Prelude"]) Erased) Erased)

245+ applyOpts (P _ (NS (UN fn) mod) _)

246+ | fn == txt "fromIntegerNat" && mod == prel

247+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

248+ applyOpts (P _ (NS (UN fn) mod) _)

249+ | fn == txt "toIntegerNat" && mod == prel

250+ = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

235251 applyOpts c@(P (DCon t arity) n _)

236252 = do i <- getIState

237253 case lookupCtxt n (idris_optimisation i) of

@@ -282,16 +298,19 @@ applyDataOptRT oi n tag arity args

282298 (collapsible oi) (M.fromList $ forceable oi) in

283299 bind extra tm

284300 where

285− satArgs n = map (\i -> MN i "sat") [1..n]

301+ satArgs n = map (\i -> sMN i "sat") [1..n]

286302

287303 bind [] tm = tm

288304 bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))

289305

290306 -- Nat special cases

291307 -- TODO: Would be nice if this was configurable in idris source!

292− doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

293− doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

294− = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

308+ doOpts (NS (UN z) [nat, prelude]) [] _ _

309+ | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310+ = Constant (BI 0)

311+ doOpts (NS (UN s) [nat, prelude]) [k] _ _

312+ | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313+ = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

295314

296315 doOpts n args True _ = Erased

297316 doOpts n args _ forceMap

@@ -302,3 +321,4 @@ applyDataOptRT oi n tag arity args

302321 where

303322 ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

304323 args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324+

src/Idris/DeepSeq.hs+2−97

@@ -1,7 +1,7 @@

1−module Idris.DeepSeq where

1+module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where

22

3+import Idris.Core.DeepSeq

34import Idris.Core.TT

4−import Idris.AbsSyntax

55import Idris.AbsSyntaxTree

66

77import Control.DeepSeq

@@ -12,32 +12,6 @@ instance NFData Forceability where

1212 rnf Conditional = ()

1313 rnf Unconditional = ()

1414

15−instance NFData Raw where

16− rnf (Var x1) = rnf x1 `seq` ()

17− rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

18− rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

19− rnf RType = ()

20− rnf (RForce x1) = rnf x1 `seq` ()

21− rnf (RConstant x1) = x1 `seq` ()

22−

23−instance NFData FC where

24− rnf (FC x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

25−

26−instance NFData Name where

27− rnf (UN x1) = rnf x1 `seq` ()

28− rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

29− rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

30− rnf NErased = ()

31− rnf (SN x1) = rnf x1 `seq` ()

32−

33−instance NFData SpecialName where

34− rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

35− rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

36− rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

37− rnf (MethodN x1) = rnf x1 `seq` ()

38− rnf (CaseN x1) = rnf x1 `seq` ()

39− rnf (ElimN x1) = rnf x1 `seq` ()

40−

4115instance NFData IntTy where

4216 rnf (ITFixed x1) = rnf x1 `seq` ()

4317 rnf ITNative = ()

@@ -45,85 +19,16 @@ instance NFData IntTy where

4519 rnf ITChar = ()

4620 rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

4721

48−

4922instance NFData NativeTy where

5023 rnf IT8 = ()

5124 rnf IT16 = ()

5225 rnf IT32 = ()

5326 rnf IT64 = ()

54−

5527

5628instance NFData ArithTy where

5729 rnf (ATInt x1) = rnf x1 `seq` ()

5830 rnf ATFloat = ()

5931

60−instance NFData Err where

61− rnf (Msg x1) = rnf x1 `seq` ()

62− rnf (InternalMsg x1) = rnf x1 `seq` ()

63− rnf (CantUnify x1 x2 x3 x4 x5 x6)

64− = rnf x1 `seq`

65− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

66− rnf (InfiniteUnify x1 x2 x3)

67− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

68− rnf (CantConvert x1 x2 x3)

69− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

70− rnf (UnifyScope x1 x2 x3 x4)

71− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

72− rnf (CantInferType x1) = rnf x1 `seq` ()

73− rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

74− rnf (CantIntroduce x1) = rnf x1 `seq` ()

75− rnf (NoSuchVariable x1) = rnf x1 `seq` ()

76− rnf (NoTypeDecl x1) = rnf x1 `seq` ()

77− rnf (NotInjective x1 x2 x3)

78− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

79− rnf (CantResolve x1) = rnf x1 `seq` ()

80− rnf (CantResolveAlts x1) = rnf x1 `seq` ()

81− rnf (IncompleteTerm x1) = rnf x1 `seq` ()

82− rnf UniverseError = ()

83− rnf ProgramLineComment = ()

84− rnf (Inaccessible x1) = rnf x1 `seq` ()

85− rnf (NonCollapsiblePostulate x1) = rnf x1 `seq` ()

86− rnf (AlreadyDefined x1) = rnf x1 `seq` ()

87− rnf (ProofSearchFail x1) = rnf x1 `seq` ()

88− rnf (NoRewriting x1) = rnf x1 `seq` ()

89− rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

90− rnf (Elaborating x1 x2 x3)

91− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

92− rnf (ProviderError x1) = rnf x1 `seq` ()

93− rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

94−

95−instance (NFData b) => NFData (Binder b) where

96− rnf (Lam x1) = rnf x1 `seq` ()

97− rnf (Pi x1) = rnf x1 `seq` ()

98− rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

99− rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

100− rnf (Hole x1) = rnf x1 `seq` ()

101− rnf (GHole x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

102− rnf (Guess x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

103− rnf (PVar x1) = rnf x1 `seq` ()

104− rnf (PVTy x1) = rnf x1 `seq` ()

105−

106−instance NFData UExp where

107− rnf (UVar x1) = rnf x1 `seq` ()

108− rnf (UVal x1) = rnf x1 `seq` ()

109−

110−instance NFData NameType where

111− rnf Bound = ()

112− rnf Ref = ()

113− rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

114− rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

115−

116−instance (NFData n) => NFData (TT n) where

117− rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

118− rnf (V x1) = rnf x1 `seq` ()

119− rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

120− rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

121− rnf (Constant x1) = x1 `seq` ()

122− rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

123− rnf Erased = ()

124− rnf Impossible = ()

125− rnf (TType x1) = rnf x1 `seq` ()

126−

12732instance NFData SizeChange where

12833 rnf Smaller = ()

12934 rnf Same = ()

src/Idris/Delaborate.hs+9−9

@@ -42,7 +42,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

4242

4343 de env _ (App f a) = deFn env f [a]

4444 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 ++ ""))

4646 de env _ (P _ n _) | n == unitTy = PTrue un

4747 | n == unitCon = PTrue un

4848 | n == falseTy = PFalse un

@@ -63,8 +63,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

6363 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

6464 de env _ (Bind n (Let ty val) sc)

6565 = 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

67− de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

66+ de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

67+ de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

6868 de env _ (Bind n _ sc) = de ((n,n):env) [] sc

6969 de env _ (Constant i) = PConstant i

7070 de env _ Erased = Placeholder

@@ -82,16 +82,16 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

8282 deFn env (P _ n _) [l,r]

8383 | n == pairTy = PPair un (de env [] l) (de env [] r)

8484 | n == eqCon = PRefl un (de env [] r)

85− | n == UN "lazy" = de env [] r

85+ | n == sUN "lazy" = de env [] r

8686 deFn env (P _ n _) [ty, Bind x (Lam _) r]

87− | n == UN "Exists"

87+ | n == sUN "Exists"

8888 = PDPair un (PRef un x) (de env [] ty)

8989 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

9090 deFn env (P _ n _) [_,_,l,r]

9191 | n == pairCon = PPair un (de env [] l) (de env [] r)

9292 | n == eqTy = PEq un (de env [] l) (de env [] r)

93− | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

94− (de env [] r)

93+ | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder

94+ (de env [] r)

9595 deFn env (P _ n _) args | not mvs

9696 = case lookup n (idris_metavars ist) of

9797 Just (Just _, mi, _) ->

@@ -220,8 +220,8 @@ showqual i n = showName (Just i) [] False False (dens n)

220220 dens n = n

221221

222222showbasic n@(UN _) = show n

223−showbasic (MN _ s) = s

224−showbasic (NS n s) = showSep "." (reverse s) ++ "." ++ showbasic n

223+showbasic (MN _ s) = str s

224+showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

225225showbasic (SN s) = show s

226226

227227

src/Idris/Docs.hs+1−1

@@ -107,7 +107,7 @@ docFun n

107107

108108 return (Doc n docstr args (delab i ty) f)

109109 where funName :: Name -> String

110− funName (UN n) = n

110+ funName (UN n) = str n

111111 funName (NS n _) = funName n

112112

113113

src/Idris/ElabDecls.hs+143−114

@@ -28,12 +28,13 @@ import Idris.Core.CaseTree

2828

2929import Control.DeepSeq

3030import Control.Monad

31−import Control.Monad.State

31+import Control.Monad.State.Strict as State

3232import Data.List

3333import Data.Maybe

3434import Debug.Trace

3535

3636import qualified Data.Map as Map

37+import qualified Data.Text as T

3738import Data.Char(isLetter, toLower)

3839import Data.List.Split (splitOn)

3940

@@ -91,8 +92,10 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

9192 let nty' = normalise ctxt [] nty

9293

9394 -- Add normalised type to internals

94− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

95− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

95+ rep <- useREPL

96+ when rep $ do

97+ addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

98+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

9699

97100 let (t, _) = unApply (getRetTy nty')

98101 let corec = case t of

@@ -137,14 +140,20 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

137140 | otherwise = mergeTy sc sc'

138141 mergeTy _ sc = sc

139142

140− tyIsHandler (Bind _ (Pi (P _ (NS (UN "Err") ns1) _))

141− (App (P _ (NS (UN "Maybe") ns2) _)

142− (App (P _ (NS (UN "List") ns3) _)

143− (P _ (NS (UN "ErrorReportPart") ns4) _))))

144− | ns1 == ["Errors","Reflection","Language"]

145− , ns2 == ["Maybe", "Prelude"]

146− , ns3 == ["List", "Prelude"]

147− , ns4 == ["Errors","Reflection","Language"] = True

143+ err = txt "Err"

144+ maybe = txt "Maybe"

145+ lst = txt "List"

146+ errrep = txt "ErrorReportPart"

147+

148+ tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _))

149+ (App (P _ (NS (UN m) ns2) _)

150+ (App (P _ (NS (UN l) ns3) _)

151+ (P _ (NS (UN r) ns4) _))))

152+ | e == err && m == maybe && l == lst && r == errrep

153+ , ns1 == map txt ["Errors","Reflection","Language"]

154+ , ns2 == map txt ["Maybe", "Prelude"]

155+ , ns3 == map txt ["List", "Prelude"]

156+ , ns4 == map txt ["Errors","Reflection","Language"] = True

148157 tyIsHandler _ = False

149158

150159

@@ -295,7 +304,8 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

295304type EliminatorState = StateT (Map.Map String Int) Idris

296305

297306-- 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 ()

299309elabEliminator paramPos n ty cons info = do

300310 elimLog $ "Elaborating eliminator"

301311 let (cnstrs, _) = splitPi ty

@@ -303,7 +313,7 @@ elabEliminator paramPos n ty cons info = do

303313 generalParams <- namePis False pms

304314 motiveIdxs <- namePis False idxs

305315 let motive = mkMotive n paramPos generalParams motiveIdxs

306− consTerms <- mapM (\(c@(_,cnm,_,_)) -> do

316+ consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

307317 name <- freshName $ "elim_" ++ simpleName cnm

308318 consTerm <- extractConsTerm c generalParams

309319 return (name, expl, consTerm)) cons

@@ -319,13 +329,13 @@ elabEliminator paramPos n ty cons info = do

319329 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

320330 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

321331 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 ())

323333 -- Do not elaborate clauses if there aren't any

324334 case eliminatorClauses of

325335 [] -> return ()

326− _ -> Control.Monad.State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

336+ _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

327337 where elimLog :: String -> EliminatorState ()

328− elimLog s = Control.Monad.State.lift (logLvl 2 s)

338+ elimLog s = State.lift (logLvl 2 s)

329339

330340 elimFC :: FC

331341 elimFC = fileFC "(eliminator)"

@@ -335,7 +345,7 @@ elabEliminator paramPos n ty cons info = do

335345

336346 applyNS :: Name -> [String] -> Name

337347 applyNS n [] = n

338− applyNS n ns = NS n ns

348+ applyNS n ns = sNS n ns

339349

340350 splitPi :: PTerm -> ([(Name, Plicity, PTerm)], PTerm)

341351 splitPi = splitPi' []

@@ -374,11 +384,11 @@ elabEliminator paramPos n ty cons info = do

374384

375385 simpleName :: Name -> String

376386 simpleName (NS n _) = simpleName n

377− simpleName (MN i n) = n ++ show i

387+ simpleName (MN i n) = str n ++ show i

378388 simpleName n = show n

379389

380390 nameSpaces :: Name -> [String]

381− nameSpaces (NS _ ns) = ns

391+ nameSpaces (NS _ ns) = map str ns

382392 nameSpaces _ = []

383393

384394 freshName :: String -> EliminatorState Name

@@ -387,16 +397,16 @@ elabEliminator paramPos n ty cons info = do

387397 let i = fromMaybe 0 (Map.lookup key nameMap)

388398 let name = key ++ show i

389399 put $ Map.insert key (i+1) nameMap

390− return (UN name)

400+ return (sUN name)

391401

392402 scrutineeName :: Name

393− scrutineeName = UN "scrutinee"

403+ scrutineeName = sUN "scrutinee"

394404

395405 scrutineeArgName :: Name

396− scrutineeArgName = UN "scrutineeArg"

406+ scrutineeArgName = sUN "scrutineeArg"

397407

398408 motiveName :: Name

399− motiveName = UN "prop"

409+ motiveName = sUN "prop"

400410

401411 mkMotive :: Name -> [Int] -> [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)] -> PTerm

402412 mkMotive n paramPos params indicies =

@@ -460,9 +470,9 @@ elabEliminator paramPos n ty cons info = do

460470 splitArgPms _ = ([],[])

461471

462472

463− implicitIndexes :: (String, Name, PTerm, FC) -> EliminatorState [(Name, Plicity, PTerm)]

464− implicitIndexes (cns@(doc, cnm, ty, fc)) = do

465− i <- Control.Monad.State.lift getIState

473+ implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

474+ implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

475+ i <- State.lift getIState

466476 implargs' <- case lookupCtxt cnm (idris_implicits i) of

467477 [] -> do fail $ "Error while showing implicits for " ++ show cnm

468478 [args] -> do return args

@@ -475,18 +485,18 @@ elabEliminator paramPos n ty cons info = do

475485 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

476486 _ -> return implargs

477487

478− extractConsTerm :: (String, Name, PTerm, FC) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

479− extractConsTerm (doc, cnm, ty, fc) generalParameters = do

488+ extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

489+ extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

480490 let cons' = replaceParams paramPos generalParameters ty

481491 let (args, resTy) = splitPi cons'

482− implidxs <- implicitIndexes (doc, cnm, ty, fc)

492+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

483493 consArgs <- namePis True args

484494 let recArgs = findRecArgs consArgs

485495 let recMotives = map applyRecMotive recArgs

486496 let (_, consIdxs) = splitArgPms resTy

487497 return $ piConstr (implidxs ++ consArgs ++ recMotives) (applyMotive consIdxs (applyCons cnm consArgs))

488498 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))

490500 where (_, idxs) = splitArgPms ty

491501

492502 findRecArgs :: [(Name, Plicity, PTerm)] -> [(Name, Plicity, PTerm)]

@@ -511,12 +521,12 @@ elabEliminator paramPos n ty cons info = do

511521 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

512522 convertImplPi _ = Nothing

513523

514− generateEliminatorClauses :: (String, Name, PTerm, FC) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

515− generateEliminatorClauses (doc, cnm, ty, fc) cnsElim generalArgs generalParameters = do

524+ generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

525+ generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

516526 let cons' = replaceParams paramPos generalParameters ty

517527 let (args, resTy) = splitPi cons'

518− i <- Control.Monad.State.lift getIState

519− implidxs <- implicitIndexes (doc, cnm, ty, fc)

528+ i <- State.lift getIState

529+ implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

520530 let (_, generalIdxs') = splitArgPms resTy

521531 let generalIdxs = map pexp generalIdxs'

522532 consArgs <- namePis True args

@@ -537,7 +547,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

537547 (zip

538548 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

539549 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

540− addNameHint eqTy (UN "prf")

550+ addNameHint eqTy (sUN "prf")

541551 elabDecl EAll toplevel elimDecl

542552 mapM_ elabPrim primitives

543553 -- Special case prim__believe_me because it doesn't work on just constants

@@ -560,11 +570,11 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

560570

561571 p_believeMe [_,_,x] = Just x

562572 p_believeMe _ = Nothing

563− believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

564− (Bind (UN "b") (Pi (TType (UVar (-2))))

565− (Bind (UN "x") (Pi (V 1)) (V 1)))

573+ believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))))

574+ (Bind (sUN "b") (Pi (TType (UVar (-2))))

575+ (Bind (sUN "x") (Pi (V 1)) (V 1)))

566576 elabBelieveMe

567− = do let prim__believe_me = (UN "prim__believe_me")

577+ = do let prim__believe_me = sUN "prim__believe_me"

568578 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

569579 setTotality prim__believe_me (Partial NotCovering)

570580 i <- getIState

@@ -578,19 +588,19 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

578588 | otherwise = Just (VApp vnNothing VErased)

579589 p_synEq args = Nothing

580590

581− nMaybe = P (TCon 0 2) (NS (UN "Maybe") ["Maybe", "Prelude"]) Erased

582− vnJust = VP (DCon 1 2) (NS (UN "Just") ["Maybe", "Prelude"]) VErased

583− vnNothing = VP (DCon 0 1) (NS (UN "Nothing") ["Maybe", "Prelude"]) VErased

591+ nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased

592+ vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased

593+ vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased

584594 vnRefl = VP (DCon 0 2) eqCon VErased

585595

586− synEqTy = Bind (UN "a") (Pi (TType (UVar (-3))))

587− (Bind (UN "b") (Pi (TType (UVar (-3))))

588− (Bind (UN "x") (Pi (V 1))

589− (Bind (UN "y") (Pi (V 1))

596+ synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))))

597+ (Bind (sUN "b") (Pi (TType (UVar (-3))))

598+ (Bind (sUN "x") (Pi (V 1))

599+ (Bind (sUN "y") (Pi (V 1))

590600 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

591601 [V 3, V 2, V 1, V 0]]))))

592602 elabSynEq

593− = do let synEq = UN "prim__syntactic_eq"

603+ = do let synEq = sUN "prim__syntactic_eq"

594604

595605 updateContext (addOperator synEq synEqTy 4 p_synEq)

596606 setTotality synEq (Total [])

@@ -628,7 +638,7 @@ elabProvider info syn fc n ty tm

628638 -- Execute the type provider and normalise the result

629639 -- use 'run__provider' to convert to a primitive IO action

630640

631− rhs <- execute (mkApp (P Ref (UN "run__provider") Erased)

641+ rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

632642 [Erased, e])

633643 let rhs' = normalise ctxt [] rhs

634644 logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

@@ -646,9 +656,10 @@ elabProvider info syn fc n ty tm

646656

647657 isProviderOf :: TT Name -> TT Name -> Bool

648658 isProviderOf tp prov

649− | (P _ (UN "IO") _, [prov']) <- unApply prov

650− , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'

651− , tp == tp' = True

659+ | (P _ (UN io) _, [prov']) <- unApply prov

660+ , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'

661+ , tp == tp', io == txt "IO"

662+ , prov == txt "Provider" && provs == txt "Providers" = True

652663 isProviderOf _ _ = False

653664

654665-- | Elaborate a type provider

@@ -658,8 +669,8 @@ elabTransform info fc safe lhs_in rhs_in

658669 i <- getIState

659670 let lhs = addImplPat i lhs_in

660671 ((lhs', dlhs, []), _) <-

661− tclift $ elaborate ctxt (MN 0 "transLHS") infP []

662− (erun fc (buildTC i info True [] (UN "transform")

672+ tclift $ elaborate ctxt (sMN 0 "transLHS") infP []

673+ (erun fc (buildTC i info True [] (sUN "transform")

663674 (infTerm lhs)))

664675 let lhs_tm = orderPats (getInferTerm lhs')

665676 let lhs_ty = getInferType lhs'

@@ -669,13 +680,13 @@ elabTransform info fc safe lhs_in rhs_in

669680 logLvl 3 ("Transform LHS " ++ show clhs_tm)

670681 let rhs = addImplBound i (map fst newargs) rhs_in

671682 ((rhs', defer), _) <-

672− tclift $ elaborate ctxt (MN 0 "transRHS") clhs_ty []

683+ tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []

673684 (do pbinds lhs_tm

674− erun fc (build i info False [] (UN "transform") rhs)

685+ setNextName

686+ erun fc (build i info False [] (sUN "transform") rhs)

675687 erun fc $ psolve lhs_tm

676688 tt <- get_term

677− let (tm, ds) = runState (collectDeferred Nothing tt) []

678− return (tm, ds))

689+ return (runState (collectDeferred Nothing tt) []))

679690 (crhs_tm, crhs_ty) <- recheckC fc [] rhs'

680691 logLvl 3 ("Transform RHS " ++ show crhs_tm)

681692 when safe $ case converts ctxt [] clhs_tm crhs_tm of

@@ -688,7 +699,7 @@ elabTransform info fc safe lhs_in rhs_in

688699elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

689700 PTerm -> String -> Name -> PTerm -> Idris ()

690701elabRecord 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, [])])

692703 cty' <- implicit syn cn cty

693704 i <- getIState

694705 cty <- case lookupTy cn (tt_ctxt i) of

@@ -742,18 +753,18 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

742753 getRecTy (PPi _ n ty s) = getRecTy s

743754 getRecTy t = t

744755

745− rec = MN 0 "rec"

756+ rec = sMN 0 "rec"

746757

747− mkp (UN n) = MN 0 ("p_" ++ n)

748− mkp (MN i n) = MN i ("p_" ++ n)

758+ mkp (UN n) = sMN 0 ("p_" ++ str n)

759+ mkp (MN i n) = sMN i ("p_" ++ str n)

749760 mkp (NS n s) = NS (mkp n) s

750761

751− mkImp (UN n) = UN ("implicit_" ++ n)

752− mkImp (MN i n) = MN i ("implicit_" ++ n)

762+ mkImp (UN n) = sUN ("implicit_" ++ str n)

763+ mkImp (MN i n) = sMN i ("implicit_" ++ str n)

753764 mkImp (NS n s) = NS (mkImp n) s

754765

755− mkType (UN n) = UN ("set_" ++ n)

756− mkType (MN i n) = MN i ("set_" ++ n)

766+ mkType (UN n) = sUN ("set_" ++ str n)

767+ mkType (MN i n) = sMN i ("set_" ++ str n)

757768 mkType (NS n s) = NS (mkType n) s

758769

759770 mkProj recty substs cimp ((pn_in, pty), pos)

@@ -776,11 +787,11 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

776787

777788 mkUpdate recty k num ((pn, pty), pos)

778789 = do let setname = expandNS syn $ mkType pn

779− let valname = MN 0 "updateval"

790+ let valname = sMN 0 "updateval"

780791 let pt = k (PPi expl pn pty

781792 (PPi expl rec recty recty))

782793 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]

784795 let lhsArgs = pls

785796 let rhsArgs = take pos pls ++ (PRef fc valname) :

786797 drop (pos + 1) pls

@@ -795,8 +806,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

795806 return (pn, pfnTy, PClauses fc [] setname [pclause])

796807

797808elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

798− (String, Name, PTerm, FC) -> Idris (Name, Type)

799−elabCon info syn tn codata (doc, n, t_in, fc)

809+ (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

810+elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

800811 = do checkUndefined fc n

801812 ctxt <- getContext

802813 i <- getIState

@@ -819,7 +830,10 @@ elabCon info syn tn codata (doc, n, t_in, fc)

819830 addIBC (IBCDef n)

820831 addDocStr n doc

821832 addIBC (IBCDoc n)

822− forceArgs tn n cty'

833+ let fs = map (getNamePos 0 t) forcenames

834+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

835+ -- erasing non-forceable things

836+ forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

823837 return (n, cty')

824838 where

825839 tyIs (Bind n b sc) = tyIs sc

@@ -831,6 +845,11 @@ elabCon info syn tn codata (doc, n, t_in, fc)

831845 mkLazy (PPi pl n ty sc) = PPi (pl { plazy = True }) n ty (mkLazy sc)

832846 mkLazy t = t

833847

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+

834853-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

835854-- top-level definition.

836855elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

@@ -1143,7 +1162,7 @@ elabPE info fc caller r =

11431162 _ -> error "Can't happen (getSpecTy)"

11441163

11451164 getSpecClause ist (n, args)

1146− = let newnm = UN ("__"++show (nsroot n) ++ "_" ++

1165+ = let newnm = sUN ("__"++show (nsroot n) ++ "_" ++

11471166 showSep "_" (map showArg args)) in

11481167 -- UN (show n ++ show (map snd args)) in

11491168 (n, newnm, mkPE_TermDecl ist newnm n args)

@@ -1168,8 +1187,8 @@ elabValBind info aspat tm_in

11681187 ((tm', defer, is), _) <-

11691188-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

11701189-- (build i info aspat (MN 0 "val") tm))

1171− tclift (elaborate ctxt (MN 0 "val") infP []

1172− (build i info aspat [Reflection] (MN 0 "val") (infTerm tm)))

1190+ tclift (elaborate ctxt (sMN 0 "val") infP []

1191+ (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

11731192 let vtm = orderPats (getInferTerm tm')

11741193

11751194 def' <- checkDef (fileFC "(input)") defer

@@ -1199,7 +1218,7 @@ checkPossible info fc tcgen fname lhs_in

11991218 i <- getIState

12001219 let lhs = addImpl i lhs_in

12011220 -- if the LHS type checks, it is possible

1202− case elaborate ctxt (MN 0 "patLHS") infP []

1221+ case elaborate ctxt (sMN 0 "patLHS") infP []

12031222 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

12041223 OK ((lhs', _, _), _) ->

12051224 do let lhs_tm = orderPats (getInferTerm lhs')

@@ -1254,7 +1273,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12541273 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

12551274

12561275 ((lhs', dlhs, []), _) <-

1257− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1276+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

12581277 (errAt "left hand side of " fname

12591278 (erun fc (buildTC i info True opts fname (infTerm lhs))))

12601279 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1267,8 +1286,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12671286

12681287 logLvl 3 ("Normalised LHS: " ++ showImp Nothing True False (delabMV i clhs))

12691288

1270− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1271− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1289+ rep <- useREPL

1290+ when rep $ do

1291+ addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1292+ addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

12721293

12731294 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

12741295 -- Elaborate where block

@@ -1296,10 +1317,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

12961317 ctxt <- getContext -- new context with where block added

12971318 logLvl 5 "STARTING CHECK"

12981319 ((rhs', defer, is), _) <-

1299− tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

1320+ tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []

13001321 (do pbinds lhs_tm

1322+ setNextName

13011323 (_, _, 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))

13031325 errAt "right hand side of " fname

13041326 (erun fc $ psolve lhs_tm)

13051327 hs <- get_holes

@@ -1326,6 +1348,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13261348

13271349 ctxt <- getContext

13281350 logLvl 5 $ "Rechecking"

1351+ logLvl 6 $ " ==> " ++ show (forget rhs')

13291352 (crhs, crhsty) <- recheckC fc [] rhs'

13301353 logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty

13311354 case converts ctxt [] clhsty crhsty of

@@ -1431,7 +1454,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

14311454 let lhs = addImplPat i (stripLinear i lhs_in)

14321455 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

14331456 ((lhs', dlhs, []), _) <-

1434− tclift $ elaborate ctxt (MN 0 "patLHS") infP []

1457+ tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

14351458 (errAt "left hand side of with in " fname

14361459 (erun fc (buildTC i info True opts fname (infTerm lhs))) )

14371460 let lhs_tm = orderPats (getInferTerm lhs')

@@ -1445,9 +1468,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

14451468 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

14461469 -- Elaborate wval in this context

14471470 ((wval', defer, is), _) <-

1448− tclift $ elaborate ctxt (MN 0 "withRHS")

1471+ tclift $ elaborate ctxt (sMN 0 "withRHS")

14491472 (bindTyArgs PVTy bargs infP) []

14501473 (do pbinds lhs_tm

1474+ setNextName

14511475 -- TODO: may want where here - see winfo abpve

14521476 (_', d, is) <- errAt "with value in " fname

14531477 (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)

14771501 let wargtype = getRetTy cwvaltyN

14781502 logLvl 5 ("Abstract over " ++ show wargval)

14791503 let wtype = bindTyArgs Pi (bargs_pre ++

1480− (MN 0 "warg", wargtype) :

1481− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1482− (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

1504+ (sMN 0 "warg", wargtype) :

1505+ map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)

1506+ (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)

14831507 logLvl 3 ("New function type " ++ show wtype)

1484− let wname = MN windex (show fname)

1508+ let wname = sMN windex (show fname)

14851509

14861510 let imps = getImps wtype -- add to implicits context

14871511 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)

15091533 ctxt <- getContext -- New context with block added

15101534 i <- getIState

15111535 ((rhs', defer, is), _) <-

1512− tclift $ elaborate ctxt (MN 0 "wpatRHS") clhsty []

1536+ tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []

15131537 (do pbinds lhs_tm

1538+ setNextName

15141539 (_, d, is) <- erun fc (build i info False opts fname rhs)

15151540 psolve lhs_tm

15161541 tt <- get_term

@@ -1589,7 +1614,7 @@ elabClass :: ElabInfo -> SyntaxInfo -> String ->

15891614 FC -> [PTerm] ->

15901615 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

15911616elabClass 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)

15931618 let tty = pibind ps PType

15941619 let constraint = PApp fc (PRef fc tn)

15951620 (map (pexp . PRef fc) (map fst ps))

@@ -1612,7 +1637,7 @@ elabClass info syn doc fc constraints tn ps ds

16121637 let cty = impbind ps $ conbind constraints

16131638 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

16141639 constraint

1615− let cons = [("", cn, cty, fc)]

1640+ let cons = [("", cn, cty, fc, [])]

16161641 let ddecl = PDatadecl tn tty cons

16171642 logLvl 5 $ "Class data " ++ showDImp True ddecl

16181643 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

16501675

16511676 impbind [] x = x

16521677 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)

16541679 conbind [] x = x

16551680

16561681 getMName (PTy _ _ _ _ n _) = nsroot n

@@ -1674,7 +1699,7 @@ elabClass info syn doc fc constraints tn ps ds

16741699 _ -> ifail $ show n ++ " is not a method"

16751700 defdecl _ _ _ = ifail "Can't happen (defdecl)"

16761701

1677− defaultdec (UN n) = UN ("default#" ++ n)

1702+ defaultdec (UN n) = sUN ("default#" ++ str n)

16781703 defaultdec (NS n ns) = NS (defaultdec n) ns

16791704

16801705 tydecl (PTy _ _ _ _ _ _) = True

@@ -1686,13 +1711,13 @@ elabClass info syn doc fc constraints tn ps ds

16861711

16871712 -- Generate a function for chasing a dictionary constraint

16881713 cfun cn c syn all con

1689− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1714+ = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con)

16901715 -- 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..]

16921717 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

16931718 let lhs = PApp fc (PRef fc cfn) [pconst capp]

16941719 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

16961721 iLOG (showImp Nothing True False ty)

16971722 iLOG (showImp Nothing True False lhs ++ " = " ++ showImp Nothing True False rhs)

16981723 i <- getIState

@@ -1712,10 +1737,10 @@ elabClass info syn doc fc constraints tn ps ds

17121737 -- dictionary (this is inlinable, always)

17131738 tfun cn c syn all (m, (doc, o, ty))

17141739 = 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..]

17161741 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

17171742 let margs = getMArgs ty

1718− let anames = map (\x -> MN x "arg") [0..]

1743+ let anames = map (\x -> sMN x "arg") [0..]

17191744 let lhs = PApp fc (PRef fc m) (pconst capp : lhsArgs margs anames)

17201745 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

17211746 iLOG (showImp Nothing True False ty)

@@ -1744,7 +1769,7 @@ elabClass info syn doc fc constraints tn ps ds

17441769

17451770 insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

17461771 = 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

17481773

17491774 -- make arguments explicit and don't bind class parameters

17501775 toExp ns e (PPi (Imp l s _ p) n ty sc)

@@ -1754,19 +1779,21 @@ elabClass info syn doc fc constraints tn ps ds

17541779 toExp ns e sc = sc

17551780

17561781elabInstance :: ElabInfo -> SyntaxInfo ->

1782+ ElabWhat -> -- phase

17571783 FC -> [PTerm] -> -- constraints

17581784 Name -> -- the class

17591785 [PTerm] -> -- class parameters (i.e. instance)

17601786 PTerm -> -- full instance type

17611787 Maybe Name -> -- explicit name

17621788 [PDecl] -> Idris ()

1763−elabInstance info syn fc cs n ps t expn ds

1764− = do i <- getIState

1765− (n, ci) <- case lookupCtxtName n (idris_classes i) of

1766− [c] -> return c

1767− _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1768− let constraint = PApp fc (PRef fc n) (map pexp ps)

1769− let iname = mkiname n ps expn

1789+elabInstance info syn what fc cs n ps t expn ds = do

1790+ i <- getIState

1791+ (n, ci) <- case lookupCtxtName n (idris_classes i) of

1792+ [c] -> return c

1793+ _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1794+ let constraint = PApp fc (PRef fc n) (map pexp ps)

1795+ let iname = mkiname n ps expn

1796+ when (what /= EDefns) $ do

17701797 nty <- elabType' True info syn "" fc [] iname t

17711798 -- if the instance type matches any of the instances we have already,

17721799 -- 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

17751802 (class_instances ci)

17761803 addInstance intInst n iname

17771804 Just _ -> addInstance intInst n iname

1805+ when (what /= ETypes) $ do

17781806 let ips = zip (class_params ci) ps

17791807 let ns = case n of

17801808 NS n ns' -> ns'

@@ -1827,7 +1855,7 @@ elabInstance info syn fc cs n ps t expn ds

18271855

18281856 mkiname n' ps' expn' =

18291857 case expn' of

1830− Nothing -> SN (InstanceN n' (map show ps'))

1858+ Nothing -> SN (sInstanceN n' (map show ps'))

18311859 Just nm -> nm

18321860

18331861 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

18751903 mkMethApp (n, _, _, ty)

18761904 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

18771905 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')

18791907 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')

18811909 lamBind i _ sc = sc

18821910 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

18841912 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

18861914 methArgs i (PPi (Constraint _ _ _) n ty sc)

18871915 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

18881916 methArgs i _ = []

@@ -1905,14 +1933,14 @@ elabInstance info syn fc cs n ps t expn ds

19051933

19061934 mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

19071935

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)

19091937 conbind [] x = x

19101938

19111939 coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

19121940 coninsert cs sc = conbind cs sc

19131941

19141942 insertDefaults :: IState -> Name ->

1915− [(Name, (Name, PDecl))] -> [String] ->

1943+ [(Name, (Name, PDecl))] -> [T.Text] ->

19161944 [PDecl] -> [PDecl]

19171945 insertDefaults i iname [] ns ds = ds

19181946 insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

@@ -2034,8 +2062,10 @@ elabDecl' what info d@(PClauses f o n ps)

20342062 [] -> []

20352063 elabClauses info f (o ++ o') n ps

20362064elabDecl' what info (PMutual f ps)

2037− = do mapM_ (elabDecl ETypes info) ps

2038− mapM_ (elabDecl EDefns info) ps

2065+ = do case ps of

2066+ [p] -> elabDecl what info p

2067+ _ -> do mapM_ (elabDecl ETypes info) ps

2068+ mapM_ (elabDecl EDefns info) ps

20392069 -- Do totality checking after entire mutual block

20402070 i <- get

20412071 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2071,9 +2101,8 @@ elabDecl' what info (PClass doc s f cs n ps ds)

20712101 = do iLOG $ "Elaborating class " ++ show n

20722102 elabClass info (s { syn_params = [] }) doc f cs n ps ds

20732103elabDecl' what info (PInstance s f cs n ps t expn ds)

2074− | what /= ETypes

20752104 = 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

20772106elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

20782107 | what /= ETypes

20792108 = do iLOG $ "Elaborating record " ++ show tyn

src/Idris/ElabTerm.hs+139−186

@@ -14,7 +14,7 @@ import Idris.Core.Evaluate

1414import Idris.Core.Typecheck (check)

1515

1616import Control.Monad

17−import Control.Monad.State

17+import Control.Monad.State.Strict

1818import Data.List

1919import Data.Maybe (mapMaybe)

2020

@@ -81,7 +81,10 @@ build ist info pattern opts fn tm

8181buildTC :: IState -> ElabInfo -> Bool -> FnOpts -> Name -> PTerm ->

8282 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

8383buildTC ist info pattern opts fn tm

84− = do elab ist info pattern opts fn tm

84+ = do -- set name supply to begin after highest index in tm

85+ let ns = allNamesIn tm

86+ initNextNameFrom ns

87+ elab ist info pattern opts fn tm

8588 probs <- get_probs

8689 tm <- get_term

8790 case probs of

@@ -107,7 +110,6 @@ elab ist info pattern opts fn tm

107110 end_unify

108111 when pattern -- convert remaining holes to pattern vars

109112 (do update_term orderPats

110− tm <- get_term

111113 mkPat)

112114 where

113115 tcgen = Dictionary `elem` opts

@@ -171,18 +173,18 @@ elab ist info pattern opts fn tm

171173 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

172174 = do g <- goal; resolveTC 5 g fn ist

173175 elab' ina (PResolveTC fc)

174− | True = do c <- unique_hole (MN 0 "class")

176+ | True = do c <- getNameFrom (sMN 0 "class")

175177 instanceArg c

176178 | otherwise = do g <- goal

177179 try (resolveTC 2 g fn ist)

178− (do c <- unique_hole (MN 0 "class")

180+ (do c <- getNameFrom (sMN 0 "class")

179181 instanceArg c)

180182 elab' ina (PRefl fc t)

181− = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

182− pimp (MN 0 "x") t False])

183+ = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True,

184+ pimp (sMN 0 "x") t False])

183185 elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

184− [pimp (MN 0 "a") Placeholder True,

185− pimp (MN 0 "b") Placeholder False,

186+ [pimp (sMN 0 "A") Placeholder True,

187+ pimp (sMN 0 "B") Placeholder False,

186188 pexp l, pexp r])

187189 elab' ina@(_, a, inty) (PPair fc l r)

188190 = do hnf_compute

@@ -191,8 +193,8 @@ elab ist info pattern opts fn tm

191193 TType _ -> elabE (True, a,inty) (PApp fc (PRef fc pairTy)

192194 [pexp l,pexp r])

193195 _ -> elabE (True, a, inty) (PApp fc (PRef fc pairCon)

194− [pimp (MN 0 "A") Placeholder True,

195− pimp (MN 0 "B") Placeholder True,

196+ [pimp (sMN 0 "A") Placeholder True,

197+ pimp (sMN 0 "B") Placeholder True,

196198 pexp l, pexp r])

197199 elab' ina (PDPair fc l@(PRef _ n) t r)

198200 = case t of

@@ -207,12 +209,12 @@ elab ist info pattern opts fn tm

207209 [pexp t,

208210 pexp (PLam n Placeholder r)])

209211 asValue = elab' ina (PApp fc (PRef fc existsCon)

210− [pimp (MN 0 "a") t False,

211− pimp (MN 0 "P") Placeholder True,

212+ [pimp (sMN 0 "a") t False,

213+ pimp (sMN 0 "P") Placeholder True,

212214 pexp l, pexp r])

213215 elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)

214− [pimp (MN 0 "a") t False,

215− pimp (MN 0 "P") Placeholder True,

216+ [pimp (sMN 0 "a") t False,

217+ pimp (sMN 0 "P") Placeholder True,

216218 pexp l, pexp r])

217219 elab' ina (PAlternative True as)

218220 = do hnf_compute

@@ -259,38 +261,35 @@ elab ist info pattern opts fn tm

259261 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

260262 elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve

261263 elab' ina@(_, a, inty) (PLam n Placeholder sc)

262− = do -- n' <- unique_hole n

263− -- let sc' = mapPT (repN n n') sc

264− ptm <- get_term

265− g <- goal

264+ = do -- if n is a type constructor name, this makes no sense...

265+ ctxt <- get_context

266+ when (isTConName n ctxt) $

267+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

266268 checkPiGoal n

267269 attack; intro (Just n);

268270 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

269271 elabE (True, a, inty) sc; solve

270− where repN n n' (PRef fc x) | x == n' = PRef fc n'

271− repN _ _ t = t

272272 elab' ina@(_, a, inty) (PLam n ty sc)

273− = do hsin <- get_holes

274− ptmin <- get_term

275− tyn <- unique_hole (MN 0 "lamty")

273+ = do tyn <- getNameFrom (sMN 0 "lamty")

274+ -- if n is a type constructor name, this makes no sense...

275+ ctxt <- get_context

276+ when (isTConName n ctxt) $

277+ lift $ tfail (Msg $ "Can't use type constructor " ++ show n ++ " here")

276278 checkPiGoal n

277279 claim tyn RType

278280 explicit tyn

279281 attack

280282 ptm <- get_term

281283 hs <- get_holes

282− -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

283− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

284284 introTy (Var tyn) (Just n)

285− -- end_unify

286285 focus tyn

287286 elabE (True, a, True) ty

288287 elabE (True, a, inty) sc

289288 solve

290289 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

292291 elab' ina@(_, a, _) (PPi _ n ty sc)

293− = do attack; tyn <- unique_hole (MN 0 "ty")

292+ = do attack; tyn <- getNameFrom (sMN 0 "ty")

294293 claim tyn RType

295294 n' <- case n of

296295 MN _ _ -> unique_hole n

@@ -302,9 +301,9 @@ elab ist info pattern opts fn tm

302301 solve

303302 elab' ina@(_, a, inty) (PLet n ty val sc)

304303 = do attack;

305− tyn <- unique_hole (MN 0 "letty")

304+ tyn <- getNameFrom (sMN 0 "letty")

306305 claim tyn RType

307− valn <- unique_hole (MN 0 "letval")

306+ valn <- getNameFrom (sMN 0 "letval")

308307 claim valn (Var tyn)

309308 explicit valn

310309 letbind n (Var tyn) (Var valn)

@@ -325,9 +324,9 @@ elab ist info pattern opts fn tm

325324 elab' ina@(_, a, inty) (PGoal fc r n sc) = do

326325 rty <- goal

327326 attack

328− tyn <- unique_hole (MN 0 "letty")

327+ tyn <- getNameFrom (sMN 0 "letty")

329328 claim tyn RType

330− valn <- unique_hole (MN 0 "letval")

329+ valn <- getNameFrom (sMN 0 "letval")

331330 claim valn (Var tyn)

332331 letbind n (Var tyn) (Var valn)

333332 focus valn

@@ -346,7 +345,7 @@ elab ist info pattern opts fn tm

346345 -- new function name

347346 env <- get_env

348347 argTys <- claimArgTys env args

349− fn <- unique_hole (MN 0 "inf_fn")

348+ fn <- getNameFrom (sMN 0 "inf_fn")

350349 let fty = fnTy argTys rty

351350-- trace (show (ptm, map fst argTys)) $ focus fn

352351 -- build and defer the function application

@@ -360,8 +359,8 @@ elab ist info pattern opts fn tm

360359 ans <- claimArgTys env xs

361360 return ((n, (False, forget nty)) : ans)

362361 claimArgTys env (_ : xs)

363− = do an <- unique_hole (MN 0 "inf_argTy")

364− aval <- unique_hole (MN 0 "inf_arg")

362+ = do an <- getNameFrom (sMN 0 "inf_argTy")

363+ aval <- getNameFrom (sMN 0 "inf_arg")

365364 claim an RType

366365 claim aval (Var an)

367366 ans <- claimArgTys env xs

@@ -381,7 +380,7 @@ elab ist info pattern opts fn tm

381380 mkN n@(NS _ _) = n

382381 mkN n@(SN _) = n

383382 mkN n = case namespace info of

384− Just xs@(_:_) -> NS n xs

383+ Just xs@(_:_) -> sNS n xs

385384 _ -> n

386385

387386 elab' ina (PMatchApp fc fn)

@@ -394,16 +393,12 @@ elab ist info pattern opts fn tm

394393 | isTConName f (tt_ctxt ist) && pattern && not reflect && not inty

395394 = lift $ tfail (Msg "Typecase is not allowed")

396395 -- if f is local, just do a simple_app

397− 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

403− if (f `elem` map fst env && length args' == 1)

396+ elab' (ina, g, inty) tm@(PApp fc (PRef _ f) args)

397+ = do env <- get_env

398+ if (f `elem` map fst env && length args == 1)

404399 then -- simple app, as below

405400 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)))

407402 (show tm)

408403 solve

409404 else

@@ -416,24 +411,17 @@ elab ist info pattern opts fn tm

416411 -- we can unify with them

417412 case lookupCtxt f (idris_classes ist) of

418413 [] -> return ()

419− _ -> mapM_ setInjective (map getTm args')

414+ _ -> mapM_ setInjective (map getTm args)

420415 ctxt <- get_context

421416 let guarded = isConName f ctxt

422417 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

426419 let (ns', eargs) = unzip $

427− sortBy (\(_,x) (_,y) ->

428− compare (priority x) (priority y))

429− (zip ns args)

420+ sortBy cmpArg (zip ns args)

430421 elabArgs (ina || not isinf, guarded, inty)

431422 [] fc False ns' (map (\x -> (lazyarg x, getTm x)) eargs)

432− mkSpecialised ist fc f (map getTm args') tm

433423 solve

434− ptm <- get_term

435424 ivs' <- get_instances

436− ps' <- get_probs

437425 -- Attempt to resolve any type classes which have 'complete' types,

438426 -- i.e. no holes in them

439427 when (not pattern || (ina && not tcgen && not guarded)) $

@@ -449,6 +437,13 @@ elab ist info pattern opts fn tm

449437 (ivs' \\ ivs)

450438 where tcArg (n, PConstraint _ _ Placeholder _) = True

451439 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

452447

453448 tacTm (PTactics _) = True

454449 tacTm (PProof _) = True

@@ -469,7 +464,7 @@ elab ist info pattern opts fn tm

469464 do attack; defer n'; solve

470465 where mkN n@(NS _ _) = n

471466 mkN n = case namespace info of

472− Just xs@(_:_) -> NS n xs

467+ Just xs@(_:_) -> sNS n xs

473468 _ -> n

474469 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

475470 elab' ina (PTactics ts)

@@ -478,11 +473,11 @@ elab ist info pattern opts fn tm

478473 elab' ina (PElabError e) = fail (pshow ist e)

479474 elab' ina (PRewrite fc r sc newg)

480475 = do attack

481− tyn <- unique_hole (MN 0 "rty")

476+ tyn <- getNameFrom (sMN 0 "rty")

482477 claim tyn RType

483− valn <- unique_hole (MN 0 "rval")

478+ valn <- getNameFrom (sMN 0 "rval")

484479 claim valn (Var tyn)

485− letn <- unique_hole (MN 0 "rewrite_rule")

480+ letn <- getNameFrom (sMN 0 "rewrite_rule")

486481 letbind letn (Var tyn) (Var valn)

487482 focus valn

488483 elab' ina r

@@ -497,11 +492,11 @@ elab ist info pattern opts fn tm

497492 solve

498493 where doEquiv t sc =

499494 do attack

500− tyn <- unique_hole (MN 0 "ety")

495+ tyn <- getNameFrom (sMN 0 "ety")

501496 claim tyn RType

502− valn <- unique_hole (MN 0 "eqval")

497+ valn <- getNameFrom (sMN 0 "eqval")

503498 claim valn (Var tyn)

504− letn <- unique_hole (MN 0 "equiv_val")

499+ letn <- getNameFrom (sMN 0 "equiv_val")

505500 letbind letn (Var tyn) (Var valn)

506501 focus tyn

507502 elab' ina t

@@ -511,10 +506,10 @@ elab ist info pattern opts fn tm

511506 solve

512507 elab' ina@(_, a, inty) c@(PCase fc scr opts)

513508 = do attack

514− tyn <- unique_hole (MN 0 "scty")

509+ tyn <- getNameFrom (sMN 0 "scty")

515510 claim tyn RType

516− valn <- unique_hole (MN 0 "scval")

517− scvn <- unique_hole (MN 0 "scvar")

511+ valn <- getNameFrom (sMN 0 "scval")

512+ scvn <- getNameFrom (sMN 0 "scvar")

518513 claim valn (Var tyn)

519514 letbind scvn (Var tyn) (Var valn)

520515 focus valn

@@ -540,7 +535,7 @@ elab ist info pattern opts fn tm

540535-- mkCaseName (MN i x) = MN i (x ++ "_case")

541536 mkN n@(NS _ _) = n

542537 mkN n = case namespace info of

543− Just xs@(_:_) -> NS n xs

538+ Just xs@(_:_) -> sNS n xs

544539 _ -> n

545540 elab' ina (PUnifyLog t) = do unifyLog True

546541 elab' ina t

@@ -620,8 +615,8 @@ elab ist info pattern opts fn tm

620615 = elabArgs ina failed fc r ns args

621616 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

622617 | lazy && not pattern

623− = do elabArg n (PApp bi (PRef bi (UN "lazy"))

624− [pimp (UN "a") Placeholder True,

618+ = do elabArg n (PApp bi (PRef bi (sUN "lazy"))

619+ [pimp (sUN "a") Placeholder True,

625620 pexp t]);

626621 | otherwise = elabArg n t

627622 where elabArg n t

@@ -701,9 +696,9 @@ findInstances ist t

701696 | otherwise = []

702697

703698trivial' ist

704− = trivial (elab ist toplevel False [] (MN 0 "tac")) ist

699+ = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

705700proofSearch' 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

707702

708703

709704resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

@@ -713,9 +708,10 @@ resolveTC depth topg fn ist

713708 = do hnf_compute

714709 g <- goal

715710 ptm <- get_term

711+ ulog <- getUnifyLog

716712 hs <- get_holes

717− if True -- all (\n -> not (n `elem` hs)) (freeNames g)

718− then try' (trivial' ist)

713+ traceWhen ulog ("Resolving class " ++ show g) $

714+ try' (trivial' ist)

719715 (do t <- goal

720716 let (tc, ttypes) = unApply t

721717 scopeOnly <- needsDefault t tc ttypes

@@ -723,28 +719,23 @@ resolveTC depth topg fn ist

723719 let insts = if scopeOnly then filter chaser insts_in

724720 else insts_in

725721 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

729722 let depth' = if scopeOnly then 2 else depth

730723 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

736724 where

737725 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

738726 | otherwise = (fail "Can't resolve", show n)

739727

740728 -- HACK! Rather than giving a special name, better to have some kind

741729 -- of flag in ClassInfo structure

742− chaser (UN ('@':'@':_)) = True -- old way

730+ chaser (UN nm)

731+ | ('@':'@':_) <- str nm = True -- old way

743732 chaser (SN (ParentN _ _)) = True

744733 chaser (NS n _) = chaser n

745734 chaser _ = False

746735

747− needsDefault t num@(P _ (NS (UN "Num") ["Classes","Prelude"]) _) [P Bound a _]

736+ numclass = sNS (sUN "Num") ["Classes","Prelude"]

737+

738+ needsDefault t num@(P _ nc _) [P Bound a _] | nc == numclass

748739 = do focus a

749740 fill (RConstant (AType (ATInt ITBig))) -- default Integer

750741 solve

@@ -777,8 +768,8 @@ resolveTC depth topg fn ist

777768 [args] -> map isImp (snd args) -- won't be overloaded!

778769 ps <- get_probs

779770 tm <- get_term

780− args <- try' (match_apply (Var n) imps)

781− (apply (Var n) imps) True

771+ args <- try' (apply (Var n) imps)

772+ (match_apply (Var n) imps) True

782773 ps' <- get_probs

783774 when (length ps < length ps') $ fail "Can't apply type class"

784775-- traceWhen (all boundVar ttypes) ("Progress: " ++ show t ++ " with " ++ show n) $

@@ -790,7 +781,9 @@ resolveTC depth topg fn ist

790781 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

791782 -- if there's any arguments left, we've failed to resolve

792783 hs <- get_holes

793− solve

784+ ulog <- getUnifyLog

785+ solve

786+ traceWhen ulog ("Got " ++ show n) $ return ()

794787 where isImp (PImp p _ _ _ _ _) = (True, p)

795788 isImp arg = (False, priority arg)

796789

@@ -832,7 +825,7 @@ runTac autoSolve ist tac

832825 where

833826 bname (Bind n _ _) = Just n

834827 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

836829 when autoSolve solveAll

837830 runT (MatchRefine fn)

838831 = do fnimps <-

@@ -872,27 +865,27 @@ runTac autoSolve ist tac

872865 when autoSolve solveAll

873866 runT (Equiv tm) -- let bind tm, then

874867 = do attack

875− tyn <- unique_hole (MN 0 "ety")

868+ tyn <- getNameFrom (sMN 0 "ety")

876869 claim tyn RType

877− valn <- unique_hole (MN 0 "eqval")

870+ valn <- getNameFrom (sMN 0 "eqval")

878871 claim valn (Var tyn)

879− letn <- unique_hole (MN 0 "equiv_val")

872+ letn <- getNameFrom (sMN 0 "equiv_val")

880873 letbind letn (Var tyn) (Var valn)

881874 focus tyn

882− elab ist toplevel False [] (MN 0 "tac") tm

875+ elab ist toplevel False [] (sMN 0 "tac") tm

883876 focus valn

884877 when autoSolve solveAll

885878 runT (Rewrite tm) -- to elaborate tm, let bind it, then rewrite by that

886879 = do attack; -- (h:_) <- get_holes

887− tyn <- unique_hole (MN 0 "rty")

880+ tyn <- getNameFrom (sMN 0 "rty")

888881 -- start_unify h

889882 claim tyn RType

890− valn <- unique_hole (MN 0 "rval")

883+ valn <- getNameFrom (sMN 0 "rval")

891884 claim valn (Var tyn)

892− letn <- unique_hole (MN 0 "rewrite_rule")

885+ letn <- getNameFrom (sMN 0 "rewrite_rule")

893886 letbind letn (Var tyn) (Var valn)

894887 focus valn

895− elab ist toplevel False [] (MN 0 "tac") tm

888+ elab ist toplevel False [] (sMN 0 "tac") tm

896889 rewrite (Var letn)

897890 when autoSolve solveAll

898891 runT (Induction nm)

@@ -900,27 +893,27 @@ runTac autoSolve ist tac

900893 when autoSolve solveAll

901894 runT (LetTac n tm)

902895 = do attack

903− tyn <- unique_hole (MN 0 "letty")

896+ tyn <- getNameFrom (sMN 0 "letty")

904897 claim tyn RType

905− valn <- unique_hole (MN 0 "letval")

898+ valn <- getNameFrom (sMN 0 "letval")

906899 claim valn (Var tyn)

907900 letn <- unique_hole n

908901 letbind letn (Var tyn) (Var valn)

909902 focus valn

910− elab ist toplevel False [] (MN 0 "tac") tm

903+ elab ist toplevel False [] (sMN 0 "tac") tm

911904 when autoSolve solveAll

912905 runT (LetTacTy n ty tm)

913906 = do attack

914− tyn <- unique_hole (MN 0 "letty")

907+ tyn <- getNameFrom (sMN 0 "letty")

915908 claim tyn RType

916− valn <- unique_hole (MN 0 "letval")

909+ valn <- getNameFrom (sMN 0 "letval")

917910 claim valn (Var tyn)

918911 letn <- unique_hole n

919912 letbind letn (Var tyn) (Var valn)

920913 focus tyn

921− elab ist toplevel False [] (MN 0 "tac") ty

914+ elab ist toplevel False [] (sMN 0 "tac") ty

922915 focus valn

923− elab ist toplevel False [] (MN 0 "tac") tm

916+ elab ist toplevel False [] (sMN 0 "tac") tm

924917 when autoSolve solveAll

925918 runT Compute = compute

926919 runT Trivial = do trivial' ist; when autoSolve solveAll

@@ -933,16 +926,16 @@ runTac autoSolve ist tac

933926 runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

934927 tgoal <- goal -- store the goal

935928 attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

936− script <- unique_hole (MN 0 "script")

929+ script <- getNameFrom (sMN 0 "script")

937930 claim script scriptTy

938− scriptvar <- unique_hole (MN 0 "scriptvar" )

931+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

939932 letbind scriptvar scriptTy (Var script)

940933 focus script

941− elab ist toplevel False [] (MN 0 "tac") tm

934+ elab ist toplevel False [] (sMN 0 "tac") tm

942935 (script', _) <- get_type_val (Var scriptvar)

943936 -- now that we have the script apply

944937 -- it to the reflected goal and context

945− restac <- unique_hole (MN 0 "restac")

938+ restac <- getNameFrom (sMN 0 "restac")

946939 claim restac tacticTy

947940 focus restac

948941 fill (raw_apply (forget script')

@@ -956,27 +949,27 @@ runTac autoSolve ist tac

956949 let tactic = normalise ctxt env restac'

957950 runReflected tactic

958951 where tacticTy = Var (reflm "Tactic")

959− listTy = Var (NS (UN "List") ["List", "Prelude"])

960− scriptTy = (RBind (UN "__pi_arg")

952+ listTy = Var (sNS (sUN "List") ["List", "Prelude"])

953+ scriptTy = (RBind (sUN "__pi_arg")

961954 (Pi (RApp listTy envTupleType))

962− (RBind (UN "__pi_arg1")

955+ (RBind (sUN "__pi_arg1")

963956 (Pi (Var $ reflm "TT")) tacticTy))

964957 runT (ByReflection tm) -- run the reflection function 'tm' on the

965958 -- goal, then apply the resulting reflected Tactic

966959 = do tgoal <- goal

967960 attack

968− script <- unique_hole (MN 0 "script")

961+ script <- getNameFrom (sMN 0 "script")

969962 claim script scriptTy

970− scriptvar <- unique_hole (MN 0 "scriptvar" )

963+ scriptvar <- getNameFrom (sMN 0 "scriptvar" )

971964 letbind scriptvar scriptTy (Var script)

972965 focus script

973966 ptm <- get_term

974− elab ist toplevel False [] (MN 0 "tac")

967+ elab ist toplevel False [] (sMN 0 "tac")

975968 (PApp emptyFC tm [pexp (delabTy' ist [] tgoal True True)])

976969 (script', _) <- get_type_val (Var scriptvar)

977970 -- now that we have the script apply

978971 -- it to the reflected goal

979− restac <- unique_hole (MN 0 "restac")

972+ restac <- getNameFrom (sMN 0 "restac")

980973 claim restac tacticTy

981974 focus restac

982975 fill (forget script')

@@ -992,28 +985,28 @@ runTac autoSolve ist tac

992985 scriptTy = tacticTy

993986

994987 runT (Reflect v) = do attack -- let x = reflect v in ...

995− tyn <- unique_hole (MN 0 "letty")

988+ tyn <- getNameFrom (sMN 0 "letty")

996989 claim tyn RType

997− valn <- unique_hole (MN 0 "letval")

990+ valn <- getNameFrom (sMN 0 "letval")

998991 claim valn (Var tyn)

999− letn <- unique_hole (MN 0 "letvar")

992+ letn <- getNameFrom (sMN 0 "letvar")

1000993 letbind letn (Var tyn) (Var valn)

1001994 focus valn

1002− elab ist toplevel False [] (MN 0 "tac") v

995+ elab ist toplevel False [] (sMN 0 "tac") v

1003996 (value, _) <- get_type_val (Var letn)

1004997 ctxt <- get_context

1005998 env <- get_env

1006999 let value' = hnf ctxt env value

10071000 runTac autoSolve ist (Exact $ PQuote (reflect value'))

10081001 runT (Fill v) = do attack -- let x = fill x in ...

1009− tyn <- unique_hole (MN 0 "letty")

1002+ tyn <- getNameFrom (sMN 0 "letty")

10101003 claim tyn RType

1011− valn <- unique_hole (MN 0 "letval")

1004+ valn <- getNameFrom (sMN 0 "letval")

10121005 claim valn (Var tyn)

1013− letn <- unique_hole (MN 0 "letvar")

1006+ letn <- getNameFrom (sMN 0 "letvar")

10141007 letbind letn (Var tyn) (Var valn)

10151008 focus valn

1016− elab ist toplevel False [] (MN 0 "tac") v

1009+ elab ist toplevel False [] (sMN 0 "tac") v

10171010 (value, _) <- get_type_val (Var letn)

10181011 ctxt <- get_context

10191012 env <- get_env

@@ -1023,12 +1016,12 @@ runTac autoSolve ist tac

10231016 runT (GoalType n tac) = do g <- goal

10241017 case unApply g of

10251018 (P _ n' _, _) ->

1026− if nsroot n' == UN n

1019+ if nsroot n' == sUN n

10271020 then runT tac

10281021 else fail "Wrong goal type"

10291022 _ -> fail "Wrong goal type"

10301023 runT ProofState = do g <- goal

1031− trace (show g) $ return ()

1024+ return ()

10321025 runT x = fail $ "Not implemented " ++ show x

10331026

10341027 runReflected t = do t' <- reify ist t

@@ -1036,7 +1029,7 @@ runTac autoSolve ist tac

10361029

10371030-- | Prefix a name with the "Language.Reflection" namespace

10381031reflm :: String -> Name

1039−reflm n = NS (UN n) ["Reflection", "Language"]

1032+reflm n = sNS (sUN n) ["Reflection", "Language"]

10401033

10411034

10421035-- | 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

10581051reifyApp ist t [Constant (Str n), x]

10591052 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

10601053reifyApp _ t [Constant (Str n)]

1061− | t == reflm "Intro" = return $ Intro [UN n]

1054+ | t == reflm "Intro" = return $ Intro [sUN n]

10621055reifyApp ist t [t']

10631056 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

10641057reifyApp ist t [t']

@@ -1149,13 +1142,13 @@ reifyTTName t = fail ("Unknown reflection term name: " ++ show t)

11491142

11501143reifyTTNameApp :: Name -> [Term] -> ElabD Name

11511144reifyTTNameApp t [Constant (Str n)]

1152− | t == reflm "UN" = return $ UN n

1145+ | t == reflm "UN" = return $ sUN n

11531146reifyTTNameApp t [n, ns]

11541147 | t == reflm "NS" = do n' <- reifyTTName n

11551148 ns' <- reifyTTNamespace ns

1156− return $ NS n' ns'

1149+ return $ sNS n' ns'

11571150reifyTTNameApp t [Constant (I i), Constant (Str n)]

1158− | t == reflm "MN" = return $ MN i n

1151+ | t == reflm "MN" = return $ sMN i n

11591152reifyTTNameApp t []

11601153 | t == reflm "NErased" = return NErased

11611154reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

@@ -1164,9 +1157,9 @@ reifyTTNamespace :: Term -> ElabD [String]

11641157reifyTTNamespace t@(App _ _)

11651158 = case unApply t of

11661159 (P _ f _, [Constant StrType])

1167− | f == NS (UN "Nil") ["List", "Prelude"] -> return []

1160+ | f == sNS (sUN "Nil") ["List", "Prelude"] -> return []

11681161 (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)

11701163 _ -> fail ("Unknown reflection namespace arg: " ++ show t)

11711164reifyTTNamespace t = fail ("Unknown reflection namespace arg: " ++ show t)

11721165

@@ -1288,19 +1281,19 @@ reflectNameType (TCon x y)

12881281 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

12891282

12901283reflectName :: Name -> Raw

1291−reflectName (UN str)

1292− = reflCall "UN" [RConstant (Str str)]

1284+reflectName (UN s)

1285+ = reflCall "UN" [RConstant (Str (str s))]

12931286reflectName (NS n ns)

12941287 = reflCall "NS" [ reflectName n

12951288 , foldr (\ n s ->

1296− raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

1289+ raw_apply ( Var $ sNS (sUN "::") ["List", "Prelude"] )

12971290 [ RConstant StrType, RConstant (Str n), s ])

1298− ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

1291+ ( raw_apply ( Var $ sNS (sUN "Nil") ["List", "Prelude"] )

12991292 [ RConstant StrType ])

1300− ns

1293+ (map str ns)

13011294 ]

13021295reflectName (MN i n)

1303− = reflCall "MN" [RConstant (I i), RConstant (Str n)]

1296+ = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

13041297reflectName (NErased) = Var (reflm "NErased")

13051298reflectName n = Var (reflm "NErased") -- special name, not yet implemented

13061299

@@ -1357,7 +1350,7 @@ reflectEnv = foldr consToEnvList emptyEnvList

13571350 where

13581351 consToEnvList :: (Name, Binder Term) -> Raw -> Raw

13591352 consToEnvList (n, b) l

1360− = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

1353+ = raw_apply (Var (sNS (sUN "::") ["List", "Prelude"]))

13611354 [ envTupleType

13621355 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

13631356 , (RApp (Var $ reflm "Binder")

@@ -1369,19 +1362,19 @@ reflectEnv = foldr consToEnvList emptyEnvList

13691362 ]

13701363

13711364 emptyEnvList :: Raw

1372− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1365+ emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))

13731366 [envTupleType]

13741367

13751368-- | Reflect an error into the internal datatype of Idris -- TODO

13761369rawBool :: Bool -> Raw

1377−rawBool True = Var (NS (UN "True") ["Bool", "Prelude"])

1378−rawBool False = Var (NS (UN "False") ["Bool", "Prelude"])

1370+rawBool True = Var (sNS (sUN "True") ["Bool", "Prelude"])

1371+rawBool False = Var (sNS (sUN "False") ["Bool", "Prelude"])

13791372

13801373rawNil :: 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]

13821375

13831376rawCons :: 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]

13851378

13861379rawList :: Raw -> [Raw] -> Raw

13871380rawList ty = foldr (rawCons ty) (rawNil ty)

@@ -1447,7 +1440,7 @@ reflectErr (NotInjective t1 t2 t3) =

14471440reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

14481441reflectErr (CantResolveAlts ss) =

14491442 raw_apply (Var $ reflErrName "CantResolve")

1450− [rawList (Var $ (UN "String")) (map (RConstant . Str) ss)]

1443+ [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)]

14511444reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

14521445reflectErr UniverseError = Var $ reflErrName "UniverseError"

14531446reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

@@ -1472,7 +1465,7 @@ reflectErr (ProviderError str) =

14721465 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

14731466reflectErr (LoadingFailed str err) =

14741467 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]

14761469

14771470withErrorReflection :: Idris a -> Idris a

14781471withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1506,11 +1499,12 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

15061499 parts -> ReflectionError errorparts e

15071500

15081501 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

15101504 fromTTMaybe x = Nothing

15111505

15121506reflErrName :: String -> Name

1513−reflErrName n = NS (UN n) ["Errors", "Reflection", "Language"]

1507+reflErrName n = sNS (sUN n) ["Errors", "Reflection", "Language"]

15141508

15151509reifyReportPart :: Term -> Idris ErrorReportPart

15161510reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflErrName "TextPart" =

@@ -1548,44 +1542,3 @@ envTupleType

15481542

15491543solveAll = try (do solve; solveAll) (return ())

15501544

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

1212

1313import System.Console.Haskeline

1414import System.Console.Haskeline.MonadException

15−import Control.Monad.State

15+import Control.Monad.State.Strict

1616import Control.Monad.Error (throwError, catchError)

1717import System.IO.Error(isUserError, ioeGetErrorString)

1818import Data.Char

src/Idris/IBC.hs+146−50

@@ -8,25 +8,31 @@ import Idris.Core.CaseTree

88import Idris.AbsSyntax

99import Idris.Imports

1010import Idris.Error

11+import Idris.Delaborate

1112

1213import Data.Binary

1314import Data.Vector.Binary

1415import Data.List

15−import Data.ByteString.Lazy as B hiding (length, elem)

16+import Data.ByteString.Lazy as B hiding (length, elem, map)

17+import qualified Data.Text as T

18+

1619import Control.Monad

17−import Control.Monad.State hiding (get, put)

20+import Control.Monad.State.Strict hiding (get, put)

21+import qualified Control.Monad.State.Strict as ST

1822import System.FilePath

1923import System.Directory

24+import Codec.Compression.Zlib

2025

2126import Debug.Trace

2227

2328import Paths_idris

2429

2530ibcVersion :: Word8

26−ibcVersion = 50

31+ibcVersion = 54

2732

2833data IBCFile = IBCFile { ver :: Word8,

2934 sourcefile :: FilePath,

35+ symbols :: [Name],

3036 ibc_imports :: [FilePath],

3137 ibc_implicits :: [(Name, [PArg])],

3238 ibc_fixes :: [FixDecl],

@@ -61,13 +67,17 @@ deriving instance Binary IBCFile

6167!-}

6268

6369initIBC :: IBCFile

64−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

70+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

6571

6672loadIBC :: FilePath -> Idris ()

6773loadIBC fp = do iLOG $ "Loading ibc " ++ fp

68− ibcf <- runIO $ (decodeFile fp :: IO IBCFile)

74+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

6975 process ibcf fp

7076

77+bencode f d = B.writeFile f (compress (encode d))

78+bdecode f = do d' <- B.readFile f

79+ return (decode (decompress d'))

80+

7181writeIBC :: FilePath -> FilePath -> Idris ()

7282writeIBC src f

7383 = do iLOG $ "Writing ibc " ++ show f

@@ -75,11 +85,12 @@ writeIBC src f

7585 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

7686 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

7787 [] -> return ()

88+ resetNameIdx

7889 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

7990 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

80− runIO $ encodeFile f ibcf

91+ runIO $ bencode f ibcf

8192 iLOG "Written")

82− (\c -> do iLOG $ "Failed " ++ show c)

93+ (\c -> do iLOG $ "Failed " ++ pshow i c)

8394 return ()

8495

8596mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

@@ -124,8 +135,64 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

124135ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

125136ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

126137ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

127− [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

138+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

139+ return f' { ibc_defs = (n,v) : ibc_defs f' }

128140 _ -> 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+

129196ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

130197 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

131198 _ -> ifail "IBC write failed"

@@ -169,7 +236,7 @@ process i fn

169236 pCGFlags (ibc_cgflags i)

170237 pDyLibs (ibc_dynamic_libs i)

171238 pHdrs (ibc_hdrs i)

172− pDefs (ibc_defs i)

239+ pDefs (symbols i) (ibc_defs i)

173240 pAccess (ibc_access i)

174241 pTotal (ibc_total i)

175242 pCG (ibc_cg i)

@@ -207,7 +274,9 @@ pImports fs

207274pImps :: [(Name, [PArg])] -> Idris ()

208275pImps imps = mapM_ (\ (n, imp) ->

209276 do i <- getIState

210− putIState (i { idris_implicits

277+ case lookupDefAcc n False (tt_ctxt i) of

278+ [(n, Hidden)] -> return ()

279+ _ -> putIState (i { idris_implicits

211280 = addDef n imp (idris_implicits i) }))

212281 imps

213282

@@ -289,12 +358,32 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

289358pHdrs :: [(Codegen, String)] -> Idris ()

290359pHdrs hs = mapM_ (uncurry addHdr) hs

291360

292−pDefs :: [(Name, Def)] -> Idris ()

293−pDefs ds = mapM_ (\ (n, d) ->

294− do i <- getIState

295− logLvl 5 $ "Added " ++ show (n, d)

296− putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

297− ds

361+pDefs :: [Name] -> [(Name, Def)] -> Idris ()

362+pDefs syms ds

363+ = mapM_ (\ (n, d) ->

364+ do i <- getIState

365+ let d' = updateDef d

366+ logLvl 5 $ "Added " ++ show (n, d')

367+ putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) 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

298387

299388pDocs :: [(Name, String)] -> Idris ()

300389pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -357,27 +446,24 @@ instance Binary CGInfo where

357446 put (CGInfo x1 x2 x3 x4 x5)

358447 = do put x1

359448 put x2

360− put x3

449+-- put x3 -- Already used SCG info for totality check

361450 put x4

362451 put x5

363452 get

364453 = do x1 <- get

365454 x2 <- get

366− x3 <- get

367455 x4 <- get

368456 x5 <- get

369− return (CGInfo x1 x2 x3 x4 x5)

457+ return (CGInfo x1 x2 [] x4 x5)

370458

371459instance Binary FC where

372460 put (FC x1 x2 x3)

373461 = do put x1

374− put x2

375− put x3

462+ put (x2 * 65536 + x3)

376463 get

377464 = do x1 <- get

378− x2 <- get

379− x3 <- get

380− return (FC x1 x2 x3)

465+ x2x3 <- get

466+ return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

381467

382468

383469instance Binary Name where

@@ -394,6 +480,8 @@ instance Binary Name where

394480 NErased -> putWord8 3

395481 SN x1 -> do putWord8 4

396482 put x1

483+ SymRef x1 -> do putWord8 5

484+ put x1

397485 get

398486 = do i <- getWord8

399487 case i of

@@ -408,8 +496,15 @@ instance Binary Name where

408496 3 -> return NErased

409497 4 -> do x1 <- get

410498 return (SN x1)

499+ 5 -> do x1 <- get

500+ return (SymRef x1)

411501 _ -> error "Corrupted binary data for Name"

412502

503+instance Binary T.Text where

504+ put x = put (str x)

505+ get = do x <- get

506+ return (txt x)

507+

413508instance Binary SpecialName where

414509 put x

415510 = case x of

@@ -624,22 +719,18 @@ instance Binary NameType where

624719 Bound -> putWord8 0

625720 Ref -> putWord8 1

626721 DCon x1 x2 -> do putWord8 2

627− put x1

628− put x2

722+ put (x1 * 65536 + x2)

629723 TCon x1 x2 -> do putWord8 3

630− put x1

631− put x2

724+ put (x1 * 65536 + x2)

632725 get

633726 = do i <- getWord8

634727 case i of

635728 0 -> return Bound

636729 1 -> return Ref

637− 2 -> do x1 <- get

638− x2 <- get

639− return (DCon x1 x2)

640− 3 -> do x1 <- get

641− x2 <- get

642− return (TCon x1 x2)

730+ 2 -> do x1x2 <- get

731+ return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

732+ 3 -> do x1x2 <- get

733+ return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536))

643734 _ -> error "Corrupted binary data for NameType"

644735

645736

@@ -650,9 +741,12 @@ instance {- (Binary n) => -} Binary (TT Name) where

650741 P x1 x2 x3 -> do putWord8 0

651742 put x1

652743 put x2

653− put x3

654− V x1 -> do putWord8 1

655− put x1

744+-- put x3

745+ V x1 -> if (x1 >= 0 && x1 < 256)

746+ then do putWord8 1

747+ putWord8 (toEnum (x1 + 1))

748+ else do putWord8 9

749+ put x1

656750 Bind x1 x2 x3 -> do putWord8 2

657751 put x1

658752 put x2

@@ -664,7 +758,7 @@ instance {- (Binary n) => -} Binary (TT Name) where

664758 put x1

665759 Proj x1 x2 -> do putWord8 5

666760 put x1

667− put x2

761+ putWord8 (toEnum (x2 + 1))

668762 Erased -> putWord8 6

669763 TType x1 -> do putWord8 7

670764 put x1

@@ -674,10 +768,10 @@ instance {- (Binary n) => -} Binary (TT Name) where

674768 case i of

675769 0 -> do x1 <- get

676770 x2 <- get

677− x3 <- get

678− return (P x1 x2 x3)

679− 1 -> do x1 <- get

680− return (V x1)

771+-- x3 <- get

772+ return (P x1 x2 Erased)

773+ 1 -> do x1 <- getWord8

774+ return (V ((fromEnum x1) - 1))

681775 2 -> do x1 <- get

682776 x2 <- get

683777 x3 <- get

@@ -688,12 +782,14 @@ instance {- (Binary n) => -} Binary (TT Name) where

688782 4 -> do x1 <- get

689783 return (Constant x1)

690784 5 -> do x1 <- get

691− x2 <- get

692− return (Proj x1 x2)

785+ x2 <- getWord8

786+ return (Proj x1 ((fromEnum x2)-1))

693787 6 -> return Erased

694788 7 -> do x1 <- get

695789 return (TType x1)

696790 8 -> return Impossible

791+ 9 -> do x1 <- get

792+ return (V x1)

697793 _ -> error "Corrupted binary data for TT"

698794

699795instance Binary SC where

@@ -772,15 +868,13 @@ instance Binary CaseAlt where

772868

773869instance Binary CaseDefs where

774870 put (CaseDefs x1 x2 x3 x4)

775− = do -- don't need totality checked version

871+ = do -- don't need totality checked or inlined versions

776872 put x2

777− put x3

778873 put x4

779874 get

780875 = do x2 <- get

781− x3 <- get -- use for totality checked version

782876 x4 <- get

783− return (CaseDefs x3 x2 x3 x4)

877+ return (CaseDefs x2 x2 x2 x4)

784878

785879instance Binary CaseInfo where

786880 put x@(CaseInfo x1 x2) = do put x1

@@ -914,7 +1008,7 @@ instance Binary MetaInformation where

9141008 return (DataMI x1)

9151009

9161010instance 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)

9181012 = {-# SCC "putIBCFile" #-}

9191013 do put x1

9201014 put x2

@@ -945,6 +1039,7 @@ instance Binary IBCFile where

9451039 put x27

9461040 put x28

9471041 put x29

1042+ put x30

9481043 get

9491044 = do x1 <- get

9501045 if x1 == ibcVersion then

@@ -976,7 +1071,8 @@ instance Binary IBCFile where

9761071 x27 <- get

9771072 x28 <- get

9781073 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)

9801076 else return (initIBC { ver = x1 })

9811077

9821078instance Binary DataOpt where

src/Idris/Imports.hs+1−1

@@ -7,7 +7,7 @@ import Paths_idris

77

88import System.FilePath

99import System.Directory

10−import Control.Monad.State

10+import Control.Monad.State.Strict

1111

1212data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

1313 deriving (Show, Eq)

src/Idris/ParseData.hs+14−10

@@ -49,7 +49,7 @@ record syn = do (doc, acc) <- try (do

4949 ty <- typeExpr (allowImp syn)

5050 let tyn = expandNS syn tyn_in

5151 reserved "where"

52− (cdoc, cn, cty, _) <- indentedBlockS (constructor syn)

52+ (cdoc, cn, cty, _, _) <- indentedBlockS (constructor syn)

5353 accData acc tyn [cn]

5454 let rsyn = syn { syn_namespace = show (nsroot tyn) :

5555 syn_namespace syn }

@@ -113,7 +113,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

113113 option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do

114114 reserved "where"

115115 cons <- indentedBlock (constructor syn)

116− accData acc tyn (map (\ (_, n, _, _) -> n) cons)

116+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons)

117117 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do

118118 args <- many name

119119 let ty = bindArgs (map (const PType) args) PType

@@ -133,10 +133,10 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

133133 cons <- sepBy1 (simpleConstructor syn) (lchar '|')

134134 terminator

135135 let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)

136− cons' <- mapM (\ (doc, x, cargs, cfc) ->

136+ cons' <- mapM (\ (doc, x, cargs, cfc, fs) ->

137137 do let cty = bindArgs cargs conty

138− return (doc, x, cty, cfc)) cons

139− accData acc tyn (map (\ (_, n, _, _) -> n) cons')

138+ return (doc, x, cty, cfc, fs)) cons

139+ accData acc tyn (map (\ (_, n, _, _, _) -> n) cons')

140140 return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons')))

141141 <?> "data type declaration"

142142 where

@@ -144,7 +144,7 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

144144 mkPApp fc t [] = t

145145 mkPApp fc t xs = PApp fc t (map pexp xs)

146146 bindArgs :: [PTerm] -> PTerm -> PTerm

147− bindArgs xs t = foldr (PPi expl (MN 0 "_t")) t xs

147+ bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs

148148 combineDataOpts :: DataOpts -> DataOpts

149149 combineDataOpts opts = if Codata `elem` opts then delete DefaultEliminator opts else opts

150150

@@ -152,20 +152,24 @@ data_ syn = do (doc, acc, dataOpts) <- try (do

152152{- | Parses a type constructor declaration

153153 Constructor ::= DocComment? FnName TypeSig;

154154-}

155−constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC)

155+constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC, [Name])

156156constructor syn

157157 = do doc <- option "" (docComment '|')

158158 cn_in <- fnName; fc <- getFC

159159 let cn = expandNS syn cn_in

160160 lchar ':'

161+ -- FIXME: 'forcenames' is an almighty hack! Need a better way of

162+ -- erasing non-forceable things

163+ fs <- option [] (do lchar '%'; reserved "erase"

164+ sepBy1 name (lchar ','))

161165 ty <- typeExpr (allowImp syn)

162− return (doc, cn, ty, fc)

166+ return (doc, cn, ty, fc, fs)

163167 <?> "constructor"

164168

165169{- | Parses a constructor for simple discriminative union data types

166170 SimpleConstructor ::= FnName SimpleExpr* DocComment?

167171-}

168−simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC)

172+simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC, [Name])

169173simpleConstructor syn

170174 = do cn_in <- fnName

171175 let cn = expandNS syn cn_in

@@ -173,7 +177,7 @@ simpleConstructor syn

173177 args <- many (do notEndApp

174178 simpleExpr syn)

175179 doc <- option "" (docComment '^')

176− return (doc, cn, args, fc)

180+ return (doc, cn, args, fc, [])

177181 <?> "constructor"

178182

179183{- | Parses a dsl block declaration

src/Idris/ParseExpr.hs+41−27

@@ -190,6 +190,7 @@ internalExpr syn =

190190 try (app syn)

191191 <|> try (matchApp syn)

192192 <|> try (unifyLog syn)

193+ <|> try (disamb syn)

193194 <|> try (noImplicits syn)

194195 <|> recordType syn

195196 <|> lambda syn

@@ -295,7 +296,7 @@ simpleExpr syn =

295296 fc <- getFC

296297 return (modifyConst syn fc (PConstant c)))

297298 <|> try (do symbol "'"; fc <- getFC; str <- name

298− return (PApp fc (PRef fc (UN "Symbol_"))

299+ return (PApp fc (PRef fc (sUN "Symbol_"))

299300 [pexp (PConstant (Str (show str)))]))

300301 <|> do fc <- getFC

301302 x <- fnName

@@ -360,12 +361,12 @@ bracketed syn =

360361 l <- expr' syn

361362 o <- operator

362363 lchar ')'

363− return $ PLam (MN 1000 "ARG") Placeholder

364− (PApp fc0 (PRef fc0 (UN o)) [pexp l,

365− pexp (PRef fc0 (MN 1000 "ARG"))]))

364+ return $ PLam (sMN 1000 "ARG") Placeholder

365+ (PApp fc0 (PRef fc0 (sUN o)) [pexp l,

366+ pexp (PRef fc0 (sMN 1000 "ARG"))]))

366367 <|> try(do fc <- getFC; o <- operator; e <- expr syn; lchar ')'

367− return $ PLam (MN 1000 "ARG") Placeholder

368− (PApp fc (PRef fc (UN o)) [pexp (PRef fc (MN 1000 "ARG")),

368+ return $ PLam (sMN 1000 "ARG") Placeholder

369+ (PApp fc (PRef fc (sUN o)) [pexp (PRef fc (sMN 1000 "ARG")),

369370 pexp e]))

370371 <|> try (do ln <- name; lchar ':'

371372 lty <- expr syn

@@ -388,7 +389,7 @@ modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

388389modifyConst syn fc (PConstant (BI x))

389390 | not (inPattern syn)

390391 = 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)))]

392393 : consts)

393394 | otherwise = PAlternative False consts

394395 where

@@ -420,8 +421,8 @@ listExpr syn = do lchar '['; fc <- getFC; xs <- sepBy (expr syn) (lchar ','); lc

420421 <?> "list expression"

421422 where

422423 mkList :: FC -> [PTerm] -> PTerm

423− mkList fc [] = PRef fc (UN "Nil")

424− mkList fc (x : xs) = PApp fc (PRef fc (UN "::")) [pexp x, pexp (mkList fc xs)]

424+ mkList fc [] = PRef fc (sUN "Nil")

425+ mkList fc (x : xs) = PApp fc (PRef fc (sUN "::")) [pexp x, pexp (mkList fc xs)]

425426

426427

427428{- | Parses an alternative expression

@@ -466,10 +467,10 @@ matchApp syn = do ty <- simpleExpr syn

466467 symbol "<=="

467468 fc <- getFC

468469 f <- fnName

469− return (PLet (MN 0 "match")

470+ return (PLet (sMN 0 "match")

470471 ty

471472 (PMatchApp fc f)

472− (PRef fc (MN 0 "match")))

473+ (PRef fc (sMN 0 "match")))

473474 <?> "matching application expression"

474475

475476{- | Parses a unification log expression

@@ -483,6 +484,19 @@ unifyLog syn = do lchar '%'; reserved "unifyLog";

483484 return (PUnifyLog tm)

484485 <?> "unification log expression"

485486

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)]

486500{- | Parses a no implicits expression

487501@

488502NoImplicits ::=

@@ -512,12 +526,12 @@ app syn = do f <- reserved "mkForeign"

512526 i <- get

513527 -- mkForeign f args ==>

514528 -- liftPrimIO (\w => mkForeignPrim f args w)

515− let ap = PApp fc (PRef fc (UN "liftPrimIO"))

516− [pexp (PLam (MN 0 "w")

529+ let ap = PApp fc (PRef fc (sUN "liftPrimIO"))

530+ [pexp (PLam (sMN 0 "w")

517531 Placeholder

518− (PApp fc (PRef fc (UN "mkForeignPrim"))

532+ (PApp fc (PRef fc (sUN "mkForeignPrim"))

519533 (fn : args ++

520− [pexp (PRef fc (MN 0 "w"))])))]

534+ [pexp (PRef fc (sMN 0 "w"))])))]

521535 return (dslify i ap)

522536

523537 <|> do f <- simpleExpr syn

@@ -566,7 +580,7 @@ implicitArg syn = do lchar '{'

566580 v <- option (PRef fc n) (do lchar '='

567581 expr syn)

568582 lchar '}'

569− return (pimp n v False)

583+ return (pimp n v True)

570584 <?> "implicit function argument"

571585

572586{-| Parses a constraint argument (for selecting a named type class instance)

@@ -611,8 +625,8 @@ recordType syn

611625 rec <- optional (simpleExpr syn)

612626 case rec of

613627 Nothing ->

614− return (PLam (MN 0 "fldx") Placeholder

615− (applyAll fc fields (PRef fc (MN 0 "fldx"))))

628+ return (PLam (sMN 0 "fldx") Placeholder

629+ (applyAll fc fields (PRef fc (sMN 0 "fldx"))))

616630 Just v -> return (applyAll fc fields v)

617631 <?> "record setting expression"

618632 where fieldType :: IdrisParser (Name, PTerm)

@@ -628,8 +642,8 @@ recordType syn

628642

629643-- | Creates setters for record types on necessary functions

630644mkType :: Name -> Name

631−mkType (UN n) = UN ("set_" ++ n)

632−mkType (MN 0 n) = MN 0 ("set_" ++ n)

645+mkType (UN n) = sUN ("set_" ++ str n)

646+mkType (MN 0 n) = sMN 0 ("set_" ++ str n)

633647mkType (NS n s) = NS (mkType n) s

634648

635649{- | Parses a type signature

@@ -645,7 +659,7 @@ TypeExpr ::= ConstraintList? Expr;

645659typeExpr :: SyntaxInfo -> IdrisParser PTerm

646660typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []

647661 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)

649663 <?> "type signature"

650664

651665{- | Parses a lambda expression

@@ -678,8 +692,8 @@ lambda syn = do lchar '\\'

678692 where pmList :: [(Int, (FC, PTerm))] -> PTerm -> PTerm

679693 pmList [] sc = sc

680694 pmList ((i, (fc, x)) : xs) sc

681− = PLam (MN i "lamp") Placeholder

682− (PCase fc (PRef fc (MN i "lamp"))

695+ = PLam (sMN i "lamp") Placeholder

696+ (PCase fc (PRef fc (sMN i "lamp"))

683697 [(x, pmList xs sc)])

684698

685699{- | Parses a term rewrite expression

@@ -696,7 +710,7 @@ rewriteTerm syn = do reserved "rewrite"

696710 giving <- optional (do symbol "==>"; expr' syn)

697711 reserved "in"; sc <- expr syn

698712 return (PRewrite fc

699− (PApp fc (PRef fc (UN "sym")) [pexp prf]) sc

713+ (PApp fc (PRef fc (sUN "sym")) [pexp prf]) sc

700714 giving)

701715 <?> "term rewrite expression"

702716

@@ -861,7 +875,7 @@ tyOptDeclList syn = sepBy1 (do x <- nameOrPlaceholder

861875 where nameOrPlaceholder :: IdrisParser Name

862876 nameOrPlaceholder = fnName

863877 <|> do symbol "_"

864− return (MN 0 "underscore")

878+ return (sMN 0 "underscore")

865879 <?> "name or placeholder"

866880

867881{- | Parses a list comprehension

@@ -885,11 +899,11 @@ comprehension syn

885899 qs <- sepBy1 (do_ syn) (lchar ',')

886900 lchar ']'

887901 return (PDoBlock (map addGuard qs ++

888− [DoExp fc (PApp fc (PRef fc (UN "return"))

902+ [DoExp fc (PApp fc (PRef fc (sUN "return"))

889903 [pexp pat])]))

890904 <?> "list comprehension"

891905 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"))

893907 [pexp e])

894908 addGuard x = x

895909

src/Idris/ParseHelpers.hs+2−2

@@ -230,8 +230,8 @@ initsEndAt p (x:xs) | p x = [] : x_inits_xs

230230 namespace.

231231-}

232232mkName :: (String, String) -> Name

233−mkName (n, "") = UN n

234−mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

233+mkName (n, "") = sUN n

234+mkName (n, ns) = sNS (sUN n) (reverse (parseNS ns))

235235 where parseNS x = case span (/= '.') x of

236236 (x, "") -> [x]

237237 (x, '.':y) -> x : parseNS y

src/Idris/ParseOps.hs+6−5

@@ -33,21 +33,22 @@ import qualified Data.ByteString.UTF8 as UTF8

3333-- using pre-build and user-defined operator/fixity declarations

3434table :: [FixDecl] -> OperatorTable IdrisParser PTerm

3535table fixes

36− = [[prefix "-" (\fc x -> PApp fc (PRef fc (UN "-"))

37− [pexp (PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

36+ = [[prefix "-" (\fc x -> PApp fc (PRef fc (sUN "-"))

37+ [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

3838 ++ toTable (reverse fixes) ++

3939 [[backtick],

40+ [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

4041 [binary "=" PEq AssocLeft],

41− [binary "->" (\fc x y -> PPi expl (MN 42 "__pi_arg") x y) AssocRight]]

42+ [binary "->" (\fc x y -> PPi expl (sMN 42 "__pi_arg") x y) AssocRight]]

4243

4344-- | Calculates table for fixtiy declarations

4445toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

4546toTable fs = map (map toBin)

4647 (groupBy (\ (Fix x _) (Fix y _) -> prec x == prec y) fs)

4748 where toBin (Fix (PrefixN _) op) = prefix op

48− (\fc x -> PApp fc (PRef fc (UN op)) [pexp x])

49+ (\fc x -> PApp fc (PRef fc (sUN op)) [pexp x])

4950 toBin (Fix f op)

50− = binary op (\fc x y -> PApp fc (PRef fc (UN op)) [pexp x,pexp y]) (assoc f)

51+ = binary op (\fc x y -> PApp fc (PRef fc (sUN op)) [pexp x,pexp y]) (assoc f)

5152 assoc (Infixl _) = AssocLeft

5253 assoc (Infixr _) = AssocRight

5354 assoc (InfixN _) = AssocNone

src/Idris/Parser.hs+22−13

@@ -21,6 +21,7 @@ import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

2121import Idris.AbsSyntax

2222import Idris.DSL

2323import Idris.Imports

24+import Idris.Delaborate

2425import Idris.Error

2526import Idris.ElabDecls

2627import Idris.ElabTerm hiding (namespace, params)

@@ -43,6 +44,7 @@ import Idris.Core.Evaluate

4344

4445import Control.Applicative

4546import Control.Monad

47+import Control.Monad.Error (throwError, catchError)

4648import Control.Monad.State.Strict

4749

4850import Data.Maybe

@@ -79,7 +81,9 @@ moduleHeader = try (do reserved "module"

7981 i <- identifier

8082 option ';' (lchar ';')

8183 return (moduleName i))

82− <|> return []

84+ <|> try (do lchar '%'; reserved "unqualified"

85+ return [])

86+ <|> return (moduleName "Main")

8387 where moduleName x = case span (/='.') x of

8488 (x, "") -> [x]

8589 (x, '.':y) -> x : moduleName y

@@ -298,9 +302,9 @@ fnDecl' syn = checkFixity $

298302 getName (PTy _ _ _ _ n _) = Just n

299303 getName _ = Nothing

300304 fixityOK (NS n _) = fixityOK n

301− fixityOK (UN n) | all (flip elem opChars) n =

305+ fixityOK (UN n) | all (flip elem opChars) (str n) =

302306 do fixities <- fmap idris_infixes get

303− return . elem n . map (\ (Fix _ op) -> op) $ fixities

307+ return . elem (str n) . map (\ (Fix _ op) -> op) $ fixities

304308 | otherwise = return True

305309 fixityOK _ = return True

306310

@@ -515,7 +519,7 @@ instance_ syn = do reserved "instance"; fc <- getFC

515519 cn <- name

516520 args <- many (simpleExpr syn)

517521 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

519523 ds <- option [] (instanceBlock syn)

520524 return [PInstance syn fc cs cn args t en ds]

521525 <?> "instance declaration"

@@ -573,7 +577,7 @@ Pattern ::= Clause;

573577pattern :: SyntaxInfo -> IdrisParser PDecl

574578pattern syn = do fc <- getFC

575579 clause <- clause syn

576− return (PClauses fc [] (MN 2 "_") [clause]) -- collect together later

580+ return (PClauses fc [] (sMN 2 "_") [clause]) -- collect together later

577581 <?> "pattern"

578582

579583{- | Parse a constant applicative form declaration

@@ -615,7 +619,7 @@ rhs syn n = do lchar '='; expr syn

615619 <|> do reserved "impossible"; return PImpossible

616620 <?> "function right hand side"

617621 where mkN :: Name -> Name

618− mkN (UN x) = UN (x++"_lemma_1")

622+ mkN (UN x) = sUN (str x++"_lemma_1")

619623 mkN (NS x n) = NS (mkN x) n

620624 n' :: Name

621625 n' = mkN n

@@ -623,7 +627,7 @@ rhs syn n = do lchar '='; expr syn

623627 addLet nm (PLet n ty val r) = PLet n ty val (addLet nm r)

624628 addLet nm (PCase fc t cs) = PCase fc t (map addLetC cs)

625629 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))

627631

628632{- |Parses a function clause

629633RHSOrWithBlock ::= RHS WhereOrTerminator

@@ -677,10 +681,10 @@ clause syn

677681 return x,

678682 do terminator

679683 return ([], [])]

680− let capp = PLet (MN 0 "match")

684+ let capp = PLet (sMN 0 "match")

681685 ty

682686 (PMatchApp fc n)

683− (PRef fc (MN 0 "match"))

687+ (PRef fc (sMN 0 "match"))

684688 ist <- get

685689 put (ist { lastParse = Just n })

686690 return $ PClause fc n capp [] r wheres

@@ -691,7 +695,7 @@ clause syn

691695 when (op == "=" || op == "?=" ) $

692696 fail "infix clause definition with \"=\" and \"?=\" not supported "

693697 return (l, op))

694− let n = expandNS syn (UN op)

698+ let n = expandNS syn (sUN op)

695699 r <- argExpr syn

696700 fc <- getFC

697701 wargs <- many (wExpr syn)

@@ -866,8 +870,13 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

866870 ty <- iName []

867871 ns <- sepBy1 name (lchar ',')

868872 return [PDirective

869− (do mapM_ (addNameHint ty) ns

870− mapM_ (\n -> addIBC (IBCNameHint (ty, n))) ns)]

873+ (do i <- getIState

874+ ty' <- case lookupCtxtName ty (idris_implicits i) of

875+ [(tyn, _)] -> return tyn

876+ [] -> throwError (NoSuchVariable ty)

877+ tyns -> throwError (CantResolveAlts (map show (map fst tyns)))

878+ mapM_ (addNameHint ty') ns

879+ mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

871880 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

872881 return [PDirective (addLangExt ext)]

873882 <?> "directive"

@@ -1004,7 +1013,7 @@ loadModule' outh f

10041013 LIDR fn -> loadSource outh True fn

10051014 IBC fn src ->

10061015 idrisCatch (loadIBC fn)

1007− (\c -> do iLOG $ fn ++ " failed " ++ show c

1016+ (\c -> do iLOG $ fn ++ " failed " ++ pshow i c

10081017 case src of

10091018 IDR sfn -> loadSource outh False sfn

10101019 LIDR sfn -> loadSource outh True sfn)

src/Idris/PartialEval.hs+2−2

@@ -54,7 +54,7 @@ specType args ty = let (t, args') = runState (unifyEq args ty) [] in

5454 sc' <- unifyEq xs sc

5555 return (Bind n (Pi t) sc')

5656 unifyEq xs t = do args <- get

57− put (args ++ (zip xs (repeat (UN "_"))))

57+ put (args ++ (zip xs (repeat (sUN "_"))))

5858 return t

5959

6060mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm

@@ -122,7 +122,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

122122 | x && imparg imp = (ImplicitS, tm)

123123 | x = (ExplicitS, tm)

124124 | imparg imp = (ImplicitD, tm)

125− | otherwise = (ExplicitD, (P Ref (UN (show n ++ "arg")) Erased))

125+ | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126126

127127 imparg (PExp _ _ _ _) = False

128128 imparg _ = True

src/Idris/Primitives.hs+50−50

@@ -26,7 +26,7 @@ data Prim = Prim { p_name :: Name,

2626

2727ty :: [Const] -> Const -> Type

2828ty [] x = Constant x

29−ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x)

29+ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x)

3030

3131total, partial :: Totality

3232total = Total []

@@ -94,83 +94,83 @@ primitives =

9494 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,

9595 iCoerce ITBig ITChar "trunc" trunc LTrunc,

9696

97− Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

97+ Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))

9898 (2, LPlus ATFloat) total,

99− Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

99+ Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))

100100 (2, LMinus ATFloat) total,

101− Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

101+ Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))

102102 (2, LTimes ATFloat) total,

103− Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

103+ Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))

104104 (2, LSDiv ATFloat) total,

105− Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

105+ Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))

106106 (2, LEq ATFloat) total,

107− Prim (UN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

107+ Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))

108108 (2, LSLt ATFloat) total,

109− Prim (UN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

109+ Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))

110110 (2, LSLe ATFloat) total,

111− Prim (UN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

111+ Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))

112112 (2, LSGt ATFloat) total,

113− Prim (UN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

113+ Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))

114114 (2, LSGe ATFloat) total,

115− Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

115+ Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))

116116 (2, LStrConcat) total,

117− Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

117+ Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))

118118 (2, LStrEq) total,

119− Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

119+ Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))

120120 (2, LStrLt) total,

121− Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

121+ Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)

122122 (1, LStrLen) total,

123123 -- Conversions

124− Prim (UN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

124+ Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)

125125 (1, LChInt ITNative) total,

126− Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

126+ Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)

127127 (1, LIntCh ITNative) total,

128− Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

128+ Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)

129129 (1, LStrFloat) total,

130− Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

130+ Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)

131131 (1, LFloatStr) total,

132132

133− Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

133+ Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

134134 (1, LFExp) total,

135− Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

135+ Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

136136 (1, LFLog) total,

137− Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

137+ Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

138138 (1, LFSin) total,

139− Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

139+ Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)

140140 (1, LFCos) total,

141− Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

141+ Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)

142142 (1, LFTan) total,

143− Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

143+ Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)

144144 (1, LFASin) total,

145− Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

145+ Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)

146146 (1, LFACos) total,

147− Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

147+ Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)

148148 (1, LFATan) total,

149− Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

149+ Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)

150150 (1, LFSqrt) total,

151− Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

151+ Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)

152152 (1, LFFloor) total,

153− Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

153+ Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)

154154 (1, LFCeil) total,

155155

156− Prim (UN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

156+ Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)

157157 (1, LStrHead) partial,

158− Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

158+ Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)

159159 (1, LStrTail) partial,

160− Prim (UN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

160+ Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)

161161 (2, LStrCons) total,

162− Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

162+ Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)

163163 (2, LStrIndex) partial,

164− Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

164+ Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)

165165 (1, LStrRev) total,

166− Prim (UN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

166+ Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)

167167 (1, LReadStr) partial,

168− Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

168+ Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)

169169 (0, LVMPtr) total,

170170 -- Streams

171− Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

171+ Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)

172172 (0, LStdIn) partial,

173− Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

173+ Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

174174 (0, LNullPtr) total

175175 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]

176176 ++ concatMap vecOps vecTypes

@@ -221,13 +221,13 @@ intArith ity =

221221

222222intConv :: IntTy -> [Prim]

223223intConv ity =

224− [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

224+ [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr

225225 (1, LIntStr ity) total

226− , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

226+ , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)

227227 (1, LStrInt ity) total

228− , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

228+ , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat

229229 (1, LIntFloat ity) total

230− , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

230+ , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)

231231 (1, LFloatInt ity) total

232232 ]

233233

@@ -246,13 +246,13 @@ vecCmps ity =

246246

247247vecOps :: IntTy -> [Prim]

248248vecOps ity@(ITVec elem count) =

249− [ Prim (UN $ "prim__mk" ++ intTyName ity)

249+ [ Prim (sUN $ "prim__mk" ++ intTyName ity)

250250 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))

251251 count (mkVecCon elem count) (count, LMkVec elem count) total

252− , Prim (UN $ "prim__index" ++ intTyName ity)

252+ , Prim (sUN $ "prim__index" ++ intTyName ity)

253253 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))

254254 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces

255− , Prim (UN $ "prim__update" ++ intTyName ity)

255+ , Prim (sUN $ "prim__update" ++ intTyName ity)

256256 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]

257257 (AType . ATInt $ ity))

258258 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces

@@ -260,7 +260,7 @@ vecOps ity@(ITVec elem count) =

260260

261261bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim

262262bitcastPrim from to impl prim =

263− Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

263+ Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)

264264 (1, prim) total

265265

266266vecBitcasts :: [IntTy] -> [Prim]

@@ -377,23 +377,23 @@ intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show cou

377377

378378iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

379379iCmp ity op self impl irop totality

380− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

380+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

381381 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))

382382 2 impl (2, irop ity) totality

383383

384384iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim

385385iBinOp ity op impl irop totality

386− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

386+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

387387 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))

388388 2 impl (2, irop ity) totality

389389iUnOp ity op impl irop totality

390− = Prim (UN $ "prim__" ++ op ++ intTyName ity)

390+ = Prim (sUN $ "prim__" ++ op ++ intTyName ity)

391391 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))

392392 1 impl (1, irop ity) totality

393393

394394iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim

395395iCoerce from to op impl irop =

396− Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

396+ Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

397397 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total

398398

399399fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const

src/Idris/Prover.hs+3−2

@@ -20,7 +20,7 @@ import Text.Trifecta.Result(Result(..))

2020

2121import System.Console.Haskeline

2222import System.Console.Haskeline.History

23−import Control.Monad.State

23+import Control.Monad.State.Strict

2424

2525import Util.Pretty

2626import Debug.Trace

@@ -102,7 +102,8 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

102102 tPretty t = pretty $ delab ist t

103103

104104 prettyPs [] = empty

105− prettyPs ((MN _ "rewrite_rule", _) : bs) = prettyPs bs

105+ prettyPs ((MN _ r, _) : bs)

106+ | r == txt "rewrite_rule" = prettyPs bs

106107 prettyPs ((n, Let t v) : bs) =

107108 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

108109 tPretty t $$ prettyPs bs)

src/Idris/Providers.hs+14−7

@@ -11,17 +11,24 @@ import Debug.Trace

1111

1212-- | Wrap a type provider in the type of type providers

1313providerTy :: FC -> PTerm -> PTerm

14−providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

14+providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 False tm ""]

15+

16+ioret = sUN "prim_io_return"

17+ermod = sNS (sUN "Error") ["Providers"]

18+prmod = sNS (sUN "Provide") ["Providers"]

1519

1620-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

1721getProvided :: TT Name -> Idris (TT Name)

18−getProvided tm | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

19− , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =

20− case err of

22+getProvided tm | (P _ pioret _, [tp, result]) <- unApply tm

23+ , (P _ nm _, [_, err]) <- unApply result

24+ , pioret == ioret && nm == ermod

25+ = case err of

2126 Constant (Str msg) -> ierror . ProviderError $ msg

2227 _ -> ifail "Internal error in type provider, non-normalised error"

23− | (P _ (UN "prim_io_return") _, [tp, result]) <- unApply tm

24− , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =

25− return res

28+ | (P _ pioret _, [tp, result]) <- unApply tm

29+ , (P _ nm _, [_, res]) <- unApply result

30+ , pioret == ioret && nm == prmod

31+ = return res

2632 | otherwise = ifail $ "Internal type provider error: result was not " ++

2733 "IO (Provider a), or perhaps missing normalisation."

34+

src/Idris/REPL.hs+56−44

@@ -80,31 +80,33 @@ repl :: IState -- ^ The initial state

8080 -> [FilePath] -- ^ The loaded modules

8181 -> InputT Idris ()

8282repl orig mods

83− = H.catch

84− (do let quiet = opt_quiet (idris_options orig)

85− i <- lift getIState

86− let colour = idris_colourRepl i

87− let theme = idris_colourTheme i

88− let mvs = idris_metavars i

89− let prompt = if quiet

90− then ""

91− else showMVs colour theme mvs ++

92− let str = mkPrompt mods ++ ">" in

93− (if colour then colourisePrompt theme str else str) ++ " "

94− x <- getInputLine prompt

95− case x of

96− Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

97− return ()

98− Just input -> H.catch

99− (do ms <- lift $ processInput input orig mods

100− case ms of

101− Just mods -> repl orig mods

102− Nothing -> return ())

103− ctrlC)

104− ctrlC

105− where ctrlC :: SomeException -> InputT Idris ()

106− ctrlC e = do lift $ iputStrLn (show e)

107− repl orig mods

83+ = -- H.catch

84+ do let quiet = opt_quiet (idris_options orig)

85+ i <- lift getIState

86+ let colour = idris_colourRepl i

87+ let theme = idris_colourTheme i

88+ let mvs = idris_metavars i

89+ let prompt = if quiet

90+ then ""

91+ else showMVs colour theme mvs ++

92+ let str = mkPrompt mods ++ ">" in

93+ (if colour then colourisePrompt theme str else str) ++ " "

94+ x <- H.catch (getInputLine prompt)

95+ (ctrlC (return Nothing))

96+ case x of

97+ Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

98+ return ()

99+ Just input -> -- H.catch

100+ do ms <- H.catch (lift $ processInput input orig mods)

101+ (ctrlC (return (Just mods)))

102+ case ms of

103+ Just mods -> repl orig mods

104+ Nothing -> return ()

105+-- ctrlC)

106+-- ctrlC

107+ where ctrlC :: InputT Idris a -> SomeException -> InputT Idris a

108+ ctrlC act e = do lift $ iputStrLn (show e)

109+ act -- repl orig mods

108110

109111 showMVs c thm [] = ""

110112 showMVs c thm ms = "Metavariables: " ++

@@ -245,19 +247,19 @@ ideslave orig mods

245247 Just x -> iPrintError $ "didn't load " ++ filename

246248 ideslave orig [filename]

247249 Just (IdeSlave.TypeOf name) ->

248− process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (UN name)))

250+ process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (sUN name)))

249251 Just (IdeSlave.CaseSplit line name) ->

250− process stdout fn (CaseSplitAt False line (UN name))

252+ process stdout fn (CaseSplitAt False line (sUN name))

251253 Just (IdeSlave.AddClause line name) ->

252− process stdout fn (AddClauseFrom False line (UN name))

254+ process stdout fn (AddClauseFrom False line (sUN name))

253255 Just (IdeSlave.AddProofClause line name) ->

254− process stdout fn (AddProofClauseFrom False line (UN name))

256+ process stdout fn (AddProofClauseFrom False line (sUN name))

255257 Just (IdeSlave.AddMissing line name) ->

256− process stdout fn (AddMissing False line (UN name))

258+ process stdout fn (AddMissing False line (sUN name))

257259 Just (IdeSlave.MakeWithBlock line name) ->

258− process stdout fn (MakeWith False line (UN name))

260+ process stdout fn (MakeWith False line (sUN name))

259261 Just (IdeSlave.ProofSearch line name hints) ->

260− process stdout fn (DoProofSearch False line (UN name) (map UN hints))

262+ process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

261263 Nothing -> do iPrintError "did not understand")

262264 (\e -> do iPrintError $ show e))

263265 (\e -> do iPrintError $ show e)

@@ -406,6 +408,7 @@ edit f orig

406408 , idris_colourTheme = idris_colourTheme i

407409 }

408410 loadInputs stdout [f]

411+-- clearOrigPats

409412 iucheck

410413 return ()

411414 where getEditor env | Just ed <- lookup "EDITOR" env = ed

@@ -441,7 +444,7 @@ process h fn (Eval t)

441444 let tm' = force (normaliseAll ctxt [] tm)

442445 let ty' = force (normaliseAll ctxt [] ty)

443446 -- Add value to context, call it "it"

444− updateContext (addCtxtDef (UN "it") (Function ty' tm'))

447+ updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

445448 ist <- getIState

446449 logLvl 3 $ "Raw: " ++ show (tm', ty')

447450 logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

@@ -482,7 +485,7 @@ process h fn (Check (PRef _ n))

482485 = let current = " " ++

483486 (case n of

484487 MN _ _ -> "_"

485− UN ('_':'_':_) -> "_"

488+ UN nm | ('_':'_':_) <- str nm -> "_"

486489 _ -> showName (Just ist) [] False c n) ++

487490 " : " ++ showImp (Just ist) imp c t ++ "\n"

488491 in

@@ -849,8 +852,8 @@ process h fn (TestInline t)

849852process h fn Execute

850853 = do (m, _) <- elabVal toplevel False

851854 (PApp fc

852− (PRef fc (UN "run__IO"))

853− [pexp $ PRef fc (NS (UN "main") ["Main"])])

855+ (PRef fc (sUN "run__IO"))

856+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

854857-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

855858 (tmpn, tmph) <- runIO tempfile

856859 runIO $ hClose tmph

@@ -861,8 +864,8 @@ process h fn Execute

861864 where fc = fileFC "main"

862865process h fn (Compile codegen f)

863866 = do (m, _) <- elabVal toplevel False

864− (PApp fc (PRef fc (UN "run__IO"))

865− [pexp $ PRef fc (NS (UN "main") ["Main"])])

867+ (PApp fc (PRef fc (sUN "run__IO"))

868+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

866869 compile codegen f m

867870 where fc = fileFC "main"

868871process h fn (LogLvl i) = setLogLevel i

@@ -1005,11 +1008,14 @@ parseArgs ("--verbose":ns) = Verbose : (parseArgs ns)

10051008parseArgs ("--ibcsubdir":n:ns) = IBCSubDir n : (parseArgs ns)

10061009parseArgs ("-i":n:ns) = ImportDir n : (parseArgs ns)

10071010parseArgs ("--warn":ns) = WarnOnly : (parseArgs ns)

1011+-- Package Related options

10081012parseArgs ("--package":n:ns) = Pkg n : (parseArgs ns)

10091013parseArgs ("-p":n:ns) = Pkg n : (parseArgs ns)

10101014parseArgs ("--build":n:ns) = PkgBuild n : (parseArgs ns)

10111015parseArgs ("--install":n:ns) = PkgInstall n : (parseArgs ns)

10121016parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns)

1017+parseArgs ("--checkpkg":n:ns) = PkgCheck n : (parseArgs ns)

1018+-- Misc Options

10131019parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns)

10141020parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

10151021parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

@@ -1101,12 +1107,13 @@ loadInputs h inputs

11011107 when (not loadCode) $ tryLoad $ nub (concat ifiles)

11021108 _ -> return ()

11031109 putIState inew)

1104− (\e -> do case e of

1110+ (\e -> do i <- getIState

1111+ case e of

11051112 At f _ -> do setErrLine (fc_line f)

11061113 iputStrLn (show e)

11071114 ProgramLineComment -> return () -- fail elsewhere

11081115 _ -> do setErrLine 3 -- FIXME! Propagate it

1109− iputStrLn (show e))

1116+ iputStrLn (pshow i e))

11101117 where -- load all files, stop if any fail

11111118 tryLoad :: [IFileType] -> Idris ()

11121119 tryLoad [] = return ()

@@ -1192,8 +1199,8 @@ idrisMain opts =

11921199 when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"

11931200 return ()

11941201 when (runrepl && not quiet && not idesl && not (isJust script) && not nobanner) $ iputStrLn banner

1195− ist <- getIState

11961202

1203+ orig <- getIState

11971204 loadInputs stdout inputs

11981205

11991206 runIO $ hSetBuffering stdout LineBuffering

@@ -1217,10 +1224,11 @@ idrisMain opts =

12171224 historyFile <- fmap (</> "repl" </> "history") getIdrisUserDataDir

12181225

12191226 when (runrepl && not idesl) $ do

1227+-- clearOrigPats

12201228 initScript

1221− startServer ist inputs

1222− runInputT (replSettings (Just historyFile)) $ repl ist inputs

1223− when (idesl) $ ideslaveStart ist inputs

1229+ startServer orig inputs

1230+ runInputT (replSettings (Just historyFile)) $ repl orig inputs

1231+ when (idesl) $ ideslaveStart orig inputs

12241232 ok <- noErrors

12251233 when (not ok) $ runIO (exitWith (ExitFailure 1))

12261234 where

@@ -1322,6 +1330,10 @@ getPkgClean :: Opt -> Maybe String

13221330getPkgClean (PkgClean str) = Just str

13231331getPkgClean _ = Nothing

13241332

1333+getPkgCheck :: Opt -> Maybe String

1334+getPkgCheck (PkgCheck str) = Just str

1335+getPkgCheck _ = Nothing

1336+

13251337getCodegen :: Opt -> Maybe Codegen

13261338getCodegen (UseCodegen x) = Just x

13271339getCodegen _ = Nothing

src/Idris/Transforms.hs+3−3

@@ -39,8 +39,8 @@ instance Transform CaseAlt where

3939

4040natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

4141

42−zname = NS (UN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

42+zname = sNS (sUN "Z") ["Nat","Prelude"]

43+sname = sNS (sUN "S") ["Nat","Prelude"]

4444

4545zero :: TT Name -> TT Name

4646zero (P _ n _) | n == zname

@@ -49,7 +49,7 @@ zero x = x

4949

5050suc :: TT Name -> TT Name

5151suc (App (P _ s _) a) | s == sname

52− = mkApp (P Ref (UN "prim__addBigInt") Erased) [Constant (BI 1), a]

52+ = mkApp (P Ref (sUN "prim__addBigInt") Erased) [Constant (BI 1), a]

5353suc x = x

5454

5555natcase :: SC -> SC

src/Idris/UnusedArgs.hs+2−1

@@ -23,6 +23,7 @@ traceUnused n

2323 recused <- mapM (\ (argn, i, (g, j)) ->

2424 do u <- used [(n, i)] g j

2525 return (argn, u)) fargs

26+ logLvl 4 $ show n ++ " recused TRACE: " ++ show recused

2627 let fused = nub $ usedns ++ map fst (filter snd recused)

2728 logLvl 1 $ show n ++ " used args: " ++ show fused

2829 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

@@ -50,7 +51,7 @@ used path g j

5051 recused <- mapM (\ (argn, j, (g', j')) ->

5152 used ((g,j):path) g' j') garg

5253 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

54+ return (directuse || or recused)

5455 _ -> return True -- no definition, assume used

5556

5657getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+1−1

@@ -27,7 +27,7 @@ data PkgDesc = PkgDesc { pkgname :: String,

2727 }

2828 deriving Show

2929

30−defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (UN "") Nothing

30+defaultPkg = PkgDesc "" [] [] Nothing [] "" [] (sUN "") Nothing

3131

3232parseDesc :: FilePath -> IO PkgDesc

3333parseDesc fp = do p <- readFile fp

src/Pkg/Package.hs+44−5

@@ -24,13 +24,14 @@ import Pkg.PParser

2424

2525import Paths_idris (getDataDir)

2626

27+-- | Run the package through the idris compiler.

28+--

2729-- To build a package:

2830-- * read the package description

2931-- * check all the library dependencies exist

3032-- * invoke the makefile if there is one

3133-- * invoke idris on each module, with idris_opts

3234-- * install everything into datadir/pname, if install flag is set

33−

3435buildPkg :: Bool -> (Bool, FilePath) -> IO ()

3536buildPkg warnonly (install, fp)

3637 = do pkgdesc <- parseDesc fp

@@ -63,7 +64,33 @@ buildPkg warnonly (install, fp)

6364 putStrLn $ "\t" ++ show ms

6465 exitWith (ExitFailure 1)

6566

66−cleanPkg :: FilePath -> IO ()

67+-- | Type check packages only

68+--

69+-- This differs from build in that executables are not built, if the

70+-- package contains an executable.

71+checkPkg :: Bool -- ^ Show Warnings

72+ -> FilePath -- ^ Path to ipkg file.

73+ -> IO ()

74+checkPkg warnonly fpath

75+ = do pkgdesc <-parseDesc fpath

76+ ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)

77+ when (and ok) $

78+ do dir <- getCurrentDirectory

79+ setCurrentDirectory $ dir </> sourcedir pkgdesc

80+ make (makefile pkgdesc)

81+ res <- buildMods (NoREPL : Verbose : idris_opts pkgdesc)

82+ (modules pkgdesc)

83+ setCurrentDirectory dir

84+ case res of

85+ Nothing -> exitWith (ExitFailure 1)

86+ Just res' -> do

87+ case errLine res' of

88+ Just _ -> exitWith (ExitFailure 1)

89+ _ -> return ()

90+

91+-- | Clean Package build files

92+cleanPkg :: FilePath -- ^ Path to ipkg file.

93+ -> IO ()

6794cleanPkg fp

6895 = do pkgdesc <- parseDesc fp

6996 dir <- getCurrentDirectory

@@ -74,6 +101,7 @@ cleanPkg fp

74101 Nothing -> return ()

75102 Just s -> rmFile $ dir </> s

76103

104+-- | Install package

77105installPkg :: PkgDesc -> IO ()

78106installPkg pkgdesc

79107 = do dir <- getCurrentDirectory

@@ -83,6 +111,11 @@ installPkg pkgdesc

83111 Just o -> return () -- do nothing, keep executable locally, for noe

84112 mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc)

85113

114+

115+-- ---------------------------------------------------------- [ Helper Methods ]

116+-- Methods for building, testing, installing, and removal of idris

117+-- packages.

118+

86119buildMods :: [Opt] -> [Name] -> IO (Maybe IState)

87120buildMods opts ns = do let f = map (toPath . showCG) ns

88121-- putStrLn $ "MODULE: " ++ show f

@@ -108,8 +141,8 @@ testLib warn p f

108141rmIBC :: Name -> IO ()

109142rmIBC m = rmFile $ toIBCFile m

110143

111−toIBCFile (UN n) = n ++ ".ibc"

112−toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

144+toIBCFile (UN n) = str n ++ ".ibc"

145+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))

113146

114147installIBC :: String -> Name -> IO ()

115148installIBC p m = do let f = toIBCFile m

@@ -120,7 +153,8 @@ installIBC p m = do let f = toIBCFile m

120153 copyFile f (destdir </> takeFileName f)

121154 return ()

122155 where getDest (UN n) = ""

123− getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))

156+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns))

157+

124158

125159installObj :: String -> String -> IO ()

126160installObj p o = do d <- getTargetDir

@@ -136,12 +170,17 @@ mkDirCmd = "mkdir "

136170mkDirCmd = "mkdir -p "

137171#endif

138172

173+-- ------------------------------------------------------- [ Makefile Commands ]

174+-- | Invoke a Makefile's default target.

139175make :: Maybe String -> IO ()

140176make Nothing = return ()

141177make (Just s) = do system $ "make -f " ++ s

142178 return ()

143179

180+-- | Invoke a Makefile's clean target.

144181clean :: Maybe String -> IO ()

145182clean Nothing = return ()

146183clean (Just s) = do system $ "make -f " ++ s ++ " clean"

147184 return ()

185+

186+-- --------------------------------------------------------------------- [ EOF ]

test/Makefile+2−1

@@ -1,3 +1,5 @@

1+.PHONY: test test_java test_js update diff distclean $(TESTS)

2+

13TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

24

35test: $(TESTS)

@@ -105,4 +107,3 @@ distclean:

105107 rm -f *~

106108 rm -f */output

107109

108−.PHONY: test test_java test_js update diff distclean $(TESTS)

test/reg001/reg001.idr−3

@@ -1,6 +1,3 @@

1−apply : (a -> b) -> a -> b

2−apply f x = f x

3−

41class Functor f => VerifiedFunctor (f : Type -> Type) where

52 identity : (fa : f a) -> map id fa = fa

63

test/reg003/expected+1−6

@@ -1,7 +1,2 @@

1−reg003a.idr:4:20:When elaborating constructor ECons:

1+reg003a.idr:4:20:When elaborating constructor Main.ECons:

22No such variable OddList

3−reg003a.idr:7:20:When elaborating constructor OCons:

4−No such variable EvenList

5−reg003a.idr:9:8:When elaborating type of test:

6−No such variable EvenList

7−reg003a.idr:10:1:No type declaration for test

test/reg030/expectednew file

No changes to the content.

test/reg030/reg030.idrnew file+15

@@ -0,0 +1,15 @@

1+import Control.Isomorphism

2+

3+class Set univ where

4+ member : univ -> univ -> Type

5+

6+isSubsetOf : Set univ => univ -> univ -> Type

7+isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

8+

9+class Set univ => HasPower univ where

10+ Powerset : (a : univ) ->

11+ Exists univ (\Pa => (c : univ) ->

12+ (isSubsetOf c a) -> member c Pa)

13+

14+powerset : HasPower univ => univ -> univ

15+powerset {univ} a = getWitness (Powerset a)

test/reg030/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ reg030.idr --check

3+rm -f *.ibc

test/reg031/expectednew file+1

@@ -0,0 +1 @@

1+[10, -128, -55, -1, 10, 51, 10, 52]

test/reg031/reg031.idrnew file+4

@@ -0,0 +1,4 @@

1+module Main

2+

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

22test010a.idr:9:1:main.bar is possibly not total due to: main.MkBad

33test010b.idr:9:1:main.bar is possibly not total due to: main.MkBad

test/test037/expected+1−1

@@ -1,6 +1,6 @@

11In file ErrorReflection.idr line 78 column 5

22 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 ()

44

55Original error:

66