idris 0.9.14.1 → 0.9.14.2
raw patch · 116 files changed
+3242/−1357 lines, 116 filesdep ~basedep ~parsersnew-component:exe:idris-cnew-component:exe:idris-javascriptnew-component:exe:idris-node
Dependency ranges changed: base, parsers
Files
- codegen/idris-c/Main.hs +44/−0
- codegen/idris-javascript/Main.hs +42/−0
- codegen/idris-node/Main.hs +42/−0
- idris.cabal +59/−2
- jsrts/Runtime-common.js +5/−0
- libs/base/Control/Monad/RWS.idr +3/−0
- libs/base/Control/Monad/Reader.idr +7/−0
- libs/base/Control/Monad/State.idr +7/−0
- libs/base/Control/Monad/Writer.idr +8/−0
- libs/base/Language/Reflection.idr +7/−6
- libs/base/Language/Reflection/Utils.idr +3/−3
- libs/base/System.idr +1/−0
- libs/effects/Effects.idr +1/−0
- libs/prelude/Builtins.idr +11/−0
- libs/prelude/Decidable/Equality.idr +10/−5
- libs/prelude/IO.idr +6/−2
- libs/prelude/Prelude/Basics.idr +1/−1
- libs/prelude/Prelude/Fin.idr +2/−1
- libs/prelude/Prelude/List.idr +14/−14
- main/Main.hs +1/−4
- rts/idris_gc.c +11/−4
- rts/idris_main.c +3/−0
- rts/idris_rts.c +32/−5
- rts/idris_rts.h +14/−6
- src/IRTS/Bytecode.hs +87/−26
- src/IRTS/CodegenC.hs +10/−3
- src/IRTS/CodegenJava.hs +2/−2
- src/IRTS/CodegenJavaScript.hs +30/−16
- src/IRTS/CodegenLLVM.hs +2/−2
- src/IRTS/Compiler.hs +62/−29
- src/IRTS/Defunctionalise.hs +16/−10
- src/IRTS/DumpBC.hs +3/−1
- src/IRTS/Java/Mangling.hs +2/−2
- src/IRTS/Lang.hs +100/−23
- src/IRTS/LangOpts.hs +79/−0
- src/IRTS/Simplified.hs +32/−26
- src/Idris/ASTUtils.hs +22/−0
- src/Idris/AbsSyntax.hs +53/−37
- src/Idris/AbsSyntaxTree.hs +39/−19
- src/Idris/Apropos.hs +2/−2
- src/Idris/CaseSplit.hs +2/−1
- src/Idris/CmdOptions.hs +5/−7
- src/Idris/Completion.hs +4/−0
- src/Idris/Core/Binary.hs +32/−6
- src/Idris/Core/CaseTree.hs +76/−75
- src/Idris/Core/DeepSeq.hs +5/−3
- src/Idris/Core/Elaborate.hs +35/−29
- src/Idris/Core/Evaluate.hs +39/−21
- src/Idris/Core/Execute.hs +29/−12
- src/Idris/Core/ProofState.hs +49/−123
- src/Idris/Core/ProofTerm.hs +283/−0
- src/Idris/Core/TT.hs +113/−41
- src/Idris/Core/Typecheck.hs +174/−79
- src/Idris/Core/Unify.hs +39/−29
- src/Idris/Coverage.hs +9/−9
- src/Idris/DataOpts.hs +8/−7
- src/Idris/DeepSeq.hs +1/−0
- src/Idris/Delaborate.hs +24/−7
- src/Idris/Elab/Clause.hs +49/−55
- src/Idris/Elab/Data.hs +35/−10
- src/Idris/Elab/Type.hs +18/−7
- src/Idris/Elab/Utils.hs +90/−3
- src/Idris/ElabDecls.hs +18/−10
- src/Idris/ElabTerm.hs +116/−24
- src/Idris/Erasure.hs +11/−11
- src/Idris/Error.hs +2/−3
- src/Idris/Help.hs +11/−1
- src/Idris/IBC.hs +61/−20
- src/Idris/IdeSlave.hs +20/−10
- src/Idris/Interactive.hs +36/−32
- src/Idris/Output.hs +65/−62
- src/Idris/ParseExpr.hs +3/−0
- src/Idris/ParseHelpers.hs +2/−2
- src/Idris/Parser.hs +34/−30
- src/Idris/PartialEval.hs +13/−12
- src/Idris/Primitives.hs +1/−1
- src/Idris/ProofSearch.hs +4/−4
- src/Idris/Prover.hs +51/−45
- src/Idris/Providers.hs +2/−1
- src/Idris/REPL.hs +345/−238
- src/Idris/REPLParser.hs +12/−7
- src/Idris/Transforms.hs +2/−2
- src/Idris/TypeSearch.hs +8/−10
- src/Idris/WhoCalls.hs +2/−2
- src/Pkg/Package.hs +1/−1
- src/Util/Net.hs +15/−2
- test/Makefile +1/−1
- test/basic001/rle-vect.idr +0/−32
- test/error004/FunErrTest.idr +1/−1
- test/error004/expected +1/−1
- test/primitives002/expected +6/−6
- test/primitives002/run +4/−2
- test/proof002/expected +1/−1
- test/quasiquote001/expected +3/−3
- test/reg010/expected +1/−1
- test/reg018/expected +1/−1
- test/reg028/expected +2/−2
- test/reg051/expected +0/−0
- test/reg051/reg051.idr +99/−0
- test/reg051/run +3/−0
- test/tutorial006/expected +1/−1
- test/unique001/expected +20/−0
- test/unique001/run +9/−0
- test/unique001/unique001.idr +32/−0
- test/unique001/unique001a.idr +62/−0
- test/unique001/unique001b.idr +30/−0
- test/unique001/unique001c.idr +53/−0
- test/unique001/unique001d.idr +3/−0
- test/unique001/unique001e.idr +4/−0
- test/unique002/expected +5/−0
- test/unique002/run +4/−0
- test/unique002/unique002.idr +20/−0
- test/unique002/unique002a.idr +18/−0
- test/unique003/expected +4/−0
- test/unique003/run +3/−0
- test/unique003/unique003.idr +22/−0
+ codegen/idris-c/Main.hs view
@@ -0,0 +1,44 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenC++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts { inputs :: [FilePath],+ output :: FilePath }++showUsage = do putStrLn "Usage: idris-c <ibc-files> [-o <output-file>]"+ exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+ return $ process (Opts [] "a.out") xs+ where+ process opts ("-o":o:xs) = process (opts { output = o }) xs+ process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+ process opts [] = opts++c_main :: Opts -> Idris ()+c_main opts = do elabPrims+ loadInputs (inputs opts) Nothing+ mainProg <- elabMain+ ir <- compile (Via "c") (output opts) mainProg+ runIO $ codegenC ir++main :: IO ()+main = do opts <- getOpts+ if (null (inputs opts)) + then showUsage+ else runMain (c_main opts)+++
+ codegen/idris-javascript/Main.hs view
@@ -0,0 +1,42 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenJavaScript++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts { inputs :: [FilePath]+ , output :: FilePath+ }++showUsage = do putStrLn "Usage: idris-javascript <ibc-files> [-o <output-file>]"+ exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+ return $ process (Opts [] "main.js") xs+ where+ process opts ("-o":o:xs) = process (opts { output = o }) xs+ process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+ process opts [] = opts++jsMain :: Opts -> Idris ()+jsMain opts = do elabPrims+ loadInputs (inputs opts) Nothing+ mainProg <- elabMain+ ir <- compile (Via "javascript") (output opts) mainProg+ runIO $ codegenJavaScript ir++main :: IO ()+main = do opts <- getOpts+ if (null (inputs opts))+ then showUsage+ else runMain (jsMain opts)
+ codegen/idris-node/Main.hs view
@@ -0,0 +1,42 @@+module Main where++import Idris.Core.TT+import Idris.AbsSyntax+import Idris.ElabDecls+import Idris.REPL++import IRTS.Compiler+import IRTS.CodegenJavaScript++import System.Environment+import System.Exit++import Paths_idris++data Opts = Opts { inputs :: [FilePath]+ , output :: FilePath+ }++showUsage = do putStrLn "Usage: idris-node <ibc-files> [-o <output-file>]"+ exitWith ExitSuccess++getOpts :: IO Opts+getOpts = do xs <- getArgs+ return $ process (Opts [] "main.js") xs+ where+ process opts ("-o":o:xs) = process (opts { output = o }) xs+ process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs+ process opts [] = opts++jsMain :: Opts -> Idris ()+jsMain opts = do elabPrims+ loadInputs (inputs opts) Nothing+ mainProg <- elabMain+ ir <- compile (Via "node") (output opts) mainProg+ runIO $ codegenNode ir++main :: IO ()+main = do opts <- getOpts+ if (null (inputs opts))+ then showUsage+ else runMain (jsMain opts)
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.14.1+Version: 0.9.14.2 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -250,6 +250,9 @@ test/reg050/run test/reg050/*.idr test/reg050/expected+ test/reg051/run+ test/reg051/*.idr+ test/reg051/expected test/basic001/run test/basic001/*.idr@@ -504,6 +507,16 @@ test/tutorial006/*.idr test/tutorial006/expected + test/unique001/run+ test/unique001/*.idr+ test/unique001/expected+ test/unique002/run+ test/unique002/*.idr+ test/unique002/expected+ test/unique003/run+ test/unique003/*.idr+ test/unique003/expected+ source-repository head type: git location: git://github.com/idris-lang/Idris-dev.git@@ -551,6 +564,7 @@ , Idris.Core.Evaluate , Idris.Core.Execute , Idris.Core.ProofState+ , Idris.Core.ProofTerm , Idris.Core.TC , Idris.Core.TT , Idris.Core.Typecheck@@ -629,6 +643,7 @@ , IRTS.Java.Mangling , IRTS.Java.Pom , IRTS.Lang+ , IRTS.LangOpts , IRTS.Simplified , IRTS.System @@ -668,7 +683,7 @@ , language-java >= 0.2.6 , lens >= 4.1.1 , mtl- , parsers >= 0.9 && < 0.11.0.2 + , parsers >= 0.9 && < 0.13 , pretty , process , split@@ -686,6 +701,8 @@ , zlib , optparse-applicative >= 0.8 Extensions: MultiParamTypeClasses+ , DeriveFoldable+ , DeriveTraversable , FunctionalDependencies , FlexibleContexts , FlexibleInstances@@ -700,6 +717,9 @@ if os(freebsd) cpp-options: -DFREEBSD build-depends: unix+ if os(dragonfly)+ cpp-options: -DDRAGONFLY+ build-depends: unix if os(darwin) cpp-options: -DMACOSX build-depends: unix@@ -739,4 +759,41 @@ ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields +Executable idris-c+ Main-is: Main.hs+ hs-source-dirs: codegen/idris-c + Build-depends: idris+ , base+ , filepath+ , haskeline >= 0.7+ , transformers++ ghc-prof-options: -auto-all -caf-all+ ghc-options: -threaded -rtsopts -funbox-strict-fields++Executable idris-javascript+ Main-is: Main.hs+ hs-source-dirs: codegen/idris-javascript++ Build-depends: idris+ , base+ , filepath+ , haskeline >= 0.7+ , transformers++ ghc-prof-options: -auto-all -caf-all+ ghc-options: -threaded -rtsopts -funbox-strict-fields++Executable idris-node+ Main-is: Main.hs+ hs-source-dirs: codegen/idris-node++ Build-depends: idris+ , base+ , filepath+ , haskeline >= 0.7+ , transformers++ ghc-prof-options: -auto-all -caf-all+ ghc-options: -threaded -rtsopts -funbox-strict-fields
jsrts/Runtime-common.js view
@@ -24,6 +24,11 @@ this.ev = ev; } +/** @constructor */+var i$POINTER = function(addr) {+ this.addr = addr;+}+ var i$SCHED = function(vm) { i$vm = vm; i$valstack = vm.valstack;
libs/base/Control/Monad/RWS.idr view
@@ -7,8 +7,10 @@ %access public +||| A combination of the Reader, Writer, and State monads class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {} +||| The transformer on which the RWS monad is based record RWST : Type -> Type -> Type -> (Type -> Type) -> Type -> Type where MkRWST : {m : Type -> Type} -> (runRWST : r -> s -> m (a, s, w)) -> RWST r w s m a@@ -46,5 +48,6 @@ instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m) where {} +||| The RWS monad. See the MonadRWS class RWS : Type -> Type -> Type -> Type -> Type RWS r w s a = RWST r w s Identity a
libs/base/Control/Monad/Reader.idr view
@@ -5,14 +5,19 @@ %access public +||| A monad representing a computation that runs in an immutable context class Monad m => MonadReader r (m : Type -> Type) where+ ||| Return the context ask : m r+ ||| Temprorarily modify the input and run an action in the new context local : (r -> r) -> m a -> m a +||| The transformer on which the Reader monad is based record ReaderT : Type -> (Type -> Type) -> Type -> Type where RD : {m : Type -> Type} -> (runReaderT : r -> m a) -> ReaderT r m a +||| Create a ReaderT with an empty context liftReaderT : {m : Type -> Type} -> m a -> ReaderT r m a liftReaderT m = RD $ const m @@ -36,9 +41,11 @@ ask = RD return local f (RD m) = RD $ m . f +||| Evaluate a function in the context of a Reader monad asks : MonadReader r m => (r -> a) -> m a asks f = do r <- ask return (f r) +||| The reader monad. See MonadReader Reader : Type -> Type -> Type Reader r a = ReaderT r Identity a
libs/base/Control/Monad/State.idr view
@@ -4,10 +4,14 @@ %access public +||| A computation which runs in a context and produces an output class Monad m => MonadState s (m : Type -> Type) where+ ||| Get the context get : m s+ ||| Write a new context/output put : s -> m () +||| The transformer on which the State monad is based record StateT : Type -> (Type -> Type) -> Type -> Type where ST : {m : Type -> Type} -> (runStateT : s -> m (a, s)) -> StateT s m a@@ -33,13 +37,16 @@ get = ST (\x => return (x, x)) put x = ST (\y => return ((), x)) +||| Apply a function to modify the context of this computation modify : MonadState s m => (s -> s) -> m () modify f = do s <- get put (f s) +||| Evaluate a function in the context held by this computation gets : MonadState s m => (s -> a) -> m a gets f = do s <- get return (f s) +||| The State monad. See the MonadState class State : Type -> Type -> Type State s a = StateT s Identity a
libs/base/Control/Monad/Writer.idr view
@@ -5,11 +5,16 @@ %access public +||| A monad representing a computation that produces a stream of output class (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where+ ||| tell w produces the output w tell : w -> m ()+ ||| Execute an action and add it's output to the value of the computation listen : m a -> m (a, w)+ ||| Execute an action and apply the returned function to the output pass : m (a, w -> w) -> m a +||| The transformer base of the Writer monad record WriterT : Type -> (Type -> Type) -> Type -> Type where WR : {m : Type -> Type} -> (runWriterT : m (a, w)) -> WriterT w m a@@ -39,14 +44,17 @@ pass (WR m) = WR $ do ((a, f), w) <- m return (a, f w) +||| Run an action in the Writer monad and transform the written output listens : MonadWriter w m => (w -> b) -> m a -> m (a, b) listens f m = listens' f (listen m) where listens' f' ma = do (a, w) <- ma return (a, f' w) +||| Run an action, apply a function to it's output, and return it's value censor : MonadWriter w m => (w -> w) -> m a -> m a censor f m = pass $ do a <- m return (a, f) +||| The Writer monad itself. See the MonadWriter class Writer : Type -> Type -> Type Writer w a = WriterT w Identity a
libs/base/Language/Reflection.idr view
@@ -92,7 +92,7 @@ ||| Types annotations for bound variables in different ||| binding contexts data Binder a = Lam a- | Pi a+ | Pi a a | Let a a | NLet a a | Hole a@@ -104,7 +104,7 @@ instance Functor Binder where map f (Lam x) = Lam (f x)- map f (Pi x) = Pi (f x)+ map f (Pi x k) = Pi (f x) (f k) map f (Let x y) = Let (f x) (f y) map f (NLet x y) = NLet (f x) (f y) map f (Hole x) = Hole (f x)@@ -115,7 +115,7 @@ instance Foldable Binder where foldr f z (Lam x) = f x z- foldr f z (Pi x) = f x z+ foldr f z (Pi x k) = f x (f k z) foldr f z (Let x y) = f x (f y z) foldr f z (NLet x y) = f x (f y z) foldr f z (Hole x) = f x z@@ -126,7 +126,7 @@ instance Traversable Binder where traverse f (Lam x) = [| Lam (f x) |]- traverse f (Pi x) = [| Pi (f x) |]+ traverse f (Pi x k) = [| Pi (f x) (f k) |] traverse f (Let x y) = [| Let (f x) (f y) |] traverse f (NLet x y) = [| NLet (f x) (f y) |] traverse f (Hole x) = [| Hole (f x) |]@@ -400,7 +400,8 @@ instance Quotable (Binder TT) where quotedTy = `(Binder TT) quote (Lam x) = `(Lam {a=TT} ~(assert_total (quote x)))- quote (Pi x) = `(Pi {a=TT} ~(assert_total (quote x)))+ quote (Pi x k) = `(Pi {a=TT} ~(assert_total (quote x))+ ~(assert_total (quote k))) quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x)) ~(assert_total (quote y))) quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x))@@ -431,7 +432,7 @@ quoteRawBinder : Binder Raw -> TT quoteRawBinder (Lam x) = `(Lam {a=Raw} ~(quoteRaw x))- quoteRawBinder (Pi x) = `(Pi {a=Raw} ~(quoteRaw x))+ quoteRawBinder (Pi x k) = `(Pi {a=Raw} ~(quoteRaw x) ~(quoteRaw k)) quoteRawBinder (Let x y) = `(Let {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) quoteRawBinder (NLet x y) = `(NLet {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) quoteRawBinder (Hole x) = `(Hole {a=Raw} ~(quoteRaw x))
libs/base/Language/Reflection/Utils.idr view
@@ -48,7 +48,7 @@ binderTy : (Eq t) => Binder t -> t binderTy (Lam t) = t-binderTy (Pi t) = t+binderTy (Pi t _) = t binderTy (Let t1 t2) = t1 binderTy (NLet t1 t2) = t1 binderTy (Hole t) = t@@ -160,7 +160,7 @@ instance (Show a) => Show (Binder a) where show (Lam t) = "(Lam " ++ show t ++ ")"- show (Pi t) = "(Pi " ++ show t ++ ")"+ show (Pi t _) = "(Pi " ++ show t ++ ")" show (Let t1 t2) = "(Let " ++ show t1 ++ " " ++ show t2 ++ ")" show (NLet t1 t2) = "(NLet " ++ show t1 ++ " " ++ show t2 ++ ")" show (Hole t) = "(Hole " ++ show t ++ ")"@@ -171,7 +171,7 @@ instance (Eq a) => Eq (Binder a) where (Lam t) == (Lam t') = t == t'- (Pi t) == (Pi t') = t == t'+ (Pi t k) == (Pi t' k') = t == t' && k == k' (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2' (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2' (Hole t) == (Hole t') = t == t'
libs/base/System.idr view
@@ -2,6 +2,7 @@ import Prelude +%include C "unistd.h" %default partial %access public
libs/effects/Effects.idr view
@@ -152,6 +152,7 @@ Eff t [x] xs' -> -- [x] (\v => xs) -> Eff t [l ::: x] (\v => map (l :::) (xs' v)) +%no_implicit (>>=) : Eff a xs xs' -> ((val : a) -> Eff b (xs' val) xs'') -> Eff b xs xs'' (>>=) = ebind
libs/prelude/Builtins.idr view
@@ -75,6 +75,17 @@ Inf : Type -> Type Inf t = Lazy' LazyCodata t +namespace Ownership+ ||| A read-only version of a unique value+ data Borrowed : UniqueType -> NullType where+ Read : {a : UniqueType} -> a -> Borrowed a+ + ||| Make a read-only version of a unique value, which can be passed to another+ ||| function without the unique value being consumed.+ implicit+ lend : {a : UniqueType} -> a -> Borrowed a+ lend x = Read x+ par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type -- is better in any case? par (Delay x) = x
libs/prelude/Decidable/Equality.idr view
@@ -201,7 +201,8 @@ instance DecEq Int where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where postulate primitiveEq : x = y+ where primitiveEq : x = y+ primitiveEq = believe_me (refl {x}) postulate primitiveNotEq : x = y -> _|_ --------------------------------------------------------------------------------@@ -210,7 +211,8 @@ instance DecEq Char where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where postulate primitiveEq : x = y+ where primitiveEq : x = y+ primitiveEq = believe_me (refl {x}) postulate primitiveNotEq : x = y -> _|_ --------------------------------------------------------------------------------@@ -219,7 +221,8 @@ instance DecEq Integer where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where postulate primitiveEq : x = y+ where primitiveEq : x = y+ primitiveEq = believe_me (refl {x}) postulate primitiveNotEq : x = y -> _|_ --------------------------------------------------------------------------------@@ -228,7 +231,8 @@ instance DecEq Float where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where postulate primitiveEq : x = y+ where primitiveEq : x = y+ primitiveEq = believe_me (refl {x}) postulate primitiveNotEq : x = y -> _|_ --------------------------------------------------------------------------------@@ -237,7 +241,8 @@ instance DecEq String where decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq- where postulate primitiveEq : x = y+ where primitiveEq : x = y+ primitiveEq = believe_me (refl {x}) postulate primitiveNotEq : x = y -> _|_
libs/prelude/IO.idr view
@@ -5,7 +5,9 @@ %access public ||| Idris's primitive IO, for building abstractions on top of-abstract data PrimIO a = prim__IO a+abstract +data PrimIO : Type -> Type where+ prim__IO : a -> PrimIO a ||| A token representing the world, for use in `IO` abstract data World = TheWorld@@ -15,7 +17,9 @@ -- abstract data WorldRes a = MkWR a World -abstract data IO a = MkIO (World -> PrimIO (WorldRes a))+abstract +data IO : Type -> Type where+ MkIO : (World -> PrimIO (WorldRes a)) -> IO a abstract prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b
libs/prelude/Prelude/Basics.idr view
@@ -28,7 +28,7 @@ infixl 9 . ||| Function composition-(.) : (b -> c) -> (a -> b) -> a -> c+(.) : {a, b, c : Type*} -> (b -> c) -> (a -> b) -> a -> c (.) f g x = f (g x) ||| Takes in the first two arguments in reverse order.
libs/prelude/Prelude/Fin.idr view
@@ -133,11 +133,12 @@ natToFin _ _ = Nothing integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)+integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction! integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing ||| Proof that some `Maybe` is actually `Just` data IsJust : Maybe a -> Type where- ItIsJust : IsJust {a} (Just x)+ ItIsJust : IsJust (Just x) ||| Allow overloading of Integer literals for Fin. ||| @ x the Integer that the user typed
libs/prelude/Prelude/List.idr view
@@ -72,9 +72,9 @@ ||| Get the first element of a non-empty list ||| @ ok proof that the list is non-empty-head : (l : List a) -> (ok : isCons l = True) -> a-head [] refl impossible-head (x::xs) p = x+head : (l : List a) -> {auto ok : isCons l = True} -> a+head [] {ok=refl} impossible+head (x::xs) {ok=p} = x ||| Attempt to get the first element of a list. If the list is empty, return ||| `Nothing`.@@ -84,9 +84,9 @@ ||| Get the tail of a non-empty list. ||| @ ok proof that the list is non-empty-tail : (l : List a) -> (ok : isCons l = True) -> List a-tail [] refl impossible-tail (x::xs) p = xs+tail : (l : List a) -> {auto ok : isCons l = True} -> List a+tail [] {ok=refl} impossible+tail (x::xs) {ok=p} = xs ||| Attempt to get the tail of a list. |||@@ -97,10 +97,10 @@ ||| Retrieve the last element of a non-empty list. ||| @ ok proof that the list is non-empty-last : (l : List a) -> (ok : isCons l = True) -> a-last [] refl impossible-last [x] p = x-last (x::y::ys) p = last (y::ys) refl+last : (l : List a) -> {auto ok : isCons l = True} -> a+last [] {ok=refl} impossible+last [x] {ok=p} = x+last (x::y::ys) {ok=p} = last (y::ys) {ok=refl} ||| Attempt to retrieve the last element of a non-empty list. |||@@ -114,10 +114,10 @@ ||| Return all but the last element of a non-empty list. ||| @ ok proof that the list is non-empty-init : (l : List a) -> (ok : isCons l = True) -> List a-init [] refl impossible-init [x] p = []-init (x::y::ys) p = x :: init (y::ys) refl+init : (l : List a) -> {auto ok : isCons l = True} -> List a+init [] {ok=refl} impossible+init [x] {ok=p} = []+init (x::y::ys) {ok=p} = x :: init (y::ys) {ok=refl} ||| Attempt to Return all but the last element of a list. |||
main/Main.hs view
@@ -38,10 +38,7 @@ -- on with the REPL. main = do opts <- runArgParser- result <- runErrorT $ execStateT (runIdris opts) idrisInit- case result of- Left err -> putStrLn $ "Uncaught error: " ++ show err- Right _ -> return ()+ runMain (runIdris opts) runIdris :: [Opt] -> Idris () runIdris [Client c] = do setVerbose False
rts/idris_gc.c view
@@ -12,10 +12,14 @@ switch(GETTY(x)) { case CON: ar = CARITY(x);- allocCon(cl, vm, CTAG(x), ar, 1);- for(i = 0; i < ar; ++i) {-// *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version- cl->info.c.args[i] = x->info.c.args[i];+ if (ar == 0 && CTAG(x) < 256) {+ return x;+ } else {+ allocCon(cl, vm, CTAG(x), ar, 1);+ for(i = 0; i < ar; ++i) {+ // *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version+ cl->info.c.args[i] = x->info.c.args[i];+ } } break; case FLOAT:@@ -147,4 +151,7 @@ printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap)); if (doGC) { idris_gc(vm); } printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap));++ printf("Total allocations %d\n", vm->stats.allocations);+ printf("Number of collections %d\n", vm->stats.collections); }
rts/idris_main.c view
@@ -15,6 +15,8 @@ __idris_argv = argv; VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1);+ initNullaries();+ _idris__123_runMain0_125_(vm, NULL); #ifdef IDRIS_DEBUG@@ -29,5 +31,6 @@ print_stats(&stats); } + freeNullaries(); return EXIT_SUCCESS; }
rts/idris_rts.c view
@@ -828,12 +828,16 @@ switch(GETTY(x)) { case CON: ar = CARITY(x);- allocCon(cl, vm, CTAG(x), ar, 1);+ if (ar == 0 && CTAG(x) < 256) { // globally allocated+ cl = x;+ } else {+ allocCon(cl, vm, CTAG(x), ar, 1); - argptr = (VAL*)(cl->info.c.args);- for(i = 0; i < ar; ++i) {- *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version- argptr++;+ argptr = (VAL*)(cl->info.c.args);+ for(i = 0; i < ar; ++i) {+ *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version+ argptr++;+ } } break; case FLOAT:@@ -962,6 +966,29 @@ return msg; } #endif++VAL* nullary_cons;++void initNullaries() {+ int i;+ VAL cl;+ nullary_cons = malloc(256 * sizeof(VAL));+ for(i = 0; i < 256; ++i) {+ cl = malloc(sizeof(Closure));+ SETTY(cl, CON);+ cl->info.c.tag_arity = i << 8;+ nullary_cons[i] = cl;+ }+}++void freeNullaries() {+ int i;+ for(i = 0; i < 256; ++i) {+ free(nullary_cons[i]);+ }+ free(nullary_cons);+}+ int __idris_argc; char **__idris_argv;
rts/idris_rts.h view
@@ -113,9 +113,6 @@ #define RVAL (vm->ret) #define LOC(x) (*(vm->valstack_base + (x))) #define TOP(x) (*(vm->valstack_top + (x)))-// Doesn't work! Ordinary assign seems fine though...-#define UPDATE(x,y) if (!ISINT(x) && !ISINT(y)) \- { (x)->ty = (y)->ty; (x)->info = (y)->info; } #define REG1 (vm->reg1) // Retrieving values@@ -125,8 +122,8 @@ #define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f) -#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )-#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )+#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) ) // Already checked it's a CON #define CTAG(x) (((x)->info.c.tag_arity) >> 8)@@ -148,7 +145,7 @@ #define MKINT(x) ((void*)((x)<<1)+1) #define GETINT(x) ((i_int)(x)>>1) #define ISINT(x) ((((i_int)x)&1) == 1)-#define ISSTR(x) (((VAL)(x))->ty == STRING)+#define ISSTR(x) (GETTY(x) == STRING) #define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1))) #define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))@@ -213,6 +210,17 @@ cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \ SETTY(cl, CON); \ cl->info.c.tag_arity = ((t) << 8) | (a);++#define updateCon(cl, old, t, a) \+ cl = old; \+ SETTY(cl, CON); \+ cl->info.c.tag_arity = ((t) << 8) | (a);++#define NULL_CON(x) nullary_cons[x]++extern VAL* nullary_cons;+void initNullaries();+void freeNullaries(); void* vmThread(VM* callvm, func f, VAL arg);
src/IRTS/Bytecode.hs view
@@ -25,31 +25,89 @@ data Reg = RVal | L Int | T Int | Tmp deriving (Show, Eq) -data BC = ASSIGN Reg Reg- | ASSIGNCONST Reg Const- | UPDATE Reg Reg- | MKCON Reg Int [Reg]- | CASE Bool -- definitely a constructor, no need to check, if true- Reg [(Int, [BC])] (Maybe [BC])- | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards- | PROJECTINTO Reg Reg Int -- project argument from one reg into another- | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])- | CALL Name- | TAILCALL Name- | FOREIGNCALL Reg FLang FType String [(FType, Reg)]- | SLIDE Int -- move this number from TOP to BASE- | REBASE -- set BASE = OLDBASE- | RESERVE Int -- reserve n more stack items- -- (i.e. check there's space, grow if necessary)- | ADDTOP Int -- move the top of stack up- | TOPBASE Int -- set TOP = BASE + n- | BASETOP Int -- set BASE = TOP + n- | STOREOLD -- set OLDBASE = BASE- | OP Reg PrimFn [Reg]- | NULL Reg -- clear reg- | ERROR String- deriving Show+data BC = + -- reg1 = reg2+ ASSIGN Reg Reg + -- reg = const+ | ASSIGNCONST Reg Const++ -- reg1 = reg2 (same as assign, it seems)+ | UPDATE Reg Reg++ -- reg = constructor, where constructor consists of a tag and+ -- values from registers, e.g. (cons tag args)+ -- the 'Maybe Reg', if set, is a register which can be overwritten+ -- (i.e. safe for mutable update), though this can be ignored+ | MKCON Reg (Maybe Reg) Int [Reg]++ -- Matching on value of reg: usually (but not always) there are+ -- constructors, hence "Int" for patterns (that's a tag on which+ -- we should match), and the following [BC] is just a list of+ -- instructions for the corresponding case. The last argument is+ -- for default case. When it's not necessary a constructor in the+ -- reg, the Bool should be False, indicating that it's not safe to+ -- work with that as with a constructor, so a check should be+ -- added. If it's not a constructor, default case should be used.+ | CASE Bool+ Reg [(Int, [BC])] (Maybe [BC])++ -- get a value from register, which should be a constructor, and+ -- put its arguments into the stack, starting from (base + int1)+ -- and onwards; second Int provides arity+ | PROJECT Reg Int Int++ -- probably not used+ | PROJECTINTO Reg Reg Int -- project argument from one reg into another++ -- same as CASE, but there's an exact value (not constructor) in reg+ | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])++ -- just call a function, passing MYOLDBASE (see below) to it+ | CALL Name++ -- same, perhaps exists just for TCO+ | TAILCALL Name++ -- set reg to (apply string args), FLang argument is the language to+ -- be called. FType is the foreign language type, which may be used to+ -- control marshaling.+ | FOREIGNCALL Reg FLang FType String [(FType, Reg)]++ -- move this number of elements from TOP to BASE+ | SLIDE Int++ -- set BASE = OLDBASE+ | REBASE++ -- reserve n more stack items (i.e. check there's space, grow if+ -- necessary)+ | RESERVE Int++ -- move the top of stack up+ | ADDTOP Int++ -- set TOP = BASE + n+ | TOPBASE Int++ -- set BASE = TOP + n+ | BASETOP Int++ -- set MYOLDBASE = BASE, where MYOLDBASE is a function-local+ -- variable, set to OLDBASE by default, and passed on function+ -- call to called functions as their OLDBASE+ | STOREOLD++ -- reg = apply primitive_function args+ | OP Reg PrimFn [Reg]++ -- clear reg+ | NULL Reg++ -- throw an error+ | ERROR String+ deriving Show+ toBC :: (Name, SDecl) -> (Name, [BC]) toBC (n, SFun n' args locs exp) = (n, reserve locs ++ bc RVal exp True)@@ -81,15 +139,18 @@ bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg] ++ clean r -- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it-bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r+bc reg (SCon atloc i _ vs) r + = MKCON reg (getAllocLoc atloc) i (map getL vs) : clean r where getL (Loc x) = L x+ getAllocLoc (Just (Loc x)) = Just (L x)+ getAllocLoc _ = Nothing bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r bc reg (SConst i) r = ASSIGNCONST reg i : clean r bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r where getL (Loc x) = L x bc reg (SError str) r = [ERROR str] bc reg SNothing r = NULL reg : clean r-bc reg (SCase (Loc l) alts) r+bc reg (SCase up (Loc l) alts) r | isConst alts = constCase reg (L l) alts r | otherwise = conCase True reg (L l) alts r bc reg (SChkCase (Loc l) alts) r
src/IRTS/CodegenC.hs view
@@ -153,9 +153,10 @@ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)" mkConst _ = "MKINT(42424242)" bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"-bcc i (MKCON l tag args)- = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++- show (length args) ++ ", 0);\n" +++bcc i (MKCON l loc tag []) | tag < 256+ = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n"+bcc i (MKCON l loc tag args)+ = indent i ++ alloc loc tag ++ indent i ++ setArgs 0 args ++ "\n" ++ indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n" @@ -165,6 +166,12 @@ setArgs i [] = "" setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++ "); " ++ setArgs (i + 1) xs+ alloc Nothing tag + = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " +++ show (length args) ++ ", 0);\n"+ alloc (Just old) tag+ = "updateCon(" ++ creg Tmp ++ ", " ++ creg old ++ ", " ++ show tag ++ ", " +++ show (length args) ++ ");\n" bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++ ", " ++ show a ++ ");\n"
src/IRTS/CodegenJava.hs view
@@ -460,11 +460,11 @@ mkExp pp newExp -- Objects-mkExp pp (SCon conId _ args) =+mkExp pp (SCon _ conId _ args) = mkIdrisObject conId args >>= ppExp pp -- Case expressions-mkExp pp (SCase var alts) = mkCase pp True var alts+mkExp pp (SCase up var alts) = mkCase pp True var alts mkExp pp (SChkCase var alts) = mkCase pp False var alts -- Projections
src/IRTS/CodegenJavaScript.hs view
@@ -244,7 +244,7 @@ , JSApp (JSIdent "i$SCHED") [JSIdent "vm"] , JSApp ( JSIdent (translateName (sMN 0 "runMain"))- ) [JSNum (JSInt 0)]+ ) [JSNew "i$POINTER" [JSNum (JSInt 0)]] , JSWhile (JSProj jsCALLSTACK "length") ( JSSeq [ JSAlloc "func" (Just jsPOP) , JSAlloc "args" (Just jsPOP)@@ -328,24 +328,33 @@ splitSequence :: JS -> RWS () [(Int, JS)] Int JS splitSequence js@(JSSeq seq) =- let (pre,post) = break isCall seq in+ let (pre,post) = break isBranch seq in case post of- [] -> JSSeq <$> traverse splitCondition seq- [js@(JSCond _)] -> splitCondition js- [js@(JSSwitch {})] -> splitCondition js- [_] -> return js+ [_] -> JSSeq <$> traverse splitCondition seq+ [call@(JSCond _),rest@(JSApp _ _)] -> do+ rest' <- splitCondition rest+ call' <- splitCondition call+ return $ JSSeq (pre ++ [rest', call'])+ [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do+ rest' <- splitCondition rest+ call' <- splitCondition call+ return $ JSSeq (pre ++ [rest', call']) (call:rest) -> do depth <- get put (depth + 1) new <- splitFunction (newFun rest) tell [(depth, new)]- return $ JSSeq (pre ++ (newCall depth : [call]))+ call' <- splitCondition call+ return $ JSSeq (pre ++ (newCall depth : [call']))+ _ -> JSSeq <$> traverse splitCondition seq splitSequence js = return js - isCall :: JS -> Bool- isCall (JSApp (JSIdent "i$CALL") _) = True- isCall _ = False+ isBranch :: JS -> Bool+ isBranch (JSApp (JSIdent "i$CALL") _) = True+ isBranch (JSCond _) = True+ isBranch (JSSwitch _ _ _) = True+ isBranch _ = False newCall :: Int -> JS newCall depth =@@ -366,7 +375,7 @@ ++ [ JSAlloc ( translateName name ) (Just $ JSFunction ["oldbase"] (- JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [+ JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app") , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE] )@@ -384,7 +393,7 @@ ++ [ JSAlloc ( translateName name ) (Just $ JSFunction ["oldbase"] (- JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [+ JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev") , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE] )@@ -431,12 +440,17 @@ [ JSAlloc ( translateName name ) (Just $ JSFunction ["oldbase"] (- JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc+ JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc ) ) ] +jsFUNPRELUDE :: [JS]+jsFUNPRELUDE = [jsALLOCMYOLDBASE] +jsALLOCMYOLDBASE :: JS+jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])+ translateReg :: Reg -> JS translateReg reg | RVal <- reg = jsRET@@ -567,10 +581,10 @@ translateReg reg jsREBASE :: CompileInfo -> JS-jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE+jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr") jsSTOREOLD :: CompileInfo ->JS-jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE+jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE jsADDTOP :: CompileInfo -> Int -> JS jsADDTOP info n@@ -1314,7 +1328,7 @@ | SLIDE n <- bc = jsSLIDE info n | REBASE <- bc = jsREBASE info | RESERVE n <- bc = jsRESERVE info n- | MKCON r t rs <- bc = jsMKCON info r t rs+ | MKCON r _ t rs <- bc = jsMKCON info r t rs | CASE s r c d <- bc = jsCASE info s r c d | CONSTCASE r c d <- bc = jsCONSTCASE info r c d | PROJECT r l a <- bc = jsPROJECT info r l a
src/IRTS/CodegenLLVM.hs view
@@ -494,7 +494,7 @@ modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } return val cgExpr (SUpdate x expr) = cgExpr expr-cgExpr (SCon tag name args) = do+cgExpr (SCon _ tag name args) = do argSlots <- mapM var args case sequence argSlots of Nothing -> return Nothing@@ -511,7 +511,7 @@ ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) [] inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])-cgExpr (SCase inspect alts) = do+cgExpr (SCase _ inspect alts) = do val <- var inspect case val of Nothing -> return Nothing
src/IRTS/Compiler.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-} -module IRTS.Compiler where+module IRTS.Compiler(compile, generate) where import IRTS.Lang+import IRTS.LangOpts import IRTS.Defunctionalise import IRTS.Simplified import IRTS.CodegenCommon@@ -43,11 +44,14 @@ import qualified Data.Set as S import System.Process import System.IO+import System.Exit import System.Directory import System.Environment import System.FilePath ((</>), addTrailingPathSeparator) -compile :: Codegen -> FilePath -> Term -> Idris ()+-- | Given a 'main' term to compiler, return the IRs which can be used to+-- generate code.+compile :: Codegen -> FilePath -> Term -> Idris CodegenInfo compile codegen f tm = do checkMVs -- check for undefined metavariables checkTotality -- refuse to compile if there are totality problems@@ -62,8 +66,14 @@ defsIn <- mkDecls tm reachableNames let defs = defsIn ++ [(sMN 0 "runMain", maindef)] -- iputStrLn $ showSep "\n" (map show defs)- let (nexttag, tagged) = addTags 65536 (liftAll defs)+ -- Inlined top level LDecl made here+ let defsInlined = inlineAll defs+ let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) + defsInlined++ let (nexttag, tagged) = addTags 65536 (liftAll defsUniq) let ctxtIn = addAlist tagged emptyContext+ iLOG "Defunctionalising" let defuns_in = defunctionalise nexttag ctxtIn logLvl 5 $ show defuns_in@@ -72,7 +82,7 @@ logLvl 5 $ show defuns iLOG "Resolving variables for CG" -- iputStrLn $ showSep "\n" (map show (toAlist defuns))- let checked = checkDefs defuns (toAlist defuns)+ let checked = simplifyDefs defuns (toAlist defuns) outty <- outputTy dumpCases <- getDumpCases dumpDefun <- getDumpDefun@@ -88,17 +98,17 @@ iLOG "Building output" case checked of- OK c -> do let cginfo = CodegenInfo f outty triple cpu optimise- hdrs impdirs objs libs flags- NONE c (toAlist defuns)- tagged- runIO $ case codegen of- ViaC -> codegenC cginfo- ViaJava -> codegenJava cginfo - ViaJavaScript -> codegenJavaScript cginfo- ViaNode -> codegenNode cginfo- ViaLLVM -> codegenLLVM cginfo- Bytecode -> dumpBC c f+ OK c -> do return $ CodegenInfo f outty triple cpu optimise+ hdrs impdirs objs libs flags+ NONE c (toAlist defuns)+ tagged+-- runIO $ case codegen of+-- ViaC -> codegenC cginfo+-- ViaJava -> codegenJava cginfo +-- ViaJavaScript -> codegenJavaScript cginfo+-- ViaNode -> codegenNode cginfo+-- ViaLLVM -> codegenLLVM cginfo+-- Bytecode -> dumpBC c f Error e -> ierror e where checkMVs = do i <- getIState case map fst (idris_metavars i) \\ primDefs of@@ -112,6 +122,21 @@ ex <- doesFileExist f if ex then return f else return h +generate :: Codegen -> FilePath -> CodegenInfo -> IO ()+generate codegen mainmod ir + = case codegen of+ -- Built-in code generators (FIXME: lift these out!)+ Via "c" -> codegenC ir + Via "java" -> codegenJava ir + Via "llvm" -> codegenLLVM ir+ -- Any external code generator+ Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod +++ " -o " ++ outputFile ir+ exit <- system cmd+ when (exit /= ExitSuccess) $+ putStrLn ("FAILURE: " ++ show cmd)+ Bytecode -> dumpBC (simpleDecls ir) (outputFile ir)+ irMain :: TT Name -> Idris LDecl irMain tm = do i <- irTerm M.empty [] tm@@ -151,6 +176,7 @@ snRank (CaseN n) = "5" ++ nameRank n snRank (ElimN n) = "6" ++ nameRank n snRank (InstanceCtorN n) = "7" ++ nameRank n+ snRank (WithN i n) = "8" ++ nameRank n ++ show i isCon (TyDecl _ _) = True isCon _ = False@@ -174,11 +200,17 @@ = declArgs [] True n <$> irTerm M.empty [] tm mkLDecl n (CaseOp ci _ _ _ pats cd)- = declArgs [] (case_inlinable ci) n <$> irTree args sc+ = declArgs [] (case_inlinable ci || caseName n) n <$> irTree args sc where (args, sc) = cases_runtime cd -mkLDecl n (TyDecl (DCon tag arity) _) =+ -- Always attempt to inline functions arising from 'case' expressions + caseName (SN (CaseN _)) = True+ caseName (SN (WithN _ _)) = True+ caseName (NS n _) = caseName n+ caseName _ = False++mkLDecl n (TyDecl (DCon tag arity _) _) = LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n) mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a@@ -261,12 +293,13 @@ x' <- irTerm vs env x t' <- irTerm vs env t e' <- irTerm vs env e- return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'+ return (LCase Shared x' + [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e' ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t' ]) -- data constructor- (P (DCon t arity) n _, args) -> do+ (P (DCon t arity _) n _, args) -> do detag <- fgetState (opt_detaggable . ist_optimisation n) used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n) @@ -371,7 +404,7 @@ arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of Just (CaseOp ci ty tys def tot cdefs) -> length tys- Just (TyDecl (DCon tag ar) _) -> ar+ Just (TyDecl (DCon tag ar _) _) -> ar Just (TyDecl Ref ty) -> length $ getArgTys ty Just (Operator ty ar op) -> ar Just def -> error $ "unknown arity: " ++ show (n, def)@@ -490,10 +523,10 @@ irSC vs (ProjCase tm alts) = do tm' <- irTerm vs [] tm alts' <- mapM (irAlt vs tm') alts- return $ LCase tm' alts'+ return $ LCase Shared tm' alts' -- Transform matching on Delay to applications of Force.-irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])+irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc]) | delay == txt "Delay" = do sc' <- irSC vs $ mkForce n' n sc return $ LLet n' (LForce (LV (Glob n))) sc'@@ -520,7 +553,7 @@ -- Hence, we check whether the variables are used at all -- and erase the casesplit if they are not. ---irSC vs (Case n [alt]) = do+irSC vs (Case up n [alt]) = do replacement <- case alt of ConCase cn a ns sc -> do detag <- fgetState (opt_detaggable . ist_optimisation cn)@@ -536,7 +569,7 @@ alt' <- irAlt vs (LV (Glob n)) alt return $ case namesBoundIn alt' `usedIn` subexpr alt' of [] -> subexpr alt' -- strip the unused top-most case- _ -> LCase (LV (Glob n)) [alt']+ _ -> LCase up (LV (Glob n)) [alt'] where namesBoundIn :: LAlt -> [Name] namesBoundIn (LConCase cn i ns sc) = ns@@ -564,13 +597,13 @@ -- This work-around is not entirely optimal; the best approach would be -- to ensure that such case trees don't arise in the first place. ---irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do+irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do detag <- fgetState (opt_detaggable . ist_optimisation cn) if detag- then irSC vs (Case n [ConCase cn a ns sc])- else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts+ then irSC vs (Case up n [ConCase cn a ns sc])+ else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts -irSC vs sc@(Case n alts) = do+irSC vs sc@(Case up n alts) = do -- check that neither alternative needs the newtype optimisation, -- see comment above goneWrong <- or <$> mapM isDetaggable alts@@ -578,7 +611,7 @@ $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc) -- everything okay- LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts+ LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts where isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn isDetaggable _ = return False
src/IRTS/Defunctionalise.hs view
@@ -5,6 +5,7 @@ import IRTS.Lang import Idris.Core.TT+import Idris.Core.CaseTree import Debug.Trace import Data.Maybe@@ -17,8 +18,8 @@ | DLet Name DExp DExp -- name just for pretty printing | DUpdate Name DExp -- eval expression, then update var with it | DProj DExp Int- | DC Int Name [DExp]- | DCase DExp [DAlt]+ | DC (Maybe LVar) Int Name [DExp]+ | DCase CaseType DExp [DAlt] | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY) | DConst Const | DForeign FLang FType String [(FType, DExp)]@@ -99,15 +100,15 @@ aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args) aa env (LForce e) = liftM eEVAL (aa env e) aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)- aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args)+ aa env (LCon loc i n args) = liftM (DC loc i n) (mapM (aa env) args) aa env (LProj t@(LV (Glob n)) i) | n `elem` env = do t' <- aa env t return $ DProj (DUpdate n t') i aa env (LProj t i) = do t' <- aa env t return $ DProj t' i- aa env (LCase e alts) = do e' <- aa env e- alts' <- mapM (aaAlt env) alts- return $ DCase e' alts'+ aa env (LCase up e alts) = do e' <- aa env e+ alts' <- mapM (aaAlt env) alts+ return $ DCase up e' alts' aa env (LConst c) = return $ DConst c aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args) aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)@@ -160,8 +161,8 @@ | otherwise = preEval xs t needsEval x (DApp _ _ args) = or (map (needsEval x) args)- needsEval x (DC _ _ args) = or (map (needsEval x) args)- needsEval x (DCase e alts) = needsEval x e || or (map nec alts)+ needsEval x (DC _ _ _ args) = or (map (needsEval x) args)+ needsEval x (DCase up e alts) = needsEval x e || or (map nec alts) where nec (DConCase _ _ _ e) = needsEval x e nec (DConstCase _ e) = needsEval x e nec (DDefaultCase e) = needsEval x e@@ -262,10 +263,15 @@ show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++ show' (env ++ [show n]) e show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")"- show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"+ show' env (DC loc i n args) = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"+ where atloc Nothing = ""+ atloc (Just l) = "@" ++ show (LV l) ++ ":" show' env (DProj t i) = show t ++ "!" ++ show i- show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" +++ show' env (DCase up e alts) = "case" ++ update ++ show' env e ++ " of {\n\t" ++ showSep "\n\t| " (map (showAlt env) alts)+ where update = case up of+ Shared -> " "+ Updatable -> "! " show' env (DChkCase e alts) = "case' " ++ show' env e ++ " of {\n\t" ++ showSep "\n\t| " (map (showAlt env) alts) show' env (DConst c) = show c
src/IRTS/DumpBC.hs view
@@ -35,8 +35,10 @@ "ASSIGNCONST " ++ serializeReg a ++ " " ++ show b UPDATE a b -> "UPDATE " ++ serializeReg a ++ " " ++ serializeReg b- MKCON a b xs ->+ MKCON a Nothing b xs -> "MKCON " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"+ MKCON a (Just r) b xs ->+ "MKCON@" ++ serializeReg r ++ " " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]" CASE safe r cases def -> "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) ++ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def
src/IRTS/Java/Mangling.hs view
@@ -31,8 +31,8 @@ SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2) prefixCallNamespacesExp name (SUpdate var e) = SUpdate var (prefixCallNamespacesExp name e)- prefixCallNamespacesExp name (SCase var alts) =- SCase var (map (prefixCallNamespacesCase name) alts)+ prefixCallNamespacesExp name (SCase up var alts) =+ SCase up var (map (prefixCallNamespacesCase name) alts) prefixCallNamespacesExp name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts) prefixCallNamespacesExp _ exp = exp
src/IRTS/Lang.hs view
@@ -1,15 +1,22 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}+ module IRTS.Lang where -import Control.Monad.State hiding (lift)-import Idris.Core.TT-import Data.List-import Debug.Trace+import Control.Monad.State hiding (lift)+import Control.Applicative hiding (Const) +import Idris.Core.TT+import Idris.Core.CaseTree++import Data.List+import Debug.Trace+ data Endianness = Native | BE | LE deriving (Show, Eq) data LVar = Loc Int | Glob Name deriving (Show, Eq) +-- ASSUMPTION: All variable bindings have unique names here data LExp = LV LVar | LApp Bool LExp [LExp] -- True = tail call | LLazyApp Name [LExp] -- True = tail call@@ -18,8 +25,9 @@ | LLet Name LExp LExp -- name just for pretty printing | LLam [Name] LExp -- lambda, lifted out before compiling | LProj LExp Int -- projection- | LCon Int Name [LExp]- | LCase LExp [LAlt]+ | LCon (Maybe LVar) -- Location to reallocate, if available+ Int Name [LExp]+ | LCase CaseType LExp [LAlt] | LConst Const | LForeign FLang FType String [(FType, LExp)] | LOp PrimFn [LExp]@@ -90,11 +98,14 @@ | FAny deriving (Show, Eq) -data LAlt = LConCase Int Name [Name] LExp- | LConstCase Const LExp- | LDefaultCase LExp- deriving (Show, Eq)+-- FIXME: Why not use this for all the IRs now?+data LAlt' e = LConCase Int Name [Name] e+ | LConstCase Const e+ | LDefaultCase e+ deriving (Show, Eq, Functor) +type LAlt = LAlt' LExp+ data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def | LConstructor Name Int Int -- constructor name, tag, arity deriving (Show, Eq)@@ -123,9 +134,9 @@ liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs lambdaLift :: Name -> LDecl -> [(Name, LDecl)]-lambdaLift n (LFun _ _ args e)+lambdaLift n (LFun opts _ args e) = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in- (n, LFun [] n args e') : decls+ (n, LFun opts n args e') : decls lambdaLift n x = [(n, x)] getNextName :: State LiftState Name@@ -168,11 +179,11 @@ return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs)) lift env (LProj t i) = do t' <- lift env t return (LProj t' i)-lift env (LCon i n args) = do args' <- mapM (lift env) args- return (LCon i n args')-lift env (LCase e alts) = do alts' <- mapM liftA alts- e' <- lift env e- return (LCase e' alts')+lift env (LCon loc i n args) = do args' <- mapM (lift env) args+ return (LCon loc i n args')+lift env (LCase up e alts) = do alts' <- mapM liftA alts+ e' <- lift env e+ return (LCase up e' alts') where liftA (LConCase i n args e) = do e' <- lift (env ++ args) e return (LConCase i n args e')@@ -191,6 +202,67 @@ lift env (LError str) = return $ LError str lift env LNothing = return $ LNothing +allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)+allocUnique defs p@(n, LConstructor _ _ _) = p+allocUnique defs (n, LFun opts fn args e)+ = let e' = evalState (findUp e) [] in+ (n, LFun opts fn args e')+ where+ -- Keep track of 'updatable' names in the state, i.e. names whose heap+ -- entry may be reused, along with the arity which was there+ findUp :: LExp -> State [(Name, Int)] LExp+ findUp (LApp t (LV (Glob n)) as) + | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,+ ar == length as+ = findUp (LCon Nothing i n as)+ findUp (LV (Glob n))+ | Just (LConstructor _ i 0) <- lookupCtxtExact n defs+ = return $ LCon Nothing i n [] -- nullary cons are global, no need to update+ findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as+ findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as+ findUp (LLazyExp e) = LLazyExp <$> findUp e+ findUp (LForce e) = LForce <$> findUp e+ -- use assumption that names are unique!+ findUp (LLet n val sc) = LLet n <$> findUp val <*> findUp sc+ findUp (LLam ns sc) = LLam ns <$> findUp sc+ findUp (LProj e i) = LProj <$> findUp e <*> return i+ findUp (LCon (Just l) i n es) = LCon (Just l) i n <$> mapM findUp es+ findUp (LCon Nothing i n es)+ = do avail <- get+ v <- findVar [] avail (length es)+ LCon v i n <$> mapM findUp es+ findUp (LForeign l t s es)+ = LForeign l t s <$> mapM (\ (t, e) -> do e' <- findUp e+ return (t, e')) es+ findUp (LOp o es) = LOp o <$> mapM findUp es+ findUp (LCase Updatable e@(LV (Glob n)) as)+ = LCase Updatable e <$> mapM (doUpAlt n) as+ findUp (LCase t e as) + = LCase t <$> findUp e <*> mapM findUpAlt as+ findUp t = return t++ findUpAlt (LConCase i t args rhs) = do avail <- get+ rhs' <- findUp rhs+ put avail+ return $ LConCase i t args rhs'+ findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs+ findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs++ doUpAlt n (LConCase i t args rhs) + = do avail <- get+ put ((n, length args) : avail)+ rhs' <- findUp rhs+ put avail+ return $ LConCase i t args rhs'+ doUpAlt n (LConstCase i rhs) = LConstCase i <$> findUp rhs+ doUpAlt n (LDefaultCase rhs) = LDefaultCase <$> findUp rhs++ findVar _ [] i = return Nothing+ findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)+ return (Just (Glob n))+ findVar acc (n : ns) i = findVar (n : acc) ns i++ -- Return variables in list which are used in the expression usedArg env n | n `elem` env = [n]@@ -204,9 +276,9 @@ usedIn env (LForce e) = usedIn env e usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e usedIn env (LLam ns e) = usedIn (env \\ ns) e-usedIn env (LCon i n args) = concatMap (usedIn env) args+usedIn env (LCon loc i n args) = concatMap (usedIn env) args usedIn env (LProj t i) = usedIn env t-usedIn env (LCase e alts) = usedIn env e ++ concatMap (usedInA env) alts+usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts where usedInA env (LConCase i n ns e) = usedIn env e usedInA env (LConstCase c e) = usedIn env e usedInA env (LDefaultCase e) = usedIn env e@@ -237,12 +309,17 @@ show' env ind (LProj t i) = show t ++ "!" ++ show i - show' env ind (LCon i n args)- = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"+ show' env ind (LCon loc i n args)+ = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"+ where atloc Nothing = ""+ atloc (Just l) = "@" ++ show (LV l) ++ ":" - show' env ind (LCase e alts)- = "case " ++ show' env ind e ++ " of \n" ++ fmt alts+ show' env ind (LCase up e alts)+ = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts where+ update = case up of+ Shared -> " "+ Updatable -> "! " fmt [] = "" fmt [alt] = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt
+ src/IRTS/LangOpts.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}++module IRTS.LangOpts where++import Control.Monad.State hiding (lift)+import Control.Applicative hiding (Const)++import IRTS.Lang+import Idris.Core.TT+import Idris.Core.CaseTree+import Data.List+import Debug.Trace++inlineAll :: [(Name, LDecl)] -> [(Name, LDecl)]+inlineAll lds = let defs = addAlist lds emptyContext in+ map (\ (n, def) -> (n, doInline defs def)) lds++nextN :: State Int Name+nextN = do i <- get+ put (i + 1)+ return $ sMN i "in"++-- Inline inside a declaration. Variables are still Name at this stage.+-- Need to preserve uniqueness of variable names in the resulting definition,+-- so invent a new name for every variable we encounter+doInline :: LDefs -> LDecl -> LDecl+doInline defs d@(LConstructor _ _ _) = d+doInline defs (LFun opts topn args exp) + = let res = evalState (inlineWith [topn] (map (\n -> (n, LV (Glob n))) args) exp) 0 in+ LFun opts topn args res+ where+ inlineWith :: [Name] -> [(Name, LExp)] -> LExp -> State Int LExp+ inlineWith done env var@(LV (Glob n)) + = case lookup n env of+ Just t -> return t+ Nothing -> return var+ inlineWith done env (LLazyApp n es) = LLazyApp n <$> (mapM (inlineWith done env) es)+ inlineWith done env (LForce e) = LForce <$> inlineWith done env e+ inlineWith done env (LLazyExp e) = LLazyExp <$> inlineWith done env e+ -- Extend the environment for Let and Lam so that bound names aren't+ -- expanded with any top level argument definitions they shadow+ inlineWith done env (LLet n val sc) + = do n' <- nextN+ LLet n' <$> inlineWith done env val <*>+ inlineWith done ((n, LV (Glob n')) : env) sc+ inlineWith done env (LLam args sc)+ = do ns' <- mapM (\n -> do n' <- nextN+ return (n, n')) args+ LLam (map snd ns') <$>+ inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) sc+ inlineWith done env (LProj exp i) = LProj <$> inlineWith done env exp <*> return i+ inlineWith done env (LCon loc i n es)+ = LCon loc i n <$> mapM (inlineWith done env) es+ inlineWith done env (LCase ty e alts) + = LCase ty <$> inlineWith done env e <*> mapM (inlineWithAlt done env) alts+ inlineWith done env (LOp f es) = LOp f <$> mapM (inlineWith done env) es+ -- the interesting case!+ inlineWith done env (LApp t (LV (Glob n)) es)+ | n `notElem` done,+ [LFun opts _ args body] <- lookupCtxt n defs,+ Inline `elem` opts,+ length es == length args+ = do es' <- mapM (inlineWith done env) es+ inlineWith (n : done) (zip args es' ++ env) body+ inlineWith done env (LApp t f es)+ = LApp t <$> inlineWith done env f <*> mapM (inlineWith done env) es+ inlineWith done env (LForeign l t s args)+ = LForeign l t s <$> mapM (\(t, e) -> do e' <- inlineWith done env e+ return (t, e')) args+ inlineWith done env t = return t++ inlineWithAlt done env (LConCase i n es rhs)+ = do ns' <- mapM (\n -> do n' <- nextN+ return (n, n')) es+ LConCase i n (map snd ns') <$> + inlineWith done (map (\ (n,n') -> (n, LV (Glob n'))) ns' ++ env) rhs+ inlineWithAlt done env (LConstCase c e) = LConstCase c <$> inlineWith done env e+ inlineWithAlt done env (LDefaultCase e) = LDefaultCase <$> inlineWith done env e+
src/IRTS/Simplified.hs view
@@ -1,7 +1,8 @@-module IRTS.Simplified where+module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where import IRTS.Defunctionalise import Idris.Core.TT+import Idris.Core.CaseTree import Idris.Core.Typecheck import Data.Maybe import Control.Monad.State@@ -15,8 +16,9 @@ | SApp Bool Name [LVar] | SLet LVar SExp SExp | SUpdate LVar SExp- | SCon Int Name [LVar]- | SCase LVar [SAlt]+ | SCon (Maybe LVar) -- location to reallocate, if available+ Int Name [LVar]+ | SCase CaseType LVar [SAlt] | SChkCase LVar [SAlt] | SProj LVar Int | SConst Const@@ -48,7 +50,7 @@ simplify tl (DV (Glob x)) = do ctxt <- ldefs case lookupCtxtExact x ctxt of- Just (DConstructor _ t 0) -> return $ SCon t x []+ Just (DConstructor _ t 0) -> return $ SCon Nothing t x [] _ -> return $ SV (Glob x) simplify tl (DApp tc n args) = do args' <- mapM sVar args mkapp (SApp (tl || tc) n) args'@@ -61,19 +63,19 @@ return (SLet (Glob n) v' e') simplify tl (DUpdate n e) = do e' <- simplify False e return (SUpdate (Glob n) e')-simplify tl (DC i n args) = do args' <- mapM sVar args- mkapp (SCon i n) args'+simplify tl (DC loc i n args) = do args' <- mapM sVar args+ mkapp (SCon loc i n) args' simplify tl (DProj t i) = do v <- sVar t case v of (x, Nothing) -> return (SProj x i) (Glob x, Just e) -> return (SLet (Glob x) e (SProj (Glob x) i))-simplify tl (DCase e alts) = do v <- sVar e- alts' <- mapM (sAlt tl) alts- case v of- (x, Nothing) -> return (SCase x alts')- (Glob x, Just e) ->- return (SLet (Glob x) e (SCase (Glob x) alts'))+simplify tl (DCase up e alts) = do v <- sVar e+ alts' <- mapM (sAlt tl) alts+ case v of+ (x, Nothing) -> return (SCase up x alts')+ (Glob x, Just e) ->+ return (SLet (Glob x) e (SCase up (Glob x) alts')) simplify tl (DChkCase e alts) = do v <- sVar e alts' <- mapM (sAlt tl) alts@@ -90,7 +92,7 @@ sVar (DV (Glob x)) = do ctxt <- ldefs case lookupCtxtExact x ctxt of- Just (DConstructor _ t 0) -> sVar (DC t x [])+ Just (DConstructor _ t 0) -> sVar (DC Nothing t x []) _ -> return (Glob x, Nothing) sVar (DV x) = return (x, Nothing) sVar e = do e' <- simplify False e@@ -118,15 +120,15 @@ sAlt tl (DDefaultCase e) = do e' <- simplify tl e return (SDefaultCase e') -checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]-checkDefs ctxt [] = return []-checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)- = do xs' <- checkDefs ctxt xs+simplifyDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]+simplifyDefs ctxt [] = return []+simplifyDefs ctxt (con@(n, DConstructor _ _ _) : xs)+ = do xs' <- simplifyDefs ctxt xs return xs'-checkDefs ctxt ((n, DFun n' args exp) : xs)+simplifyDefs ctxt ((n, DFun n' args exp) : xs) = do let sexp = evalState (simplify True exp) (ctxt, 0) (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)- xs' <- checkDefs ctxt xs+ xs' <- simplifyDefs ctxt xs return ((n, SFun n' args ((locs + 1) - length args) exp') : xs') lvar v = do i <- get@@ -142,7 +144,7 @@ Nothing -> case lookupCtxtExact n ctxt of Just (DConstructor _ i ar) -> if True -- ar == 0- then return (SCon i n [])+ then return (SCon Nothing i n []) else failsc $ "Constructor " ++ show n ++ " has arity " ++ show ar Just _ -> return (SV (Glob n))@@ -152,7 +154,7 @@ case lookupCtxtExact f ctxt of Just (DConstructor n tag ar) -> if True -- (ar == length args)- then return $ SCon tag n args'+ then return $ SCon Nothing tag n args' else failsc $ "Constructor " ++ show f ++ " has arity " ++ show ar Just _ -> return $ SApp tc f args'@@ -161,22 +163,26 @@ = do args' <- mapM (\ (t, a) -> do a' <- scVar env a return (t, a')) args return $ SForeign l ty f args'- sc env (SCon tag f args)- = do args' <- mapM (scVar env) args+ sc env (SCon loc tag f args)+ = do loc' <- case loc of+ Nothing -> return Nothing+ Just l -> do l' <- scVar env l+ return (Just l')+ args' <- mapM (scVar env) args case lookupCtxtExact f ctxt of Just (DConstructor n tag ar) -> if True -- (ar == length args)- then return $ SCon tag n args'+ then return $ SCon loc' tag n args' else failsc $ "Constructor " ++ show f ++ " has arity " ++ show ar _ -> failsc $ "No such constructor " ++ show f sc env (SProj e i) = do e' <- scVar env e return (SProj e' i)- sc env (SCase e alts)+ sc env (SCase up e alts) = do e' <- scVar env e alts' <- mapM (scalt env) alts- return (SCase e' alts')+ return (SCase up e' alts') sc env (SChkCase e alts) = do e' <- scVar env e alts' <- mapM (scalt env) alts
src/Idris/ASTUtils.hs view
@@ -38,6 +38,7 @@ import Prelude hiding (id, (.)) import Idris.Core.TT+import Idris.Core.Evaluate import Idris.AbsSyntaxTree data Field rec fld = Field@@ -132,3 +133,24 @@ opts_idrisCmdline = Field opt_cmdline (\v opts -> opts{ opt_cmdline = v }) . Field idris_options (\v ist -> ist{ idris_options = v })++-- TT Context+-------------+-- This has a terrible name, but I'm not sure of a better one that isn't+-- confusingly close to tt_ctxt+known_terms :: Field IState (Ctxt (Def, Accessibility, Totality, MetaInformation))+known_terms = Field (definitions . tt_ctxt)+ (\v state -> state {tt_ctxt = (tt_ctxt state) {definitions = v}})++known_classes :: Field IState (Ctxt ClassInfo)+known_classes = Field idris_classes (\v state -> state {idris_classes = idris_classes state})+++-- Names defined at the repl+----------------------------+repl_definitions :: Field IState [Name]+repl_definitions = Field idris_repl_defs (\v state -> state {idris_repl_defs = v})++-- Fixity declarations in an IState+idris_fixities :: Field IState [FixDecl]+idris_fixities = Field idris_infixes (\v state -> state {idris_infixes = v})
src/Idris/AbsSyntax.hs view
@@ -82,7 +82,17 @@ findDyLib (lib:libs) l | l == lib_name lib = Just lib | otherwise = findDyLib libs l +getAutoImports :: Idris [FilePath]+getAutoImports = do i <- getIState+ return (opt_autoImport (idris_options i)) +addAutoImport :: FilePath -> Idris ()+addAutoImport fp = do i <- getIState+ let opts = idris_options i+ let autoimps = opt_autoImport opts+ put (i { idris_options = opts { opt_autoImport =+ fp : opt_autoImport opts } } )+ addHdr :: Codegen -> String -> Idris () addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } @@ -122,6 +132,9 @@ setFlags :: Name -> [FnOpt] -> Idris () setFlags n fs = do i <- getIState; putIState $ i { idris_flags = addDef n fs (idris_flags i) } +setFnInfo :: Name -> FnInfo -> Idris ()+setFnInfo n fs = do i <- getIState; putIState $ i { idris_fninfo = addDef n fs (idris_fninfo i) }+ setAccessibility :: Name -> Accessibility -> Idris () setAccessibility n a = do i <- getIState@@ -215,7 +228,7 @@ (P (TCon _ _) n _, P (TCon _ _) n' _) -> errWhen (n/=n) (P (TCon _ _) n _, Constant _) -> errWhen True (Constant _, P (TCon _ _) n' _) -> errWhen True- (P (DCon _ _) n _, P (DCon _ _) n' _) -> errWhen (n/=n) + (P (DCon _ _ _) n _, P (DCon _ _ _) n' _) -> errWhen (n/=n) _ -> return () where errWhen True @@ -537,7 +550,7 @@ isetPrompt :: String -> Idris () isetPrompt p = do i <- getIState case idris_outputmode i of- IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n+ IdeSlave n h -> runIO . hPutStrLn h $ convSExp "set-prompt" p n -- | Tell clients how much was parsed and loaded isetLoadedRegion :: Idris ()@@ -546,8 +559,8 @@ case span of Just fc -> case idris_outputmode i of- IdeSlave n ->- runIO . putStrLn $+ IdeSlave n h ->+ runIO . hPutStrLn h $ convSExp "set-loaded-region" fc n Nothing -> return () @@ -662,10 +675,10 @@ outputTy = do i <- getIState return $ opt_outputTy $ idris_options i -setIdeSlave :: Bool -> Idris ()-setIdeSlave True = do i <- getIState- putIState $ i { idris_outputmode = (IdeSlave 0), idris_colourRepl = False }-setIdeSlave False = return ()+setIdeSlave :: Bool -> Handle -> Idris ()+setIdeSlave True h = do i <- getIState+ putIState $ i { idris_outputmode = (IdeSlave 0 h), idris_colourRepl = False }+setIdeSlave False _ = return () setTargetTriple :: String -> Idris () setTargetTriple t = do i <- getIState@@ -739,7 +752,7 @@ addImportDir :: FilePath -> Idris () addImportDir fp = do i <- getIState let opts = idris_options i- let opt' = opts { opt_importdirs = fp : opt_importdirs opts }+ let opt' = opts { opt_importdirs = nub $ fp : opt_importdirs opts } putIState $ i { idris_options = opt' } setImportDirs :: [FilePath] -> Idris ()@@ -761,10 +774,6 @@ setColourise b = do i <- getIState putIState $ i { idris_colourRepl = b } -setOutH :: Handle -> Idris ()-setOutH h = do i <- getIState- putIState $ i { idris_outh = h }- impShow :: Idris Bool impShow = do i <- getIState return (opt_showimp (idris_options i))@@ -793,10 +802,10 @@ let lvl = opt_logLevel (idris_options i) when (lvl >= l) $ case idris_outputmode i of- RawOutput -> do runIO $ putStrLn str- IdeSlave n ->+ RawOutput h -> do runIO $ hPutStrLn h str+ IdeSlave n h -> do let good = SexpList [IntegerAtom (toInteger l), toSExp str]- runIO $ putStrLn $ convSExp "log" good n+ runIO . hPutStrLn h $ convSExp "log" good n cmdOptType :: Opt -> Idris Bool cmdOptType x = do i <- getIState@@ -1017,7 +1026,7 @@ where pri (PRef _ n) = case lookupP n (tt_ctxt i) of- ((P (DCon _ _) _ _):_) -> 1+ ((P (DCon _ _ _) _ _):_) -> 1 ((P (TCon _ _) _ _):_) -> 1 ((P Ref _ _):_) -> 1 [] -> 0 -- must be locally bound, if it's not an error...@@ -1056,7 +1065,7 @@ putIState $ i { idris_statics = addDef n stpos (idris_statics i) } addIBC (IBCStatic n) where- initStatics (Bind n (Pi ty) sc) (PPi p _ _ s)+ initStatics (Bind n (Pi ty _) sc) (PPi p _ _ s) = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in if pstatic p == Static then ((n, ty) : static, dynamic) else if (not (searchArg p)) @@ -1064,7 +1073,7 @@ else (static, dynamic) initStatics t pt = ([], []) - freeArgNames (Bind n (Pi ty) sc) + freeArgNames (Bind n (Pi ty _) sc) = nub $ freeArgNames ty freeArgNames tm = let (_, args) = unApply tm in concatMap freeNames args@@ -1076,7 +1085,7 @@ searchArg (TacImp _ _ _) = True searchArg _ = False - staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc+ staticList sts (Bind n (Pi _ _) sc) = (n `elem` sts) : staticList sts sc staticList _ _ = [] -- Dealing with implicit arguments@@ -1172,22 +1181,29 @@ -- status of each pi-bound argument, and whether it's inaccessible (True) or not. getUnboundImplicits :: IState -> Type -> PTerm -> [(Bool, PArg)]-getUnboundImplicits i (Bind n (Pi t) sc) (PPi p n' t' sc')- | n == n' = argInfo n p : getUnboundImplicits i sc sc'- where- argInfo n (Imp opt _ _) = (True, PImp (getPriority i t') True opt n t')- argInfo n (Exp opt _ _) = (InaccessibleArg `elem` opt,- PExp (getPriority i t') opt n t')- argInfo n (Constraint opt _) = (InaccessibleArg `elem` opt,- PConstraint 10 opt n t')- argInfo n (TacImp opt _ scr) = (InaccessibleArg `elem` opt,- PTacImplicit 10 opt n scr t')-getUnboundImplicits i (Bind n (Pi t) sc) tm- = impBind n t : getUnboundImplicits i sc tm- where- impBind n t = (True, PImp 1 True [] n Placeholder)-getUnboundImplicits i sc tm = []+getUnboundImplicits i t tm = getImps t (collectImps tm)+ where collectImps (PPi p n t sc)+ = (n, (p, t)) : collectImps sc+ collectImps _ = [] + getImps (Bind n (Pi t _) sc) imps+ | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps+ where+ argInfo n (Imp opt _ _) t' + = (True, PImp (getPriority i t') True opt n t')+ argInfo n (Exp opt _ _) t'+ = (InaccessibleArg `elem` opt,+ PExp (getPriority i t') opt n t')+ argInfo n (Constraint opt _) t' + = (InaccessibleArg `elem` opt,+ PConstraint 10 opt n t')+ argInfo n (TacImp opt _ scr) t' + = (InaccessibleArg `elem` opt,+ PTacImplicit 10 opt n scr t')+ getImps (Bind n (Pi t _) sc) imps = impBind n t : getImps sc imps+ where impBind n t = (True, PImp 1 True [] n Placeholder)+ getImps sc tm = []+ -- Add implicit Pi bindings for any names in the term which appear in an -- argument position. @@ -1458,7 +1474,7 @@ imp _ = True -- allImp [] = False allImp xs = all imp xs- constructor (TyDecl (DCon _ _) _) = True+ constructor (TyDecl (DCon _ _ _) _) = True constructor _ = False conCaf ctxt (n, cia) = (isDConName n ctxt || (qq && isTConName n ctxt)) && allImp cia@@ -1596,7 +1612,7 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where su :: PTerm -> PTerm su (PRef fc f)- | (Bind n (Pi t) sc :_) <- lookupTy f (tt_ctxt i) + | (Bind n (Pi t _) sc :_) <- lookupTy f (tt_ctxt i) = Placeholder su (PApp fc fn args) = PApp fc fn (fmap (fmap su) args)
src/Idris/AbsSyntaxTree.hs view
@@ -76,7 +76,8 @@ opt_optLevel :: Word, opt_cmdline :: [Opt], -- remember whole command line opt_origerr :: Bool,- opt_autoSolve :: Bool -- ^ automatically apply "solve" tactic in prover+ opt_autoSolve :: Bool, -- ^ automatically apply "solve" tactic in prover+ opt_autoImport :: [FilePath] -- ^ e.g. Builtins+Prelude } deriving (Show, Eq) @@ -90,7 +91,7 @@ , opt_verbose = True , opt_nobanner = False , opt_quiet = False- , opt_codegen = ViaC+ , opt_codegen = Via "c" , opt_outputTy = Executable , opt_ibcsubdir = "" , opt_importdirs = []@@ -100,6 +101,7 @@ , opt_cmdline = [] , opt_origerr = False , opt_autoSolve = True+ , opt_autoImport = [] } data PPOption = PPOption {@@ -127,7 +129,9 @@ data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord) -- | The output mode in use-data OutputMode = RawOutput | IdeSlave Integer deriving Show+data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle+ | IdeSlave Integer Handle -- ^ Send IDE output for some request ID to the handle+ deriving Show -- | How wide is the console? data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines should not be broken@@ -154,6 +158,7 @@ idris_calledgraph :: Ctxt [Name], idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]), idris_tyinfodata :: Ctxt TIData,+ idris_fninfo :: Ctxt FnInfo, idris_totcheck :: [(FC, Name)], -- names to check totality on idris_defertotcheck :: [(FC, Name)], -- names to check at the end idris_totcheckfail :: [(FC, String)],@@ -192,7 +197,6 @@ idris_outputmode :: OutputMode, idris_colourRepl :: Bool, idris_colourTheme :: ColourTheme,- idris_outh :: Handle, idris_errorhandlers :: [Name], -- ^ Global error handlers idris_nameIdx :: (Int, Ctxt (Int, Name)), idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers@@ -200,7 +204,8 @@ idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console? idris_postulates :: S.Set Name, idris_whocalls :: Maybe (M.Map Name [Name]),- idris_callswho :: Maybe (M.Map Name [Name])+ idris_callswho :: Maybe (M.Map Name [Name]),+ idris_repl_defs :: [Name] -- ^ List of names that were defined in the repl, and can be re-/un-defined } -- Required for parsers library, and therefore trifecta@@ -246,6 +251,7 @@ | IBCSyntax Syntax | IBCKeyword String | IBCImport FilePath+ | IBCImportDir FilePath | IBCObj Codegen FilePath | IBCLib Codegen String | IBCCGFlag Codegen String@@ -255,6 +261,7 @@ | IBCMetaInformation Name MetaInformation | IBCTotal Name Totality | IBCFlags Name [FnOpt]+ | IBCFnInfo Name FnInfo | IBCTrans (Term, Term) | IBCErrRev (Term, Term) | IBCCG Name@@ -275,11 +282,11 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext- emptyContext emptyContext+ emptyContext emptyContext emptyContext [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []- [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] RawOutput- True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty- AutomaticWidth S.empty Nothing Nothing+ [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []+ (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty+ AutomaticWidth S.empty Nothing Nothing [] -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad).@@ -288,11 +295,12 @@ -- Commands in the REPL -data Codegen = ViaC- | ViaJava- | ViaNode- | ViaJavaScript- | ViaLLVM+data Codegen = Via String+-- | ViaC+-- | ViaJava+-- | ViaNode+-- | ViaJavaScript+-- | ViaLLVM | Bytecode deriving (Show, Eq) @@ -301,6 +309,7 @@ | Help | Eval PTerm | NewDefn [PDecl] -- ^ Each 'PDecl' should be either a type declaration (at most one) or a clause defining the same name.+ | Undefine [Name] | Check PTerm | DocStr (Either Name Const) | TotCheck Name@@ -358,6 +367,7 @@ | NoBanner | ColourREPL Bool | Ideslave+ | IdeslaveSocket | ShowLibs | ShowLibdir | ShowIncs@@ -476,11 +486,13 @@ | Dictionary -- type class dictionary, eval only when -- a function argument, and further evaluation resutls | Implicit -- implicit coercion+ | NoImplicit -- do not apply implicit coercions | CExport String -- export, with a C name | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension | ErrorReverse -- ^^ attempt to reverse normalise before showing in error | Reflection -- a reflecting function, compile-time only | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names+ | Constructor -- Data constructor type deriving (Show, Eq) {-! deriving instance Binary FnOpt@@ -701,6 +713,7 @@ | PAlternative Bool [PTerm] -- True if only one may work | PHidden PTerm -- ^ Irrelevant or hidden pattern | PType -- ^ 'Type' type+ | PUniverse Universe -- ^ Some universe | PGoal FC PTerm Name PTerm | PConstant Const -- ^ Builtin types | Placeholder@@ -896,6 +909,13 @@ | TISolution [Term] -- ^ possible solutions to a metavariable in a type deriving Show +-- | Miscellaneous information about functions+data FnInfo = FnInfo { fn_params :: [Int] }+ deriving Show+{-!+deriving instance Binary FnInfo+!-}+ data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting detaggable :: Bool } deriving Show@@ -1030,7 +1050,7 @@ getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc- where toTy (Lam t) = Pi t+ where toTy (Lam t) = Pi t (TType (UVar 0)) toTy (PVar t) = PVTy t toTy b = b getInferType (App (App _ ty) _) = ty@@ -1361,6 +1381,7 @@ prettyAs = foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"+ prettySe p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u) prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c)) -- XXX: add pretty for tactics prettySe p bnd (PProof ts) =@@ -1625,6 +1646,7 @@ size (PDisamb _ tm) = size tm size (PNoImplicits tm) = size tm size PType = 1+ size (PUniverse _) = 1 size (PConstant const) = 1 + size const size Placeholder = 1 size (PDoBlock dos) = 1 + size dos@@ -1634,6 +1656,7 @@ size (PProof tactics) = size tactics size (PElabError err) = size err size PImpossible = 1+ size _ = 0 getPArity :: PTerm -> Int getPArity (PPi _ _ _ sc) = 1 + getPArity sc@@ -1713,7 +1736,7 @@ (nub (concatMap (ni env) (map snd os)) \\ nub (concatMap (ni env) (map fst os))) ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc- ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc+ ni env (PPi p n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r ni env (PTyped l r) = ni env l ++ ni env r@@ -1726,9 +1749,6 @@ ni env (PDisamb _ tm) = ni env tm ni env (PNoImplicits tm) = ni env tm ni env _ = []-- niTacImp env (TacImp _ _ scr) = ni env scr- niTacImp _ _ = [] -- Return names which are free in the given term. namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]
src/Idris/Apropos.hs view
@@ -53,7 +53,7 @@ instance Apropos (Binder (TT Name)) where isApropos str (Lam ty) = str == T.pack "\\" || isApropos str ty- isApropos str (Pi ty) = str == T.pack "->" || isApropos str ty+ isApropos str (Pi ty _) = str == T.pack "->" || isApropos str ty isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str _ = False -- these shouldn't occur in defined libraries@@ -61,7 +61,7 @@ instance Apropos (TT Name) where isApropos str (P Ref n ty) = isApropos str n || isApropos str ty isApropos str (P (TCon _ _) n ty) = isApropos str n || isApropos str ty- isApropos str (P (DCon _ _) n ty) = isApropos str n || isApropos str ty+ isApropos str (P (DCon _ _ _) n ty) = isApropos str n || isApropos str ty isApropos str (P Bound _ ty) = isApropos str ty isApropos str (Bind n b tm) = isApropos str b || isApropos str tm isApropos str (App t1 t2) = isApropos str t1 || isApropos str t2
src/Idris/CaseSplit.hs view
@@ -176,7 +176,7 @@ = case lookupTy n (tt_ctxt ist) of [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing _ -> repeat Nothing- where tyName (Bind _ (Pi _) _) = Just (sUN "->")+ where tyName (Bind _ (Pi _ _) _) = Just (sUN "->") tyName t | (P _ n _, _) <- unApply t = Just n | otherwise = Nothing argTys _ _ = repeat Nothing@@ -297,6 +297,7 @@ updatePat start n tm ('{':rest) = let (space, rest') = span isSpace rest in '{' : space ++ updatePat False n tm rest'+ updatePat start n tm done@('?':rest) = done updatePat True n tm xs@(c:rest) | length xs > length n = let (before, after@(next:_)) = splitAt (length n) xs in if (before == n && not (isAlphaNum next))
src/Idris/CmdOptions.hs view
@@ -8,6 +8,7 @@ import Options.Applicative import Options.Applicative.Arrows+import Data.Char import Data.Maybe import qualified Text.PrettyPrint.ANSI.Leijen as PP@@ -71,12 +72,13 @@ flag' NoBanner (long "nobanner" <> help "Suppress the banner") <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity") <|> flag' Ideslave (long "ideslave")+ <|> flag' IdeslaveSocket (long "ideslave-socket") <|> (Client <$> strOption (long "client")) <|> (OLogging <$> option (long "log" <> metavar "LEVEL" <> help "Debugging log level")) <|> flag' NoBasePkgs (long "nobasepkgs") <|> flag' NoPrelude (long "noprelude") <|> flag' NoBuiltins (long "nobuiltins")- <|> flag' NoREPL (long "check")+ <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL") <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file")) <|> flag' TypeCase (long "typecase") <|> flag' TypeInType (long "typeintype")@@ -140,10 +142,6 @@ preProcOpts (x:xs) ys = preProcOpts xs (x:ys) parseCodegen :: String -> Codegen-parseCodegen "C" = ViaC-parseCodegen "Java" = ViaJava parseCodegen "bytecode" = Bytecode-parseCodegen "javascript" = ViaJavaScript-parseCodegen "node" = ViaNode-parseCodegen "llvm" = ViaLLVM-parseCodegen _ = error "unknown codegen" -- FIXME: partial function+parseCodegen cg = Via (map toLower cg)+
src/Idris/Completion.hs view
@@ -168,6 +168,10 @@ completeArg ColourArg = completeColour (prev, next) completeArg NoArg = noCompletion (prev, next) completeArg ConsoleWidthArg = completeConsoleWidth (prev, next)+ completeArg DeclArg = completeExpr [] (prev, next)+ completeArg (ManyArgs a) = completeArg a+ completeArg (OptionalArg a) = completeArg a+ completeArg (SeqArgs a b) = completeArg a completeCmdName = return $ ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers
src/Idris/Core/Binary.hs view
@@ -78,6 +78,9 @@ CaseN x1 -> do putWord8 4; put x1 ElimN x1 -> do putWord8 5; put x1 InstanceCtorN x1 -> do putWord8 6; put x1+ WithN x1 x2 -> do putWord8 7+ put x1+ put x2 get = do i <- getWord8 case i of@@ -99,6 +102,9 @@ return (ElimN x1) 6 -> do x1 <- get return (InstanceCtorN x1)+ 7 -> do x1 <- get+ x2 <- get+ return (WithN x1 x2) _ -> error "Corrupted binary data for SpecialName" @@ -227,8 +233,9 @@ = case x of Lam x1 -> do putWord8 0 put x1- Pi x1 -> do putWord8 1- put x1+ Pi x1 x2 -> do putWord8 1+ put x1+ put x2 Let x1 x2 -> do putWord8 2 put x1 put x2@@ -253,7 +260,8 @@ 0 -> do x1 <- get return (Lam x1) 1 -> do x1 <- get- return (Pi x1)+ x2 <- get+ return (Pi x1 x2) 2 -> do x1 <- get x2 <- get return (Let x1 x2)@@ -275,13 +283,26 @@ _ -> error "Corrupted binary data for Binder" +instance Binary Universe where+ put x = case x of+ UniqueType -> putWord8 0+ AllTypes -> putWord8 1+ NullType -> putWord8 2+ get = do i <- getWord8+ case i of+ 0 -> return UniqueType+ 1 -> return AllTypes+ 2 -> return NullType+ _ -> error "Corrupted binary data for Universe"+ instance Binary NameType where put x = case x of Bound -> putWord8 0 Ref -> putWord8 1- DCon x1 x2 -> do putWord8 2- put (x1 * 65536 + x2)+ DCon x1 x2 x3 -> do putWord8 2+ put (x1 * 65536 + x2)+ put x3 TCon x1 x2 -> do putWord8 3 put (x1 * 65536 + x2) get@@ -290,7 +311,8 @@ 0 -> return Bound 1 -> return Ref 2 -> do x1x2 <- get- return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536))+ x3 <- get+ return (DCon (x1x2 `div` 65536) (x1x2 `mod` 65536) x3) 3 -> do x1x2 <- get return (TCon (x1x2 `div` 65536) (x1x2 `mod` 65536)) _ -> error "Corrupted binary data for NameType"@@ -325,6 +347,8 @@ TType x1 -> do putWord8 7 put x1 Impossible -> putWord8 8+ UType x1 -> do putWord8 10+ put x1 get = do i <- getWord8 case i of@@ -352,5 +376,7 @@ 8 -> return Impossible 9 -> do x1 <- get return (V x1)+ 10 -> do x1 <- get+ return (UType x1) _ -> error "Corrupted binary data for TT"
src/Idris/Core/CaseTree.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), ErasureInfo,- Phase(..), CaseTree,+ Phase(..), CaseTree, CaseType(..), simpleCase, small, namesUsed, findCalls, findUsedArgs, substSC, substAlt, mkForce) where @@ -30,7 +30,7 @@ -- allows casing on arbitrary terms, here we choose to maintain the distinction -- in order to allow for better optimisation opportunities. ---data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first+data SC' t = Case CaseType Name [CaseAlt' t] -- ^ invariant: lowest tags first | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection | STerm !t | UnmatchedCase String -- ^ error message@@ -41,6 +41,9 @@ deriving instance NFData SC' !-} +data CaseType = Updatable | Shared + deriving (Eq, Ord, Show)+ type SC = SC' Term data CaseAlt' t = ConCase Name Int [Name] !(SC' t)@@ -59,8 +62,11 @@ instance Show t => Show (SC' t) where show sc = show' 1 sc where- show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i +++ show' i (Case up n alts) = "case" ++ u ++ show n ++ " of\n" ++ indent i ++ showSep ("\n" ++ indent i) (map (showA i) alts)+ where u = case up of+ Updatable -> "! "+ Shared -> " " show' i (ProjCase tm alts) = "case " ++ show tm ++ " of " ++ showSep ("\n" ++ indent i) (map (showA i) alts) show' i (STerm tm) = show tm@@ -88,7 +94,7 @@ type CS = ([Term], Int, [(Name, Type)]) instance TermSize SC where- termsize n (Case n' as) = termsize n as+ termsize n (Case _ n' as) = termsize n as termsize n (ProjCase n' as) = termsize n as termsize n (STerm t) = termsize n t termsize n _ = 1@@ -111,7 +117,7 @@ namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where- nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]+ nu' ps (Case _ n alts) = nub (concatMap (nua ps) alts) \\ [n] nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts nu' ps (STerm t) = nub $ nut ps t nu' ps _ = []@@ -136,7 +142,7 @@ findCalls :: SC -> [Name] -> [(Name, [[Name]])] findCalls sc topargs = nub $ nu' topargs sc where- nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)+ nu' ps (Case _ n alts) = nub (concatMap (nua (n : ps)) alts) nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts nu' ps (STerm t) = nub $ nut ps t nu' ps _ = []@@ -189,7 +195,7 @@ findUsedArgs sc topargs = nub (findAllUsedArgs sc topargs) findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where- nu' (Case n alts) = n : concatMap nua alts+ nu' (Case _ n alts) = n : concatMap nua alts nu' (ProjCase t alts) = directUse t ++ concatMap nua alts nu' (STerm t) = directUse t nu' _ = []@@ -204,7 +210,7 @@ isUsed :: SC -> Name -> Bool isUsed sc n = used sc where - used (Case n' alts) = n == n' || or (map usedA alts)+ used (Case _ n' alts) = n == n' || or (map usedA alts) used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts) used (STerm t) = n `elem` freeNames t used _ = False@@ -276,7 +282,7 @@ acc [] n = Error (Inaccessible n) acc (PV x t : xs) n | x == n = OK ()- acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n+ acc (PCon _ _ _ ps : xs) n = acc (ps ++ xs) n acc (PSuc p : xs) n = acc (p : xs) n acc (_ : xs) n = acc xs n @@ -285,7 +291,7 @@ -- going on). checkSameTypes :: [(Name, Type)] -> SC -> Bool-checkSameTypes tys (Case n alts)+checkSameTypes tys (Case _ n alts) = case lookup n tys of Just t -> and (map (checkAlts t) alts) _ -> and (map ((checkSameTypes tys).getSC) alts)@@ -324,7 +330,7 @@ isConstType (B64V _) (AType (ATInt _)) = True isConstType _ _ = False -data Pat = PCon Name Int [Pat]+data Pat = PCon Bool Name Int [Pat] | PConst Const | PV Name Type | PSuc Pat -- special case for n+1 on Integer@@ -344,34 +350,24 @@ toPat :: Bool -> Bool -> [Term] -> [Pat] toPat reflect tc = map $ toPat' [] where- toPat' [_,_,arg](P (DCon t a) nm@(UN n) _)+ toPat' [_,_,arg] (P (DCon t a uniq) nm@(UN n) _) | n == txt "Delay"- = PCon nm t [PAny, PAny, toPat' [] arg]+ = PCon uniq nm t [PAny, PAny, toPat' [] arg] - toPat' args (P (DCon t a) n _)- = PCon n t $ map (toPat' []) args+ toPat' args (P (DCon t a uniq) nm@(NS (UN n) [own]) _)+ | n == txt "Read" && own == txt "Ownership"+ = PCon False nm t (map shareCons (map (toPat' []) args))+ where shareCons (PCon _ n i ps) = PCon False n i (map shareCons ps)+ shareCons p = p + toPat' args (P (DCon t a uniq) n _)+ = PCon uniq n t $ map (toPat' []) args+ -- n + 1 toPat' [p, Constant (BI 1)] (P _ (UN pabi) _) | pabi == txt "prim__addBigInt" = PSuc $ toPat' [] p - -- Typecase--- toPat' (P (TCon t a) n _) args | tc--- = do args' <- mapM (\x -> toPat' x []) args--- return $ PCon n t args'--- toPat' (Constant (AType (ATInt ITNative))) []--- | tc = return $ PCon (UN "Int") 1 []--- toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 []--- toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 []--- toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []--- toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []--- toPat' (Constant (AType (ATInt ITBig))) []--- | tc = return $ PCon (UN "Integer") 6 []--- toPat' (Constant (AType (ATInt (ITFixed n)))) []--- | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive---- toPat' [] (P Bound n ty) = PV n ty toPat' args (App f a) = toPat' (a : args) f toPat' [] (Constant (AType _)) = PTyPat@@ -380,7 +376,7 @@ toPat' [] (Constant VoidType) = PTyPat toPat' [] (Constant x) = PConst x - toPat' [] (Bind n (Pi t) sc)+ toPat' [] (Bind n (Pi t _) sc) | reflect && noOccurrence n sc = PReflected (sUN "->") [toPat' [] t, toPat' [] sc] @@ -405,7 +401,7 @@ isVarPat (PTyPat : ps , _) = True isVarPat _ = False -isConPat (PCon _ _ _ : ps, _) = True+isConPat (PCon _ _ _ _ : ps, _) = True isConPat (PReflected _ _ : ps, _) = True isConPat (PSuc _ : ps, _) = True isConPat (PConst _ : ps, _) = True@@ -449,18 +445,18 @@ noClash [] = True noClash (p : ps) = not (any (clashPat p) ps) && noClash ps - clashPat (PCon _ _ _) (PConst _) = True- clashPat (PConst _) (PCon _ _ _) = True- clashPat (PCon _ _ _) (PSuc _) = True- clashPat (PSuc _) (PCon _ _ _) = True- clashPat (PCon n i _) (PCon n' i' _) | i == i' = n /= n'+ clashPat (PCon _ _ _ _) (PConst _) = True+ clashPat (PConst _) (PCon _ _ _ _) = True+ clashPat (PCon _ _ _ _) (PSuc _) = True+ clashPat (PSuc _) (PCon _ _ _ _) = True+ clashPat (PCon _ n i _) (PCon _ n' i' _) | i == i' = n /= n' clashPat _ _ = False -- this compares (+isInaccessible, -numberOfCases) moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys)) (snd . fst . head $ ys, numNames [] (map snd xs)) - numNames xs (PCon n _ _ : ps)+ numNames xs (PCon _ n _ _ : ps) | not (Left n `elem` xs) = numNames (Left n : xs) ps numNames xs (PConst c : ps) | not (Right c `elem` xs) = numNames (Right c : xs) ps@@ -497,7 +493,8 @@ | CConst Const -- constant, not implemented yet deriving (Show, Eq) -data Group = ConGroup ConType -- Constructor+data Group = ConGroup Bool -- Uniqueness flag+ ConType -- Constructor [([Pat], Clause)] -- arguments and rest of alternative deriving Show @@ -507,26 +504,30 @@ caseGroups :: [Name] -> [Group] -> SC -> CaseBuilder SC caseGroups (v:vs) gs err = do g <- altGroups gs- return $ Case v (sort g)+ return $ Case (getShared gs) v (sort g) where+ getShared (ConGroup True _ _ : _) = Updatable+ getShared _ = Shared+ altGroups [] = return [DefaultCase err] - altGroups (ConGroup (CName n i) args : cs)+ altGroups (ConGroup _ (CName n i) args : cs) = (:) <$> altGroup n i args <*> altGroups cs - altGroups (ConGroup (CFn n) args : cs)+ altGroups (ConGroup _ (CFn n) args : cs) = (:) <$> altFnGroup n args <*> altGroups cs - altGroups (ConGroup CSuc args : cs)+ altGroups (ConGroup _ CSuc args : cs) = (:) <$> altSucGroup args <*> altGroups cs - altGroups (ConGroup (CConst c) args : cs)+ altGroups (ConGroup _ (CConst c) args : cs) = (:) <$> altConstGroup c args <*> altGroups cs - altGroup n i args = do inacc <- inaccessibleArgs n- (newVars, accVars, inaccVars, nextCs) <- argsToAlt inacc args- matchCs <- match (accVars ++ vs ++ inaccVars) nextCs err- return $ ConCase n i newVars matchCs+ altGroup n i args + = do inacc <- inaccessibleArgs n+ (newVars, accVars, inaccVars, nextCs) <- argsToAlt inacc args+ matchCs <- match (accVars ++ vs ++ inaccVars) nextCs err+ return $ ConCase n i newVars matchCs altFnGroup n args = do (newVars, _, [], nextCs) <- argsToAlt [] args matchCs <- match (newVars ++ vs) nextCs err@@ -601,21 +602,21 @@ do acc' <- addGroup p ps res acc gc acc' cs addGroup p ps res acc = case p of- PCon con i args -> return $ addg (CName con i) args (ps, res) acc+ PCon uniq con i args -> return $ addg uniq (CName con i) args (ps, res) acc PConst cval -> return $ addConG cval (ps, res) acc- PSuc n -> return $ addg CSuc [n] (ps, res) acc- PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc+ PSuc n -> return $ addg False CSuc [n] (ps, res) acc+ PReflected fn args -> return $ addg False (CFn fn) args (ps, res) acc pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)" - addg c conargs res []- = [ConGroup c [(conargs, res)]]- addg c conargs res (g@(ConGroup c' cs):gs)- | c == c' = ConGroup c (cs ++ [(conargs, res)]) : gs- | otherwise = g : addg c conargs res gs+ addg uniq c conargs res []+ = [ConGroup uniq c [(conargs, res)]]+ addg uniq c conargs res (g@(ConGroup _ c' cs):gs)+ | c == c' = ConGroup uniq c (cs ++ [(conargs, res)]) : gs+ | otherwise = g : addg uniq c conargs res gs - addConG con res [] = [ConGroup (CConst con) [([], res)]]- addConG con res (g@(ConGroup (CConst n) cs) : gs)- | con == n = ConGroup (CConst n) (cs ++ [([], res)]) : gs+ addConG con res [] = [ConGroup False (CConst con) [([], res)]]+ addConG con res (g@(ConGroup False (CConst n) cs) : gs)+ | con == n = ConGroup False (CConst n) (cs ++ [([], res)]) : gs -- | otherwise = g : addConG con res gs addConG con res (g : gs) = g : addConG con res gs @@ -637,7 +638,7 @@ depatt ns tm = dp [] tm where dp ms (STerm tm) = STerm (applyMaps ms tm)- dp ms (Case x alts) = Case x (map (dpa ms x) alts)+ dp ms (Case up x alts) = Case up x (map (dpa ms x) alts) dp ms sc = sc dpa ms x (ConCase n i args sc)@@ -667,7 +668,7 @@ -- FIXME: Do this for SucCase too prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) -> SC -> SC-prune proj (Case n alts) = case alts' of+prune proj (Case up n alts) = case alts' of [] -> ImpossibleCase -- Projection transformations prevent us from seeing some uses of ctor fields@@ -689,7 +690,7 @@ as@[ConCase cn i args sc] | proj -> let sc' = prune proj sc in if any (isUsed sc') args - then Case n [ConCase cn i args sc']+ then Case up n [ConCase cn i args sc'] else sc' [SucCase cn sc]@@ -702,9 +703,9 @@ -- Bit of a hack here! The default case will always be 0, make sure -- it gets caught first. [s@(SucCase _ _), DefaultCase dc]- -> Case n [ConstCase (BI 0) dc, s]+ -> Case up n [ConstCase (BI 0) dc, s] - as -> Case n as+ as -> Case up n as where alts' = filter (not . erased) $ map pruneAlt alts @@ -719,10 +720,10 @@ erased _ = False projRep :: Name -> Name -> Int -> SC -> SC- projRep arg n i (Case x alts) | x == arg+ projRep arg n i (Case up x alts) | x == arg = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts- projRep arg n i (Case x alts)- = Case x (map (projRepAlt arg n i) alts)+ projRep arg n i (Case up x alts)+ = Case up x (map (projRepAlt arg n i) alts) projRep arg n i (ProjCase t alts) = ProjCase (projRepTm arg n i t) $ map (projRepAlt arg n i) alts projRep arg n i (STerm t) = STerm (projRepTm arg n i t)@@ -749,9 +750,9 @@ stripLambdas x = x substSC :: Name -> Name -> SC -> SC-substSC n repl (Case n' alts)- | n == n' = Case repl (map (substAlt n repl) alts)- | otherwise = Case n' (map (substAlt n repl) alts)+substSC n repl (Case up n' alts)+ | n == n' = Case up repl (map (substAlt n repl) alts)+ | otherwise = Case up n' (map (substAlt n repl) alts) substSC n repl (STerm t) = STerm $ subst n (P Bound repl Erased) t substSC n repl (UnmatchedCase errmsg) = UnmatchedCase errmsg substSC n repl ImpossibleCase = ImpossibleCase@@ -771,11 +772,11 @@ mkForce :: Name -> Name -> SC -> SC mkForce = mkForceSC where- mkForceSC n arg (Case x alts) | x == arg- = Case n $ map (mkForceAlt n arg) alts+ mkForceSC n arg (Case up x alts) | x == arg+ = Case up n $ map (mkForceAlt n arg) alts - mkForceSC n arg (Case x alts)- = Case x (map (mkForceAlt n arg) alts)+ mkForceSC n arg (Case up x alts)+ = Case up x (map (mkForceAlt n arg) alts) mkForceSC n arg (ProjCase t alts) = ProjCase t $ map (mkForceAlt n arg) alts
src/Idris/Core/DeepSeq.hs view
@@ -14,6 +14,7 @@ instance NFData SpecialName where rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+ rnf (WithN x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (MethodN x1) = rnf x1 `seq` ()@@ -69,7 +70,7 @@ instance (NFData b) => NFData (Binder b) where rnf (Lam x1) = rnf x1 `seq` ()- rnf (Pi x1) = rnf x1 `seq` ()+ rnf (Pi x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Hole x1) = rnf x1 `seq` ()@@ -85,7 +86,7 @@ instance NFData NameType where rnf Bound = () rnf Ref = ()- rnf (DCon x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (DCon x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () instance (NFData n) => NFData (TT n) where@@ -98,9 +99,10 @@ rnf Erased = () rnf Impossible = () rnf (TType x1) = rnf x1 `seq` ()+ rnf (UType _) = () instance (NFData t) => NFData (SC' t) where- rnf (Case x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Case _ x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (ProjCase x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (STerm x1) = rnf x1 `seq` () rnf (UnmatchedCase x1) = rnf x1 `seq` ()
src/Idris/Core/Elaborate.hs view
@@ -12,6 +12,8 @@ module Idris.Core.ProofState) where import Idris.Core.ProofState+import Idris.Core.ProofTerm(bound_in, getProofTerm, mkProofTerm, bound_in_term,+ refocus) import Idris.Core.TT import Idris.Core.Evaluate import Idris.Core.Typecheck@@ -128,10 +130,6 @@ (a, ES ps' str _) <- runElab d elab ps return $! (a, str) -force_term :: Elab' aux ()-force_term = do ES (ps, a) l p <- get- put (ES (ps { pterm = force (pterm ps) }, a) l p)- -- | Modify the auxiliary state updateAux :: (aux -> aux) -> Elab' aux () updateAux f = do ES (ps, a) l p <- get@@ -190,12 +188,12 @@ -- get the proof term get_term :: Elab' aux Term get_term = do ES p _ _ <- get- return $! (pterm (fst p))+ return $! (getProofTerm (pterm (fst p))) -- get the proof term update_term :: (Term -> Term) -> Elab' aux () update_term f = do ES (p,a) logs prev <- get- let p' = p { pterm = f (pterm p) }+ let p' = p { pterm = mkProofTerm (f (getProofTerm (pterm p))) } put (ES (p', a) logs prev) -- get the local context at the currently in focus hole@@ -256,7 +254,7 @@ isInj ctxt (App f a) = isInj ctxt f isInj ctxt (Constant _) = True isInj ctxt (TType _) = True- isInj ctxt (Bind _ (Pi _) sc) = True+ isInj ctxt (Bind _ (Pi _ _) sc) = True isInj ctxt _ = False -- get instance argument names@@ -271,7 +269,7 @@ unique_hole' reusable n = do ES p _ _ <- get let bs = bound_in (pterm (fst p)) ++- bound_in (ptype (fst p))+ bound_in_term (ptype (fst p)) let nouse = holes (fst p) ++ bs ++ dontunify (fst p) ++ usedns (fst p) n' <- return $! uniqueNameCtxt (context (fst p)) n nouse ES (p, a) s u <- get@@ -280,14 +278,6 @@ put (ES (p { nextname = i + 1 }, a) s u) _ -> return $! () return $! n'- where- bound_in (Bind n b sc) = n : bi b ++ bound_in sc- where- bi (Let t v) = bound_in t ++ bound_in v- bi (Guess t v) = bound_in t ++ bound_in v- bi b = bound_in (binderTy b)- bound_in (App f a) = bound_in f ++ bound_in a- bound_in _ = [] elog :: String -> Elab' aux () elog str = do ES p logs prev <- get@@ -401,15 +391,22 @@ movelast :: Name -> Elab' aux () movelast n = processTactic' (MoveLast n) +-- | Set the zipper in the proof state to point at the current sub term+-- (This currently happens automatically, so this will have no effect...)+zipHere :: Elab' aux ()+zipHere = do ES (ps, a) s m <- get+ let pt' = refocus (Just (head (holes ps))) (pterm ps)+ put (ES (ps { pterm = pt' }, a) s m)+ matchProblems :: Bool -> Elab' aux () matchProblems all = processTactic' (MatchProblems all) unifyProblems :: Elab' aux () unifyProblems = processTactic' UnifyProblems -defer :: Name -> Elab' aux ()-defer n = do n' <- unique_hole n- processTactic' (Defer n')+defer :: [Name] -> Name -> Elab' aux ()+defer ds n = do n' <- unique_hole n+ processTactic' (Defer ds n') deferType :: Name -> Raw -> [Name] -> Elab' aux () deferType n ty ns = processTactic' (DeferType n ty ns)@@ -429,7 +426,7 @@ qed :: Elab' aux Term qed = do processTactic' QED ES p _ _ <- get- return $! (pterm (fst p))+ return $! (getProofTerm (pterm (fst p))) undo :: Elab' aux () undo = processTactic' Undo@@ -457,7 +454,7 @@ -> [(Name, Name)] -- ^ Accumulator for produced claims -> [Name] -- ^ Hypotheses -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.- mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs = + mkClaims (Bind n' (Pi t_in _) sc) (i : is) claims hs = do let t = rebind hs t_in n <- getNameFrom (mkMN n') -- when (null claims) (start_unify n)@@ -501,10 +498,9 @@ -- (remove from unified list before calling end_unify) hs <- get_holes ES (p, a) s prev <- get- let dont = head hs : dontunify p ++- if null imps then [] -- do all we can- else- map fst (filter (not . snd) (zip (map snd args) (map fst imps)))+ let dont = if null imps + then head hs : dontunify p+ else getNonUnify (head hs : dontunify p) imps args let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ unified p let unify = -- trace ("Not done " ++ show hs) $@@ -523,6 +519,15 @@ Just (P _ t _) -> t _ -> n + getNonUnify acc [] _ = acc+ getNonUnify acc _ [] = acc+ getNonUnify acc ((i,_):is) ((a, t):as) + | i = getNonUnify acc is as+ | otherwise = getNonUnify (t : acc) is as++-- getNonUnify imps args = map fst (filter (not . snd) (zip (map snd args) (map fst imps)))++ apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux () apply2 fn elabs = do args <- prepare_apply fn (map isJust elabs)@@ -557,7 +562,7 @@ priOrder _ Nothing = GT priOrder (Just (x, _)) (Just (y, _)) = compare x y - doClaims (Bind n' (Pi t) sc) (i : is) claims =+ doClaims (Bind n' (Pi t _) sc) (i : is) claims = do n <- unique_hole (mkMN n') when (null claims) (start_unify n) let sc' = instantiate (P Bound n t) sc@@ -592,13 +597,13 @@ checkPiGoal n = do g <- goal case g of- Bind _ (Pi _) _ -> return ()+ Bind _ (Pi _ _) _ -> return () _ -> do a <- getNameFrom (sMN 0 "pargTy") b <- getNameFrom (sMN 0 "pretTy") f <- getNameFrom (sMN 0 "pf") claim a RType claim b RType- claim f (RBind n (Pi (Var a)) (Var b))+ claim f (RBind n (Pi (Var a) RType) (Var b)) movelast a movelast b fill (Var f)@@ -613,7 +618,7 @@ s <- getNameFrom (sMN 0 "s") claim a RType claim b RType- claim f (RBind (sMN 0 "aX") (Pi (Var a)) (Var b))+ claim f (RBind (sMN 0 "aX") (Pi (Var a) RType) (Var b)) tm <- get_term start_unify s claim s (Var a)@@ -639,6 +644,7 @@ arg :: Name -> Name -> Elab' aux () arg n tyhole = do ty <- unique_hole tyhole claim ty RType+ movelast ty forall n (Var ty) -- try a tactic, if it adds any unification problem, return an error
src/Idris/Core/Evaluate.hs view
@@ -11,7 +11,8 @@ lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal, mapDefCtxt, lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,- Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions) where+ Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,+ isUniverse) where import Debug.Trace import Control.Applicative hiding (Const)@@ -47,6 +48,7 @@ | VBLet Int Name Value Value Value | VApp Value Value | VType UExp+ | VUType Universe | VErased | VImpossible | VConstant Const@@ -237,20 +239,21 @@ ev ntimes stk top env (V i) | i < length env && i >= 0 = return $ snd (env !! i) | otherwise = return $ VV i- ev ntimes stk top env (Bind n (Let t v) sc)+ ev ntimes stk top env (Bind n (Let t v) sc) + | not runtime || occurrences n sc < 2 = do v' <- ev ntimes stk top env v --(finalise v) sc' <- ev ntimes stk top ((n, v') : env) sc wknV (-1) sc'--- | otherwise--- = do t' <- ev ntimes stk top env t--- v' <- ev ntimes stk top env v --(finalise v)--- -- use Tmp as a placeholder, then make it a variable reference--- -- again when evaluation finished--- hs <- get--- let vd = nexthole hs--- put (hs { nexthole = vd + 1 })--- sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc--- return $ VBLet vd n t' v' sc'+ | otherwise+ = do t' <- ev ntimes stk top env t+ v' <- ev ntimes stk top env v --(finalise v)+ -- use Tmp as a placeholder, then make it a variable reference+ -- again when evaluation finished+ hs <- get+ let vd = nexthole hs+ put (hs { nexthole = vd + 1 })+ sc' <- ev ntimes stk top ((n, VP Bound (sMN vd "vlet") VErased) : env) sc+ return $ VBLet vd n t' v' sc' ev ntimes stk top env (Bind n (NLet t v) sc) = do t' <- ev ntimes stk top env (finalise t) v' <- ev ntimes stk top env (finalise v)@@ -290,7 +293,7 @@ t' <- ev ntimes stk top env t -- tfull' <- reapply ntimes stk top env t' [] return (doProj t' (getValArgs t'))- where doProj t' (VP (DCon _ _) _ _, args) + where doProj t' (VP (DCon _ _ _) _ _, args) | i >= 0 && i < length args = args!!i doProj t' _ = VProj t' i @@ -298,6 +301,7 @@ ev ntimes stk top env Erased = return VErased ev ntimes stk top env Impossible = return VImpossible ev ntimes stk top env (TType i) = return $ VType i+ ev ntimes stk top env (UType u) = return $ VUType u evApply ntimes stk top env args (VApp f a) = evApply ntimes stk top env (a:args) f@@ -393,7 +397,7 @@ evTree ntimes stk top env amap (ProjCase t alts) = do t' <- ev ntimes stk top env t doCase ntimes stk top env amap t' alts- evTree ntimes stk top env amap (Case n alts)+ evTree ntimes stk top env amap (Case _ n alts) = case lookup n amap of Just v -> doCase ntimes stk top env amap v alts _ -> return Nothing@@ -409,7 +413,7 @@ _ -> return Nothing conHeaded tm@(App _ _)- | (P (DCon _ _) _ _, args) <- unApply tm = True+ | (P (DCon _ _ _) _ _, args) <- unApply tm = True conHeaded t = False chooseAlt' ntimes stk env _ (f, args) alts amap@@ -420,7 +424,7 @@ chooseAlt :: [(Name, Value)] -> Value -> (Value, [Value]) -> [CaseAlt] -> [(Name, Value)] -> Eval (Maybe ([(Name, Value)], SC))- chooseAlt env _ (VP (DCon i a) _ _, args) alts amap+ chooseAlt env _ (VP (DCon i a _) _ _, args) alts amap | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc) | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VP (TCon i a) _ _, args) alts amap@@ -434,7 +438,7 @@ | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VP _ n _, args) alts amap | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)- chooseAlt env _ (VBind _ _ (Pi s) t, []) alts amap+ chooseAlt env _ (VBind _ _ (Pi s k) t, []) alts amap | Just (ns, sc) <- findFn (sUN "->") alts = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern return $ Just (updateAmap (zip ns [s, t']) amap, sc)@@ -519,6 +523,7 @@ return (Bind n (Let t' v') sc'') quote i (VApp f a) = liftM2 App (quote i f) (quote i a) quote i (VType u) = return $ TType u+ quote i (VUType u) = return $ UType u quote i VErased = return $ Erased quote i VImpossible = return $ Impossible quote i (VProj v j) = do v' <- quote i v@@ -534,6 +539,15 @@ wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a) wknV i t = return t +isUniverse :: Term -> Bool+isUniverse (TType _) = True+isUniverse (UType _) = True+isUniverse _ = False++isUsableUniverse :: Term -> Bool+isUsableUniverse (UType NullType) = False+isUsableUniverse x = isUniverse x+ convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, []) convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool@@ -567,17 +581,21 @@ where ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')+ ceqB ps (Pi v t) (Pi v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps b b' = ceq ps (binderTy b) (binderTy b') ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) ceq ps (Constant x) (Constant y) = return (x == y) ceq ps (TType x) (TType y) = do (v, cs) <- get put (v, ULE x y : cs) return True+ ceq ps (UType AllTypes) x = return (isUsableUniverse x)+ ceq ps x (UType AllTypes) = return (isUsableUniverse x)+ ceq ps (UType u) (UType v) = return (u == v) ceq ps Erased _ = return True ceq ps _ Erased = return True ceq ps x y = return False - caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs'+ caseeq ps (Case _ n cs) (Case _ n' cs') = caseeqA ((n,n'):ps) cs cs' where caseeqA ps (ConCase x i as sc : rest) (ConCase x' i' as' sc' : rest') = do q1 <- caseeq (zip as as' ++ ps) sc sc'@@ -780,7 +798,7 @@ uctxt { definitions = ctxt' } addDatatype :: Datatype Name -> Context -> Context-addDatatype (Data n tag ty cons) uctxt+addDatatype (Data n tag ty unique cons) uctxt = let ctxt = definitions uctxt ty' = normalise uctxt [] ty ctxt' = addCons 0 cons (addDef n@@ -791,7 +809,7 @@ addCons tag ((n, ty) : cons) ctxt = let ty' = normalise uctxt [] ty in addCons (tag+1) cons (addDef n- (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked, EmptyMI) ctxt)+ (TyDecl (DCon tag (arity ty') unique) ty, Public, Unchecked, EmptyMI) ctxt) -- FIXME: Too many arguments! Refactor all these Bools. addCasedef :: Name -> ErasureInfo -> CaseInfo ->@@ -916,7 +934,7 @@ isDConName n ctxt = or $ do def <- lookupCtxt n (definitions ctxt) case tfst def of- (TyDecl (DCon _ _) _) -> return True+ (TyDecl (DCon _ _ _) _) -> return True _ -> return False isFnName :: Name -> Context -> Bool
src/Idris/Core/Execute.hs view
@@ -23,9 +23,11 @@ import Control.Monad.Trans import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Error-import Control.Monad+import Control.Monad hiding (forM) import Data.Maybe import Data.Bits+import Data.Traversable (forM)+import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Map as M #ifdef IDRIS_FFI@@ -82,7 +84,7 @@ b' <- fixBinder b Bind n b' <$> toTT body' where fixBinder (Lam t) = Lam <$> toTT t- fixBinder (Pi t) = Pi <$> toTT t+ fixBinder (Pi t k) = Pi <$> toTT t <*> toTT k fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2 fixBinder (Hole t) = Hole <$> toTT t@@ -144,7 +146,7 @@ Right tm' -> return tm' ioWrap :: ExecVal -> ExecVal-ioWrap tm = mkEApp (EP (DCon 0 2) (sUN "prim__IO") EErased) [EErased, tm]+ioWrap tm = mkEApp (EP (DCon 0 2 False) (sUN "prim__IO") EErased) [EErased, tm] ioUnit :: ExecVal ioUnit = ioWrap (EP Ref unitCon EErased)@@ -163,21 +165,22 @@ doExec env ctxt tm [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased) [] -> execFail . Msg $ "Could not find " ++ show n ++ " in definitions."- thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined+ other | length other > 1 -> execFail . Msg $ "Multiple definitions found for " ++ show n+ | otherwise -> execFail . Msg . take 500 $ "got to " ++ show other ++ " lookup up " ++ show n doExec env ctxt p@(P Bound n ty) = case lookup n env of Nothing -> execFail . Msg $ "not found" Just tm -> return tm-doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)+doExec env ctxt (P (DCon a b u) n _) = return (EP (DCon a b u) n EErased) doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased) doExec env ctxt v@(V i) | i < length env = return (snd (env !! i)) | otherwise = execFail . Msg $ "env too small" doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v doExec ((n, v'):env) ctxt body doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined-doExec env ctxt tm@(Bind n b body) = return $- EBind n (fmap (\_->EErased) b)- (\arg -> doExec ((n, arg):env) ctxt body)+doExec env ctxt tm@(Bind n b body) = do b' <- forM b (doExec env ctxt)+ return $+ EBind n b' (\arg -> doExec ((n, arg):env) ctxt body) doExec env ctxt a@(App _ _) = do let (f, args) = unApply a f' <- doExec env ctxt f@@ -250,6 +253,10 @@ "The argument to idris_readStr should be a handle, but it was " ++ show handle ++ ". Are all cases covered?"+execApp env ctxt (EP _ fp _) (_:fn:rest)+ | fp == mkfprim,+ Just (FFun "idris_time" _ _) <- foreignFromTT fn+ = do execIO $ fmap (ioWrap . EConstant . I . round) getPOSIXTime execApp env ctxt (EP _ fp _) (_:fn:fileStr:modeStr:rest) | fp == mkfprim, Just (FFun "fileOpen" _ _) <- foreignFromTT fn@@ -265,7 +272,9 @@ "r+" -> Right ReadWriteMode _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode) case fmap (openFile f) m of- Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)+ Right h -> do h' <- h+ hSetBinaryMode h' True+ return $ Right (ioWrap (EHandle h'), tail rest) Left err -> return $ Left err) (\e -> let _ = ( e::SomeException) in return $ Right (ioWrap (EPtr nullPtr), tail rest))@@ -340,7 +349,7 @@ Just r -> return (mkEApp r xs') Nothing -> return (mkEApp f args) -execApp env ctxt c@(EP (DCon _ arity) n _) args =+execApp env ctxt c@(EP (DCon _ arity _) n _) args = do let args' = take arity args let restArgs = drop arity args execApp env ctxt (mkEApp c args') restArgs@@ -434,7 +443,7 @@ execCase' env ctxt amap (UnmatchedCase _) = return Nothing execCase' env ctxt amap (STerm tm) = Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm-execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =+execCase' env ctxt amap (Case sh n alts) | Just tm <- lookup n amap = case chooseAlt tm alts of Just (newCase, newBindings) -> let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in@@ -442,7 +451,15 @@ Nothing -> return Nothing chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])-chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])+chooseAlt tm (DefaultCase sc : alts) | ok tm = Just (sc, [])+ | otherwise = Nothing+ where -- Default cases should only work on applications of constructors or on constants+ ok (EApp f x) = ok f+ ok (EP Bound _ _) = False+ ok (EP Ref _ _) = False+ ok _ = True++ chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, []) chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm , cn == n = Just (sc, zip ns args)
src/Idris/Core/ProofState.hs view
@@ -12,6 +12,7 @@ import Idris.Core.Evaluate import Idris.Core.TT import Idris.Core.Unify+import Idris.Core.ProofTerm import Control.Monad.State.Strict import Control.Applicative hiding (empty)@@ -25,7 +26,7 @@ holes :: [Name], -- holes still to be solved usedns :: [Name], -- used names, don't use again nextname :: Int, -- name supply- pterm :: Term, -- current proof term+ pterm :: ProofTerm, -- current proof term ptype :: Type, -- original goal dontunify :: [Name], -- explicitly given by programmer, leave it unified :: (Name, [(Name, Term)]),@@ -43,10 +44,6 @@ while_elaborating :: [FailContext] } -data Goal = GD { premises :: Env,- goalType :: Binder Term- }- data Tactic = Attack | Claim Name Raw | Reorder Name@@ -78,7 +75,7 @@ | PatVar Name | PatBind Name | Focus Name- | Defer Name+ | Defer [Name] Name | DeferType Name Raw [Name] | Instance Name | SetInjective Name@@ -141,13 +138,6 @@ nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) <+> nest nestingSize (prettyPs env bs)) -same Nothing n = True-same (Just x) n = x == n--hole (Hole _) = True-hole (Guess _ _) = True-hole _ = False- holeName i = sMN i "hole" qshow :: Fails -> String@@ -165,7 +155,7 @@ " in " ++ show env ++ "\nHoles: " ++ show (holes ps) ++ "\n" - ++ "\n" ++ show (pterm ps) ++ "\n\n"+ ++ "\n" ++ show (getProofTerm (pterm ps)) ++ "\n\n" ) $ case match_unify ctxt env topx topy inj (holes ps) while of OK u -> traceWhen (unifylog ps)@@ -226,9 +216,11 @@ -- ++ show (pterm ps) ++ "\n----------") $ do let (h, ns) = unified ps+ -- solve in results (maybe unify should do this itself...)+ let u' = map (\(n, sol) -> (n, updateSolvedTerm u sol)) u -- if a metavar has multiple solutions, make a new unification -- problem for each.- uns <- mergeSolutions env (u ++ ns)+ uns <- mergeSolutions env (u' ++ ns) ps <- get let (ns', probs') = updateProblems (context ps) uns (fails ++ problems ps)@@ -290,15 +282,14 @@ newProof :: Name -> Context -> Type -> ProofState newProof n ctxt ty = let h = holeName 0 ty' = vToP ty in- PS n [h] [] 1 (Bind h (Hole ty')- (P Bound h ty')) ty [] (h, []) []+ PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')+ (P Bound h ty'))) ty [] (h, []) [] Nothing [] [] [] [] Nothing ctxt "" False False [] type TState = ProofState -- [TacticAction])-type RunTactic = Context -> Env -> Term -> StateT TState TC Term-type Hole = Maybe Name -- Nothing = default hole, first in list in proof state+type RunTactic = RunTactic' TState envAtFocus :: ProofState -> TC Env envAtFocus ps@@ -310,65 +301,14 @@ goalAtFocus ps | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps) return (goalType g)- | otherwise = Error . Msg $ "No goal in " ++ show (holes ps) ++ show (pterm ps)--goal :: Hole -> Term -> TC Goal-goal h tm = g [] tm where- g env (Bind n b@(Guess _ _) sc)- | same h n = return $ GD env b- | otherwise- = gb env b `mplus` g ((n, b):env) sc- g env (Bind n b sc) | hole b && same h n = return $ GD env b- | otherwise- = g ((n, b):env) sc `mplus` gb env b- g env (App f a) = g env f `mplus` g env a- g env t = fail "Can't find hole"-- gb env (Let t v) = g env v `mplus` g env t- gb env (Guess t v) = g env v `mplus` g env t- gb env t = g env (binderTy t)+ | otherwise = Error . Msg $ "No goal in " ++ show (holes ps) ++ show (getProofTerm (pterm ps)) tactic :: Hole -> RunTactic -> StateT TState TC () tactic h f = do ps <- get- (tm', _) <- atH (context ps) [] (pterm ps)+ (tm', _) <- atHole h f (context ps) [] (pterm ps) ps <- get -- might have changed while processing put (ps { pterm = tm' })- where- updated o = do o' <- o- return (o', True) - ulift2 c env op a b- = do (b', u) <- atH c env b- if u then return (op a b', True)- else do (a', u) <- atH c env a- return (op a' b', u)-- -- Search the things most likely to contain the binding first!-- atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool)- atH c env binder@(Bind n b@(Guess t v) sc)- | same h n = updated (f c env binder)- | otherwise- = do -- binder first- (b', u) <- ulift2 c env Guess t v- if u then return (Bind n b' sc, True)- else do (sc', u) <- atH c ((n, b) : env) sc- return (Bind n b' sc', u)- atH c env binder@(Bind n b sc)- | hole b && same h n = updated (f c env binder)- | otherwise -- scope first- = do (sc', u) <- atH c ((n, b) : env) sc- if u then return (Bind n b sc', True)- else do (b', u) <- atHb c env b- return (Bind n b' sc', u)- atH c env (App f a) = ulift2 c env App f a- atH c env t = return (t, False)-- atHb c env (Let t v) = ulift2 c env Let t v- atHb c env (Guess t v) = ulift2 c env Guess t v- atHb c env t = do (ty', u) <- atH c env (binderTy t)- return (t { binderTy = ty' }, u)- computeLet :: Context -> Name -> Term -> Term computeLet ctxt n tm = cl [] tm where cl env (Bind n' (Let t v) sc)@@ -447,15 +387,16 @@ ps { injective = n : is }) return (Bind x b sc) -defer :: Name -> RunTactic-defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =- do action (\ps -> let hs = holes ps in+defer :: [Name] -> Name -> RunTactic+defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =+ do let env' = filter (\(n, t) -> n `notElem` dropped) env+ action (\ps -> let hs = holes ps in ps { holes = hs \\ [x] })- return (Bind n (GHole (length env) (mkTy (reverse env) t))- (mkApp (P Ref n ty) (map getP (reverse env))))+ return (Bind n (GHole (length env') (mkTy (reverse env') t))+ (mkApp (P Ref n ty) (map getP (reverse env')))) where mkTy [] t = t- mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b)) (mkTy bs t)+ mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b) (TType (UVar 0))) (mkTy bs t) getP (n, b) = P Bound n (binderTy b) @@ -574,17 +515,17 @@ Just name -> name Nothing -> x let t' = case t of- x@(Bind y (Pi s) _) -> x+ x@(Bind y (Pi s _) _) -> x _ -> hnf ctxt env t (tyv, tyt) <- lift $ check ctxt env ty -- ns <- lift $ unify ctxt env tyv t' case t' of- Bind y (Pi s) t -> let t' = subst y (P Bound n s) t in- do ns <- unify' ctxt env s tyv- ps <- get- let (uh, uns) = unified ps--- put (ps { unified = (uh, uns ++ ns) })- return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))+ Bind y (Pi s _) t -> let t' = subst y (P Bound n s) t in+ do ns <- unify' ctxt env s tyv+ ps <- get+ let (uh, uns) = unified ps+-- put (ps { unified = (uh, uns ++ ns) })+ return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' introTy ty n ctxt env _ = fail "Can't introduce here." @@ -594,10 +535,10 @@ Just name -> name Nothing -> x let t' = case t of- x@(Bind y (Pi s) _) -> x+ x@(Bind y (Pi s _) _) -> x _ -> hnf ctxt env t case t' of- Bind y (Pi s) t -> -- trace ("in type " ++ show t') $+ Bind y (Pi s _) t -> -- trace ("in type " ++ show t') $ let t' = subst y (P Bound n s) t in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t'@@ -608,11 +549,11 @@ do (tyv, tyt) <- lift $ check ctxt env ty unify' ctxt env tyt (TType (UVar 0)) unify' ctxt env t (TType (UVar 0))- return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t))+ return $ Bind n (Pi tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t)) forall n ty ctxt env _ = fail "Can't pi bind here" patvar :: Name -> RunTactic-patvar n ctxt env (Bind x (Hole t) sc) =+patvar n ctxt env (Bind x (Hole t) sc) = do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $ holes ps \\ [x], solved = Just (x, P Bound n t),@@ -697,13 +638,13 @@ let indxargs = drop (length restargs - length indicies) $ restargs let scr = last $ tail args' let indxnames = makeIndexNames indicies- currentNames <- query $ allTTNames . pterm+ currentNames <- query $ allTTNames . getProofTerm . pterm let tmnm = case tm of Var nm -> uniqueNameCtxt ctxt nm currentNames _ -> uniqueNameCtxt ctxt (sMN 0 "iv") currentNames let tmvar = P Bound tmnm tmt' prop <- replaceIndicies indxnames indicies $ Bind tmnm (Lam tmt') (mkP tmvar tmv tmvar t)- consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (pterm ps)) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (pterm ps))) consargs)+ consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs) let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0))) (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv]))) action (\ps -> ps {holes = holes ps \\ [x]})@@ -800,7 +741,7 @@ action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping holes " ++ show (map fst unify)) $ holes ps \\ map fst unify }) action (\ps -> ps { pterm = updateSolved unify (pterm ps) })- return (updateSolved unify tm)+ return (updateSolvedTerm unify tm) dropGiven du [] hs = [] dropGiven du ((n, P Bound t ty) : us) hs@@ -821,26 +762,9 @@ | n `elem` du = u : keepGiven du us hs keepGiven du (u : us) hs = keepGiven du us hs -updateSolved :: [(Name, Term)] -> Term -> Term -updateSolved xs x = updateSolved' xs x-updateSolved' [] x = x-updateSolved' xs (Bind n (Hole ty) t)- | Just v <- lookup n xs - = case xs of- [_] -> substV v $ psubst n v t -- some may be Vs! Can't assume- -- explicit names- _ -> substV v $ psubst n v (updateSolved' xs t)-updateSolved' xs (Bind n b t)- | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)-updateSolved' xs (App f a) - = App (updateSolved' xs f) (updateSolved' xs a)-updateSolved' xs (P _ n@(MN _ _) _)- | Just v <- lookup n xs = v-updateSolved' xs t = t- updateEnv [] e = e updateEnv ns [] = []-updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env+updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env updateError [] err = err updateError ns (At f e) = At f (updateError ns e)@@ -848,7 +772,7 @@ updateError ns (ElaboratingArg f a env e) = ElaboratingArg f a env (updateError ns e) updateError ns (CantUnify b l r e xs sc)- = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc+ = CantUnify b (updateSolvedTerm ns l) (updateSolvedTerm ns r) (updateError ns e) xs sc updateError ns e = e solveInProblems x val [] = []@@ -868,7 +792,7 @@ updateNotunified [] nu = nu updateNotunified ns nu = up nu where up [] = []- up ((n, t) : nus) = let t' = updateSolved ns t in+ up ((n, t) : nus) = let t' = updateSolvedTerm ns t in ((n, t') : up nus) -- FIXME: Why not just pass the whole proof state?@@ -878,8 +802,8 @@ updateProblems ctxt ns ps inj holes usupp = up ns ps where up ns [] = (ns, []) up ns ((x, y, env, err, while, um) : ps) =- let x' = updateSolved ns x- y' = updateSolved ns y+ let x' = updateSolvedTerm ns x+ y' = updateSolvedTerm ns y err' = updateError ns err env' = updateEnv ns env in -- trace ("Updating " ++ show (x',y')) $ @@ -895,8 +819,8 @@ up ns [] = (ns, []) up ns ((x, y, env, err, while, um) : ps) | all || um == Match =- let x' = updateSolved ns x- y' = updateSolved ns y+ let x' = updateSolvedTerm ns x+ y' = updateSolvedTerm ns y err' = updateError ns err env' = updateEnv ns env in case match_unify ctxt env' x' y' inj holes while of@@ -909,19 +833,19 @@ processTactic :: Tactic -> ProofState -> TC (ProofState, String) processTactic QED ps = case holes ps of- [] -> do let tm = {- normalise (context ps) [] -} (pterm ps)+ [] -> do let tm = {- normalise (context ps) [] -} getProofTerm (pterm ps) (tm', ty', _) <- recheck (context ps) [] (forget tm) tm- return (ps { done = True, pterm = tm' },+ return (ps { done = True, pterm = mkProofTerm tm' }, "Proof complete: " ++ showEnv [] tm') _ -> fail "Still holes to fill."-processTactic ProofState ps = return (ps, showEnv [] (pterm ps))+processTactic ProofState ps = return (ps, showEnv [] (getProofTerm (pterm ps))) processTactic Undo ps = case previous ps of Nothing -> Error . Msg $ "Nothing to undo." Just pold -> return (pold, "") processTactic EndUnify ps = let (h, ns_in) = unified ps ns = dropGiven (dontunify ps) ns_in (holes ps)- ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns+ ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns (ns'', probs') = updateProblems (context ps) ns' (problems ps) (injective ps) (holes ps) (map fst (notunified ps))@@ -941,7 +865,9 @@ = do ps' <- execStateT (tactic (Just n) reorder_claims) ps return (ps' { previous = Just ps, plog = "" }, plog ps') processTactic (ComputeLet n) ps- = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "")+ = return (ps { pterm = mkProofTerm $+ computeLet (context ps) n + (getProofTerm (pterm ps)) }, "") processTactic UnifyProblems ps = let (ns', probs') = updateProblems (context ps) [] (problems ps)@@ -977,7 +903,7 @@ = case solved ps' of Just s -> traceWhen (unifylog ps') ("SOLVED " ++ show s) $- updateProblems (context ps')+ updateProblems (context ps') [s] (problems ps') (injective ps') (holes ps')@@ -1027,7 +953,7 @@ mktac (CheckIn r) = check_in r mktac (EvalIn r) = eval_in r mktac (Focus n) = focus n- mktac (Defer n) = defer n+ mktac (Defer ns n) = defer ns n mktac (DeferType n t a) = deferType n t a mktac (Instance n) = instanceArg n mktac (SetInjective n) = setinj n
+ src/Idris/Core/ProofTerm.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}++{- Implements a proof state, some primitive tactics for manipulating+ proofs, and some high level commands for introducing new theorems,+ evaluation/checking inside the proof system, etc. --}++module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,+ updateSolved, updateSolvedTerm, + bound_in, bound_in_term, refocus,+ Hole, RunTactic',+ goal, atHole) where++import Idris.Core.Typecheck+import Idris.Core.Evaluate+import Idris.Core.TT++import Control.Monad.State.Strict+import Data.List+import Debug.Trace++data TermPath = Top+ | AppL TermPath Term+ | AppR Term TermPath+ | InBind Name BinderPath Term+ | InScope Name (Binder Term) TermPath+ deriving Show++data BinderPath = Binder (Binder TermPath)+ | LetT TermPath Term+ | LetV Term TermPath+ | GuessT TermPath Term+ | GuessV Term TermPath+ deriving Show++replaceTop :: TermPath -> TermPath -> TermPath+replaceTop p Top = p+replaceTop p (AppL l t) = AppL (replaceTop p l) t+replaceTop p (AppR t r) = AppR t (replaceTop p r)+replaceTop p (InBind n bp sc) = InBind n (replaceTopB p bp) sc+ where+ replaceTopB p (Binder b) = Binder (fmap (replaceTop p) b)+ replaceTopB p (LetT t v) = LetT (replaceTop p t) v+ replaceTopB p (LetV t v) = LetV t (replaceTop p v)+ replaceTopB p (GuessT t v) = GuessT (replaceTop p t) v+ replaceTopB p (GuessV t v) = GuessV t (replaceTop p v)+replaceTop p (InScope n b sc) = InScope n b (replaceTop p sc)++rebuildTerm :: Term -> TermPath -> Term+rebuildTerm tm Top = tm+rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a+rebuildTerm tm (AppR f p) = App f (rebuildTerm tm p)+rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p)+rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc++rebuildBinder :: Term -> BinderPath -> Binder Term+rebuildBinder tm (Binder p) = fmap (rebuildTerm tm) p+rebuildBinder tm (LetT p t) = Let (rebuildTerm tm p) t+rebuildBinder tm (LetV v p) = Let v (rebuildTerm tm p)+rebuildBinder tm (GuessT p t) = Guess (rebuildTerm tm p) t+rebuildBinder tm (GuessV v p) = Guess v (rebuildTerm tm p)++findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term)+findHole n env t = fh' env Top t where+ fh' env path tm@(Bind x h sc) + | hole h && n == x = Just (path, env, tm)+ fh' env path (App f a)+ | Just (p, env', tm) <- fh' env path a = Just (AppR f p, env', tm)+ | Just (p, env', tm) <- fh' env path f = Just (AppL p a, env', tm)+ fh' env path (Bind x b sc)+ | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)+ | Just (p, env', tm) <- fh' ((x,b):env) path sc = Just (InScope x b p, env', tm)+ fh' _ _ _ = Nothing++ fhB env path (Let t v)+ | Just (p, env', tm) <- fh' env path t = Just (LetT p v, env', tm)+ | Just (p, env', tm) <- fh' env path v = Just (LetV t p, env', tm)+ fhB env path (Guess t v)+ | Just (p, env', tm) <- fh' env path t = Just (GuessT p v, env', tm)+ | Just (p, env', tm) <- fh' env path v = Just (GuessV t p, env', tm)+ fhB env path b+ | Just (p, env', tm) <- fh' env path (binderTy b)+ = Just (Binder (fmap (\_ -> p) b), env', tm)+ fhB _ _ _ = Nothing ++data ProofTerm = PT { -- wholeterm :: Term,+ path :: TermPath,+ subterm_env :: Env,+ subterm :: Term,+ updates :: [(Name, Term)] }+ deriving Show++type RunTactic' a = Context -> Env -> Term -> StateT a TC Term+type Hole = Maybe Name -- Nothing = default hole, first in list in proof state++refocus :: Hole -> ProofTerm -> ProofTerm+refocus h t = let res = refocus' h t in res+-- trace ("OLD: " ++ show t ++ "\n" +++-- "REFOCUSSED " ++ show h ++ ": " ++ show res) res+refocus' (Just n) pt@(PT path env tm ups)+ | Just (p', env', tm') <- findHole n env tm+ = PT (replaceTop p' path) env' tm' ups+ | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))+ = PT p' env' tm' []+ | otherwise = pt+refocus' _ pt = pt++data Goal = GD { premises :: Env,+ goalType :: Binder Term+ }++mkProofTerm :: Term -> ProofTerm+mkProofTerm tm = PT Top [] tm []++getProofTerm :: ProofTerm -> Term+getProofTerm (PT path _ sub ups) = rebuildTerm sub (updateSolvedPath ups path) ++same Nothing n = True+same (Just x) n = x == n++hole (Hole _) = True+hole (Guess _ _) = True+hole _ = False++updateSolvedTerm :: [(Name, Term)] -> Term -> Term +updateSolvedTerm [] x = x+updateSolvedTerm xs x = -- updateSolved' xs x where+-- This version below saves allocations, because it doesn't need to reallocate+-- the term if there are no updates to do. +-- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is+-- the wrong combinator. Feel free to tidy up as long as it's still as cheap :).+ fst $ updateSolved' xs x where+ updateSolved' [] x = (x, False)+ updateSolved' xs (Bind n (Hole ty) t)+ | Just v <- lookup n xs + = case xs of+ [_] -> (subst n v t, True) -- some may be Vs! Can't assume+ -- explicit names+ _ -> let (t', _) = updateSolved' xs t in+ (subst n v t', True)+ updateSolved' xs tm@(Bind n b t)+ | otherwise = let (t', ut) = updateSolved' xs t+ (b', ub) = updateSolvedB' xs b in+ if ut || ub then (Bind n b' t', True)+ else (tm, False)+ updateSolved' xs t@(App f a) + = let (f', uf) = updateSolved' xs f+ (a', ua) = updateSolved' xs a in+ if uf || ua then (App f' a', True)+ else (t, False)+ updateSolved' xs t@(P _ n@(MN _ _) _)+ | Just v <- lookup n xs = (v, True)+ updateSolved' xs t = (t, False)++ updateSolvedB' xs b@(Let t v) = let (t', ut) = updateSolved' xs t + (v', uv) = updateSolved' xs v in+ if ut || uv then (Let t' v', True)+ else (b, False)+ updateSolvedB' xs b@(Guess t v) = let (t', ut) = updateSolved' xs t + (v', uv) = updateSolved' xs v in+ if ut || uv then (Guess t' v', True)+ else (b, False)+ updateSolvedB' xs b = let (ty', u) = updateSolved' xs (binderTy b) in+ if u then (b { binderTy = ty' }, u) else (b, False)++ noneOf ns (P _ n _) | n `elem` ns = False+ noneOf ns (App f a) = noneOf ns a && noneOf ns f+ noneOf ns (Bind n (Hole ty) t) = n `notElem` ns && noneOf ns ty && noneOf ns t+ noneOf ns (Bind n b t) = noneOf ns t && noneOfB ns b+ where+ noneOfB ns (Let t v) = noneOf ns t && noneOf ns v+ noneOfB ns (Guess t v) = noneOf ns t && noneOf ns v+ noneOfB ns b = noneOf ns (binderTy b)+ noneOf ns _ = True++updateEnv [] e = e+updateEnv ns [] = []+updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env++updateSolvedPath [] t = t+updateSolvedPath ns Top = Top+updateSolvedPath ns (AppL p r) = AppL p (updateSolvedTerm ns r)+updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) p+updateSolvedPath ns (InBind n b sc) + = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc)+ where+ updateSolvedPathB (Binder b) = Binder (fmap (updateSolvedPath ns) b)+ updateSolvedPathB (LetT p v) = LetT (updateSolvedPath ns p) (updateSolvedTerm ns v)+ updateSolvedPathB (LetV v p) = LetV (updateSolvedTerm ns v) (updateSolvedPath ns p)+ updateSolvedPathB (GuessT p v) = GuessT (updateSolvedPath ns p) (updateSolvedTerm ns v)+ updateSolvedPathB (GuessV v p) = GuessV (updateSolvedTerm ns v) (updateSolvedPath ns p)+updateSolvedPath ns (InScope n (Hole ty) t)+ | Just v <- lookup n ns = case ns of+ [_] -> updateSolvedPath [(n,v)] t+ _ -> updateSolvedPath ns $+ updateSolvedPath [(n,v)] t+updateSolvedPath ns (InScope n b sc)+ = InScope n (fmap (updateSolvedTerm ns) b) (updateSolvedPath ns sc)++updateSolved :: [(Name, Term)] -> ProofTerm -> ProofTerm +updateSolved xs pt@(PT path env sub ups) + = PT path -- (updateSolvedPath xs path) + (updateEnv xs (filter (\(n, t) -> n `notElem` map fst xs) env)) + (updateSolvedTerm xs sub) + (ups ++ xs)++goal :: Hole -> ProofTerm -> TC Goal+goal h pt@(PT path env sub ups) +-- | OK ginf <- g env sub = return ginf+ | otherwise = g [] (rebuildTerm sub (updateSolvedPath ups path))+ where + g :: Env -> Term -> TC Goal+ g env (Bind n b@(Guess _ _) sc)+ | same h n = return $ GD env b+ | otherwise+ = gb env b `mplus` g ((n, b):env) sc+ g env (Bind n b sc) | hole b && same h n = return $ GD env b+ | otherwise+ = g ((n, b):env) sc `mplus` gb env b+ g env (App f a) = g env a `mplus` g env f+ g env t = fail "Can't find hole"++ gb env (Let t v) = g env v `mplus` g env t+ gb env (Guess t v) = g env v `mplus` g env t+ gb env t = g env (binderTy t)++atHole :: Hole -> RunTactic' a -> Context -> Env -> ProofTerm -> + StateT a TC (ProofTerm, Bool)+atHole h f c e pt -- @(PT path env sub) + = do let PT path env sub ups = refocus h pt+ (tm, u) <- atH f c env sub+ return (PT path env tm ups, u)+-- if u then return (PT path env tm ups, u)+-- else do let PT path env sub ups = refocus h pt+-- (tm, u) <- atH f c env sub+-- return (PT path env tm ups, u)+ where+ updated o = do o' <- o+ return (o', True)++ ulift2 f c env op a b+ = do (b', u) <- atH f c env b+ if u then return (op a b', True)+ else do (a', u) <- atH f c env a+ return (op a' b', u)++ -- Search the things most likely to contain the binding first!++ atH :: RunTactic' a -> Context -> Env -> Term -> StateT a TC (Term, Bool)+ atH f c env binder@(Bind n b@(Guess t v) sc)+ | same h n = updated (f c env binder)+ | otherwise+ = do -- binder first+ (b', u) <- ulift2 f c env Guess t v+ if u then return (Bind n b' sc, True)+ else do (sc', u) <- atH f c ((n, b) : env) sc+ return (Bind n b' sc', u)+ atH f c env binder@(Bind n b sc)+ | hole b && same h n = updated (f c env binder)+ | otherwise -- scope first+ = do (sc', u) <- atH f c ((n, b) : env) sc+ if u then return (Bind n b sc', True)+ else do (b', u) <- atHb f c env b+ return (Bind n b' sc', u)+ atH tac c env (App f a) = ulift2 tac c env App f a+ atH tac c env t = return (t, False)++ atHb f c env (Let t v) = ulift2 f c env Let t v+ atHb f c env (Guess t v) = ulift2 f c env Guess t v+ atHb f c env t = do (ty', u) <- atH f c env (binderTy t)+ return (t { binderTy = ty' }, u)++bound_in :: ProofTerm -> [Name]+bound_in (PT path _ tm ups) = bound_in_term (rebuildTerm tm (updateSolvedPath ups path))++bound_in_term :: Term -> [Name]+bound_in_term (Bind n b sc) = n : bi b ++ bound_in_term sc+ where+ bi (Let t v) = bound_in_term t ++ bound_in_term v+ bi (Guess t v) = bound_in_term t ++ bound_in_term v+ bi b = bound_in_term (binderTy b)+bound_in_term (App f a) = bound_in_term f ++ bound_in_term a+bound_in_term _ = []+
src/Idris/Core/TT.hs view
@@ -31,6 +31,8 @@ import qualified Data.Text as T import Data.List import Data.Maybe (listToMaybe)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable) import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import qualified Data.Binary as B@@ -137,6 +139,8 @@ | CantResolveAlts [Name] | IncompleteTerm t | UniverseError+ | UniqueError Universe Name+ | UniqueKindError Universe Name | ProgramLineComment | Inaccessible Name | NonCollapsiblePostulate Name@@ -303,6 +307,7 @@ !-} data SpecialName = WhereN Int Name Name+ | WithN Int Name | InstanceN Name [T.Text] | ParentN Name T.Text | MethodN Name@@ -347,6 +352,7 @@ instance Show SpecialName where show (WhereN i p c) = show p ++ ", " ++ show c+ show (WithN i n) = "with block in " ++ show n show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl show (MethodN m) = "method " ++ show m show (ParentN p c) = show p ++ "#" ++ T.unpack c@@ -362,6 +368,7 @@ showCG (MN i s) = "{" ++ T.unpack s ++ show i ++ "}" showCG (SN s) = showCG' s where showCG' (WhereN i p c) = showCG p ++ ":" ++ showCG c ++ ":" ++ show i+ showCG' (WithN i n) = "_" ++ showCG n ++ "_with_" ++ show i showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst) showCG' (MethodN m) = '!':showCG m showCG' (ParentN p c) = showCG p ++ "#" ++ show c@@ -592,10 +599,19 @@ constDocs (B64V v) = "A vector of sixty-four-bit values" constDocs prim = "Undocumented" +data Universe = NullType | UniqueType | AllTypes+ deriving (Eq, Ord)++instance Show Universe where+ show UniqueType = "UniqueType"+ show NullType = "NullType"+ show AllTypes = "Type*"+ data Raw = Var Name | RBind Name (Binder Raw) Raw | RApp Raw Raw | RType+ | RUType Universe | RForce Raw | RConstant Const deriving (Show, Eq)@@ -605,6 +621,7 @@ size (RBind name bind right) = 1 + size bind + size right size (RApp left right) = 1 + size left + size right size RType = 1+ size (RUType _) = 1 size (RForce raw) = 1 + size raw size (RConstant const) = size const @@ -623,7 +640,8 @@ -- the types of bindings (and their values, if any); the attached identifiers are part -- of the 'Bind' constructor for the 'TT' type. data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}- | Pi { binderTy :: !b }+ | Pi { binderTy :: !b,+ binderKind :: !b } {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -} | Let { binderTy :: !b, binderVal :: b {-^ value for bound variable-}}@@ -638,7 +656,7 @@ | PVar { binderTy :: !b } -- ^ A pattern variable | PVTy { binderTy :: !b }- deriving (Show, Eq, Ord, Functor)+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable) {-! deriving instance Binary Binder deriving instance NFData Binder@@ -646,7 +664,7 @@ instance Sized a => Sized (Binder a) where size (Lam ty) = 1 + size ty- size (Pi ty) = 1 + size ty+ size (Pi ty _) = 1 + size ty size (Let ty val) = 1 + size ty + size val size (NLet ty val) = 1 + size ty + size val size (Hole ty) = 1 + size ty@@ -660,9 +678,9 @@ fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) fmapMB f (Lam t) = liftM Lam (f t)-fmapMB f (Pi t) = liftM Pi (f t)+fmapMB f (Pi t k) = liftM2 Pi (f t) (f k) fmapMB f (Hole t) = liftM Hole (f t)-fmapMB f (GHole i t) = liftM (GHole i) (f t)+fmapMB f (GHole i t) = liftM (GHole i) (f t) fmapMB f (PVar t) = liftM PVar (f t) fmapMB f (PVTy t) = liftM PVTy (f t) @@ -715,7 +733,7 @@ data NameType = Bound | Ref- | DCon {nt_tag :: Int, nt_arity :: Int} -- ^ Data constructor+ | DCon {nt_tag :: Int, nt_arity :: Int, nt_unique :: Bool} -- ^ Data constructor | TCon {nt_tag :: Int, nt_arity :: Int} -- ^ Type constructor deriving (Show, Ord) {-!@@ -732,7 +750,7 @@ instance Eq NameType where Bound == Bound = True Ref == Ref = True- DCon _ a == DCon _ b = (a == b) -- ignore tag+ DCon _ a _ == DCon _ b _ = (a == b) -- ignore tag TCon _ a == TCon _ b = (a == b) -- ignore tag _ == _ = False @@ -751,6 +769,7 @@ | Erased -- ^ an erased term | Impossible -- ^ special case for totality checking | TType UExp -- ^ the type of types at some level+ | UType Universe -- ^ Uniqueness type universe (disjoint from TType) deriving (Ord, Functor) {-! deriving instance Binary TT@@ -800,6 +819,7 @@ data Datatype n = Data { d_typename :: n, d_typetag :: Int, d_type :: (TT n),+ d_unique :: Bool, d_cons :: [(n, TT n)] } deriving (Show, Functor, Eq) @@ -821,11 +841,11 @@ -- constant, the type Type, pi-binding, or an application of an injective -- term. isInjective :: TT n -> Bool-isInjective (P (DCon _ _) _ _) = True+isInjective (P (DCon _ _ _) _ _) = True isInjective (P (TCon _ _) _ _) = True isInjective (Constant _) = True isInjective (TType x) = True-isInjective (Bind _ (Pi _) sc) = True+isInjective (Bind _ (Pi _ _) sc) = True isInjective (App f a) = isInjective f isInjective _ = False @@ -935,17 +955,50 @@ TT n {-^ The replacement term -} -> TT n {-^ The term to replace in -} -> TT n-subst n v tm = instantiate v (pToV n tm)+-- subst n v tm = instantiate v (pToV n tm)+subst n v tm = fst $ subst' 0 tm+ where+ -- keep track of updates to save allocations - this is a big win on+ -- large terms in particular+ -- ('Maybe' would be neater here, but >>= is not the right combinator.+ -- Feel free to tidy up, as long as it still saves allocating when no+ -- substitution happens...)+ subst' i (V x) | i == x = (v, True)+ subst' i (P _ x _) | n == x = (v, True)+ subst' i t@(Bind x b sc) | x /= n+ = let (b', ub) = substB' i b+ (sc', usc) = subst' (i+1) sc in+ if ub || usc then (Bind x b' sc', True) else (t, False) + subst' i t@(App f a) = let (f', uf) = subst' i f + (a', ua) = subst' i a in+ if uf || ua then (App f' a', True) else (t, False)+ subst' i t@(Proj x idx) = let (x', u) = subst' i x in+ if u then (Proj x' idx, u) else (t, False)+ subst' i t = (t, False) + substB' i b@(Let t v) = let (t', ut) = subst' i t + (v', uv) = subst' i v in+ if ut || uv then (Let t' v', True)+ else (b, False)+ substB' i b@(Guess t v) = let (t', ut) = subst' i t + (v', uv) = subst' i v in+ if ut || uv then (Guess t' v', True)+ else (b, False)+ substB' i b = let (ty', u) = subst' i (binderTy b) in+ if u then (b { binderTy = ty' }, u) else (b, False)+ -- If there are no Vs in the term (i.e. in proof state) psubst :: Eq n => n -> TT n -> TT n -> TT n-psubst n v tm = s' tm where- s' (P _ x _) | n == x = v- s' (Bind x b sc) | n == x = Bind x (fmap s' b) sc- | otherwise = Bind x (fmap s' b) (s' sc)- s' (App f a) = App (s' f) (s' a)- s' (Proj t idx) = Proj (s' t) idx- s' t = t+psubst n v tm = s' 0 tm where+ s' i (V x) | x > i = V (x - 1)+ | x == i = v+ | otherwise = V x+ s' i (P _ x _) | n == x = v+ s' i (Bind x b sc) | n == x = Bind x (fmap (s' i) b) sc+ | otherwise = Bind x (fmap (s' i) b) (s' (i+1) sc)+ s' i (App f a) = App (s' i f) (s' i a)+ s' i (Proj t idx) = Proj (s' i t) idx+ s' i t = t -- | As 'subst', but takes a list of (name, substitution) pairs instead -- of a single name and substitution@@ -965,6 +1018,20 @@ st (Bind x b sc) = Bind x (fmap st b) (st sc) st t = t +-- | Return number of occurrences of V 0 or bound name i the term+occurrences :: Eq n => n -> TT n -> Int+occurrences n t = execState (no' 0 t) 0+ where+ no' i (V x) | i == x = do num <- get; put (num + 1)+ no' i (P Bound x _) | n == x = do num <- get; put (num + 1)+ no' i (Bind n b sc) = do noB' i b; no' (i+1) sc+ where noB' i (Let t v) = do no' i t; no' i v+ noB' i (Guess t v) = do no' i t; no' i v+ noB' i b = no' i (binderTy b)+ no' i (App f a) = do no' i f; no' i a+ no' i (Proj x _) = no' i x+ no' i _ = return ()+ -- | Returns true if V 0 and bound name n do not occur in the term noOccurrence :: Eq n => n -> TT n -> Bool noOccurrence n t = no' 0 t@@ -991,7 +1058,7 @@ -- | Return the arity of a (normalised) type arity :: TT n -> Int-arity (Bind n (Pi t) sc) = 1 + arity sc+arity (Bind n (Pi t _) sc) = 1 + arity sc arity _ = 0 -- | Deconstruct an application; returns the function and a list of arguments@@ -1019,18 +1086,18 @@ -- with the corresponding name. It is an error if there are free de -- Bruijn indices. forget :: TT Name -> Raw-forget tm = fe [] tm- where- fe env (P _ n _) = Var n- fe env (V i) = Var (env !! i)- fe env (Bind n b sc) = let n' = uniqueName n env in- RBind n' (fmap (fe env) b)- (fe (n':env) sc)- fe env (App f a) = RApp (fe env f) (fe env a)- fe env (Constant c)- = RConstant c- fe env (TType i) = RType- fe env Erased = RConstant Forgot+forget tm = forgetEnv [] tm+ +forgetEnv env (P _ n _) = Var n+forgetEnv env (V i) = Var (env !! i)+forgetEnv env (Bind n b sc) = let n' = uniqueName n env in+ RBind n' (fmap (forgetEnv env) b)+ (forgetEnv (n':env) sc)+forgetEnv env (App f a) = RApp (forgetEnv env f) (forgetEnv env a)+forgetEnv env (Constant c) = RConstant c+forgetEnv env (TType i) = RType+forgetEnv env (UType u) = RUType u+forgetEnv env Erased = RConstant Forgot -- | Introduce a 'Bind' into the given term for each element of the -- given list of (name, binder) pairs.@@ -1048,13 +1115,13 @@ -- | Return a list of pairs of the names of the outermost 'Pi'-bound -- variables in the given term, together with their types. getArgTys :: TT n -> [(n, TT n)]-getArgTys (Bind n (Pi t) sc) = (n, t) : getArgTys sc+getArgTys (Bind n (Pi t _) sc) = (n, t) : getArgTys sc getArgTys _ = [] getRetTy :: TT n -> TT n getRetTy (Bind n (PVar _) sc) = getRetTy sc getRetTy (Bind n (PVTy _) sc) = getRetTy sc-getRetTy (Bind n (Pi _) sc) = getRetTy sc+getRetTy (Bind n (Pi _ _) sc) = getRetTy sc getRetTy sc = sc uniqueNameFrom :: [Name] -> [Name] -> Name@@ -1087,6 +1154,7 @@ nextName (SN x) = SN (nextName' x) where nextName' (WhereN i f x) = WhereN i f (nextName x)+ nextName' (WithN i n) = WithN i (nextName n) nextName' (CaseN n) = CaseN (nextName n) nextName' (MethodN n) = MethodN (nextName n) @@ -1160,7 +1228,7 @@ else lbracket <+> text (show i) <+> rbracket | otherwise = text "unbound" <+> text (show i) <+> text "!"- prettySe p env (Bind n b@(Pi t) sc) debug+ prettySe p env (Bind n b@(Pi t _) sc) debug | noOccurrence n sc && not debug = bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug prettySe p env (Bind n b sc) debug =@@ -1176,7 +1244,7 @@ -- Render a `Binder` and its name prettySb env n (Lam t) = prettyB env "λ" "=>" n t prettySb env n (Hole t) = prettyB env "?defer" "." n t- prettySb env n (Pi t) = prettyB env "(" ") ->" n t+ prettySb env n (Pi t _) = prettyB env "(" ") ->" n t prettySb env n (PVar t) = prettyB env "pat" "." n t prettySb env n (PVTy t) = prettyB env "pty" "." n t prettySb env n (Let t v) = prettyBv env "let" "in" n t v@@ -1202,8 +1270,10 @@ = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!"- se p env (Bind n b@(Pi t) sc)- | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc+ se p env (Bind n b@(Pi t k) sc)+ | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc+ where arrow (TType _) = " -> "+ arrow u = " [" ++ show u ++ "] -> " se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a se p env (Proj x i) = se 1 env x ++ "!" ++ show i@@ -1211,11 +1281,12 @@ se p env Erased = "[__]" se p env Impossible = "[impossible]" se p env (TType i) = "Type " ++ show i+ se p env (UType u) = show u sb env n (Lam t) = showb env "\\ " " => " n t sb env n (Hole t) = showb env "? " ". " n t sb env n (GHole i t) = showb env "?defer " ". " n t- sb env n (Pi t) = showb env "(" ") -> " n t+ sb env n (Pi t _) = showb env "(" ") -> " n t sb env n (PVar t) = showb env "pat " ". " n t sb env n (PVTy t) = showb env "pty " ". " n t sb env n (Let t v) = showbv env "let " " in " n t v@@ -1275,7 +1346,7 @@ op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc- op ps (Bind n (Pi t) sc) = op ((n, Pi t) : ps) sc+ op ps (Bind n (Pi t k) sc) = op ((n, Pi t k) : ps) sc op ps sc = bindAll (sortP ps) sc sortP ps = pick [] (reverse ps)@@ -1320,9 +1391,10 @@ v' <- getPats v sc' <- getPats sc return (Bind n (Let t' v') sc')- getPats (Bind n (Pi t) sc) = do t' <- getPats t- sc' <- getPats sc- return (Bind n (Pi t') sc')+ getPats (Bind n (Pi t k) sc) = do t' <- getPats t+ k' <- getPats k+ sc' <- getPats sc+ return (Bind n (Pi t' k') sc') getPats (Bind n (Lam t) sc) = do t' <- getPats t sc' <- getPats sc return (Bind n (Lam t') sc')
src/Idris/Core/Typecheck.hs view
@@ -47,63 +47,73 @@ isType :: Context -> Env -> Term -> TC () isType ctxt env tm = isType' (normalise ctxt env tm)- where isType' (TType _) = return ()- isType' tm = fail (showEnv env tm ++ " is not a TType")+ where isType' tm | isUniverse tm = return ()+ | otherwise = fail (showEnv env tm ++ " is not a Type") recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs)-recheck ctxt env tm orig+recheck = recheck_borrowing False []++recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term -> + TC (Term, Type, UCs)+recheck_borrowing uniq_check bs ctxt env tm orig = let v = next_tvar ctxt in case runStateT (check' False ctxt env tm) (v, []) of -- holes banned Error (IncompleteTerm _) -> Error $ IncompleteTerm orig Error e -> Error e OK ((tm, ty), constraints) ->- return (tm, ty, constraints)+ do when uniq_check $ checkUnique bs ctxt env tm+ return (tm, ty, constraints) check :: Context -> Env -> Raw -> TC (Term, Type)-check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed+check ctxt env tm + = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)-check' holes ctxt env top = chk env top where- chk env (Var n)+check' holes ctxt env top = chk (TType (UVar (-5))) env top where++ smaller (UType NullType) _ = UType NullType+ smaller _ (UType NullType) = UType NullType+ smaller (UType u) _ = UType u+ smaller _ (UType u) = UType u+ smaller x _ = x++ chk :: Type -> -- uniqueness level+ Env -> Raw -> StateT UCs TC (Term, Type)+ chk u env (Var n) | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty) | (P nt n' ty : _) <- lookupP n ctxt = return (P nt n' ty, ty) | otherwise = do lift $ tfail $ NoSuchVariable n- chk env (RApp f a)- = do (fv, fty) <- chk env f- (av, aty) <- chk env a+ chk u env ap@(RApp f a)+ = do (fv, fty) <- chk u env f+ (av, aty) <- chk u env a let fty' = case uniqueBinders (map fst env) (finalise fty) of- ty@(Bind x (Pi s) t) -> ty+ ty@(Bind x (Pi s k) t) -> ty _ -> uniqueBinders (map fst env) $ case hnf ctxt env fty of- ty@(Bind x (Pi s) t) -> ty+ ty@(Bind x (Pi s k) t) -> ty _ -> normalise ctxt env fty case fty' of- Bind x (Pi s) t ->--- trace ("Converting " ++ show aty ++ " and " ++ show s ++--- " from " ++ show fv ++ " : " ++ show fty) $+ Bind x (Pi s k) t -> do convertsC ctxt env aty s- -- let apty = normalise initContext env- -- (Bind x (Let aty av) t) let apty = simplify initContext env (Bind x (Let aty av) t) return (App fv av, apty)- t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type"- -- This rather unpleasant hack is needed because during incomplete- -- proofs, variables are locally bound with an explicit name. If we just- -- make sure bound names in function types are locally unique, machine- -- generated names, we'll be fine.- -- NOTE: now replaced with 'uniqueBinders' above- where renameBinders i (Bind x (Pi s) t) = Bind (sMN i "binder") (Pi s)- (renameBinders (i+1) t)- renameBinders i sc = sc- chk env RType+ t -> lift $ tfail $ NonFunctionType fv fty + chk u env RType | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get let c = ULT (UVar v) (UVar (v+1)) put (v+2, (c:cs)) return (TType (UVar v), TType (UVar (v+1)))- chk env (RConstant Forgot) = return (Erased, Erased)- chk env (RConstant c) = return (Constant c, constType c)+ chk u env (RUType un)+ | holes = return (UType un, TType (UVal 0))+ | otherwise = do -- TODO! (v, cs) <- get+ -- let c = ULT (UVar v) (UVar (v+1))+ -- put (v+2, (c:cs))+ -- return (TType (UVar v), TType (UVar (v+1)))+ return (UType un, TType (UVal 0))+ chk u env (RConstant Forgot) = return (Erased, Erased)+ chk u env (RConstant c) = return (Constant c, constType c) where constType (I _) = Constant (AType (ATInt ITNative)) constType (BI _) = Constant (AType (ATInt ITBig)) constType (Fl _) = Constant (AType ATFloat)@@ -119,103 +129,188 @@ constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a)))) constType Forgot = Erased constType _ = TType (UVal 0)- chk env (RForce t) = do (_, ty) <- chk env t- return (Erased, ty)- chk env (RBind n (Pi s) t)- = do (sv, st) <- chk env s- (tv, tt) <- chk ((n, Pi sv) : env) t+ chk u env (RForce t) = do (_, ty) <- chk u env t+ return (Erased, ty)+ chk u env (RBind n (Pi s k) t)+ = do (sv, st) <- chk u env s+ (kv, kt) <- chk u env k+ (tv, tt) <- chk st ((n, Pi sv kv) : env) t+-- let tv = mkUniquePi kv tv_in (v, cs) <- get- let TType su = normalise ctxt env st- let TType tu = normalise ctxt env tt- when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs)- return (Bind n (Pi (uniqueBinders (map fst env) sv))- (pToV n tv), TType (UVar v))- chk env (RBind n b sc)- = do b' <- checkBinder b- (scv, sct) <- chk ((n, b'):env) sc- discharge n b' (pToV n scv) (pToV n sct)+ case (normalise ctxt env st, normalise ctxt env tt) of+ (TType su, TType tu) -> do+ when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs)+ let k' = st `smaller` kv `smaller` TType (UVar v) `smaller` u+ return (Bind n (Pi (uniqueBinders (map fst env) sv) k')+ (pToV n tv), k')+ (un, un') ->+ let k' = st `smaller` kv `smaller` un `smaller` un' `smaller` u in+ return (Bind n (Pi (uniqueBinders (map fst env) sv) k')+ (pToV n tv), k')++ where mkUniquePi kv (Bind n (Pi s k) sc) + = let k' = smaller kv k in+ Bind n (Pi s k') (mkUniquePi k' sc)+ mkUniquePi kv (Bind n (Lam t) sc) + = Bind n (Lam (mkUniquePi kv t)) (mkUniquePi kv sc)+ mkUniquePi kv (Bind n (Let t v) sc) + = Bind n (Let (mkUniquePi kv t) v) (mkUniquePi kv sc)+ mkUniquePi kv t = t++ -- Kind of the whole thing is the kind of the most unique thing+ -- in the environment (because uniqueness taints everything...)+ mostUnique [] k = k+ mostUnique (Pi _ pk : es) k = mostUnique es (smaller pk k)+ mostUnique (_ : es) k = mostUnique es k++ chk u env (RBind n b sc)+ = do (b', bt') <- checkBinder b+ (scv, sct) <- chk (smaller bt' u) ((n, b'):env) sc+ discharge n b' bt' (pToV n scv) (pToV n sct) where checkBinder (Lam t)- = do (tv, tt) <- chk env t- let tv' = normalise ctxt env tv- let tt' = normalise ctxt env tt- lift $ isType ctxt env tt'- return (Lam tv)- checkBinder (Pi t)- = do (tv, tt) <- chk env t+ = do (tv, tt) <- chk u env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt'- return (Pi tv)+ return (Lam tv, tt') checkBinder (Let t v)- = do (tv, tt) <- chk env t- (vv, vt) <- chk env v+ = do (tv, tt) <- chk u env t+ (vv, vt) <- chk u env v let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv lift $ isType ctxt env tt'- return (Let tv vv)+ return (Let tv vv, tt') checkBinder (NLet t v)- = do (tv, tt) <- chk env t- (vv, vt) <- chk env v+ = do (tv, tt) <- chk u env t+ (vv, vt) <- chk u env v let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv lift $ isType ctxt env tt'- return (NLet tv vv)+ return (NLet tv vv, tt') checkBinder (Hole t) | not holes = lift $ tfail (IncompleteTerm undefined) | otherwise- = do (tv, tt) <- chk env t+ = do (tv, tt) <- chk u env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt'- return (Hole tv)+ return (Hole tv, tt') checkBinder (GHole i t)- = do (tv, tt) <- chk env t+ = do (tv, tt) <- chk u env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt'- return (GHole i tv)+ return (GHole i tv, tt') checkBinder (Guess t v) | not holes = lift $ tfail (IncompleteTerm undefined) | otherwise- = do (tv, tt) <- chk env t- (vv, vt) <- chk env v+ = do (tv, tt) <- chk u env t+ (vv, vt) <- chk u env v let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv lift $ isType ctxt env tt'- return (Guess tv vv)+ return (Guess tv vv, tt') checkBinder (PVar t)- = do (tv, tt) <- chk env t+ = do (tv, tt) <- chk u env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt' -- Normalised version, for erasure purposes (it's easier -- to tell if it's a collapsible variable)- return (PVar tv)+ return (PVar tv, tt') checkBinder (PVTy t)- = do (tv, tt) <- chk env t+ = do (tv, tt) <- chk u env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt lift $ isType ctxt env tt'- return (PVTy tv)+ return (PVTy tv, tt') - discharge n (Lam t) scv sct- = return (Bind n (Lam t) scv, Bind n (Pi t) sct)- discharge n (Pi t) scv sct- = return (Bind n (Pi t) scv, sct)- discharge n (Let t v) scv sct+ discharge n (Lam t) bt scv sct+ = return (Bind n (Lam t) scv, Bind n (Pi t bt) sct)+ discharge n (Pi t k) bt scv sct+ = return (Bind n (Pi t k) scv, sct)+ discharge n (Let t v) bt scv sct = return (Bind n (Let t v) scv, Bind n (Let t v) sct)- discharge n (NLet t v) scv sct+ discharge n (NLet t v) bt scv sct = return (Bind n (NLet t v) scv, Bind n (Let t v) sct)- discharge n (Hole t) scv sct+ discharge n (Hole t) bt scv sct = return (Bind n (Hole t) scv, sct)- discharge n (GHole i t) scv sct+ discharge n (GHole i t) bt scv sct = return (Bind n (GHole i t) scv, sct)- discharge n (Guess t v) scv sct+ discharge n (Guess t v) bt scv sct = return (Bind n (Guess t v) scv, sct)- discharge n (PVar t) scv sct+ discharge n (PVar t) bt scv sct = return (Bind n (PVar t) scv, Bind n (PVTy t) sct)- discharge n (PVTy t) scv sct+ discharge n (PVTy t) bt scv sct = return (Bind n (PVTy t) scv, sct)++-- Number of times a name can be used+data UniqueUse = Never -- no more times+ | Once -- at most once more+ | LendOnly -- only under 'lend'+ | Many -- unlimited+ deriving Eq++-- If any binders are of kind 'UniqueType' or 'AllTypes' and the name appears+-- in the scope more than once, this is an error.+checkUnique :: [Name] -> Context -> Env -> Term -> TC ()+checkUnique borrowed ctxt env tm + = evalStateT (chkBinders env (explicitNames tm)) []+ where + isVar (P _ _ _) = True+ isVar (V _) = True+ isVar _ = False++ chkBinders :: Env -> Term -> StateT [(Name, (UniqueUse, Universe))] TC ()+ chkBinders env (V i) | length env > i = chkName (fst (env!!i))+ chkBinders env (P _ n _) = chkName n+ -- 'lending' a unique or nulltype variable doesn't count as a use,+ -- but we still can't lend something that's already been used.+ chkBinders env (App (App (P _ (NS (UN lend) [owner]) _) t) a)+ | isVar a && owner == txt "Ownership" &&+ (lend == txt "lend" || lend == txt "Read")+ = do chkBinders env t -- Check the type normally + st <- get+ -- Remove the 'LendOnly' names from the unusable set+ put (filter (\(n, (ok, _)) -> ok /= LendOnly) st) + chkBinders env a+ put st -- Reset the old state after checking the argument+ chkBinders env (App f a) = do chkBinders env f; chkBinders env a+ chkBinders env (Bind n b t)+ = do chkBinderName env n b+ st <- get+ case b of+ Let t v -> chkBinders env v+ _ -> return ()+ chkBinders ((n, b) : env) t+ chkBinders env t = return ()++ chkBinderName :: Env -> Name -> Binder Term -> + StateT [(Name, (UniqueUse, Universe))] TC ()+ chkBinderName env n b+ = do let rawty = forgetEnv (map fst env) (binderTy b)+ (_, kind) <- lift $ check ctxt env rawty -- FIXME: Cache in binder?+ case kind of+ UType UniqueType -> do ns <- get+ if n `elem` borrowed + then put ((n, (LendOnly, NullType)) : ns)+ else put ((n, (Once, UniqueType)) : ns)+ UType NullType -> do ns <- get+ put ((n, (Many, NullType)) : ns)+ UType AllTypes -> do ns <- get+ put ((n, (Once, AllTypes)) : ns)+ _ -> return ()++ chkName n + = do ns <- get+ case lookup n ns of+ Nothing -> return ()+ Just (Many, k) -> return ()+ Just (Never, k) -> lift $ tfail (UniqueError k n)+ Just (LendOnly, k) -> lift $ tfail (UniqueError k n)+ Just (Once, k) -> put ((n, (Never, k)) : + filter (\x -> fst x /= n) ns)+
src/Idris/Core/Unify.hs view
@@ -84,13 +84,13 @@ -- but it scares me. However, matching is never guaranteed to give a unique -- answer, merely a valid one, so perhaps we're okay. -- In other words: it may vanish without warning some day :)- un names x tm@(App (P _ f (Bind fn (Pi t) sc)) a)- | (P (DCon _ _) _ _, _) <- unApply x,+ un names x tm@(App (P _ f (Bind fn (Pi t _) sc)) a)+ | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes = let n' = uniqueName (sMN 0 "mv") (map fst env) in checkCycle names (f, Bind n' (Lam t) x) - un names tm@(App (P _ f (Bind fn (Pi t) sc)) a) x- | (P (DCon _ _) _ _, _) <- unApply x,+ un names tm@(App (P _ f (Bind fn (Pi t _) sc)) a) x+ | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes = let n' = uniqueName fn (map fst env) in checkCycle names (f, Bind n' (Lam t) x) @@ -133,7 +133,7 @@ h2 <- un bnames vx vy combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = un bnames tx ty- uB bnames (Pi tx) (Pi ty) = un bnames tx ty+ uB bnames (Pi tx _) (Pi ty _) = un bnames tx ty uB bnames x y = do UI s f <- get let r = recoverable (normalise ctxt env (binderTy x)) (normalise ctxt env (binderTy y))@@ -265,11 +265,11 @@ -- Error e@(CantUnify False _ _ _ _ _) -> tfail e Error e -> tfail e where- headDiff (P (DCon _ _) x _) (P (DCon _ _) y _) = x /= y+ headDiff (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x /= y headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y headDiff _ _ = False - injective (P (DCon _ _) _ _) = True+ injective (P (DCon _ _ _) _ _) = True injective (P (TCon _ _) _ _) = True -- injective (App f (P _ _ _)) = injective f -- injective (App f (Constant _)) = injective f@@ -315,13 +315,13 @@ StateT UInfo TC [(Name, TT Name)] un' fn names x y | x == y = return [] -- shortcut- un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _)+ un' fn names topx@(P (DCon _ _ _) x _) topy@(P (DCon _ _ _) y _) | x /= y = unifyFail topx topy un' fn names topx@(P (TCon _ _) x _) topy@(P (TCon _ _) y _) | x /= y = unifyFail topx topy- un' fn names topx@(P (DCon _ _) x _) topy@(P (TCon _ _) y _)+ un' fn names topx@(P (DCon _ _ _) x _) topy@(P (TCon _ _) y _) = unifyFail topx topy- un' fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _) y _)+ un' fn names topx@(P (TCon _ _) x _) topy@(P (DCon _ _ _) y _) = unifyFail topx topy un' fn names topx@(Constant _) topy@(P (TCon _ _) y _) = unifyFail topx topy@@ -333,6 +333,15 @@ = unifyTmpFail tx ty | injective ty && not (holeIn env x || x `elem` holes) = unifyTmpFail tx ty+ -- pick the one bound earliest if both are holes+ | tx /= ty && (holeIn env x || x `elem` holes)+ && (holeIn env y || y `elem` holes)+ = case compare (envPos 0 x env) (envPos 0 y env) of+ LT -> do sc 1; checkCycle bnames (x, ty)+ _ -> do sc 1; checkCycle bnames (y, tx)+ where envPos i n ((n',_):env) | n == n' = i+ envPos i n (_:env) = envPos (i+1) n env+ envPos _ _ _ = 100000 un' fn bnames xtm@(P _ x _) tm | pureTerm tm, holeIn env x || x `elem` holes = do UI s f <- get@@ -394,18 +403,18 @@ -- f D unifies with t -> D. This is dubious, but it helps with type -- class resolution for type classes over functions. - un' fn bnames (App f x) (Bind n (Pi t) y)+ un' fn bnames (App f x) (Bind n (Pi t k) y) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames x y uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t) (V 1)))+ (Bind n (Pi t k) (V 1))) combine bnames ux uf - un' fn bnames (Bind n (Pi t) y) (App f x)+ un' fn bnames (Bind n (Pi t k) y) (App f x) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames y x uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t) (V 1))) f+ (Bind n (Pi t k) (V 1))) f combine bnames ux uf un' fn bnames (Bind x bx sx) (Bind y by sy)@@ -414,10 +423,11 @@ h2 <- un' False (((x,y),binderTy bx):bnames) sx sy combine bnames h1 h2 where sameBinder (Lam _) (Lam _) = True- sameBinder (Pi _) (Pi _) = True+ sameBinder (Pi _ _) (Pi _ _) = True sameBinder _ _ = False un' fn bnames x y | OK True <- convEq' ctxt holes x y = do sc 1; return []+ | isUniverse x && isUniverse y = do sc 1; return [] | otherwise = do UI s f <- get let r = recoverable (normalise ctxt env x) (normalise ctxt env y)@@ -451,13 +461,13 @@ | otherwise = unifyTmpFail appx appy where hnormalise [] _ _ t = t hnormalise ns ctxt env t = normalise ctxt env t- checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _)+ checkHeads (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) | x /= y = unifyFail appx appy checkHeads (P (TCon _ _) x _) (P (TCon _ _) y _) | x /= y = unifyFail appx appy- checkHeads (P (DCon _ _) x _) (P (TCon _ _) y _)+ checkHeads (P (DCon _ _ _) x _) (P (TCon _ _) y _) = unifyFail appx appy- checkHeads (P (TCon _ _) x _) (P (DCon _ _) y _)+ checkHeads (P (TCon _ _) x _) (P (DCon _ _ _) y _) = unifyFail appx appy checkHeads _ _ = return [] @@ -483,7 +493,7 @@ all (\x -> pat x || metavar x) (f : args) && nub args == args - rigid (P (DCon _ _) _ _) = True+ rigid (P (DCon _ _ _) _ _) = True rigid (P (TCon _ _) _ _) = True rigid t@(P Ref _ _) = inenv t || globmetavar t rigid (Constant _) = True@@ -541,7 +551,7 @@ sc 1 combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty- uB bnames (Pi tx) (Pi ty) = do sc 1; un' False bnames tx ty+ uB bnames (Pi tx _) (Pi ty _) = do sc 1; un' False bnames tx ty uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty uB bnames x y = do UI s f <- get@@ -623,15 +633,15 @@ | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable _ t@(App _ _) | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False-recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) = x == y+recoverable (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x == y recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y-recoverable (Constant _) (P (DCon _ _) y _) = False+recoverable (Constant _) (P (DCon _ _ _) y _) = False recoverable (Constant x) (Constant y) = x == y-recoverable (P (DCon _ _) x _) (Constant _) = False+recoverable (P (DCon _ _ _) x _) (Constant _) = False recoverable (Constant _) (P (TCon _ _) y _) = False recoverable (P (TCon _ _) x _) (Constant _) = False-recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False-recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False+recoverable (P (DCon _ _ _) x _) (P (TCon _ _) y _) = False+recoverable (P (TCon _ _) x _) (P (DCon _ _ _) y _) = False recoverable p@(Constant _) (App f a) = recoverable p f recoverable (App f a) p@(Constant _) = recoverable f p recoverable p@(P _ n _) (App f a) = recoverable p f@@ -640,11 +650,11 @@ | f == f' = recoverable a a' recoverable (App f a) (App f' a') = recoverable f f' -- && recoverable a a'-recoverable f (Bind _ (Pi _) sc)- | (P (DCon _ _) _ _, _) <- unApply f = False+recoverable f (Bind _ (Pi _ _) sc)+ | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False-recoverable (Bind _ (Pi _) sc) f- | (P (DCon _ _) _ _, _) <- unApply f = False+recoverable (Bind _ (Pi _ _) sc) f+ | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f recoverable f (Bind _ (Lam _) sc) = recoverable f sc
src/Idris/Coverage.hs view
@@ -206,7 +206,7 @@ otherPats arg = return Placeholder ops fc n xs o- | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)+ | (TyDecl c@(DCon _ arity _) ty : _) <- lookupDef n (tt_ctxt i) = do xs' <- mapM otherPats (map getExpTm xs) let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs)) let tyn = getTy n (tt_ctxt i)@@ -283,12 +283,12 @@ where args t = [0..length (getArgTys t)-1] - cp (Bind n (Pi aty) sc) = posArg aty && cp sc+ cp (Bind n (Pi aty _) sc) = posArg aty && cp sc cp t | (P _ n' _, args) <- unApply t, n' `elem` mut_ns = all noRec args cp _ = True - posArg (Bind _ (Pi nty) sc)+ posArg (Bind _ (Pi nty _) sc) | (P _ n' _, args) <- unApply nty = n' `notElem` mut_ns && all noRec args && posArg sc posArg t | (P _ n' _, args) <- unApply t,@@ -341,7 +341,7 @@ return (and ok) _ -> return True -- defined elsewhere, can't call topn - cotype (DCon _ _) n ty+ cotype (DCon _ _ _) n ty | (P _ t _, _) <- unApply (getRetTy ty) = case lookupCtxt t (idris_datatypes i) of [TI _ True _ _ _] -> True@@ -391,7 +391,7 @@ setTotality n t' addIBC (IBCTotal n t') return t'- [TyDecl (DCon _ _) ty] ->+ [TyDecl (DCon _ _ _) ty] -> case unApply (getRetTy ty) of (P _ tyn _, _) -> do let ms = case lookupCtxt tyn (idris_datatypes i) of@@ -531,8 +531,8 @@ = case lookupTy n (tt_ctxt ist) of [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args _ -> args- where expand i (Bind n (Pi _) sc) (x : xs) = x : expand (i + 1) sc xs- expand i (Bind n (Pi _) sc) [] = Just (i, Same) : expand (i + 1) sc []+ where expand i (Bind n (Pi _ _) sc) (x : xs) = x : expand (i + 1) sc xs+ expand i (Bind n (Pi _ _) sc) [] = Just (i, Same) : expand (i + 1) sc [] expand i _ xs = xs mkChange n args pargs = [(n, expandToArity n (sizes args))]@@ -558,7 +558,7 @@ | a == t = isInductive (fst (unApply (getRetTy tyn))) (fst (unApply (getRetTy tyt))) smaller ty a (ap@(App f s), _)- | (P (DCon _ _) n _, args) <- unApply ap+ | (P (DCon _ _ _) n _, args) <- unApply ap = let tyn = getType n in any (smaller (ty `mplus` Just tyn) a) (zip args (map toJust (getArgTys tyn)))@@ -652,7 +652,7 @@ -- = Partial BelieveMe -- if we get to a constructor, it's fine as long as it's strictly positive tryPath desc path ((f, _) : es) arg- | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist)+ | [TyDecl (DCon _ _ _) _] <- lookupDef f (tt_ctxt ist) = case lookupTotal f (tt_ctxt ist) of [Total _] -> Unchecked -- okay so far [Partial _] -> Partial (Other [f])
src/Idris/DataOpts.hs view
@@ -72,19 +72,19 @@ applyOpts (P _ (NS (UN fn) mod) _) | fn == txt "toIntegerNat" && mod == prel = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)- applyOpts c@(P (DCon t arity) n _)- = return $ applyDataOptRT n t arity []+ applyOpts c@(P (DCon t arity uniq) n _)+ = return $ applyDataOptRT n t arity uniq [] applyOpts t@(App f a)- | (c@(P (DCon t arity) n _), args) <- unApply t- = applyDataOptRT n t arity <$> mapM applyOpts args+ | (c@(P (DCon t arity uniq) n _), args) <- unApply t+ = applyDataOptRT n t arity uniq <$> mapM applyOpts args | otherwise = App <$> applyOpts f <*> applyOpts a applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i applyOpts t = return t -- Need to saturate arguments first to ensure that optimisation happens uniformly-applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term-applyDataOptRT n tag arity args+applyDataOptRT :: Name -> Int -> Int -> Bool -> [Term] -> Term+applyDataOptRT n tag arity uniq args | length args == arity = doOpts n args | otherwise = let extra = satArgs (arity - length args) tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)@@ -104,4 +104,5 @@ | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude" = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1)) - doOpts n args = mkApp (P (DCon tag arity) n Erased) args+ doOpts n args = mkApp (P (DCon tag arity uniq) n Erased) args+
src/Idris/DeepSeq.hs view
@@ -214,6 +214,7 @@ rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PHidden x1) = rnf x1 `seq` () rnf PType = ()+ rnf (PUniverse _) = () rnf (PGoal x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (PConstant x1) = x1 `seq` ()
src/Idris/Delaborate.hs view
@@ -58,18 +58,18 @@ _ -> PRef un n de env _ (Bind n (Lam ty) sc) = PLam n (de env [] ty) (de ((n,n):env) [] sc)- de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)+ de env ((PImp { argopts = opts }):is) (Bind n (Pi ty _) sc) = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)- de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)+ de env (PConstraint _ _ _ _:is) (Bind n (Pi ty _) sc) = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)- de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty) sc)+ de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty _) sc) = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)- de env (plic:is) (Bind n (Pi ty) sc)+ de env (plic:is) (Bind n (Pi ty _) sc) = PPi (Exp (argopts plic) Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)- de env [] (Bind n (Pi ty) sc)+ de env [] (Bind n (Pi ty _) sc) = PPi expl n (de env [] ty) (de ((n,n):env) [] sc) de env _ (Bind n (Let ty val) sc) = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)@@ -80,6 +80,7 @@ de env _ Erased = Placeholder de env _ Impossible = Placeholder de env _ (TType i) = PType+ de env _ (UType u) = PUniverse u dens x | fullname = x dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of@@ -182,10 +183,18 @@ if (opt_errContext (idris_options i)) then showSc i sc else empty pprintErr' i (CantConvert x y env) = text "Can't convert" <>- indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x))) <$>+ indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + (delab i (flagUnique x)))) <$> text "with" <>- indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i y))) <>+ indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + (delab i (flagUnique y)))) <> if (opt_errContext (idris_options i)) then line <> showSc i env else empty+ where flagUnique (Bind n (Pi t k@(UType u)) sc)+ = App (P Ref (sUN (show u)) Erased)+ (Bind n (Pi (flagUnique t) k) (flagUnique sc))+ flagUnique (App f a) = App (flagUnique f) (flagUnique a)+ flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)+ flagUnique t = t pprintErr' i (CantSolveGoal x env) = text "Can't solve goal " <> indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x))) <>@@ -223,6 +232,14 @@ pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i UniverseError = text "Universe inconsistency"+pprintErr' i (UniqueError NullType n) + = text "Borrowed name" <+> annName' n (showbasic n)+ <+> text "must not be used on RHS"+pprintErr' i (UniqueError _ n) = text "Unique name" <+> annName' n (showbasic n)+ <+> text "is used more than once"+pprintErr' i (UniqueKindError k n) = text "Constructor" <+> annName' n (showbasic n)+ <+> text ("has a " ++ show k ++ ",")+ <+> text "but the data type does not" pprintErr' i ProgramLineComment = text "Program line next to comment" pprintErr' i (Inaccessible n) = annName n <+> text "is not an accessible pattern variable" pprintErr' i (NonCollapsiblePostulate n) = text "The return type of postulate" <+>
src/Idris/Elab/Clause.hs view
@@ -248,7 +248,7 @@ force (normalisePats ctxt [] y)) simple_lhs ctxt t = t - simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p + simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p (rt_simplify ctxt [] y))) -- this is so pattern types are in the right form for erasure@@ -422,55 +422,6 @@ | Ref <- y = True | otherwise = False -- name is different, unrecoverable -getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)- = nub $ getFixedInType i env [] t ++- getFixedInType i (n : env) is (instantiate (P Bound n t) sc)-getFixedInType i env (_ : is) (Bind n (Pi t) sc)- = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)-getFixedInType i env is tm@(App f a)- | (P _ tn _, args) <- unApply tm- = case lookupCtxt tn (idris_datatypes i) of- [t] -> nub $ paramNames args env (param_pos t) ++- getFixedInType i env is f ++- getFixedInType i env is a- [] -> nub $ getFixedInType i env is f ++- getFixedInType i env is a- | otherwise = nub $ getFixedInType i env is f ++- getFixedInType i env is a-getFixedInType i _ _ _ = []--getFlexInType i env ps (Bind n (Pi t) sc)- = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++- getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)-getFlexInType i env ps tm@(App f a)- | (P _ tn _, args) <- unApply tm- = case lookupCtxt tn (idris_datatypes i) of- [t] -> nub $ paramNames args env [x | x <- [0..length args],- not (x `elem` param_pos t)] - ++ getFlexInType i env ps f ++- getFlexInType i env ps a- [] -> nub $ getFlexInType i env ps f ++- getFlexInType i env ps a- | otherwise = nub $ getFlexInType i env ps f ++- getFlexInType i env ps a-getFlexInType i _ _ _ = []---- Treat a name as a parameter if it appears in parameter positions in--- types, and never in a non-parameter position in a (non-param) argument type.--getParamsInType i env ps t = let fix = getFixedInType i env ps t- flex = getFlexInType i env fix t in- [x | x <- fix, not (x `elem` flex)]--paramNames args env [] = []-paramNames args env (p : ps)- | length args > p = case args!!p of- P _ n _ -> if n `elem` env- then n : paramNames args env ps- else paramNames args env ps- _ -> paramNames args env ps- | otherwise = paramNames args env ps- propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm propagateParams i ps t tm@(PApp _ (PRef fc n) args) = PApp fc (PRef fc n) (addP t args)@@ -491,6 +442,18 @@ isImplicit (_ : is) n = isImplicit is n propagateParams i ps t x = x +findUnique :: Context -> Env -> Term -> [Name]+findUnique ctxt env (Bind n b sc)+ = let rawTy = forgetEnv (map fst env) (binderTy b)+ uniq = case check ctxt env rawTy of+ OK (_, UType UniqueType) -> True+ OK (_, UType NullType) -> True+ OK (_, UType AllTypes) -> True+ _ -> False in+ if uniq then n : findUnique ctxt ((n, b) : env) sc+ else findUnique ctxt ((n, b) : env) sc+findUnique _ _ _ = []+ -- Return the elaborated LHS/RHS, and the original LHS with implicits added elabClause :: ElabInfo -> FnOpts -> (Int, PClause) -> Idris (Either Term (Term, Term), PTerm)@@ -548,6 +511,13 @@ then recheckC fc [] lhs_tm else return (lhs_tm, lhs_ty) let clhs = normalise ctxt [] clhs_c+ let borrowed = borrowedNames [] clhs++ -- These are the names we're not allowed to use on the RHS, because+ -- they're UniqueTypes and borrowed from another function.+ -- FIXME: There is surely a nicer way than this...+ when (not (null borrowed)) $+ logLvl 5 ("Borrowed names on LHS: " ++ show borrowed) logLvl 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs)) @@ -562,7 +532,14 @@ windex <- getName let decls = nub (concatMap declared whereblock) let defs = nub (decls ++ concatMap defined whereblock)- let newargs = pvars ist lhs_tm+ let newargs_all = pvars ist lhs_tm++ -- Unique arguments must be passed to the where block explicitly+ -- (since we can't control "usage" easlily otherwise). Remove them+ -- from newargs here+ let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm+ let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all+ let winfo = pinfo info newargs defs windex let wb = map (expandParamsD False ist decorate newargs defs) whereblock @@ -621,8 +598,9 @@ ctxt <- getContext logLvl 5 $ "Rechecking" logLvl 6 $ " ==> " ++ show (forget rhs')+ (crhs, crhsty) <- if not inf - then recheckC fc [] rhs'+ then recheckC_borrowing True borrowed fc [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty case converts ctxt [] clhsty crhsty of@@ -659,6 +637,22 @@ -- _ -> MN i (show n)) . l } + -- Find the variable names which appear under a 'Ownership.Read' so that+ -- we know they can't be used on the RHS+ borrowedNames :: [Name] -> Term -> [Name]+ borrowedNames env (App (App (P _ (NS (UN lend) [owner]) _) _) arg)+ | owner == txt "Ownership" && + (lend == txt "lend" || lend == txt "Read") = getVs arg+ where+ getVs (V i) = [env!!i]+ getVs (App f a) = nub $ getVs f ++ getVs a+ getVs _ = []+ borrowedNames env (App f a) = nub $ borrowedNames env f ++ borrowedNames env a+ borrowedNames env (Bind n b sc) = nub $ borrowedB b ++ borrowedNames (n:env) sc+ where borrowedB (Let t v) = nub $ borrowedNames env t ++ borrowedNames env v+ borrowedB b = borrowedNames env (binderTy b)+ borrowedNames _ _ = []+ mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t [] mkLHSapp t = t @@ -766,12 +760,12 @@ let wargval = getRetTy cwvalN let wargtype = getRetTy cwvaltyN logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)- let wtype = bindTyArgs Pi (bargs_pre +++ let wtype = bindTyArgs (flip Pi (TType (UVar 0))) (bargs_pre ++ (sMN 0 "warg", wargtype) : map (abstract (sMN 0 "warg") wargval wargtype) bargs_post) (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty) logLvl 5 ("New function type " ++ show wtype)- let wname = sMN windex (show fname)+ let wname = SN (WithN windex fname) let imps = getImps wtype -- add to implicits context putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })@@ -814,7 +808,7 @@ (crhs, crhsty) <- recheckC fc [] rhs' return $ (Right (clhs, crhs), lhs) where- getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t+ getImps (Bind n (Pi _ _) t) = pexp Placeholder : getImps t getImps _ = [] mkAuxC wname lhs ns ns' (PClauses fc o n cs)
src/Idris/Elab/Data.hs view
@@ -54,7 +54,7 @@ = do let codata = Codata `elem` opts iLOG (show (fc, doc)) checkUndefined fc n- (cty, t, inacc) <- buildType info syn fc [] n t_in+ (cty, _, t, inacc) <- buildType info syn fc [] n t_in addIBC (IBCDef n) updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons@@ -63,7 +63,7 @@ = do let codata = Codata `elem` opts iLOG (show fc) undef <- isUndefined fc n- (cty, t, inacc) <- buildType info syn fc [] n t_in+ (cty, _, t, inacc) <- buildType info syn fc [] n t_in -- if n is defined already, make sure it is just a type declaration -- with the same type we've just elaborated i <- getIState@@ -71,7 +71,10 @@ -- temporary, to check cons when undef $ updateContext (addTyDecl n (TCon 0 0) cty) let cnameinfo = cinfo info (map cname dcons)- cons <- mapM (elabCon cnameinfo syn n codata) dcons+ let unique = case getRetTy cty of+ UType UniqueType -> True+ _ -> False+ cons <- mapM (elabCon cnameinfo syn n codata (getRetTy cty)) dcons ttag <- getName i <- getIState let as = map (const Nothing) (getArgTys cty)@@ -90,7 +93,7 @@ let metainf = DataMI params addIBC (IBCMetaInformation n metainf) -- TMP HACK! Make this a data option- updateContext (addDatatype (Data n ttag cty cons))+ updateContext (addDatatype (Data n ttag cty unique cons)) updateContext (setMetaInformation n metainf) mapM_ totcheck (zip (repeat fc) (map fst cons)) -- mapM_ (checkPositive n) cons@@ -132,9 +135,16 @@ -- them for repeated arguments findParams :: [Type] -> [Int]- findParams ts = let allapps = concatMap getDataApp ts in- paramPos allapps+ findParams ts = let allapps = map getDataApp ts+ -- do each constructor separately, then merge the results (names+ -- may change between constructors)+ conParams = map paramPos allapps in+ inAll conParams + inAll :: [[Int]] -> [Int]+ inAll [] = []+ inAll (x : xs) = filter (\p -> all (\ps -> p `elem` ps) xs) x+ paramPos [] = [] paramPos (args : rest) = dropNothing $ keepSame (zip [0..] args) rest@@ -158,7 +168,7 @@ getDataApp f@(App _ _) | (P _ d _, args) <- unApply f = if (d == n) then [mParam args args] else []- getDataApp (Bind n (Pi t) sc)+ getDataApp (Bind n (Pi t _) sc) = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc) getDataApp _ = [] @@ -196,12 +206,15 @@ -- TODO: the above is a comment from the past; -- forcenames is probably no longer needed elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->- (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)-elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)+ Type -> -- for kind checking+ (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> + Idris (Name, Type)+elabCon info syn tn codata expkind (doc, argDocs, n, t_in, fc, forcenames) = do checkUndefined fc n- (cty, t, inacc) <- buildType info syn fc [] n (if codata then mkLazy t_in else t_in)+ (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in) ctxt <- getContext let cty' = normalise ctxt [] cty+ checkUniqueKind ckind expkind -- Check that the constructor type is, in fact, a part of the family being defined tyIs n cty'@@ -242,6 +255,18 @@ getNamePos i (PPi _ n _ sc) x | n == x = Just i | otherwise = getNamePos (i + 1) sc x getNamePos _ _ _ = Nothing++ -- if the constructor is a UniqueType, the datatype must be too+ -- (Type* is fine, since that is checked for uniqueness too)+ checkUniqueKind (UType NullType) (UType NullType) = return ()+ checkUniqueKind (UType NullType) _+ = tclift $ tfail (At fc (UniqueKindError NullType n))+ checkUniqueKind (UType UniqueType) (UType UniqueType) = return ()+ checkUniqueKind (UType UniqueType) (UType AllTypes) = return ()+ checkUniqueKind (UType UniqueType) (TType _)+ = tclift $ tfail (At fc (UniqueKindError UniqueType n))+ checkUniqueKind (UType AllTypes) _ = return ()+ checkUniqueKind (TType _) _ = return () type EliminatorState = StateT (Map.Map String Int) Idris
src/Idris/Elab/Type.hs view
@@ -49,7 +49,7 @@ import Util.Pretty(pretty, text) buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm -> - Idris (Type, PTerm, [(Int, Name)])+ Idris (Type, Type, PTerm, [(Int, Name)]) buildType info syn fc opts n ty' = do ctxt <- getContext i <- getIState@@ -80,24 +80,35 @@ logLvl 5 $ "Rechecking" logLvl 6 $ show tyT logLvl 10 $ "Elaborated to " ++ showEnvDbg [] tyT- (cty, _) <- recheckC fc [] tyT+ (cty, ckind) <- recheckC fc [] tyT -- record the implicit and inaccessible arguments i <- getIState let (inaccData, impls) = unzip $ getUnboundImplicits i cty ty let inacc = inaccessibleImps 0 cty inaccData- logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc+ logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc +++ " from " ++ show (cty, ty) putIState $ i { idris_implicits = addDef n impls (idris_implicits i) } logLvl 3 ("Implicit " ++ show n ++ " " ++ show impls) addIBC (IBCImp n) - return (cty, ty, inacc)+ when (Constructor `notElem` opts) $ do+ let pnames = getParamsInType i [] impls cty+ let fninfo = FnInfo (param_pos 0 pnames cty)+ setFnInfo n fninfo+ addIBC (IBCFnInfo n fninfo)++ return (cty, ckind, ty, inacc) where- patToImp (Bind n (PVar t) sc) = Bind n (Pi t) (patToImp sc)+ patToImp (Bind n (PVar t) sc) = Bind n (Pi t (TType (UVar 0))) (patToImp sc) patToImp (Bind n b sc) = Bind n b (patToImp sc) patToImp t = t + param_pos i ns (Bind n (Pi t _) sc) + | n `elem` ns = i : param_pos (i + 1) ns sc+ | otherwise = param_pos (i + 1) ns sc+ param_pos i ns t = [] -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int". elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->@@ -110,7 +121,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in n = liftname info n_in in -} do checkUndefined fc n- (cty, ty, inacc) <- buildType info syn fc opts n ty'+ (cty, _, ty, inacc) <- buildType info syn fc opts n ty' addStatics n cty ty let nty = cty -- normalise ctxt [] cty@@ -178,7 +189,7 @@ lst = txt "List" errrep = txt "ErrorReportPart" - tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _))+ tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _) _) (App (P _ (NS (UN m) ns2) _) (App (P _ (NS (UN l) ns3) _) (P _ (NS (UN r) ns4) _))))
src/Idris/Elab/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} module Idris.Elab.Utils where import Idris.AbsSyntax@@ -12,6 +13,7 @@ import Idris.Core.Typecheck import Control.Applicative hiding (Const)+import Control.Monad.State import Control.Monad import Data.List @@ -19,10 +21,12 @@ import qualified Data.Map as Map -recheckC fc env t+recheckC = recheckC_borrowing False [] ++recheckC_borrowing uniq_check bs fc env t = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...) ctxt <- getContext- (tm, ty, cs) <- tclift $ case recheck ctxt env (forget t) t of+ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env (forget t) t of Error e -> tfail (At fc e) OK x -> return x addConstraints fc cs@@ -43,7 +47,7 @@ -- Get the list of (index, name) of inaccessible arguments from an elaborated -- type inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)]-inaccessibleImps i (Bind n (Pi t) sc) (inacc : ins)+inaccessibleImps i (Bind n (Pi t _) sc) (inacc : ins) | inacc = (i, n) : inaccessibleImps (i + 1) sc ins | otherwise = inaccessibleImps (i + 1) sc ins inaccessibleImps _ _ _ = []@@ -148,4 +152,87 @@ pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc pvars ist _ = []++getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t _) sc)+ = nub $ getFixedInType i env [] t +++ getFixedInType i (n : env) is (instantiate (P Bound n t) sc)+getFixedInType i env (_ : is) (Bind n (Pi t _) sc)+ = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)+getFixedInType i env is tm@(App f a)+ | (P _ tn _, args) <- unApply tm+ = case lookupCtxt tn (idris_datatypes i) of+ [t] -> nub $ paramNames args env (param_pos t) +++ getFixedInType i env is f +++ getFixedInType i env is a+ [] -> nub $ getFixedInType i env is f +++ getFixedInType i env is a+ | otherwise = nub $ getFixedInType i env is f +++ getFixedInType i env is a+getFixedInType i _ _ _ = []++getFlexInType i env ps (Bind n (Pi t _) sc)+ = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) +++ getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)+getFlexInType i env ps tm@(App f a)+ | (P _ tn _, args) <- unApply tm+ = case lookupCtxt tn (idris_datatypes i) of+ [t] -> nub $ paramNames args env [x | x <- [0..length args],+ not (x `elem` param_pos t)] + ++ getFlexInType i env ps f +++ getFlexInType i env ps a+ [] -> let ppos = case lookupCtxt tn (idris_fninfo i) of+ [fi] -> fn_params fi + [] -> [] in+ nub $ paramNames args env [x | x <- [0..length args],+ not (x `elem` ppos)] + ++ getFlexInType i env ps f +++ getFlexInType i env ps a+ | otherwise = nub $ getFlexInType i env ps f +++ getFlexInType i env ps a+getFlexInType i _ _ _ = []++-- Treat a name as a parameter if it appears in parameter positions in+-- types, and never in a non-parameter position in a (non-param) argument type.++getParamsInType i env ps t = let fix = getFixedInType i env ps t+ flex = getFlexInType i env fix t in+ [x | x <- fix, not (x `elem` flex)]++paramNames args env [] = []+paramNames args env (p : ps)+ | length args > p = case args!!p of+ P _ n _ -> if n `elem` env+ then n : paramNames args env ps+ else paramNames args env ps+ _ -> paramNames args env ps+ | otherwise = paramNames args env ps++getUniqueUsed :: Context -> Term -> [Name]+getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []+ where+ getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] () + getUniq env us (Bind n b sc)+ = let uniq = case check ctxt env (forgetEnv (map fst env) (binderTy b)) of+ OK (_, UType UniqueType) -> True+ OK (_, UType NullType) -> True+ OK (_, UType AllTypes) -> True+ _ -> False in+ do getUniqB env us b+ getUniq ((n,b):env) ((n, uniq):us) sc+ getUniq env us (App f a) = do getUniq env us f; getUniq env us a+ getUniq env us (V i)+ | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()+ getUniq env us (P _ n _)+ | Just u <- lookup n us = if u then use n else return ()+ getUniq env us _ = return ()++ use n = do ns <- get; put (n : ns)++ getUniqB env us (Let t v) = do getUniq env us t; getUniq env us v+ getUniqB env us (Guess t v) = do getUniq env us t; getUniq env us v+ getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v+ getUniqB env us (NLet t v) = do getUniq env us t; getUniq env us v+ getUniqB env us b = getUniq env us (binderTy b)++
src/Idris/ElabDecls.hs view
@@ -63,6 +63,14 @@ recinfo :: ElabInfo recinfo = EInfo [] emptyContext id Nothing elabDecl' +-- | Return the elaborated term which calls 'main'+elabMain :: Idris Term+elabMain = do (m, _) <- elabVal recinfo ERHS+ (PApp fc (PRef fc (sUN "run__IO"))+ [pexp $ PRef fc (sNS (sUN "main") ["Main"])])+ return m+ where fc = fileFC "toplevel"+ -- | Elaborate primitives elabPrims :: Idris () elabPrims = do mapM_ (elabDecl' EAll recinfo)@@ -95,9 +103,9 @@ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing- believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))))- (Bind (sUN "b") (Pi (TType (UVar (-2))))- (Bind (sUN "x") (Pi (V 1)) (V 1)))+ believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))) (TType (UVar (-1))))+ (Bind (sUN "b") (Pi (TType (UVar (-2))) (TType (UVar (-1))))+ (Bind (sUN "x") (Pi (V 1) (TType (UVar (-1)))) (V 1))) elabBelieveMe = do let prim__believe_me = sUN "prim__believe_me" updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)@@ -114,14 +122,14 @@ p_synEq args = Nothing nMaybe = P (TCon 0 2) (sNS (sUN "Maybe") ["Maybe", "Prelude"]) Erased- vnJust = VP (DCon 1 2) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased- vnNothing = VP (DCon 0 1) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased- vnRefl = VP (DCon 0 2) eqCon VErased+ vnJust = VP (DCon 1 2 False) (sNS (sUN "Just") ["Maybe", "Prelude"]) VErased+ vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased+ vnRefl = VP (DCon 0 2 False) eqCon VErased - synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))))- (Bind (sUN "b") (Pi (TType (UVar (-3))))- (Bind (sUN "x") (Pi (V 1))- (Bind (sUN "y") (Pi (V 1))+ synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))) (TType (UVar (-2))))+ (Bind (sUN "b") (Pi (TType (UVar (-3))) (TType (UVar (-2))))+ (Bind (sUN "x") (Pi (V 1) (TType (UVar (-2))))+ (Bind (sUN "y") (Pi (V 1) (TType (UVar (-2)))) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) elabSynEq
src/Idris/ElabTerm.hs view
@@ -17,6 +17,8 @@ import Idris.Core.Typecheck (check, recheck) import Idris.ErrReverse (errReverse) import Idris.ElabQuasiquote (extractUnquotes)+import Idris.Elab.Utils+import qualified Util.Pretty as U import Control.Applicative ((<$>)) import Control.Monad@@ -144,6 +146,7 @@ compute -- expand type synonyms, etc elabE (False, False, False, False) tm -- (in argument, guarded, in type, in qquote) end_unify+ ptm <- get_term when pattern -- convert remaining holes to pattern vars (do update_term orderPats unify_all@@ -236,13 +239,14 @@ -> ElabD () elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step elab' ina PType = do apply RType []; solve+ elab' ina (PUniverse u) = do apply (RUType u) []; solve -- elab' (_,_,inty) (PConstant c) -- | constType c && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed") elab' ina (PConstant c) = do apply (RConstant c) []; solve elab' ina (PQuote r) = do fill r; solve elab' ina (PTrue fc _) = try (elab' ina (PRef fc unitCon))- (elab' ina (PRef fc unitTy))+ (elab' ina (PRef fc unitTy)) elab' ina (PFalse fc) = elab' ina (PRef fc falseTy) elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes = do g <- goal; resolveTC False 5 g fn ist@@ -469,7 +473,7 @@ ans <- claimArgTys env xs return ((aval, (True, (Var an))) : ans) fnTy [] ret = forget ret- fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt) (fnTy xs ret)+ fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt RType) (fnTy xs ret) localVar env (PRef _ x) = case lookup x env of@@ -626,8 +630,16 @@ solve elab' ina Placeholder = do (h : hs) <- get_holes movelast h- elab' ina (PMetavar n) = let n' = mkN n in- do attack; defer n'; solve+ elab' ina (PMetavar n) = + do ptm <- get_term+ -- When building the metavar application, leave out the unique+ -- names which have been used elsewhere in the term, since we+ -- won't be able to use them in the resulting application.+ let unique_used = getUniqueUsed (tt_ctxt ist) ptm+ let n' = mkN n+ attack+ defer unique_used n'+ solve where mkN n@(NS _ _) = n mkN n = case namespace info of Just xs@(_:_) -> sNS n xs@@ -681,16 +693,40 @@ focus valn elabE (True, a, inty, qq) scr args <- get_env+ envU <- mapM (getKind args) args+ let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts+-- ++ allNamesIn scr+ + -- in the definition we build for the case, only pass through+ -- names which are directly used, type class constraints, and+ -- variables any of these depend on+ -- FIXME: This probably doesn't help us, but leaving it in+ -- temporarily (but commented out). If this comment is still+ -- here in master, please delete the code!+-- let directUse = filter (\n -> usedIn namesUsedInRHS n+-- || tcName (binderTy (snd n))) args+-- let args' = args -- chaseDeps args (map fst directUse) directUse+-- let argsDropped = map fst $+-- filter (\(n, _) -> case lookup n args' of+-- Nothing -> True+-- _ -> False) args++ -- Drop the unique arguments used in the scrutinee (since it's+ -- not valid to use them again anyway)+ let argsDropped = filter (isUnique envU) (nub $ allNamesIn scr)+ let args' = filter (\(n, _) -> n `notElem` argsDropped) args+ cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname- elab' ina (PMetavar cname')+-- elab' ina (PMetavar cname')+ attack; defer argsDropped cname'; solve+ -- if the scrutinee is one of the 'args' in env, we should -- inspect it directly, rather than adding it as a new argument let newdef = PClauses fc [] cname' (caseBlock fc cname'- (map (isScr scr) (reverse args)) opts)+ (map (isScr scr) (reverse args')) opts) -- elaborate case- env <- get_env updateAux (newdef : ) -- if we haven't got the type yet, hopefully we'll get it later! movelast tyn@@ -703,6 +739,47 @@ mkN n = case namespace info of Just xs@(_:_) -> sNS n xs _ -> n++ isUnique envk n = case lookup n envk of+ Just u -> u+ _ -> False++ getKind env (n, _) + = case lookup n env of+ Nothing -> return (n, False) -- can't happen, actually...+ Just b -> + do ty <- get_type (forget (binderTy b))+ case ty of+ UType UniqueType -> return (n, True)+ UType AllTypes -> return (n, True)+ _ -> return (n, False)++ tcName tm | (P _ n _, _) <- unApply tm+ = case lookupCtxt n (idris_classes ist) of+ [_] -> True+ _ -> False+ tcName _ = False++ usedIn ns (n, b) + = n `elem` ns + || any (\x -> x `elem` ns) (allTTNames (binderTy b))++ -- FIXME: This probably doesn't help us here, but leaving+ -- it in temporarily... if this comment is still here in master,+ -- please delete the code!+ chaseDeps env acc [] = filter (\(n, _) -> n `elem` acc) env+ chaseDeps env acc ((n,b) : args)+ = let ns = allTTNames (binderTy b) in+ extendAcc ns acc args+ where+ extendAcc [] acc args = chaseDeps env acc args+ extendAcc (n:ns) acc args+ | elem n acc = extendAcc ns acc args+ | otherwise = case lookup n env of+ Just b -> extendAcc ns (n : acc)+ ((n,b) : args)+ Nothing -> extendAcc ns acc args+ elab' ina (PUnifyLog t) = do unifyLog True elab' ina t unifyLog False@@ -855,9 +932,23 @@ addImplBound ist (map fst env) (PApp fc (PRef fc (sUN "Delay")) [pexp t]) ++ -- Don't put implicit coercions around applications which are marked+ -- as '%noImplicit', or around case blocks, otherwise we get exponential+ -- blowup especially where there are errors deep in large expressions.+ notImplicitable (PApp _ f _) = notImplicitable f+ -- TMP HACK no coercing on bind (make this configurable)+ notImplicitable (PRef _ n)+ | [opts] <- lookupCtxt n (idris_flags ist)+ = NoImplicit `elem` opts+ notImplicitable (PAlternative True as) = any notImplicitable as -- case is tricky enough without implicit coercions! If they are needed, -- they can go in the branches separately.+ notImplicitable (PCase _ _ _) = True+ notImplicitable _ = False+ insertCoerce ina t@(PCase _ _ _) = return t+ insertCoerce ina t | notImplicitable t = return t insertCoerce ina t = do ty <- goal -- Check for possible coercions to get to the goal@@ -891,7 +982,7 @@ elabArgs ist ina failed fc r f (n:ns) force (Placeholder : args) = elabArgs ist ina failed fc r f ns force args elabArgs ist ina failed fc r f ((argName, holeName):ns) force (t : args)- = do elabArg argName holeName t+ = elabArg argName holeName t where elabArg argName holeName t = do now_elaborating fc f argName wrapErr f argName $ do@@ -1290,9 +1381,9 @@ where tacticTy = Var (reflm "Tactic") listTy = Var (sNS (sUN "List") ["List", "Prelude"]) scriptTy = (RBind (sMN 0 "__pi_arg")- (Pi (RApp listTy envTupleType))+ (Pi (RApp listTy envTupleType) RType) (RBind (sMN 1 "__pi_arg")- (Pi (Var $ reflm "TT")) tacticTy))+ (Pi (Var $ reflm "TT") RType) tacticTy)) runT (ByReflection tm) -- run the reflection function 'tm' on the -- goal, then apply the resulting reflected Tactic = do tgoal <- goal@@ -1526,7 +1617,7 @@ reifyTTNameType t@(App _ _) = case unApply t of (P _ f _, [Constant (I tag), Constant (I num)])- | f == reflm "DCon" -> return $ DCon tag num+ | f == reflm "DCon" -> return $ DCon tag num False -- FIXME: Uniqueness! | f == reflm "TCon" -> return $ TCon tag num _ -> fail ("Unknown reflection name type: " ++ show t) reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)@@ -1542,8 +1633,8 @@ reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a) reifyTTBinderApp reif f [t] | f == reflm "Lam" = liftM Lam (reif t)-reifyTTBinderApp reif f [t]- | f == reflm "Pi" = liftM Pi (reif t)+reifyTTBinderApp reif f [t, k]+ | f == reflm "Pi" = liftM2 Pi (reif t) (reif k) reifyTTBinderApp reif f [x, y] | f == reflm "Let" = liftM2 Let (reif x) (reif y) reifyTTBinderApp reif f [x, y]@@ -1686,9 +1777,10 @@ fill $ reflCall "Lam" [Var (reflm "TT"), Var t'] solve focus t'; reflectQuotePattern unq t- reflectBinderQuotePattern unq (Pi t)+ reflectBinderQuotePattern unq (Pi t k) = do t' <- claimTT (sMN 0 "ty") ; movelast t'- fill $ reflCall "Pi" [Var (reflm "TT"), Var t']+ k' <- claimTT (sMN 0 "k"); movelast k';+ fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k'] solve focus t'; reflectQuotePattern unq t reflectBinderQuotePattern unq (Let x y)@@ -1784,8 +1876,8 @@ reflectNameType :: NameType -> Raw reflectNameType (Bound) = Var (reflm "Bound") reflectNameType (Ref) = Var (reflm "Ref")-reflectNameType (DCon x y)- = reflCall "DCon" [RConstant (I x), RConstant (I y)]+reflectNameType (DCon x y _)+ = reflCall "DCon" [RConstant (I x), RConstant (I y)] -- FIXME: Uniqueness! reflectNameType (TCon x y) = reflCall "TCon" [RConstant (I x), RConstant (I y)] @@ -1835,8 +1927,8 @@ reflectBinderQuote :: [Name] -> Binder Term -> Raw reflectBinderQuote unq (Lam t) = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t]-reflectBinderQuote unq (Pi t)- = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t]+reflectBinderQuote unq (Pi t k)+ = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t, reflectQuote unq k] reflectBinderQuote unq (Let x y) = reflCall "Let" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y] reflectBinderQuote unq (NLet x y)@@ -2083,7 +2175,7 @@ parts -> ReflectionError errorparts e fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a-fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)+fromTTMaybe (App (App (P (DCon _ _ _) (NS (UN just) _) _) ty) tm) | just == txt "Just" = Just tm fromTTMaybe x = Nothing @@ -2094,9 +2186,9 @@ -- representation. Not in Idris or ElabD monads because it should be usable -- from either. reifyReportPart :: Term -> Either Err ErrorReportPart-reifyReportPart (App (P (DCon _ _) n _) (Constant (Str msg))) | n == reflm "TextPart" =+reifyReportPart (App (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "TextPart" = Right (TextPart msg)-reifyReportPart (App (P (DCon _ _) n _) ttn)+reifyReportPart (App (P (DCon _ _ _) n _) ttn) | n == reflm "NamePart" = case runElab [] (reifyTTName ttn) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $@@ -2104,7 +2196,7 @@ show ttn ++ " when reflecting an error:" ++ show e OK (n', _)-> Right $ NamePart n'-reifyReportPart (App (P (DCon _ _) n _) tm)+reifyReportPart (App (P (DCon _ _ _) n _) tm) | n == reflm "TermPart" = case runElab [] (reifyTT tm) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $@@ -2112,7 +2204,7 @@ show tm ++ " when reflecting an error:" ++ show e OK (tm', _) -> Right $ TermPart tm'-reifyReportPart (App (P (DCon _ _) n _) tm)+reifyReportPart (App (P (DCon _ _ _) n _) tm) | n == reflm "SubReport" = case unList tm of Just xs -> do subParts <- mapM reifyReportPart xs
src/Idris/Erasure.hs view
@@ -281,13 +281,13 @@ -- for the purposes of erasure, we can disregard the projection getDepsSC fn es vs (ProjCase (Proj t i) alts) = getDepsSC fn es vs (ProjCase t alts) -- step- getDepsSC fn es vs (ProjCase (P _ n _) alts) = getDepsSC fn es vs (Case n alts) -- base+ getDepsSC fn es vs (ProjCase (P _ n _) alts) = getDepsSC fn es vs (Case Shared n alts) -- base -- other ProjCase's are not supported getDepsSC fn es vs (ProjCase t alts) = error $ "ProjCase not supported:\n" ++ show (ProjCase t alts) getDepsSC fn es vs (STerm t) = getDepsTerm vs [] (S.singleton (fn, Result)) (etaExpand es t)- getDepsSC fn es vs (Case n alts)+ getDepsSC fn es vs (Case sh n alts) -- we case-split on this variable, which marks it as used -- (unless there is exactly one case branch) -- hence we add a new dependency, whose only precondition is@@ -353,16 +353,16 @@ -- dependencies of de bruijn variables are described in `bs' getDepsTerm vs bs cd (V i) = snd (bs !! i) cd - getDepsTerm vs bs cd (Bind n bdr t)+ getDepsTerm vs bs cd (Bind n bdr body) -- here we just push IM.empty on the de bruijn stack -- the args will be marked as used at the usage site- | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t- | Pi ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t+ | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body+ | Pi ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body -- let-bound variables can get partially evaluated -- it is sufficient just to plug the Cond in when the bound names are used- | Let ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t- | NLet ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t+ | Let ty t <- bdr = var t cd `union` getDepsTerm vs ((n, var t) : bs) cd body+ | NLet ty t <- bdr = var t cd `union` getDepsTerm vs ((n, var t) : bs) cd body where var t cd = getDepsTerm vs bs cd t @@ -370,13 +370,13 @@ getDepsTerm vs bs cd app@(App _ _) | (fun, args) <- unApply app = case fun of -- instance constructors -> create metamethod deps- P (DCon _ _) ctorName@(SN (InstanceCtorN className)) _+ P (DCon _ _ _) ctorName@(SN (InstanceCtorN className)) _ -> conditionalDeps ctorName args -- regular data ctor stuff `union` unionMap (methodDeps ctorName) (zip [0..] args) -- method-specific stuff -- ordinary constructors P (TCon _ _) n _ -> unconditionalDeps args -- does not depend on anything- P (DCon _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used+ P (DCon _ _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used -- mkForeign* calls must be special-cased because they are variadic -- All arguments must be marked as used, except for the first one,@@ -469,7 +469,7 @@ -- Get the number of arguments that might be considered for erasure. getArity :: Name -> Int getArity (SN (WhereN i' ctorName (MN i field)))- | Just (TyDecl (DCon _ _) ty) <- lookupDefExact ctorName ctx+ | Just (TyDecl (DCon _ _ _) ty) <- lookupDefExact ctorName ctx = let argTys = map snd $ getArgTys ty in if i <= length argTys then length $ getArgTys (argTys !! i)@@ -479,7 +479,7 @@ getArity n = case lookupDefExact n ctx of Just (CaseOp ci ty tys def tot cdefs) -> length tys- Just (TyDecl (DCon tag arity) _) -> arity+ Just (TyDecl (DCon tag arity _) _) -> arity Just (TyDecl (Ref) ty) -> length $ getArgTys ty Just (Operator ty arity op) -> arity Just df -> error $ "Erasure/getArity: unrecognised entity '"
src/Idris/Error.hs view
@@ -42,12 +42,11 @@ setAndReport :: Err -> Idris () setAndReport e = do ist <- getIState- let h = idris_outh ist case (unwrap e) of At fc e -> do setErrSpan fc- ihWarn h fc $ pprintErr ist e+ iWarn fc $ pprintErr ist e _ -> do setErrSpan (getErrSpan e)- ihWarn h emptyFC $ pprintErr ist e+ iWarn emptyFC $ pprintErr ist e where unwrap (ProofSearchFail e) = e -- remove bookkeeping constructor unwrap e = e
src/Idris/Help.hs view
@@ -11,6 +11,10 @@ | NoArg -- ^ No completion (yet!?) | SpecialHeaderArg -- ^ do not use | ConsoleWidthArg -- ^ The width of the console+ | DeclArg -- ^ An Idris declaration, as might be contained in a file+ | ManyArgs CmdArg -- ^ Zero or more of one kind of argument+ | OptionalArg CmdArg -- ^ Zero or one of one kind of argument+ | SeqArgs CmdArg CmdArg -- ^ One kind of argument followed by another instance Show CmdArg where show ExprArg = "<expr>"@@ -24,6 +28,10 @@ show NoArg = "" show SpecialHeaderArg = "Arguments" show ConsoleWidthArg = "auto|infinite|<number>"+ show DeclArg = "<top-level declaration>"+ show (ManyArgs a) = "(" ++ show a ++ ")..."+ show (OptionalArg a) = "[" ++ show a ++ "]"+ show (SeqArgs a b) = show a ++ " " ++ show b help :: [([String], CmdArg, String)] help =@@ -59,7 +67,9 @@ ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"), ([":consolewidth"], ConsoleWidthArg, "Set the width of the console"), ([":q",":quit"], NoArg, "Exit the Idris system"),- ([":w", ":warranty"], NoArg, "Displays warranty information")+ ([":w", ":warranty"], NoArg, "Displays warranty information"),+ ([":let"], ManyArgs DeclArg, "Evaluate a declaration, such as a function definition, instance implementation, or fixity declaration"),+ ([":undefine",":unlet"], ManyArgs NameArg, "Remove the listed repl definitions, or all repl definitions if no names given") ] -- | Use these for completion, but don't show them in :help
src/Idris/IBC.hs view
@@ -31,12 +31,13 @@ import Util.Zlib (decompressEither) ibcVersion :: Word8-ibcVersion = 75+ibcVersion = 80 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath, symbols :: [Name], ibc_imports :: [FilePath],+ ibc_importdirs :: [FilePath], ibc_implicits :: [(Name, [PArg])], ibc_fixes :: [FixDecl], ibc_statics :: [(Name, [Bool])],@@ -56,6 +57,7 @@ ibc_total :: [(Name, Totality)], ibc_totcheckfail :: [(FC, String)], ibc_flags :: [(Name, [FnOpt])],+ ibc_fninfo :: [(Name, FnInfo)], ibc_cg :: [(Name, CGInfo)], ibc_defs :: [(Name, Def)], ibc_docstrings :: [(Name, (Docstring, [(Name, Docstring)]))],@@ -78,7 +80,7 @@ !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing loadIBC :: FilePath -> Idris () loadIBC fp = do imps <- getImported@@ -149,6 +151,7 @@ ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f } ibc i (IBCKeyword n) f = return f { ibc_keywords = n : ibc_keywords f } ibc i (IBCImport n) f = return f { ibc_imports = n : ibc_imports f }+ibc i (IBCImportDir n) f = return f { ibc_importdirs = n : ibc_importdirs f } ibc i (IBCObj tgt n) f = return f { ibc_objs = (tgt, n) : ibc_objs f } ibc i (IBCLib tgt n) f = return f { ibc_libs = (tgt, n) : ibc_libs f } ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }@@ -180,8 +183,8 @@ = do c' <- updateSC c; r' <- updateSC r return (CaseDefs (ts, t) (cs, c') (is, i) (rs, r')) - updateSC (Case n alts) = do alts' <- mapM updateAlt alts- return (Case n alts')+ updateSC (Case up n alts) = do alts' <- mapM updateAlt alts+ return (Case up n alts') updateSC (ProjCase t alts) = do t' <- update t alts' <- mapM updateAlt alts return (ProjCase t' alts')@@ -226,6 +229,7 @@ ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f } ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f } ibc i (IBCFlags n a) f = return f { ibc_flags = (n,a) : ibc_flags f }+ibc i (IBCFnInfo n a) f = return f { ibc_fninfo = (n,a) : ibc_fninfo f } ibc i (IBCTotal n a) f = return f { ibc_total = (n,a) : ibc_total f } ibc i (IBCTrans t) f = return f { ibc_transforms = t : ibc_transforms f } ibc i (IBCErrRev t) f = return f { ibc_errRev = t : ibc_errRev f }@@ -255,6 +259,7 @@ v <- verbose quiet <- getQuiet -- when (v && srcok && not quiet) $ iputStrLn $ "Skipping " ++ sourcefile i+ pImportDirs (ibc_importdirs i) pImports (ibc_imports i) pImps (ibc_implicits i) pFixes (ibc_fixes i)@@ -274,6 +279,8 @@ pDefs (symbols i) (ibc_defs i) pPatdefs (ibc_patdefs i) pAccess (ibc_access i)+ pFlags (ibc_flags i)+ pFnInfo (ibc_fninfo i) pTotal (ibc_total i) pTotCheckErr (ibc_totcheckfail i) pCG (ibc_cg i)@@ -306,6 +313,9 @@ pParsedSpan fc = do ist <- getIState putIState ist { idris_parsedSpan = fc } +pImportDirs :: [FilePath] -> Idris ()+pImportDirs fs = mapM_ addImportDir fs+ pImports :: [FilePath] -> Idris () pImports fs = do mapM_ (\f -> do i <- getIState@@ -459,6 +469,9 @@ pFlags :: [(Name, [FnOpt])] -> Idris () pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds +pFnInfo :: [(Name, FnInfo)] -> Idris ()+pFnInfo ds = mapM_ (\ (n, a) -> setFnInfo n a) ds+ pTotal :: [(Name, Totality)] -> Idris () pTotal ds = mapM_ (\ (n, a) -> do i <- getIState@@ -618,12 +631,24 @@ x4 <- get x5 <- get return (CGInfo x1 x2 [] x4 x5)++instance Binary CaseType where+ put x = case x of+ Updatable -> putWord8 0+ Shared -> putWord8 1+ get = do i <- getWord8+ case i of+ 0 -> return Updatable+ 1 -> return Shared+ _ -> error "Corrupted binary data for CaseType"+ instance Binary SC where put x = case x of- Case x1 x2 -> do putWord8 0- put x1- put x2+ Case x1 x2 x3 -> do putWord8 0+ put x1+ put x2+ put x3 ProjCase x1 x2 -> do putWord8 1 put x1 put x2@@ -637,7 +662,8 @@ case i of 0 -> do x1 <- get x2 <- get- return (Case x1 x2)+ x3 <- get+ return (Case x1 x2 x3) 1 -> do x1 <- get x2 <- get return (ProjCase x1 x2)@@ -830,7 +856,7 @@ return (DataMI x1) instance Binary IBCFile where- put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38)+ put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40) = {-# SCC "putIBCFile" #-} do put x1 put x2@@ -870,6 +896,8 @@ put x36 put x37 put x38+ put x39+ put x40 get = do x1 <- get@@ -911,7 +939,9 @@ x36 <- get x37 <- get x38 <- get- return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38)+ x39 <- get+ x40 <- get+ return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40) else return (initIBC { ver = x1 }) instance Binary DataOpt where@@ -943,6 +973,8 @@ ErrorHandler -> putWord8 9 ErrorReverse -> putWord8 10 CoveringFn -> putWord8 11+ NoImplicit -> putWord8 12+ Constructor -> putWord8 13 get = do i <- getWord8 case i of@@ -959,6 +991,8 @@ 9 -> return ErrorHandler 10 -> return ErrorReverse 11 -> return CoveringFn+ 12 -> return NoImplicit+ 13 -> return Constructor _ -> error "Corrupted binary data for FnOpt" instance Binary Fixity where@@ -1465,6 +1499,8 @@ PDisamb x1 x2 -> do putWord8 37 put x1 put x2+ PUniverse x1 -> do putWord8 38+ put x1 get = do i <- getWord8@@ -1581,6 +1617,8 @@ 37 -> do x1 <- get x2 <- get return (PDisamb x1 x2)+ 38 -> do x1 <- get+ return (PUniverse x1) _ -> error "Corrupted binary data for PTerm" instance (Binary t) => Binary (PTactic' t) where@@ -1818,6 +1856,13 @@ x2 <- get return (Optimise x1 x2) +instance Binary FnInfo where+ put (FnInfo x1)+ = put x1+ get+ = do x1 <- get+ return (FnInfo x1)+ instance Binary TypeInfo where put (TI x1 x2 x3 x4 x5) = do put x1 put x2@@ -1913,18 +1958,14 @@ instance Binary Codegen where put x = case x of- ViaC -> putWord8 0- ViaJava -> putWord8 1- ViaNode -> putWord8 2- ViaJavaScript -> putWord8 3- Bytecode -> putWord8 4+ Via str -> do putWord8 0+ put str+ Bytecode -> putWord8 1 get = do i <- getWord8 case i of- 0 -> return ViaC- 1 -> return ViaJava- 2 -> return ViaNode- 3 -> return ViaJavaScript- 4 -> return Bytecode+ 0 -> do x1 <- get+ return (Via x1)+ 1 -> return Bytecode _ -> error "Corrupted binary data for Codegen"
src/Idris/IdeSlave.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-} -module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..)) where+module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..), ideSlaveEpoch, getLen, getNChar) where import Text.Printf import Numeric@@ -12,12 +12,24 @@ -- import qualified Data.Text as T import Text.Trifecta hiding (Err) import Text.Trifecta.Delta+import System.IO import Idris.Core.TT import Idris.Core.Binary import Control.Applicative hiding (Const) +getNChar :: Handle -> Int -> String -> IO (String)+getNChar _ 0 s = return (reverse s)+getNChar h n s = do c <- hGetChar h+ getNChar h (n - 1) (c : s)++getLen :: Handle -> IO (Either Err Int)+getLen h = do s <- getNChar h 6 ""+ case readHex s of+ ((num, ""):_) -> return $ Right num+ _ -> return $ Left . Msg $ "Couldn't read length " ++ s+ data SExp = SexpList [SExp] | StringAtom String | BoolAtom Bool@@ -247,19 +259,14 @@ parseMessage :: String -> Either Err (SExp, Integer) parseMessage x = case receiveString x of Right (SexpList [cmd, (IntegerAtom id)]) -> Right (cmd, id)+ Right x -> Left . Msg $ "Invalid message " ++ show x Left err -> Left err receiveString :: String -> Either Err SExp receiveString x =- case readHex (take 6 x) of- ((num, ""):_) ->- let msg = drop 6 x in- if (length msg) /= (num - 1)- then Left . Msg $ "bad input length"- else (case parseSExp msg of- Failure _ -> Left . Msg $ "parse failure"- Success r -> Right r)- _ -> Left . Msg $ "readHex failed"+ case parseSExp x of+ Failure _ -> Left . Msg $ "parse failure"+ Success r -> Right r convSExp :: SExpable a => String -> a -> Integer -> String convSExp pre s id =@@ -269,3 +276,6 @@ getHexLength :: String -> String getHexLength s = printf "%06x" (1 + (length s))++ideSlaveEpoch :: Int+ideSlaveEpoch = 1
src/Idris/Interactive.hs view
@@ -28,11 +28,12 @@ import System.IO import Data.Char import Data.Maybe (fromMaybe)+import Data.List (isSuffixOf) import Debug.Trace -caseSplitAt :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-caseSplitAt h fn updatefile l n+caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris ()+caseSplitAt fn updatefile l n = do src <- runIO $ readFile fn res <- splitOnLine l n fn iLOG (showSep "\n" (map show res))@@ -43,11 +44,11 @@ then do let fb = fn ++ "~" -- make a backup! runIO $ writeFile fb (unlines before ++ new ++ unlines later) runIO $ copyFile fb fn- else -- do ihputStrLn h (show res)- ihPrintResult h new+ else -- do iputStrLn (show res)+ iPrintResult new -addClauseFrom :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-addClauseFrom h fn updatefile l n+addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()+addClauseFrom fn updatefile l n = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) let indent = getIndent 0 (show n) tyline@@ -61,15 +62,15 @@ cl ++ "\n" ++ unlines rest) runIO $ copyFile fb fn- else ihPrintResult h cl+ else iPrintResult cl where getIndent i n [] = 0 getIndent i n xs | take 9 xs == "instance " = i getIndent i n xs | take (length n) xs == n = i getIndent i n (x : xs) = getIndent (i + 1) n xs -addProofClauseFrom :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-addProofClauseFrom h fn updatefile l n+addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()+addProofClauseFrom fn updatefile l n = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) let indent = getIndent 0 (show n) tyline@@ -83,14 +84,14 @@ cl ++ "\n" ++ unlines rest) runIO $ copyFile fb fn- else ihPrintResult h cl+ else iPrintResult cl where getIndent i n [] = 0 getIndent i n xs | take (length n) xs == n = i getIndent i n (x : xs) = getIndent (i + 1) n xs -addMissing :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-addMissing h fn updatefile l n+addMissing :: FilePath -> Bool -> Int -> Name -> Idris ()+addMissing fn updatefile l n = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) let indent = getIndent 0 (show n) tyline@@ -108,7 +109,7 @@ runIO $ writeFile fb (unlines (before ++ nonblank) ++ extras ++ unlines rest) runIO $ copyFile fb fn- else ihPrintResult h extras+ else iPrintResult extras where showPat = show . stripNS stripNS tm = mapPT dens tm where dens (PRef fc n) = PRef fc (nsroot n)@@ -122,10 +123,13 @@ getAppName (PRef _ r) = r getAppName _ = n + makeIndent ind | ".lidr" `isSuffixOf` fn = '>' : ' ' : replicate (ind-2) ' '+ | otherwise = replicate ind ' '+ showNew nm i ind (tm : tms) = do (nm', i') <- getUniq nm i rest <- showNew nm i' ind tms- return (replicate ind ' ' +++ return (makeIndent ind ++ showPat tm ++ " = ?" ++ nm' ++ "\n" ++ rest) showNew nm i _ [] = return ""@@ -135,8 +139,8 @@ getIndent i n (x : xs) = getIndent (i + 1) n xs -makeWith :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-makeWith h fn updatefile l n+makeWith :: FilePath -> Bool -> Int -> Name -> Idris ()+makeWith fn updatefile l n = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) let ind = getIndent tyline@@ -151,15 +155,15 @@ ++ with ++ "\n" ++ unlines rest) runIO $ copyFile fb fn- else ihPrintResult h with+ else iPrintResult with where getIndent s = length (takeWhile isSpace s) -doProofSearch :: Handle -> FilePath -> Bool -> Bool -> +doProofSearch :: FilePath -> Bool -> Bool -> Int -> Name -> [Name] -> Maybe Int -> Idris ()-doProofSearch h fn updatefile rec l n hints Nothing- = doProofSearch h fn updatefile rec l n hints (Just 10)-doProofSearch h fn updatefile rec l n hints (Just depth)+doProofSearch fn updatefile rec l n hints Nothing+ = doProofSearch fn updatefile rec l n hints (Just 10)+doProofSearch fn updatefile rec l n hints (Just depth) = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) ctxt <- getContext@@ -192,7 +196,7 @@ updateMeta False tyline (show n) newmv ++ "\n" ++ unlines later) runIO $ copyFile fb fn- else ihPrintResult h newmv+ else iPrintResult newmv where dropCtxt 0 sc = sc dropCtxt i (PPi _ _ _ sc) = dropCtxt (i - 1) sc dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc@@ -235,8 +239,8 @@ | otherwise = new -makeLemma :: Handle -> FilePath -> Bool -> Int -> Name -> Idris ()-makeLemma h fn updatefile l n+makeLemma :: FilePath -> Bool -> Int -> Name -> Idris ()+makeLemma fn updatefile l n = do src <- runIO $ readFile fn let (before, tyline : later) = splitAt (l-1) (lines src) @@ -266,8 +270,8 @@ runIO $ writeFile fb (addLem before tyline lem lem_app later) runIO $ copyFile fb fn else case idris_outputmode i of- RawOutput -> ihPrintResult h $ lem ++ "\n" ++ lem_app- IdeSlave n ->+ RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app+ IdeSlave n h -> let good = SexpList [SymbolAtom "ok", SexpList [SymbolAtom "metavariable-lemma", SexpList [SymbolAtom "replace-metavariable",@@ -284,8 +288,8 @@ runIO $ writeFile fb (addProv before tyline lem_app later) runIO $ copyFile fb fn else case idris_outputmode i of- RawOutput -> ihPrintResult h $ lem_app- IdeSlave n ->+ RawOutput _ -> iPrintResult $ lem_app+ IdeSlave n h -> let good = SexpList [SymbolAtom "ok", SexpList [SymbolAtom "provisional-definition-lemma", SexpList [SymbolAtom "definition-clause",@@ -295,10 +299,10 @@ where getIndent s = length (takeWhile isSpace s) appArgs skip 0 _ = ""- appArgs skip i (Bind n@(UN c) (Pi _) sc) + appArgs skip i (Bind n@(UN c) (Pi _ _) sc) | (thead c /= '_' && n `notElem` skip) = " " ++ show n ++ appArgs skip (i - 1) sc- appArgs skip i (Bind _ (Pi _) sc) = appArgs skip (i - 1) sc+ appArgs skip i (Bind _ (Pi _ _) sc) = appArgs skip (i - 1) sc appArgs skip i _ = "" stripMNBind skip (PPi b n@(UN c) ty sc) @@ -312,7 +316,7 @@ -- Make them implicit if they appear guarded by a top level constructor, -- or at the top level themselves. guessImps :: Context -> Term -> [Name]- guessImps ctxt (Bind n (Pi _) sc)+ guessImps ctxt (Bind n (Pi _ _) sc) | guarded ctxt n (substV (P Bound n Erased) sc) = n : guessImps ctxt sc | otherwise = guessImps ctxt sc@@ -324,7 +328,7 @@ isConName f ctxt = any (guarded ctxt n) args -- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows -- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc- guarded ctxt n (Bind _ (Pi t) sc) + guarded ctxt n (Bind _ (Pi t _) sc) = guarded ctxt n t || guarded ctxt n sc guarded ctxt n _ = False
src/Idris/Output.hs view
@@ -24,27 +24,28 @@ renderPretty 1.0 80 . fmap (fancifyAnnots ist) $ pprintErr ist err -ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()-ihWarn h fc err = do i <- getIState- case idris_outputmode i of- RawOutput ->- do err' <- iRender . fmap (fancifyAnnots i) $- if fc_fname fc /= ""- then text (show fc) <> colon <//> err- else err- runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'- IdeSlave n ->- do err' <- iRender . fmap (fancifyAnnots i) $ err- let (str, spans) = displaySpans err'- runIO . hPutStrLn h $- convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n+iWarn :: FC -> Doc OutputAnnotation -> Idris ()+iWarn fc err =+ do i <- getIState+ case idris_outputmode i of+ RawOutput h ->+ do err' <- iRender . fmap (fancifyAnnots i) $+ if fc_fname fc /= ""+ then text (show fc) <> colon <//> err+ else err+ runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'+ IdeSlave n h ->+ do err' <- iRender . fmap (fancifyAnnots i) $ err+ let (str, spans) = displaySpans err'+ runIO . hPutStrLn h $+ convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n iRender :: Doc a -> Idris (SimpleDoc a) iRender d = do w <- getWidth ist <- getIState let ideSlave = case idris_outputmode ist of- IdeSlave _ -> True- _ -> False+ IdeSlave _ _ -> True+ _ -> False case w of InfinitelyWide -> return $ renderPretty 1.0 1000000000 d ColsWide n -> return $@@ -63,37 +64,37 @@ displayDecorated (consoleDecorate ist) $ rendered -ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()-ihPrintTermWithType h tm ty = ihRenderResult h (tm <+> colon <+> align ty)+iPrintTermWithType :: Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()+iPrintTermWithType tm ty = iRenderResult (tm <+> colon <+> align ty) -- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name-ihPrintFunTypes :: Handle -> [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris ()-ihPrintFunTypes h bnd n [] = ihPrintError h $ "No such variable " ++ show n-ihPrintFunTypes h bnd n overloads = do ist <- getIState- let ppo = ppOptionIst ist- let infixes = idris_infixes ist- let output = vsep (map (uncurry (ppOverload ppo infixes)) overloads)- ihRenderResult h output+iPrintFunTypes :: [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris ()+iPrintFunTypes bnd n [] = iPrintError $ "No such variable " ++ show n+iPrintFunTypes bnd n overloads = do ist <- getIState+ let ppo = ppOptionIst ist+ let infixes = idris_infixes ist+ let output = vsep (map (uncurry (ppOverload ppo infixes)) overloads)+ iRenderResult output where fullName n = prettyName True True bnd n ppOverload ppo infixes n tm = fullName n <+> colon <+> align (pprintPTerm ppo bnd [] infixes tm) -ihRenderOutput :: Handle -> Doc OutputAnnotation -> Idris ()-ihRenderOutput h doc =+iRenderOutput :: Doc OutputAnnotation -> Idris ()+iRenderOutput doc = do i <- getIState case idris_outputmode i of- RawOutput -> do out <- iRender doc- runIO $ putStrLn (displayDecorated (consoleDecorate i) out)- IdeSlave n ->+ RawOutput h -> do out <- iRender doc+ runIO $ putStrLn (displayDecorated (consoleDecorate i) out)+ IdeSlave n h -> do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc let out = [toSExp str, toSExp spans]- runIO . putStrLn $ convSExp "write-decorated" out n+ runIO . hPutStrLn h $ convSExp "write-decorated" out n -ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()-ihRenderResult h d = do ist <- getIState- case idris_outputmode ist of- RawOutput -> consoleDisplayAnnotated h d- IdeSlave n -> ideSlaveReturnAnnotated n h d+iRenderResult :: Doc OutputAnnotation -> Idris ()+iRenderResult d = do ist <- getIState+ case idris_outputmode ist of+ RawOutput h -> consoleDisplayAnnotated h d+ IdeSlave n h -> ideSlaveReturnAnnotated n h d ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris () ideSlaveReturnWithStatus status n h out = do@@ -111,59 +112,61 @@ ideSlaveReturnAnnotated = ideSlaveReturnWithStatus "ok" -- | Show an error with semantic highlighting-ihRenderError :: Handle -> Doc OutputAnnotation -> Idris ()-ihRenderError h e = do ist <- getIState- case idris_outputmode ist of- RawOutput -> consoleDisplayAnnotated h e- IdeSlave n -> ideSlaveReturnWithStatus "error" n h e+iRenderError :: Doc OutputAnnotation -> Idris ()+iRenderError e = do ist <- getIState+ case idris_outputmode ist of+ RawOutput h -> consoleDisplayAnnotated h e+ IdeSlave n h -> ideSlaveReturnWithStatus "error" n h e -ihPrintWithStatus :: String -> Handle -> String -> Idris ()-ihPrintWithStatus status h s = do +iPrintWithStatus :: String -> String -> Idris ()+iPrintWithStatus status s = do i <- getIState case idris_outputmode i of- RawOutput -> case s of+ RawOutput h -> case s of "" -> return () s -> runIO $ hPutStrLn h s- IdeSlave n ->+ IdeSlave n h -> let good = SexpList [SymbolAtom status, toSExp s] in runIO $ hPutStrLn h $ convSExp "return" good n -ihPrintResult :: Handle -> String -> Idris ()-ihPrintResult = ihPrintWithStatus "ok"+iPrintResult :: String -> Idris ()+iPrintResult = iPrintWithStatus "ok" -ihPrintError :: Handle -> String -> Idris ()-ihPrintError = ihPrintWithStatus "error"+iPrintError :: String -> Idris ()+iPrintError = iPrintWithStatus "error" -ihputStrLn :: Handle -> String -> Idris ()-ihputStrLn h s = do i <- getIState- case idris_outputmode i of- RawOutput -> runIO $ hPutStrLn h s- IdeSlave n -> runIO . hPutStrLn h $ convSExp "write-string" s n+iputStrLn :: String -> Idris ()+iputStrLn s = do i <- getIState+ case idris_outputmode i of+ RawOutput h -> runIO $ hPutStrLn h s+ IdeSlave n h -> runIO . hPutStrLn h $ convSExp "write-string" s n -iputStrLn = ihputStrLn stdout-iPrintError = ihPrintError stdout-iPrintResult = ihPrintResult stdout-iWarn = ihWarn stdout ideslavePutSExp :: SExpable a => String -> a -> Idris () ideslavePutSExp cmd info = do i <- getIState case idris_outputmode i of- IdeSlave n -> runIO . putStrLn $ convSExp cmd info n+ IdeSlave n h -> runIO . hPutStrLn h $ convSExp cmd info n _ -> return () -- TODO: send structured output similar to the metavariable list iputGoal :: SimpleDoc OutputAnnotation -> Idris () iputGoal g = do i <- getIState case idris_outputmode i of- RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)- IdeSlave n ->+ RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)+ IdeSlave n h -> let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g goal = [toSExp str, toSExp spans]- in runIO . putStrLn $ convSExp "write-goal" goal n+ in runIO . hPutStrLn h $ convSExp "write-goal" goal n -- | Warn about totality problems without failing to compile warnTotality :: Idris () warnTotality = do ist <- getIState mapM_ (warn ist) (nub (idris_totcheckfail ist)) where warn ist (fc, e) = iWarn fc (pprintErr ist (Msg e))+++printUndefinedNames :: [Name] -> Doc OutputAnnotation+printUndefinedNames ns = text "Undefined " <> names <> text "."+ where names = encloseSep empty empty (char ',') $ map ppName ns+ ppName = prettyName True True []
src/Idris/ParseExpr.hs view
@@ -307,7 +307,10 @@ <|> do reserved "elim_for"; fc <- getFC; t <- fnName; return (PRef fc (SN $ ElimN t)) <|> proofExpr syn <|> tacticsExpr syn+ <|> try (do reserved "Type"; symbol "*"; return $ PUniverse AllTypes) <|> do reserved "Type"; return PType+ <|> do reserved "UniqueType"; return $ PUniverse UniqueType+ <|> do reserved "NullType"; return $ PUniverse NullType <|> do c <- constant fc <- getFC return (modifyConst syn fc (PConstant c))
src/Idris/ParseHelpers.hs view
@@ -17,7 +17,7 @@ import Idris.Core.Evaluate import Idris.Delaborate (pprintErr) import Idris.Docstrings-import Idris.Output (ihWarn)+import Idris.Output (iWarn) import qualified Util.Pretty as Pretty (text) @@ -79,7 +79,7 @@ reportParserWarnings :: Idris () reportParserWarnings = do ist <- getIState- mapM_ (uncurry $ ihWarn (idris_outh ist))+ mapM_ (uncurry iWarn) (map (\ (fc, err) -> (fc, pprintErr ist err)) . reverse . nub $
src/Idris/Parser.hs view
@@ -376,6 +376,7 @@ FnOpts ::= 'total' | 'partial' | 'implicit'+ | '%' 'no_implicit' | '%' 'assert_total' | '%' 'error_handler' | '%' 'reflection'@@ -402,6 +403,8 @@ <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn])) <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral; fnOpts (CExport c : opts)+ <|> do try (lchar '%' *> reserved "no_implicit");+ fnOpts (NoImplicit : opts) <|> do try (lchar '%' *> reserved "assert_total"); fnOpts (AssertTotal : opts) <|> do try (lchar '%' *> reserved "error_handler");@@ -938,11 +941,7 @@ @ -} codegen_ :: IdrisParser Codegen-codegen_ = do reserved "C"; return ViaC- <|> do reserved "Java"; return ViaJava- <|> do reserved "JavaScript"; return ViaJavaScript- <|> do reserved "Node"; return ViaNode- <|> do reserved "LLVM"; return ViaLLVM+codegen_ = do n <- identifier; return (Via (map toLower n)) <|> do reserved "Bytecode"; return Bytecode <?> "code generation language" @@ -1156,8 +1155,8 @@ let (fc, msg) = findFC doc i <- getIState case idris_outputmode i of- RawOutput -> ihputStrLn (idris_outh i) (show $ fixColour (idris_colourRepl i) doc)- IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)+ RawOutput h -> iputStrLn (show $ fixColour (idris_colourRepl i) doc)+ IdeSlave n h -> iWarn fc (P.text msg) putIState (i { errSpan = Just fc }) return [] Success (x, i) -> do putIState i@@ -1173,17 +1172,17 @@ return (ds, i') {- | Load idris module and show error if something wrong happens -}-loadModule :: Handle -> FilePath -> Idris String-loadModule outh f- = idrisCatch (loadModule' outh f)+loadModule :: FilePath -> Idris String+loadModule f+ = idrisCatch (loadModule' f) (\e -> do setErrSpan (getErrSpan e) ist <- getIState- ihWarn outh (getErrSpan e) $ pprintErr ist e+ iWarn (getErrSpan e) $ pprintErr ist e return "") {- | Load idris module -}-loadModule' :: Handle -> FilePath -> Idris String-loadModule' outh f+loadModule' :: FilePath -> Idris String+loadModule' f = do i <- getIState let file = takeWhile (/= ' ') f ibcsd <- valIBCSubDir i@@ -1193,21 +1192,21 @@ then iLOG $ "Already read " ++ file else do putIState (i { imported = file : imported i }) case fp of- IDR fn -> loadSource outh False fn Nothing- LIDR fn -> loadSource outh True fn Nothing+ IDR fn -> loadSource False fn Nothing+ LIDR fn -> loadSource True fn Nothing IBC fn src -> idrisCatch (loadIBC fn) (\c -> do iLOG $ fn ++ " failed " ++ pshow i c case src of- IDR sfn -> loadSource outh False sfn Nothing- LIDR sfn -> loadSource outh True sfn Nothing)+ IDR sfn -> loadSource False sfn Nothing+ LIDR sfn -> loadSource True sfn Nothing) let (dir, fh) = splitFileName file return (dropExtension fh) {- | Load idris code from file -}-loadFromIFile :: Handle -> IFileType -> Maybe Int -> Idris ()-loadFromIFile h i@(IBC fn src) maxline+loadFromIFile :: IFileType -> Maybe Int -> Idris ()+loadFromIFile i@(IBC fn src) maxline = do iLOG $ "Skipping " ++ getSrcFile i idrisCatch (loadIBC fn) (\err -> ierror $ LoadingFailed fn err)@@ -1216,28 +1215,30 @@ getSrcFile (LIDR fn) = fn getSrcFile (IBC f src) = getSrcFile src -loadFromIFile h (IDR fn) maxline = loadSource' h False fn maxline-loadFromIFile h (LIDR fn) maxline = loadSource' h True fn maxline+loadFromIFile (IDR fn) maxline = loadSource' False fn maxline+loadFromIFile (LIDR fn) maxline = loadSource' True fn maxline {-| Load idris source code and show error if something wrong happens -}-loadSource' :: Handle -> Bool -> FilePath -> Maybe Int -> Idris ()-loadSource' h lidr r maxline- = idrisCatch (loadSource h lidr r maxline)+loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()+loadSource' lidr r maxline+ = idrisCatch (loadSource lidr r maxline) (\e -> do setErrSpan (getErrSpan e) ist <- getIState case e of- At f e' -> ihWarn h f (pprintErr ist e')- _ -> ihWarn h (getErrSpan e) (pprintErr ist e))+ At f e' -> iWarn f (pprintErr ist e')+ _ -> iWarn (getErrSpan e) (pprintErr ist e)) {- | Load Idris source code-}-loadSource :: Handle -> Bool -> FilePath -> Maybe Int -> Idris ()-loadSource h lidr f toline+loadSource :: Bool -> FilePath -> Maybe Int -> Idris ()+loadSource lidr f toline = do iLOG ("Reading " ++ f) i <- getIState let def_total = default_total i file_in <- runIO $ readFile f file <- if lidr then tclift $ unlit f file_in else return file_in- (mname, imports, pos) <- parseImports f file+ (mname, imports_in, pos) <- parseImports f file+ ai <- getAutoImports+ let imports = map (\n -> (n, Just n, emptyFC)) ai ++ imports_in ids <- allImportDirs ibcsd <- valIBCSubDir i mapM_ (\f -> do fp <- findImport ids ibcsd f@@ -1261,6 +1262,9 @@ i <- getIState putIState (i { default_access = Hidden, module_aliases = modAliases }) clearIBC -- start a new .ibc file+ -- record package info in .ibc+ imps <- allImportDirs + mapM_ addIBC (map IBCImportDir imps) mapM_ (addIBC . IBCImport) [realName | (realName, alias, fc) <- imports] let syntax = defaultSyntax{ syn_namespace = reverse mname, maxline = toline }@@ -1275,7 +1279,7 @@ logLvl 3 (show (idris_infixes i)) -- Now add all the declarations to the context v <- verbose- when v $ ihputStrLn h $ "Type checking " ++ f+ when v $ iputStrLn $ "Type checking " ++ f -- we totality check after every Mutual block, so if -- anything is a single definition, wrap it in a -- mutual block on its own
src/Idris/PartialEval.hs view
@@ -35,35 +35,35 @@ where -- Specialise static argument in type by let-binding provided value instead -- of expecting it as a function argument- st ((ExplicitS, v) : xs) (Bind n (Pi t) sc)+ st ((ExplicitS, v) : xs) (Bind n (Pi t _) sc) = Bind n (Let t v) (st xs sc)- st ((ImplicitS, v) : xs) (Bind n (Pi t) sc)+ st ((ImplicitS, v) : xs) (Bind n (Pi t _) sc) = Bind n (Let t v) (st xs sc) -- Erase argument from function type- st ((UnifiedD, _) : xs) (Bind n (Pi t) sc)+ st ((UnifiedD, _) : xs) (Bind n (Pi t _) sc) = st xs sc -- Keep types as is- st (_ : xs) (Bind n (Pi t) sc)- = Bind n (Pi t) (st xs sc)+ st (_ : xs) (Bind n (Pi t k) sc)+ = Bind n (Pi t k) (st xs sc) st _ t = t -- Erase implicit dynamic argument if existing argument shares it value, -- by substituting the value of previous argument- unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi t) sc)+ unifyEq (imp@(ImplicitD, v) : xs) (Bind n (Pi t k) sc) = do amap <- get case lookup imp amap of Just n' -> do put (amap ++ [((UnifiedD, Erased), n)]) sc' <- unifyEq xs (subst n (P Bound n' Erased) sc)- return (Bind n (Pi t) sc') -- erase later+ return (Bind n (Pi t k) sc') -- erase later _ -> do put (amap ++ [(imp, n)]) sc' <- unifyEq xs sc- return (Bind n (Pi t) sc')- unifyEq (x : xs) (Bind n (Pi t) sc)+ return (Bind n (Pi t k) sc')+ unifyEq (x : xs) (Bind n (Pi t k) sc) = do args <- get put (args ++ [(x, n)]) sc' <- unifyEq xs sc- return (Bind n (Pi t) sc')+ return (Bind n (Pi t k) sc') unifyEq xs t = do args <- get put (args ++ (zip xs (repeat (sUN "_")))) return t@@ -73,13 +73,14 @@ mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm mkPE_TyDecl ist args ty = mkty args ty where- mkty ((ExplicitD, v) : xs) (Bind n (Pi t) sc)+ mkty ((ExplicitD, v) : xs) (Bind n (Pi t k) sc) = PPi expl n (delab ist t) (mkty xs sc)- mkty ((ImplicitD, v) : xs) (Bind n (Pi t) sc)+ mkty ((ImplicitD, v) : xs) (Bind n (Pi t k) sc) | concreteClass ist t = mkty xs sc | classConstraint ist t = PPi constraint n (delab ist t) (mkty xs sc) | otherwise = PPi impl n (delab ist t) (mkty xs sc)+ mkty (_ : xs) t = mkty xs t mkty [] t = delab ist t
src/Idris/Primitives.hs view
@@ -26,7 +26,7 @@ ty :: [Const] -> Const -> Type ty [] x = Constant x-ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x)+ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t) (TType (UVar (-3)))) (ty ts x) total, partial, iopartial :: Totality total = Total []
src/Idris/ProofSearch.hs view
@@ -59,7 +59,7 @@ where -- if nothing worked, make a new metavariable tryAllFns [] | fromProver = cantSolveGoal - tryAllFns [] = do attack; defer nroot; solve+ tryAllFns [] = do attack; defer [] nroot; solve tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True tryFn (f, args) = do let imps = map isImp args@@ -75,7 +75,7 @@ if fromProver then cantSolveGoal else do mapM_ (\ h -> do focus h- attack; defer nroot; solve) + attack; defer [] nroot; solve) (hs' \\ hs) -- (filter (\ (x, y) -> not x) (zip (map fst imps) args)) solve@@ -96,7 +96,7 @@ toUN t = t psRec _ 0 | fromProver = cantSolveGoal- psRec rec 0 = do attack; defer nroot; solve --fail "Maximum depth reached"+ psRec rec 0 = do attack; defer [] nroot; solve --fail "Maximum depth reached" psRec False d = tryCons d hints psRec True d = try' (trivial elab ist) (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))@@ -104,7 +104,7 @@ -- if all else fails, make a new metavariable (if fromProver then cantSolveGoal- else do attack; defer nroot; solve) True) True+ else do attack; defer [] nroot; solve) True) True getFn d Nothing = [] getFn d (Just f) | d < maxDepth-1 = [f]
src/Idris/Prover.hs view
@@ -19,12 +19,13 @@ import Idris.Error import Idris.DataOpts import Idris.Completion-import Idris.IdeSlave+import qualified Idris.IdeSlave as IdeSlave import Idris.Output import Idris.TypeSearch (searchByType) import Text.Trifecta.Result(Result(..)) +import System.IO (Handle, stdin, stdout, hPutStrLn) import System.Console.Haskeline import System.Console.Haskeline.History import Control.Monad.State.Strict@@ -70,8 +71,8 @@ iLOG $ "Adding " ++ show tm i <- getIState case idris_outputmode i of- IdeSlave _ -> ideslavePutSExp "end-proof-mode" (n, showProof lit n prf)- _ -> iputStrLn $ showProof lit n prf+ IdeSlave _ _ -> ideslavePutSExp "end-proof-mode" (n, showProof lit n prf)+ _ -> iputStrLn $ showProof lit n prf let proofs = proof_list i putIState (i { proof_list = (n, prf) : proofs }) let tree = simpleCase False True False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)]@@ -93,9 +94,8 @@ [([], P Ref n ty, ptm')] ty) solveDeferred n case idris_outputmode i of- IdeSlave n ->- runIO . putStrLn $- convSExp "return" (SymbolAtom "ok", "") n+ IdeSlave n h ->+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", "") n _ -> return () elabStep :: ElabState [PDecl] -> ElabD a -> Idris (a, ElabState [PDecl])@@ -140,6 +140,8 @@ prettyPs bnd [] = empty prettyPs bnd ((n@(MN _ r), _) : bs) | r == txt "rewrite_rule" = prettyPs ((n, False):bnd) bs+ prettyPs bnd ((n@(MN _ _), _) : bs)+ | not (n `elem` freeEnvNames bs) = prettyPs bnd bs prettyPs bnd ((n, Let t v) : bs) = line <> bindingOf n False <+> text "=" <+> tPretty bnd v <+> colon <+> align (tPretty bnd t) <> prettyPs ((n, False):bnd) bs@@ -168,27 +170,35 @@ text "---------- Other goals: ----------" <$$> nest nestingSize (align . cat . punctuate (text ",") . map (flip bindingOf False) $ hs) + freeEnvNames :: Env -> [Name]+ freeEnvNames = foldl (++) [] . map (\(n, b) -> freeNames (Bind n b Erased))+ lifte :: ElabState [PDecl] -> ElabD a -> Idris a lifte st e = do (v, _) <- elabStep st e return v -receiveInput :: ElabState [PDecl] -> Idris (Maybe String)-receiveInput e =+receiveInput :: Handle -> ElabState [PDecl] -> Idris (Maybe String)+receiveInput h e = do i <- getIState- l <- runIO $ getLine- (sexp, id) <- case parseMessage l of+ let inh = if h == stdout then stdin else h+ len' <- runIO $ IdeSlave.getLen inh+ len <- case len' of+ Left err -> ierror err+ Right n -> return n+ l <- runIO $ IdeSlave.getNChar inh len ""+ (sexp, id) <- case IdeSlave.parseMessage l of Left err -> ierror err Right (sexp, id) -> return (sexp, id)- putIState $ i { idris_outputmode = (IdeSlave id) }- case sexpToCommand sexp of- Just (REPLCompletions prefix) ->+ putIState $ i { idris_outputmode = (IdeSlave id h) }+ case IdeSlave.sexpToCommand sexp of+ Just (IdeSlave.REPLCompletions prefix) -> do (unused, compls) <- proverCompletion (assumptionNames e) (reverse prefix, "")- let good = SexpList [SymbolAtom "ok", toSExp (map replacement compls, reverse unused)]+ let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)] ideslavePutSExp "return" good- receiveInput e- Just (Interpret cmd) -> return (Just cmd)- Just (TypeOf str) -> return (Just (":t " ++ str))- Just (DocsFor str) -> return (Just (":doc " ++ str))+ receiveInput h e+ Just (IdeSlave.Interpret cmd) -> return (Just cmd)+ Just (IdeSlave.TypeOf str) -> return (Just (":t " ++ str))+ Just (IdeSlave.DocsFor str) -> return (Just (":doc " ++ str)) _ -> return Nothing ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])@@ -198,17 +208,18 @@ when d $ dumpState i (proof e) (x, h') <- case idris_outputmode i of- RawOutput -> runInputT (proverSettings e) $- -- Manually track the history so that we can use the proof state- do _ <- case h of- Just history -> putHistory history- Nothing -> return ()- l <- getInputLine (prompt ++ "> ")- h' <- getHistory- return (l, Just h')- IdeSlave n ->+ RawOutput _ ->+ runInputT (proverSettings e) $+ -- Manually track the history so that we can use the proof state+ do case h of+ Just history -> putHistory history+ Nothing -> return ()+ l <- getInputLine (prompt ++ "> ")+ h' <- getHistory+ return (l, Just h')+ IdeSlave _ handle -> do isetPrompt prompt- i <- receiveInput e+ i <- receiveInput handle e return (i, h) (cmd, step) <- case x of Nothing -> do iPrintError ""; ifail "Abandoned"@@ -240,7 +251,8 @@ (\err -> return (False, e, False, prf, Left err)) ideslavePutSExp "write-proof-state" (prf', length prf') case res of- Left err -> do iPrintError (pshow i err)+ Left err -> do ist <- getIState+ iRenderError $ pprintErr ist err ploop fn d prompt prf' st h' Right ok -> if done then do (tm, _) <- elabStep st get_term@@ -253,8 +265,7 @@ ist <- getIState imp <- impShow idrisCatch (do- let h = idris_outh ist- OK env = envAtFocus (proof e)+ let OK env = envAtFocus (proof e) ctxt' = envCtxt env ctxt bnd = map (\x -> (fst x, False)) env ist' = ist { tt_ctxt = ctxt' }@@ -262,8 +273,8 @@ -- Unlike the REPL, metavars have no special treatment, to -- make it easier to see how to prove with them. let action = case lookupNames n ctxt' of- [] -> ihPrintError h $ "No such variable " ++ show n- ts -> ihPrintFunTypes h bnd n (map (\n -> (n, delabTy ist' n)) ts)+ [] -> iPrintError $ "No such variable " ++ show n+ ts -> iPrintFunTypes bnd n (map (\n -> (n, delabTy ist' n)) ts) putIState ist return (False, e, False, prf, Right action)) (\err -> do putIState ist ; ierror err)@@ -278,14 +289,13 @@ (tm, ty) <- elabVal recinfo ERHS t let ppo = ppOptionIst ist ty' = normaliseC ctxt [] ty- h = idris_outh ist infixes = idris_infixes ist action = case tm of TType _ ->- ihPrintTermWithType h (prettyImp ppo PType) type1Doc+ iPrintTermWithType (prettyImp ppo PType) type1Doc _ -> let bnd = map (\x -> (fst x, False)) env in- ihPrintTermWithType h (pprintPTerm ppo bnd [] infixes (delab ist tm))- (pprintPTerm ppo bnd [] infixes (delab ist ty))+ iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))+ (pprintPTerm ppo bnd [] infixes (delab ist ty)) putIState ist return (False, e, False, prf, Right action)) (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)@@ -306,25 +316,21 @@ infixes = idris_infixes ist tmDoc = pprintPTerm ppo bnd [] infixes (delab ist' tm') tyDoc = pprintPTerm ppo bnd [] infixes (delab ist' ty')- action = ihPrintTermWithType (idris_outh ist') tmDoc tyDoc+ action = iPrintTermWithType tmDoc tyDoc putIState ist return (False, e, False, prf, Right action)) (\err -> do putIState ist ; ierror err) docStr :: Either Name Const -> Idris (Bool, ElabState [PDecl], Bool, [String], Either Err (Idris ())) docStr (Left n) = do ist <- getIState- let h = idris_outh ist idrisCatch (case lookupCtxtName n (idris_docstrings ist) of [] -> return (False, e, False, prf, Left . Msg $ "No documentation for " ++ show n) ns -> do toShow <- mapM (showDoc ist) ns return (False, e, False, prf,- Right $ ihRenderResult h (vsep toShow)))+ Right $ iRenderResult (vsep toShow))) (\err -> do putIState ist ; ierror err) where showDoc ist (n, d) = do doc <- getDocs n return $ pprintDocs ist doc docStr (Right c) = do ist <- getIState- let h = idris_outh ist- return (False, e, False, prf, Right . ihRenderResult h $ pprintConstDocs ist c (constDocs c))- search t = do ist <- getIState- let h = idris_outh ist- return (False, e, False, prf, Right $ searchByType h t)+ return (False, e, False, prf, Right . iRenderResult $ pprintConstDocs ist c (constDocs c))+ search t = return (False, e, False, prf, Right $ searchByType t)
src/Idris/Providers.hs view
@@ -34,5 +34,6 @@ , pioret == ioret && nm == prmod = return . Provide $ res | otherwise = ifail $ "Internal type provider error: result was not " ++- "IO (Provider a), or perhaps missing normalisation."+ "IO (Provider a), or perhaps missing normalisation." +++ "Term: " ++ take 1000 (show tm)
src/Idris/REPL.hs view
@@ -42,7 +42,7 @@ import Version_idris (gitHash) import Util.System import Util.DynamicLinker-import Util.Net (listenOnLocalhost)+import Util.Net (listenOnLocalhost, listenOnLocalhostAnyPort) import Util.Pretty hiding ((</>)) import Idris.Core.Evaluate@@ -54,6 +54,8 @@ import IRTS.CodegenCommon import IRTS.System +import Control.Category+import Prelude hiding ((.), id) import Data.List.Split (splitOn) import Data.List (groupBy) import qualified Data.Text as T@@ -91,6 +93,8 @@ import Data.Either (partitionEithers) import Control.DeepSeq +import Numeric ( readHex )+ import Debug.Trace -- | Run the REPL@@ -149,7 +153,7 @@ -- TODO: option for port number serverLoop = withSocketsDo $ do sock <- listenOnLocalhost $ PortNumber 4294- loop fn orig sock+ loop fn orig { idris_colourRepl = False } sock fn = case fn_in of (f:_) -> f@@ -159,7 +163,10 @@ = do (h,_,_) <- accept sock hSetEncoding h utf8 cmd <- hGetLine h- (ist', fn) <- processNetCmd orig ist h fn cmd+ let isth = case idris_outputmode ist of+ RawOutput _ -> ist {idris_outputmode = RawOutput h}+ IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h}+ (ist', fn) <- processNetCmd orig isth h fn cmd hClose h loop fn ist' sock @@ -185,12 +192,18 @@ setOutH h setQuiet True setVerbose False- mods <- loadInputs h [f] toline+ mods <- loadInputs [f] toline ist <- getIState return (ist, f)- processNet fn c = do process h fn c+ processNet fn c = do process fn c ist <- getIState return (ist, fn)+ setOutH :: Handle -> Idris ()+ setOutH h =+ do ist <- getIState+ putIState $ case idris_outputmode ist of+ RawOutput _ -> ist {idris_outputmode = RawOutput h}+ IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h} -- | Run a command on the server on localhost runClient :: String -> IO ()@@ -206,55 +219,73 @@ else do l <- hGetLine h hGetResp (acc ++ l ++ "\n") h +initIdeslaveSocket :: IO Handle+initIdeslaveSocket = do+ (sock, port) <- listenOnLocalhostAnyPort+ putStrLn $ show port+ (h, _, _) <- accept sock+ hSetEncoding h utf8+ return h+ -- | Run the IdeSlave-ideslaveStart :: IState -> [FilePath] -> Idris ()-ideslaveStart orig mods- = do i <- getIState+ideslaveStart :: Bool -> IState -> [FilePath] -> Idris ()+ideslaveStart s orig mods+ = do h <- runIO $ if s then initIdeslaveSocket else return stdout+ setIdeSlave True h+ i <- getIState case idris_outputmode i of- IdeSlave n ->- when (mods /= []) (do isetPrompt (mkPrompt mods))- ideslave orig mods-+ IdeSlave n h ->+ do runIO $ hPutStrLn h $ IdeSlave.convSExp "protocol-version" IdeSlave.ideSlaveEpoch n+ case mods of+ a:_ -> runIdeSlaveCommand h n i "" [] (IdeSlave.LoadFile a Nothing)+ _ -> return ()+ ideslave h orig mods -ideslave :: IState -> [FilePath] -> Idris ()-ideslave orig mods+ideslave :: Handle -> IState -> [FilePath] -> Idris ()+ideslave h orig mods = do idrisCatch- (do l <- runIO $ getLine+ (do let inh = if h == stdout then stdin else h+ len' <- runIO $ IdeSlave.getLen inh+ len <- case len' of+ Left err -> ierror err+ Right n -> return n+ l <- runIO $ IdeSlave.getNChar inh len "" (sexp, id) <- case IdeSlave.parseMessage l of Left err -> ierror err Right (sexp, id) -> return (sexp, id) i <- getIState- putIState $ i { idris_outputmode = (IdeSlave id) }+ putIState $ i { idris_outputmode = (IdeSlave id h) } idrisCatch -- to report correct id back! (do let fn = case mods of (f:_) -> f- _ -> ""+ _ -> "" case IdeSlave.sexpToCommand sexp of- Just cmd -> runIdeSlaveCommand id orig fn mods cmd+ Just cmd -> runIdeSlaveCommand h id orig fn mods cmd Nothing -> iPrintError "did not understand" ) (\e -> do iPrintError $ show e)) (\e -> do iPrintError $ show e)- ideslave orig mods+ ideslave h orig mods -- | Run IDESlave commands-runIdeSlaveCommand :: Integer -- ^^ The continuation ID for the client+runIdeSlaveCommand :: Handle -- ^^ The handle for communication+ -> Integer -- ^^ The continuation ID for the client -> IState -- ^^ The original IState -> FilePath -- ^^ The current open file -> [FilePath] -- ^^ The currently loaded modules -> IdeSlave.IdeSlaveCommand -- ^^ The command to process -> Idris ()-runIdeSlaveCommand id orig fn mods (IdeSlave.Interpret cmd) =+runIdeSlaveCommand h id orig fn mods (IdeSlave.Interpret cmd) = do c <- colourise i <- getIState case parseCmd i "(input)" cmd of- Failure err -> iPrintError $ show (fixColour c err)+ Failure err -> iPrintError $ show (fixColour False err) Success (Prove n') -> idrisCatch- (do process stdout fn (Prove n')+ (do process fn (Prove n') isetPrompt (mkPrompt mods) case idris_outputmode i of- IdeSlave n -> -- signal completion of proof to ide- runIO . hPutStrLn stdout $+ IdeSlave n h -> -- signal completion of proof to ide+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", "") n@@ -262,26 +293,26 @@ (\e -> do ist <- getIState isetPrompt (mkPrompt mods) case idris_outputmode i of- IdeSlave n ->- runIO . hPutStrLn stdout $+ IdeSlave n h ->+ runIO . hPutStrLn h $ IdeSlave.convSExp "abandon-proof" "Abandoned" n _ -> return ()- ihRenderError stdout $ pprintErr ist e)+ iRenderError $ pprintErr ist e) Success cmd -> idrisCatch (ideslaveProcess fn cmd)- (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)-runIdeSlaveCommand id orig fn mods (IdeSlave.REPLCompletions str) =+ (\e -> getIState >>= iRenderError . flip pprintErr e)+runIdeSlaveCommand h id orig fn mods (IdeSlave.REPLCompletions str) = do (unused, compls) <- replCompletion (reverse str, "") let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]- runIO $ putStrLn $ IdeSlave.convSExp "return" good id-runIdeSlaveCommand id orig fn mods (IdeSlave.LoadFile filename toline) =+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" good id+runIdeSlaveCommand h id orig fn mods (IdeSlave.LoadFile filename toline) = do i <- getIState clearErr putIState (orig { idris_options = idris_options i,- idris_outputmode = (IdeSlave id) })- loadInputs stdout [filename] toline+ idris_outputmode = (IdeSlave id h) })+ loadInputs [filename] toline isetPrompt (mkPrompt [filename]) -- Report either success or failure i <- getIState@@ -291,45 +322,45 @@ (\fc -> IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp fc]) (idris_parsedSpan i)- in runIO . putStrLn $ IdeSlave.convSExp "return" msg id+ in runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id Just x -> iPrintError $ "didn't load " ++ filename- ideslave orig [filename]-runIdeSlaveCommand id orig fn mods (IdeSlave.TypeOf name) =+ ideslave h orig [filename]+runIdeSlaveCommand h id orig fn mods (IdeSlave.TypeOf name) = case splitName name of Left err -> iPrintError err- Right n -> process stdout "(ideslave)"+ Right n -> process "(ideslave)" (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n)) where splitName :: String -> Either String Name splitName s = case reverse $ splitOn "." s of [] -> Left ("Didn't understand name '" ++ s ++ "'") [n] -> Right $ sUN n (n:ns) -> Right $ sNS (sUN n) ns-runIdeSlaveCommand id orig fn mods (IdeSlave.DocsFor name) =+runIdeSlaveCommand h id orig fn mods (IdeSlave.DocsFor name) = case parseConst orig name of- Success c -> process stdout "(ideslave)" (DocStr (Right c))+ Success c -> process "(ideslave)" (DocStr (Right c)) Failure _ -> case splitName name of Left err -> iPrintError err- Right n -> process stdout "(ideslave)" (DocStr (Left n))-runIdeSlaveCommand id orig fn mods (IdeSlave.CaseSplit line name) =- process stdout fn (CaseSplitAt False line (sUN name))-runIdeSlaveCommand id orig fn mods (IdeSlave.AddClause line name) =- process stdout fn (AddClauseFrom False line (sUN name))-runIdeSlaveCommand id orig fn mods (IdeSlave.AddProofClause line name) =- process stdout fn (AddProofClauseFrom False line (sUN name))-runIdeSlaveCommand id orig fn mods (IdeSlave.AddMissing line name) =- process stdout fn (AddMissing False line (sUN name))-runIdeSlaveCommand id orig fn mods (IdeSlave.MakeWithBlock line name) =- process stdout fn (MakeWith False line (sUN name))-runIdeSlaveCommand id orig fn mods (IdeSlave.ProofSearch r line name hints depth) =- doProofSearch stdout fn False r line (sUN name) (map sUN hints) depth-runIdeSlaveCommand id orig fn mods (IdeSlave.MakeLemma line name) =+ Right n -> process "(ideslave)" (DocStr (Left n))+runIdeSlaveCommand h id orig fn mods (IdeSlave.CaseSplit line name) =+ process fn (CaseSplitAt False line (sUN name))+runIdeSlaveCommand h id orig fn mods (IdeSlave.AddClause line name) =+ process fn (AddClauseFrom False line (sUN name))+runIdeSlaveCommand h id orig fn mods (IdeSlave.AddProofClause line name) =+ process fn (AddProofClauseFrom False line (sUN name))+runIdeSlaveCommand h id orig fn mods (IdeSlave.AddMissing line name) =+ process fn (AddMissing False line (sUN name))+runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeWithBlock line name) =+ process fn (MakeWith False line (sUN name))+runIdeSlaveCommand h id orig fn mods (IdeSlave.ProofSearch r line name hints depth) =+ doProofSearch fn False r line (sUN name) (map sUN hints) depth+runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeLemma line name) = case splitName name of Left err -> iPrintError err- Right n -> process stdout fn (MakeLemma False line n)-runIdeSlaveCommand id orig fn mods (IdeSlave.Apropos a) =- process stdout fn (Apropos a)-runIdeSlaveCommand id orig fn mods (IdeSlave.GetOpts) =+ Right n -> process fn (MakeLemma False line n)+runIdeSlaveCommand h id orig fn mods (IdeSlave.Apropos a) =+ process fn (Apropos a)+runIdeSlaveCommand h id orig fn mods (IdeSlave.GetOpts) = do ist <- getIState let opts = idris_options ist let impshow = opt_showimp opts@@ -337,16 +368,16 @@ let options = (IdeSlave.SymbolAtom "ok", [(IdeSlave.SymbolAtom "show-implicits", impshow), (IdeSlave.SymbolAtom "error-context", errCtxt)])- runIO . putStrLn $ IdeSlave.convSExp "return" options id-runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) =+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" options id+runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) = do setImpShow b let msg = (IdeSlave.SymbolAtom "ok", b)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) =+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) = do setErrContext b let msg = (IdeSlave.SymbolAtom "ok", b)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand id orig fn mods (IdeSlave.Metavariables cols) =+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand h id orig fn mods (IdeSlave.Metavariables cols) = do ist <- getIState let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs let ppo = ppOptionIst ist@@ -362,7 +393,7 @@ (zip bnds hs), render ist bnd c pc)) splitMvs- runIO . putStrLn $+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", mvOutput) id where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs) mapSnd f xs = zip (map fst xs) (map (f . snd) xs)@@ -370,7 +401,7 @@ -- | Split a function type into a pair of premises, conclusion. -- Each maintains both the original and delaborated versions. splitPi :: IState -> Type -> ([(Name, Type, PTerm)], Type, PTerm)- splitPi ist (Bind n (Pi t) rest) =+ splitPi ist (Bind n (Pi t _) rest) = let (hs, c, pc) = splitPi ist rest in ((n, t, delabTy' ist [] t False False):hs, c, delabTy' ist [] c False False)@@ -407,32 +438,32 @@ let (out, spans) = render ist bnd t pt in (show n , out, spans) -runIdeSlaveCommand id orig fn mods (IdeSlave.WhoCalls n) =+runIdeSlaveCommand h id orig fn mods (IdeSlave.WhoCalls n) = case splitName n of Left err -> iPrintError err Right n -> do calls <- whoCalls n ist <- getIState let msg = (IdeSlave.SymbolAtom "ok", map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id where pn ist = displaySpans . renderPretty 0.9 1000 . fmap (fancifyAnnots ist) . prettyName True True []-runIdeSlaveCommand id orig fn mods (IdeSlave.CallsWho n) =+runIdeSlaveCommand h id orig fn mods (IdeSlave.CallsWho n) = case splitName n of Left err -> iPrintError err Right n -> do calls <- callsWho n ist <- getIState let msg = (IdeSlave.SymbolAtom "ok", map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id where pn ist = displaySpans . renderPretty 0.9 1000 . fmap (fancifyAnnots ist) . prettyName True True [] -runIdeSlaveCommand id orig fn modes (IdeSlave.TermNormalise bnd tm) =+runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNormalise bnd tm) = do ctxt <- getContext ist <- getIState let tm' = force (normaliseAll ctxt [] tm)@@ -446,15 +477,15 @@ displaySpans . renderPretty 0.9 80 . fmap (fancifyAnnots ist) $ ptm)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id-runIdeSlaveCommand id orig fn modes (IdeSlave.TermShowImplicits bnd tm) =- ideSlaveForceTermImplicits id bnd True tm-runIdeSlaveCommand id orig fn modes (IdeSlave.TermNoImplicits bnd tm) =- ideSlaveForceTermImplicits id bnd False tm+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id+runIdeSlaveCommand h id orig fn modes (IdeSlave.TermShowImplicits bnd tm) =+ ideSlaveForceTermImplicits h id bnd True tm+runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNoImplicits bnd tm) =+ ideSlaveForceTermImplicits h id bnd False tm -- | Show a term for IDESlave with the specified implicitness-ideSlaveForceTermImplicits :: Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()-ideSlaveForceTermImplicits id bnd impl tm =+ideSlaveForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()+ideSlaveForceTermImplicits h id bnd impl tm = do ist <- getIState let expl = annotate (AnnTerm bnd tm) (pprintPTerm ((ppOptionIst ist) { ppopt_impl = impl })@@ -464,7 +495,7 @@ displaySpans . renderPretty 0.9 80 . fmap (fancifyAnnots ist) $ expl)- runIO . putStrLn $ IdeSlave.convSExp "return" msg id+ runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id splitName :: String -> Either String Name splitName s = case reverse $ splitOn "." s of@@ -473,70 +504,70 @@ (n:ns) -> Right $ sNS (sUN n) ns ideslaveProcess :: FilePath -> Command -> Idris ()-ideslaveProcess fn Warranty = process stdout fn Warranty-ideslaveProcess fn Help = process stdout fn Help-ideslaveProcess fn (ChangeDirectory f) = do process stdout fn (ChangeDirectory f)+ideslaveProcess fn Warranty = process fn Warranty+ideslaveProcess fn Help = process fn Help+ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f) iPrintResult "changed directory to"-ideslaveProcess fn (Eval t) = process stdout fn (Eval t)-ideslaveProcess fn (NewDefn decls) = do process stdout fn (NewDefn decls)+ideslaveProcess fn (Eval t) = process fn (Eval t)+ideslaveProcess fn (NewDefn decls) = do process fn (NewDefn decls) iPrintResult "defined"-ideslaveProcess fn (ExecVal t) = process stdout fn (ExecVal t)-ideslaveProcess fn (Check (PRef x n)) = process stdout fn (Check (PRef x n))-ideslaveProcess fn (Check t) = process stdout fn (Check t)-ideslaveProcess fn (DocStr n) = process stdout fn (DocStr n)-ideslaveProcess fn Universes = process stdout fn Universes-ideslaveProcess fn (Defn n) = do process stdout fn (Defn n)+ideslaveProcess fn (ExecVal t) = process fn (ExecVal t)+ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))+ideslaveProcess fn (Check t) = process fn (Check t)+ideslaveProcess fn (DocStr n) = process fn (DocStr n)+ideslaveProcess fn Universes = process fn Universes+ideslaveProcess fn (Defn n) = do process fn (Defn n) iPrintResult ""-ideslaveProcess fn (TotCheck n) = process stdout fn (TotCheck n)-ideslaveProcess fn (DebugInfo n) = do process stdout fn (DebugInfo n)+ideslaveProcess fn (TotCheck n) = process fn (TotCheck n)+ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n) iPrintResult ""-ideslaveProcess fn (Search t) = process stdout fn (Search t)-ideslaveProcess fn (Spec t) = process stdout fn (Spec t)+ideslaveProcess fn (Search t) = process fn (Search t)+ideslaveProcess fn (Spec t) = process fn (Spec t) -- RmProof and AddProof not supported!-ideslaveProcess fn (ShowProof n') = process stdout fn (ShowProof n')-ideslaveProcess fn (HNF t) = process stdout fn (HNF t)---ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode!-ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t)+ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')+ideslaveProcess fn (HNF t) = process fn (HNF t)+--ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode!+ideslaveProcess fn (TestInline t) = process fn (TestInline t) -ideslaveProcess fn Execute = do process stdout fn Execute+ideslaveProcess fn Execute = do process fn Execute iPrintResult ""-ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f)+ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f) iPrintResult ""-ideslaveProcess fn (LogLvl i) = do process stdout fn (LogLvl i)+ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i) iPrintResult ""-ideslaveProcess fn (Pattelab t) = process stdout fn (Pattelab t)-ideslaveProcess fn (Missing n) = process stdout fn (Missing n)-ideslaveProcess fn (DynamicLink l) = do process stdout fn (DynamicLink l)+ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)+ideslaveProcess fn (Missing n) = process fn (Missing n)+ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l) iPrintResult ""-ideslaveProcess fn ListDynamic = do process stdout fn ListDynamic+ideslaveProcess fn ListDynamic = do process fn ListDynamic iPrintResult ""-ideslaveProcess fn Metavars = process stdout fn Metavars-ideslaveProcess fn (SetOpt ErrContext) = do process stdout fn (SetOpt ErrContext)+ideslaveProcess fn Metavars = process fn Metavars+ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext) iPrintResult ""-ideslaveProcess fn (UnsetOpt ErrContext) = do process stdout fn (UnsetOpt ErrContext)+ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext) iPrintResult ""-ideslaveProcess fn (SetOpt ShowImpl) = do process stdout fn (SetOpt ShowImpl)+ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl) iPrintResult ""-ideslaveProcess fn (UnsetOpt ShowImpl) = do process stdout fn (UnsetOpt ShowImpl)+ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl) iPrintResult ""-ideslaveProcess fn (SetOpt ShowOrigErr) = do process stdout fn (SetOpt ShowOrigErr)+ideslaveProcess fn (SetOpt ShowOrigErr) = do process fn (SetOpt ShowOrigErr) iPrintResult ""-ideslaveProcess fn (UnsetOpt ShowOrigErr) = do process stdout fn (UnsetOpt ShowOrigErr)+ideslaveProcess fn (UnsetOpt ShowOrigErr) = do process fn (UnsetOpt ShowOrigErr) iPrintResult ""-ideslaveProcess fn (SetOpt x) = process stdout fn (SetOpt x)-ideslaveProcess fn (UnsetOpt x) = process stdout fn (UnsetOpt x)-ideslaveProcess fn (CaseSplitAt False pos str) = process stdout fn (CaseSplitAt False pos str)-ideslaveProcess fn (AddProofClauseFrom False pos str) = process stdout fn (AddProofClauseFrom False pos str)-ideslaveProcess fn (AddClauseFrom False pos str) = process stdout fn (AddClauseFrom False pos str)-ideslaveProcess fn (AddMissing False pos str) = process stdout fn (AddMissing False pos str)-ideslaveProcess fn (MakeWith False pos str) = process stdout fn (MakeWith False pos str)-ideslaveProcess fn (DoProofSearch False r pos str xs) = process stdout fn (DoProofSearch False r pos str xs)-ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)+ideslaveProcess fn (SetOpt x) = process fn (SetOpt x)+ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x)+ideslaveProcess fn (CaseSplitAt False pos str) = process fn (CaseSplitAt False pos str)+ideslaveProcess fn (AddProofClauseFrom False pos str) = process fn (AddProofClauseFrom False pos str)+ideslaveProcess fn (AddClauseFrom False pos str) = process fn (AddClauseFrom False pos str)+ideslaveProcess fn (AddMissing False pos str) = process fn (AddMissing False pos str)+ideslaveProcess fn (MakeWith False pos str) = process fn (MakeWith False pos str)+ideslaveProcess fn (DoProofSearch False r pos str xs) = process fn (DoProofSearch False r pos str xs)+ideslaveProcess fn (SetConsoleWidth w) = do process fn (SetConsoleWidth w) iPrintResult ""-ideslaveProcess fn (Apropos a) = do process stdout fn (Apropos a)+ideslaveProcess fn (Apropos a) = do process fn (Apropos a) iPrintResult ""-ideslaveProcess fn (WhoCalls n) = process stdout fn (WhoCalls n)-ideslaveProcess fn (CallsWho n) = process stdout fn (CallsWho n)+ideslaveProcess fn (WhoCalls n) = process fn (WhoCalls n)+ideslaveProcess fn (CallsWho n) = process fn (CallsWho n) ideslaveProcess fn _ = iPrintError "command not recognized or not supported" @@ -568,18 +599,18 @@ , idris_colourTheme = idris_colourTheme i } clearErr- mods <- loadInputs stdout inputs Nothing+ mods <- loadInputs inputs Nothing return (Just inputs) Success (Load f toline) -> do putIState orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i } clearErr- mod <- loadInputs stdout [f] toline+ mod <- loadInputs [f] toline return (Just [f]) Success (ModImport f) -> do clearErr- fmod <- loadModule stdout f+ fmod <- loadModule f return (Just (inputs ++ [fmod])) Success Edit -> do -- takeMVar stvar edit fn orig@@ -588,7 +619,7 @@ return (Just inputs) Success Quit -> do when (not quiet) (iputStrLn "Bye bye") return Nothing- Success cmd -> do idrisCatch (process stdout fn cmd)+ Success cmd -> do idrisCatch (process fn cmd) (\e -> do msg <- showErr e ; iputStrLn msg) return (Just inputs) @@ -624,7 +655,7 @@ putIState $ orig { idris_options = idris_options i , idris_colourTheme = idris_colourTheme i }- loadInputs stdout [f] Nothing+ loadInputs [f] Nothing -- clearOrigPats iucheck return ()@@ -650,13 +681,13 @@ = p : "" : prf : xs insertScript prf (x : xs) = x : insertScript prf xs -process :: Handle -> FilePath -> Command -> Idris ()-process h fn Help = iPrintResult displayHelp-process h fn Warranty = iPrintResult warranty-process h fn (ChangeDirectory f)+process :: FilePath -> Command -> Idris ()+process fn Help = iPrintResult displayHelp+process fn Warranty = iPrintResult warranty+process fn (ChangeDirectory f) = do runIO $ setCurrentDirectory f return ()-process h fn (Eval t)+process fn (Eval t) = withErrorReflection $ do logLvl 5 $ show t (tm, ty) <- elabVal recinfo ERHS t ctxt <- getContext@@ -669,15 +700,18 @@ logLvl 10 $ "Debug: " ++ showEnvDbg [] tm' let tmDoc = pprintDelab ist tm' tyDoc = pprintDelab ist ty'- ihPrintTermWithType h tmDoc tyDoc+ iPrintTermWithType tmDoc tyDoc -process h fn (NewDefn decls) = logLvl 3 ("Defining names using these decls: " ++ show namedGroups) >> mapM_ defineName namedGroups where+process fn (NewDefn decls) = do+ logLvl 3 ("Defining names using these decls: " ++ show (showDecls verbosePPOption decls))+ mapM_ defineName namedGroups where namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls getName :: PDecl -> Maybe Name getName (PTy docs argdocs syn fc opts name ty) = Just name getName (PClauses fc opts name (clause:clauses)) = Just (getClauseName clause) getName (PData doc argdocs syn fc opts dataDecl) = Just (d_name dataDecl)+ getName (PClass doc syn fc constraints name parms parmdocs decls) = Just name getName _ = Nothing -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes getClauseName (PClause fc name whole with rhs whereBlock) = name@@ -686,6 +720,7 @@ defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do elabDecl EAll recinfo tyDecl elabClauses recinfo fc opts name (concatMap getClauses decls)+ setReplDefined (Just name) defineName [PClauses fc opts _ [clause]] = do let pterm = getRHS clause (tm,ty) <- elabVal recinfo ERHS pterm@@ -693,8 +728,16 @@ let tm' = force (normaliseAll ctxt [] tm) let ty' = force (normaliseAll ctxt [] ty) updateContext (addCtxtDef (getClauseName clause) (Function ty' tm'))- defineName [PData doc argdocs syn fc opts decl] = do- elabData recinfo syn doc argdocs fc opts decl+ setReplDefined (Just $ getClauseName clause)+ defineName (PClauses{} : _) = tclift $ tfail (Msg "Only one function body is allowed without a type declaration.")+ -- fixity and syntax declarations are ignored by elabDecls, so they'll have to be handled some other way+ defineName (PFix fc fixity strs : defns) = do+ fmodifyState idris_fixities (map (Fix fixity) strs ++)+ unless (null defns) $ defineName defns+ defineName (PSyntax{}:_) = tclift $ tfail (Msg "That kind of declaration is not supported. If you feel it should be supported, please submit an issue at https://github.com/idris-lang/Idris-dev.")+ defineName decls = do+ elabDecls toplevel (map fixClauses decls)+ setReplDefined (getName (head decls)) getClauses (PClauses fc opts name clauses) = clauses getClauses _ = [] getRHS :: PClause -> PTerm@@ -702,8 +745,58 @@ getRHS (PWith fc name whole with rhs whereBlock) = rhs getRHS (PClauseR fc with rhs whereBlock) = rhs getRHS (PWithR fc with rhs whereBlock) = rhs+ setReplDefined :: Maybe Name -> Idris ()+ setReplDefined Nothing = return ()+ setReplDefined (Just n) = do+ oldState <- get+ fmodifyState repl_definitions (n:)+ -- the "name" field of PClauses seems to always be MN 2 "__", so we need to+ -- retrieve the actual name from deeper inside.+ -- This should really be a full recursive walk through the structure of PDecl, but+ -- I think it should work this way and I want to test sooner. Also lazy.+ fixClauses :: PDecl' t -> PDecl' t+ fixClauses (PClauses fc opts _ css@(clause:cs)) =+ PClauses fc opts (getClauseName clause) css+ fixClauses (PInstance syn fc constraints cls parms ty instName decls) = + PInstance syn fc constraints cls parms ty instName (map fixClauses decls)+ fixClauses decl = decl -process h fn (ExecVal t)+process fn (Undefine names) = undefine names+ where+ undefine :: [Name] -> Idris ()+ undefine [] = do+ allDefined <- idris_repl_defs `fmap` get+ undefine' allDefined []+ -- Keep track of which names you've removed so you can + -- print them out to the user afterward+ undefine names = undefine' names []+ undefine' [] list = do iRenderOutput $ printUndefinedNames list + return ()+ undefine' (n:names) already = do+ allDefined <- idris_repl_defs `fmap` get+ if n `elem` allDefined+ then do undefinedJustNow <- undefClosure n+ undefine' names (undefinedJustNow ++ already)+ else do tclift $ tfail $ Msg ("Can't undefine " ++ show n ++ " because it wasn't defined at the repl")+ undefine' names already+ undefOne n = do fputState (ctxt_lookup n . known_terms) Nothing+ -- for now just assume it's a class. Eventually we'll want some kind of+ -- smart detection of exactly what kind of name we're undefining.+ fputState (ctxt_lookup n . known_classes) Nothing+ fmodifyState repl_definitions (delete n)+ undefClosure n = + do replDefs <- idris_repl_defs `fmap` get+ callGraph <- whoCalls n+ let users = case lookup n callGraph of+ Just ns -> nub ns+ Nothing -> fail ("Tried to undefine nonexistent name" ++ show n) + undefinedJustNow <- concat `fmap` mapM undefClosure users+ undefOne n+ return (nub (n : undefinedJustNow))++++process fn (ExecVal t) = do ctxt <- getContext ist <- getIState (tm, ty) <- elabVal recinfo ERHS t@@ -712,19 +805,19 @@ res <- execute tm let (resOut, tyOut) = (prettyIst ist (delab ist res), prettyIst ist (delab ist ty'))- ihPrintTermWithType h resOut tyOut+ iPrintTermWithType resOut tyOut -process h fn (Check (PRef _ n))+process fn (Check (PRef _ n)) = do ctxt <- getContext ist <- getIState let ppo = ppOptionIst ist case lookupNames n ctxt of ts@(t:_) -> case lookup t (idris_metavars ist) of- Just (_, i, _) -> ihRenderResult h . fmap (fancifyAnnots ist) $+ Just (_, i, _) -> iRenderResult . fmap (fancifyAnnots ist) $ showMetavarInfo ppo ist n i- Nothing -> ihPrintFunTypes h [] n (map (\n -> (n, delabTy ist n)) ts)- [] -> ihPrintError h $ "No such variable " ++ show n+ Nothing -> iPrintFunTypes [] n (map (\n -> (n, delabTy ist n)) ts)+ [] -> iPrintError $ "No such variable " ++ show n where showMetavarInfo ppo ist n i = case lookupTy n (tt_ctxt ist) of@@ -749,7 +842,7 @@ tPretty bnd ist t = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) t -process h fn (Check t)+process fn (Check t) = do (tm, ty) <- elabVal recinfo ERHS t ctxt <- getContext ist <- getIState@@ -757,24 +850,24 @@ ty' = normaliseC ctxt [] ty case tm of TType _ ->- ihPrintTermWithType h (prettyIst ist PType) type1Doc- _ -> ihPrintTermWithType h (pprintDelab ist tm)- (pprintDelab ist ty)+ iPrintTermWithType (prettyIst ist PType) type1Doc+ _ -> iPrintTermWithType (pprintDelab ist tm)+ (pprintDelab ist ty) -process h fn (DocStr (Left n))+process fn (DocStr (Left n)) = do ist <- getIState case lookupCtxtName n (idris_docstrings ist) of [] -> iPrintError $ "No documentation for " ++ show n ns -> do toShow <- mapM (showDoc ist) ns- ihRenderResult h (vsep toShow)+ iRenderResult (vsep toShow) where showDoc ist (n, d) = do doc <- getDocs n return $ pprintDocs ist doc -process h fn (DocStr (Right c))+process fn (DocStr (Right c)) = do ist <- getIState- ihRenderResult h $ pprintConstDocs ist c (constDocs c)+ iRenderResult $ pprintConstDocs ist c (constDocs c) -process h fn Universes+process fn Universes = do i <- getIState let cs = idris_constraints i -- iputStrLn $ showSep "\n" (map show cs)@@ -784,7 +877,7 @@ case ucheck cs of Error e -> iPrintError $ pshow i e OK _ -> iPrintResult "Universes OK"-process h fn (Defn n)+process fn (Defn n) = do i <- getIState iputStrLn "Compiled patterns:\n" iputStrLn $ show (lookupDef n (tt_ctxt i))@@ -799,20 +892,20 @@ = let i' = i { idris_options = (idris_options i) { opt_showimp = True } } in iputStrLn (showTm i' (delab i lhs) ++ " = " ++ showTm i' (delab i rhs))-process h fn (TotCheck n)+process fn (TotCheck n) = do i <- getIState case lookupNameTotal n (tt_ctxt i) of- [] -> ihPrintError h $ "Unknown operator " ++ show n+ [] -> iPrintError $ "Unknown operator " ++ show n ts -> do ist <- getIState c <- colourise let ppo = ppOptionIst ist let showN = showName (Just ist) [] ppo c- ihPrintResult h . concat . intersperse "\n" .+ iPrintResult . concat . intersperse "\n" . map (\(n, t) -> showN n ++ " is " ++ showTotal t i) $ ts -process h fn (DebugInfo n)+process fn (DebugInfo n) = do i <- getIState let oi = lookupCtxtName n (idris_optimisation i) when (not (null oi)) $ iputStrLn (show oi)@@ -827,31 +920,33 @@ let cg' = lookupCtxtName n (idris_callgraph i) sc <- checkSizeChange n iputStrLn $ "Size change: " ++ show sc+ let fn = lookupCtxtName n (idris_fninfo i) when (not (null cg')) $ do iputStrLn "Call graph:\n" iputStrLn (show cg')-process h fn (Search t) = searchByType h t-process h fn (CaseSplitAt updatefile l n)- = caseSplitAt h fn updatefile l n-process h fn (AddClauseFrom updatefile l n)- = addClauseFrom h fn updatefile l n-process h fn (AddProofClauseFrom updatefile l n)- = addProofClauseFrom h fn updatefile l n-process h fn (AddMissing updatefile l n)- = addMissing h fn updatefile l n-process h fn (MakeWith updatefile l n)- = makeWith h fn updatefile l n-process h fn (MakeLemma updatefile l n)- = makeLemma h fn updatefile l n-process h fn (DoProofSearch updatefile rec l n hints)- = doProofSearch h fn updatefile rec l n hints Nothing-process h fn (Spec t)+ when (not (null fn)) $ iputStrLn (show fn)+process fn (Search t) = searchByType t+process fn (CaseSplitAt updatefile l n)+ = caseSplitAt fn updatefile l n+process fn (AddClauseFrom updatefile l n)+ = addClauseFrom fn updatefile l n+process fn (AddProofClauseFrom updatefile l n)+ = addProofClauseFrom fn updatefile l n+process fn (AddMissing updatefile l n)+ = addMissing fn updatefile l n+process fn (MakeWith updatefile l n)+ = makeWith fn updatefile l n+process fn (MakeLemma updatefile l n)+ = makeLemma fn updatefile l n+process fn (DoProofSearch updatefile rec l n hints)+ = doProofSearch fn updatefile rec l n hints Nothing+process fn (Spec t) = do (tm, ty) <- elabVal recinfo ERHS t ctxt <- getContext ist <- getIState let tm' = simplify ctxt [] {- (idris_statics ist) -} tm iPrintResult (show (delab ist tm')) -process h fn (RmProof n')+process fn (RmProof n') = do i <- getIState n <- resolveProof n' let proofs = proof_list i@@ -867,7 +962,7 @@ let ms = idris_metavars i putIState $ i { idris_metavars = (n, (Nothing, 0, False)) : ms } -process h fn' (AddProof prf)+process fn' (AddProof prf) = do fn <- do let fn'' = takeWhile (/= ' ') fn' ex <- runIO $ doesFileExist fn''@@ -897,7 +992,7 @@ iputStrLn $ "Added proof " ++ show n where ls = (lines prog) -process h fn (ShowProof n')+process fn (ShowProof n') = do i <- getIState n <- resolveProof n' let proofs = proof_list i@@ -905,7 +1000,7 @@ Nothing -> iPrintError "No proof to show" Just p -> iPrintResult $ showProof False n p -process h fn (Prove n')+process fn (Prove n') = do ctxt <- getContext ist <- getIState let ns = lookupNames n' ctxt@@ -923,20 +1018,20 @@ mapM_ checkDeclTotality (idris_totcheck i) warnTotality -process h fn (HNF t)+process fn (HNF t) = do (tm, ty) <- elabVal recinfo ERHS t ctxt <- getContext ist <- getIState let tm' = hnf ctxt [] tm iPrintResult (show (delab ist tm'))-process h fn (TestInline t)+process fn (TestInline t) = do (tm, ty) <- elabVal recinfo ERHS t ctxt <- getContext ist <- getIState let tm' = inlineTerm ist tm c <- colourise iPrintResult (showTm ist (delab ist tm'))-process h fn Execute+process fn Execute = idrisCatch (do ist <- getIState (m, _) <- elabVal recinfo ERHS@@ -946,35 +1041,38 @@ (tmpn, tmph) <- runIO tempfile runIO $ hClose tmph t <- codegen- compile t tmpn m+ ir <- compile t tmpn m+ runIO $ generate t (head (idris_imported ist)) ir case idris_outputmode ist of- RawOutput -> do runIO $ system tmpn- return ()- IdeSlave n -> runIO . hPutStrLn h $- IdeSlave.convSExp "run-program" tmpn n)- (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)+ RawOutput h -> do runIO $ system tmpn+ return ()+ IdeSlave n h -> runIO . hPutStrLn h $+ IdeSlave.convSExp "run-program" tmpn n)+ (\e -> getIState >>= iRenderError . flip pprintErr e) where fc = fileFC "main"-process h fn (Compile codegen f)+process fn (Compile codegen f) = do (m, _) <- elabVal recinfo ERHS (PApp fc (PRef fc (sUN "run__IO")) [pexp $ PRef fc (sNS (sUN "main") ["Main"])])- compile codegen f m+ ir <- compile codegen f m+ i <- getIState+ runIO $ generate codegen (head (idris_imported i)) ir where fc = fileFC "main"-process h fn (LogLvl i) = setLogLevel i+process fn (LogLvl i) = setLogLevel i -- Elaborate as if LHS of a pattern (debug command)-process h fn (Pattelab t)+process fn (Pattelab t) = do (tm, ty) <- elabVal recinfo ELHS t iPrintResult $ show tm ++ "\n\n : " ++ show ty -process h fn (Missing n)+process fn (Missing n) = do i <- getIState let i' = i { idris_options = (idris_options i) { opt_showimp = True } } case lookupCtxt n (idris_patdefs i) of- [] -> ihPrintError h $ "Unknown operator " ++ show n+ [] -> iPrintError $ "Unknown operator " ++ show n [(_, tms)] -> iPrintResult (showSep "\n" (map (showTm i') tms)) _ -> iPrintError $ "Ambiguous name"-process h fn (DynamicLink l)+process fn (DynamicLink l) = do i <- getIState let importdirs = opt_importdirs (idris_options i) lib = trim l@@ -987,80 +1085,80 @@ return () else putIState $ i { idris_dynamic_libs = x:libs } where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace-process h fn ListDynamic+process fn ListDynamic = do i <- getIState iputStrLn "Dynamic libraries:" showLibs $ idris_dynamic_libs i where showLibs [] = return () showLibs ((Lib name _):ls) = do iputStrLn $ "\t" ++ name; showLibs ls-process h fn Metavars+process fn Metavars = do ist <- getIState let mvs = map fst (idris_metavars ist) \\ primDefs case mvs of [] -> iPrintError "No global metavariables to solve" _ -> iPrintResult $ "Global metavariables:\n\t" ++ show mvs-process h fn NOP = return ()+process fn NOP = return () -process h fn (SetOpt ErrContext) = setErrContext True-process h fn (UnsetOpt ErrContext) = setErrContext False-process h fn (SetOpt ShowImpl) = setImpShow True-process h fn (UnsetOpt ShowImpl) = setImpShow False-process h fn (SetOpt ShowOrigErr) = setShowOrigErr True-process h fn (UnsetOpt ShowOrigErr) = setShowOrigErr False-process h fn (SetOpt AutoSolve) = setAutoSolve True-process h fn (UnsetOpt AutoSolve) = setAutoSolve False-process h fn (SetOpt NoBanner) = setNoBanner True-process h fn (UnsetOpt NoBanner) = setNoBanner False-process h fn (SetOpt WarnReach) = fmodifyState opts_idrisCmdline $ nub . (WarnReach:)-process h fn (UnsetOpt WarnReach) = fmodifyState opts_idrisCmdline $ delete WarnReach+process fn (SetOpt ErrContext) = setErrContext True+process fn (UnsetOpt ErrContext) = setErrContext False+process fn (SetOpt ShowImpl) = setImpShow True+process fn (UnsetOpt ShowImpl) = setImpShow False+process fn (SetOpt ShowOrigErr) = setShowOrigErr True+process fn (UnsetOpt ShowOrigErr) = setShowOrigErr False+process fn (SetOpt AutoSolve) = setAutoSolve True+process fn (UnsetOpt AutoSolve) = setAutoSolve False+process fn (SetOpt NoBanner) = setNoBanner True+process fn (UnsetOpt NoBanner) = setNoBanner False+process fn (SetOpt WarnReach) = fmodifyState opts_idrisCmdline $ nub . (WarnReach:)+process fn (UnsetOpt WarnReach) = fmodifyState opts_idrisCmdline $ delete WarnReach -process h fn (SetOpt _) = iPrintError "Not a valid option"-process h fn (UnsetOpt _) = iPrintError "Not a valid option"-process h fn (SetColour ty c) = setColour ty c-process h fn ColourOn+process fn (SetOpt _) = iPrintError "Not a valid option"+process fn (UnsetOpt _) = iPrintError "Not a valid option"+process fn (SetColour ty c) = setColour ty c+process fn ColourOn = do ist <- getIState putIState $ ist { idris_colourRepl = True }-process h fn ColourOff+process fn ColourOff = do ist <- getIState putIState $ ist { idris_colourRepl = False }-process h fn ListErrorHandlers =+process fn ListErrorHandlers = do ist <- getIState iPrintResult $ case idris_errorhandlers ist of [] -> "No registered error handlers" handlers -> "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers-process h fn (SetConsoleWidth w) = setWidth w+process fn (SetConsoleWidth w) = setWidth w -process h fn (Apropos a) =+process fn (Apropos a) = do ist <- getIState let names = apropos ist (T.pack a) let aproposInfo = [ (n, delabTy ist n, fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist))) | n <- sort names, isUN n ]- ihRenderResult h $ vsep (map (prettyDocumentedIst ist) aproposInfo)+ iRenderResult $ vsep (map (prettyDocumentedIst ist) aproposInfo) where isUN (UN _) = True isUN (NS n _) = isUN n isUN _ = False -process h fn (WhoCalls n) =+process fn (WhoCalls n) = do calls <- whoCalls n ist <- getIState- ihRenderResult h . vsep $+ iRenderResult . vsep $ map (\(n, ns) -> text "Callers of" <+> prettyName True True [] n <$> indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns))) calls -process h fn (CallsWho n) =+process fn (CallsWho n) = do calls <- callsWho n ist <- getIState- ihRenderResult h . vsep $+ iRenderResult . vsep $ map (\(n, ns) -> prettyName True True [] n <+> text "calls:" <$> indent 1 (vsep (map ((text "*" <+>) . align . prettyName True True []) ns))) calls -- IdrisDoc-process h fn (MakeDoc s) =+process fn (MakeDoc s) = do istate <- getIState let names = words s parse n | Success x <- runparser name istate fn n = Right x@@ -1117,8 +1215,8 @@ [] -> return () -loadInputs :: Handle -> [FilePath] -> Maybe Int -> Idris ()-loadInputs h inputs toline -- furthest line to read in input source files+loadInputs :: [FilePath] -> Maybe Int -> Idris ()+loadInputs inputs toline -- furthest line to read in input source files = idrisCatch (do ist <- getIState -- if we're in --check and not outputting anything, don't bother@@ -1170,10 +1268,10 @@ (\e -> do i <- getIState case e of At f e' -> do setErrSpan f- ihWarn stdout f $ pprintErr i e'+ iWarn f $ pprintErr i e' ProgramLineComment -> return () -- fail elsewhere _ -> do setErrSpan emptyFC -- FIXME! Propagate it- ihWarn stdout emptyFC $ pprintErr i e)+ iWarn emptyFC $ pprintErr i e) where -- load all files, stop if any fail tryLoad :: Bool -> [IFileType] -> Idris () tryLoad keepstate [] = warnTotality >> return ()@@ -1190,7 +1288,7 @@ then Just l else Nothing _ -> Nothing- loadFromIFile h f maxline+ loadFromIFile f maxline inew <- getIState -- FIXME: Save these in IBC to avoid this hack! Need to -- preserve it all from source inputs@@ -1238,7 +1336,7 @@ do let inputs = opt getFile opts let quiet = Quiet `elem` opts let nobanner = NoBanner `elem` opts- let idesl = Ideslave `elem` opts+ let idesl = Ideslave `elem` opts || IdeslaveSocket `elem` opts let runrepl = not (NoREPL `elem` opts) let verbose = runrepl || Verbose `elem` opts let output = opt getOutput opts@@ -1259,7 +1357,7 @@ [] -> Executable xs -> last xs let cgn = case opt getCodegen opts of- [] -> ViaC+ [] -> Via "c" xs -> last xs script <- case opt getExecScript opts of [] -> return Nothing@@ -1275,7 +1373,6 @@ mapM_ addLangExt (opt getLanguageExt opts) setREPL runrepl setQuiet (quiet || isJust script || not (null immediate))- setIdeSlave idesl setVerbose verbose setCmdLine opts setOutputTy outty@@ -1301,9 +1398,11 @@ addPkgDir "base" mapM_ addPkgDir pkgdirs elabPrims- when (not (NoBuiltins `elem` opts)) $ do x <- loadModule stdout "Builtins"+ when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"+ addAutoImport "Builtins" return ()- when (not (NoPrelude `elem` opts)) $ do x <- loadModule stdout "Prelude"+ when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"+ addAutoImport "Prelude" return () when (runrepl && not idesl) initScript@@ -1319,14 +1418,14 @@ iputStrLn banner orig <- getIState- loadInputs stdout inputs Nothing+ when (not idesl) $ loadInputs inputs Nothing runIO $ hSetBuffering stdout LineBuffering ok <- noErrors when ok $ case output of [] -> return ()- (o:_) -> idrisCatch (process stdout "" (Compile cgn o))+ (o:_) -> idrisCatch (process "" (Compile cgn o)) (\e -> do ist <- getIState ; iputStrLn $ pshow ist e) case immediate of@@ -1337,7 +1436,7 @@ case parseExpr ist str of Failure err -> do iputStrLn $ show (fixColour c err) runIO $ exitWith (ExitFailure 1)- Success e -> process stdout "" (Eval e))+ Success e -> process "" (Eval e)) exprs runIO $ exitWith ExitSuccess @@ -1359,7 +1458,8 @@ -- clearOrigPats startServer orig inputs runInputT (replSettings (Just historyFile)) $ repl orig inputs- when (idesl) $ ideslaveStart orig inputs+ let idesock = IdeslaveSocket `elem` opts+ when (idesl) $ ideslaveStart idesock orig inputs ok <- noErrors when (not ok) $ runIO (exitWith (ExitFailure 1)) where@@ -1373,7 +1473,14 @@ addPkgDir :: String -> Idris () addPkgDir p = do ddir <- runIO $ getDataDir addImportDir (ddir </> p)+ addIBC (IBCImportDir (ddir </> p)) +runMain :: Idris () -> IO ()+runMain prog = do res <- runErrorT $ execStateT prog idrisInit+ case res of+ Left err -> putStrLn $ "Uncaught error: " ++ show err+ Right _ -> return ()+ execScript :: String -> Idris () execScript expr = do i <- getIState c <- colourise@@ -1421,7 +1528,7 @@ Success Edit -> iPrintError "Init scripts cannot invoke the editor" Success Proofs -> proofs i Success Quit -> iPrintError "Init scripts cannot quit Idris"- Success cmd -> process stdout [] cmd+ Success cmd -> process [] cmd getFile :: Opt -> Maybe String getFile (Filename str) = Just str
src/Idris/REPLParser.hs view
@@ -32,6 +32,7 @@ docmd (x:xs) = try (discard (P.reserved x)) <|> docmd xs pCmd :: P.IdrisParser Command+ pCmd = do P.whiteSpace; do cmd ["q", "quit"]; eof; return Quit <|> do cmd ["h", "?", "help"]; eof; return Help <|> do cmd ["w", "warranty"]; eof; return Warranty@@ -40,9 +41,14 @@ return (ModImport (toPath f)) <|> do cmd ["e", "edit"]; eof; return Edit <|> do cmd ["exec", "execute"]; eof; return Execute+ <|> try (do cmd ["c", "compile"]+ i <- get+ f <- P.identifier+ eof+ return (Compile (Via "c") f)) <|> do cmd ["c", "compile"] i <- get- c <- option (opt_codegen $ idris_options i) codegenOption+ c <- codegenOption f <- P.identifier eof return (Compile c f)@@ -53,6 +59,8 @@ <|> do cmd ["let"] defn <- concat <$> many (P.decl defaultSyntax) return (NewDefn defn)+ <|> do cmd ["unlet","undefine"]+ Undefine `fmap` many P.name <|> do cmd ["lto", "loadto"]; toline <- P.natural f <- many anyChar;@@ -139,12 +147,9 @@ <|> do discard (P.symbol "warnreach"); return WarnReach codegenOption :: P.IdrisParser Codegen-codegenOption = do discard (P.symbol "javascript"); return ViaJavaScript- <|> do discard (P.symbol "node"); return ViaNode- <|> do discard (P.symbol "Java"); return ViaJava- <|> do discard (P.symbol "llvm"); return ViaLLVM- <|> do discard (P.symbol "bytecode"); return Bytecode- <|> do discard (P.symbol "C"); return ViaC+codegenOption = do discard (P.symbol "bytecode"); return Bytecode+ <|> do x <- P.identifier+ return (Via (map toLower x)) pConsoleWidth :: P.IdrisParser ConsoleWidth pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth
src/Idris/Transforms.hs view
@@ -25,10 +25,10 @@ instance Transform SC where transform o@(CaseTrans t) sc = trans t sc where- trans t (Case n alts) = t (Case n (map (transform o) alts))+ trans t (Case up n alts) = t (Case up n (map (transform o) alts)) trans t x = t x transform o@(TermTrans t) sc = trans t sc where- trans t (Case n alts) = Case n (map (transform o) alts)+ trans t (Case up n alts) = Case up n (map (transform o) alts) trans t (STerm tm) = STerm (t tm) trans t x = x
src/Idris/TypeSearch.hs view
@@ -29,14 +29,12 @@ import Idris.Delaborate (delabTy) import Idris.Docstrings (noDocs, overview) import Idris.Elab.Type (elabType)-import Idris.Output (ihRenderOutput, ihPrintResult, ihRenderResult)--import System.IO (Handle)+import Idris.Output (iRenderOutput, iPrintResult, iRenderResult) import Util.Pretty (text, char, vsep, (<>), Doc) -searchByType :: Handle -> PTerm -> Idris ()-searchByType h pterm = do+searchByType :: PTerm -> Idris ()+searchByType pterm = do pterm' <- addUsingConstraints syn emptyFC pterm pterm'' <- implicit toplevel syn n pterm' i <- getIState@@ -50,9 +48,9 @@ displayScore score <> char ' ' <> prettyDocumentedIst i docInfo | (n, score) <- names'] case idris_outputmode i of- RawOutput -> do mapM_ (ihRenderOutput h) docs- ihPrintResult h ""- IdeSlave n -> ihRenderResult h (vsep docs)+ RawOutput _ -> do mapM_ iRenderOutput docs+ iPrintResult ""+ IdeSlave n h -> iRenderResult (vsep docs) where numLimit = 50 syn = defaultSyntax { implicitAllowed = True } -- syntax@@ -114,7 +112,7 @@ (numArgs, args, removedArgs, retTy) = go 0 [] [] t -- NOTE : args are in reverse order- go k args removedArgs (Bind n (Pi t) sc) = let arg = (n, t) in+ go k args removedArgs (Bind n (Pi t _) sc) = let arg = (n, t) in if removePred t then go k args (arg : removedArgs) sc else go (succ k) (arg : args) removedArgs sc@@ -348,7 +346,7 @@ unifyQueue state [] = return state unifyQueue state ((ty1, ty2) : queue) = do --trace ("go: \n" ++ show state) True `seq` return ()- res <- tcToMaybe $ match_unify ctxt [ (n, Pi ty) | (n, ty) <- holes state] ty1 ty2 [] (map fst $ holes state) []+ res <- tcToMaybe $ match_unify ctxt [ (n, Pi ty (TType (UVar 0))) | (n, ty) <- holes state] ty1 ty2 [] (map fst $ holes state) [] (state', queueAdditions) <- resolveUnis res state guard $ scoreCriterion (score state') unifyQueue state' (queue ++ queueAdditions)
src/Idris/WhoCalls.hs view
@@ -36,13 +36,13 @@ namesBinder b = names (binderTy b) occursSC :: Name -> SC -> Bool-occursSC n (Case _ alts) = any (occursCaseAlt n) alts+occursSC n (Case _ _ alts) = any (occursCaseAlt n) alts occursSC n (ProjCase t alts) = occurs n t || any (occursCaseAlt n) alts occursSC n (STerm t) = occurs n t occursSC n _ = False namesSC :: SC -> [Name]-namesSC (Case _ alts) = concatMap namesCaseAlt alts+namesSC (Case _ _ alts) = concatMap namesCaseAlt alts namesSC (ProjCase t alts) = names t ++ concatMap namesCaseAlt alts namesSC (STerm t) = names t namesSC _ = []
src/Pkg/Package.hs view
@@ -144,7 +144,7 @@ setCurrentDirectory $ pkgDir let run l = runErrorT . (execStateT l) load [] = return () - load (f:fs) = do loadModule stdout f; load fs+ load (f:fs) = do loadModule f; load fs loader = do idrisMain opts; load fs idrisInstance <- run loader idrisInit setCurrentDirectory cd
src/Util/Net.hs view
@@ -1,6 +1,6 @@-module Util.Net (listenOnLocalhost) where+module Util.Net (listenOnLocalhost, listenOnLocalhostAnyPort) where -import Network+import Network hiding (socketPort) import Network.Socket hiding (sClose, PortNumber) import Network.BSD (getProtocolNumber) import Control.Exception (bracketOnError)@@ -20,3 +20,16 @@ return sock ) +listenOnLocalhostAnyPort = do+ proto <- getProtocolNumber "tcp"+ localhost <- inet_addr "127.0.0.1"+ bracketOnError+ (socket AF_INET Stream proto)+ (sClose)+ (\sock -> do+ setSocketOption sock ReuseAddr 1+ bindSocket sock (SockAddrInet aNY_PORT localhost)+ listen sock maxListenQueue+ port <- socketPort sock+ return (sock, port)+ )
test/Makefile view
@@ -14,7 +14,7 @@ @perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 --codegen node test_llvm:- @perl ./runtest.pl without sugar004 io003 buffer001 --codegen llvm+ @perl ./runtest.pl without primitives003 sugar004 io003 buffer001 --codegen llvm update: /usr/bin/env perl ./runtest.pl all -u
− test/basic001/rle-vect.idr
@@ -1,32 +0,0 @@-module Main--data RLE : Vect n Char -> Type where- REnd : RLE []- RChar : {xs : Vect k Char} ->- (n : Nat) -> (c : Char) -> (rs : RLE xs) ->- RLE (replicate (S n) c ++ xs)----------------rle : (xs : Vect n Char) -> RLE xs-rle [] = REnd-rle (x :: xs) with (rle xs)- rle (x :: []) | REnd = RChar 0 x REnd- rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) with (decEq x c)- rle (x :: (x :: (replicate n x ++ ys))) | (RChar n x rs) | (Yes refl) - = RChar (S n) x rs- rle (x :: (c :: (replicate n c ++ ys))) | (RChar n c rs) | (No f) - = RChar 0 x (RChar n c rs)--compress : Vect n Char -> String-compress xs with (rle xs)- compress [] | REnd = ""- compress (c :: (replicate n c ++ xs1)) | (RChar n c rs) - = show (the Integer (cast (S n))) ++- strCons c (compress xs1)--compressString : String -> String-compressString xs = compress (fromList (unpack xs))--main : IO ()-main = putStrLn (compressString "foooobaaaarbaaaz")
test/error004/FunErrTest.idr view
@@ -9,7 +9,7 @@ total cadr : (xs : List a) -> {auto cons1 : isCons xs = True}- -> {auto cons2 : isCons (tail xs cons1) = True}+ -> {auto cons2 : isCons (tail xs) = True} -> a cadr (x :: (y :: _)) {cons1=refl} {cons2=refl} = y cadr (x :: []) {cons1=refl} {cons2=refl} impossible
test/error004/expected view
@@ -3,4 +3,4 @@ Could not prove that [] has at least two elements. FunErrTest.idr:38:10:When elaborating right hand side of badCadr2: When elaborating argument cons2 to function FunErrTest.cadr:- Could not prove that tail [(fromInteger 1)] refl has at least two elements.+ Could not prove that tail [(fromInteger 1)] has at least two elements.
test/primitives002/expected view
@@ -23,21 +23,21 @@ prim__floatACos 1.0 0.0 prim__floatATan 1.0-0.7853981633974483+0.78539816 prim__floatCos 1.0-0.5403023058681398+0.54030230 prim__floatFloor 1.0 1.0 prim__floatSin 1.0-0.8414709848078965+0.84147098 prim__floatTan 1.0-1.5574077246549023+1.55740772 prim__floatASin 1.0-1.5707963267948966+1.57079632 prim__floatCeil 1.0 1.0 prim__floatExp 1.0-2.718281828459045+2.71828182 prim__floatLog 1.0 0.0 prim__floatSqrt 1.0
test/primitives002/run view
@@ -4,6 +4,9 @@ import Data.Floats +strtake : Nat -> String -> String+strtake n str = pack (take n (unpack str))+ main : IO ()" TESTS=("prim__floatToStr 0.0"@@ -34,8 +37,7 @@ { cat <<EOF > $1 ${HEAD}-main = do- putStrLn $ show $ $2+main = putStrLn $ strtake 10 (show $ $2) EOF }
test/proof002/expected view
@@ -1,7 +1,7 @@ Reflect.idr:207:38:When elaborating right hand side of testReflect1: When elaborating an application of function Reflect.getJust: Can't unify- IsJust (Just x2)+ IsJust (Just x1) with IsJust (prove (getProof x))
test/quasiquote001/expected view
@@ -1,5 +1,5 @@-(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 6))))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 6))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 6))))))+(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 10)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 10))))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 10)))) (P (DCon 0 0) (MN 0 "__II") (P (TCon 0 0) (MN 0 "__Unit") (TType (UVar 10))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (P (TCon 7 0) (MN 0 "__Unit") (TType (UVar 10)))))) ---------------(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 110))) (TType (UVar 112))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 114))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 116)))))+(App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 190))) (TType (UVar 192))) (App (App (App (P (DCon 1 3) (NS (UN ::) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (Bind (MN 0 "_t") (Pi (V 0)) (Bind (MN 2 "_t") (Pi (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 2)))))) (TType (UVar 194))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 64))) (Bind (MN 0 "B") (Pi (TType (UVar 68))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 52))) (Bind (MN 1 "B") (Pi (TType (UVar 56))) (TType (UVar 60))))) (V 3)) (V 2))))))) (TType (UVar 184))) (TType (UVar 186))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1)))) (P (TCon 15 0) (NS (UN Nat) ["Nat", "Prelude"]) (TType (UVar -1))))) (App (P (DCon 0 1) (NS (UN Nil) ["List", "Prelude"]) (Bind (UN a) (Pi (TType (UVar -1))) (App (P (TCon 0 0) (NS (UN List) ["List", "Prelude"]) Erased) (V 0)))) (TType (UVar 196))))) ---------------(App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (TType (UVar 110))) (TType (UVar 110)))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 36))) (Bind (MN 0 "B") (Pi (TType (UVar 38))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 28))) (Bind (MN 1 "B") (Pi (TType (UVar 30))) (TType (UVar 32))))) (V 3)) (V 2))))))) (TType (UVar 108))) (TType (UVar 110))) (TType (UVar 110))) (TType (UVar 110))))+(App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 64))) (Bind (MN 0 "B") (Pi (TType (UVar 68))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 52))) (Bind (MN 1 "B") (Pi (TType (UVar 56))) (TType (UVar 60))))) (V 3)) (V 2))))))) (TType (UVar 184))) (TType (UVar 186))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 64))) (Bind (MN 0 "B") (Pi (TType (UVar 68))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 52))) (Bind (MN 1 "B") (Pi (TType (UVar 56))) (TType (UVar 60))))) (V 3)) (V 2))))))) (TType (UVar 184))) (TType (UVar 186))) (TType (UVar 190))) (TType (UVar 190)))) (App (App (App (App (P (DCon 0 4) (MN 0 "__MkPair") (Bind (MN 0 "A") (Pi (TType (UVar 64))) (Bind (MN 0 "B") (Pi (TType (UVar 68))) (Bind (MN 0 "a") (Pi (V 1)) (Bind (MN 0 "b") (Pi (V 1)) (App (App (P (TCon 0 0) (MN 0 "__Pair") (Bind (MN 1 "A") (Pi (TType (UVar 52))) (Bind (MN 1 "B") (Pi (TType (UVar 56))) (TType (UVar 60))))) (V 3)) (V 2))))))) (TType (UVar 184))) (TType (UVar 186))) (TType (UVar 190))) (TType (UVar 190))))
test/reg010/expected view
@@ -1,4 +1,4 @@-reg010.idr:5:15:When elaborating right hand side of usubst.unsafeSubst:+reg010.idr:5:15:When elaborating right hand side of with block in usubst.unsafeSubst: Can't unify P x with
test/reg018/expected view
@@ -1,5 +1,5 @@ reg018a.idr:16:1:conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat reg018a.idr:21:1:conat.loopForever is possibly not total due to: conat.minusCoNat reg018b.idr:8:1:A.showB is possibly not total due to recursive path A.showB-reg018c.idr:19:1:CodataTest.inf is possibly not total due to: {CodataTest.inf19}+reg018c.idr:19:1:CodataTest.inf is possibly not total due to: with block in CodataTest.inf reg018d.idr:5:1:Main.pull is not total as there are missing cases
test/reg028/expected view
@@ -1,2 +1,2 @@-reg028.idr:5:1:tbad.bad is possibly not total due to: {tbad.bad16}-reg028a.idr:11:1:tbad.qsort' is possibly not total due to: {tbad.qsort'18}+reg028.idr:5:1:tbad.bad is possibly not total due to: with block in tbad.bad+reg028a.idr:11:1:tbad.qsort' is possibly not total due to: with block in tbad.qsort'
+ test/reg051/expected view
+ test/reg051/reg051.idr view
@@ -0,0 +1,99 @@+-- Test for problem with parameter propagation in fromState'++data StateTy : Type where+ STInt : StateTy+ STString : StateTy+ STMaybe : StateTy -> StateTy+ STList : StateTy -> StateTy++interpSTy : StateTy -> Type+interpSTy STInt = Int+interpSTy STString = String+interpSTy (STMaybe a) = Maybe (interpSTy a)+interpSTy (STList a) = List (interpSTy a)++data State : StateTy -> Type where+ MkState : (t : StateTy) -> Ptr -> State t++abstract+data StateC : StateTy -> Type where+ MkStateC : Int -> (t : StateTy) -> Ptr -> StateC t++isObj : Ptr -> IO Bool+isObj p = do+ "object" <- mkForeign (FFun "typeof %0" [FPtr] FString) p+ | _ => pure False+ pure True++stateVarName : String+stateVarName = "__IDR__IQUERY__STATE__"++stateVarExists : IO Bool+stateVarExists = do+ o <- mkForeign (FFun ("typeof " ++ stateVarName) [] FString) + pure $ if o == "object" then True else False++initStateVar : IO Ptr+initStateVar = mkForeign (FFun (stateVarName ++ " = {count: 0}") [] FPtr)++getStateVar : IO (Maybe Ptr) +getStateVar = case !stateVarExists of+ True => map Just $ mkForeign (FFun stateVarName [] FPtr)+ False => pure Nothing++getStateVar' : IO Ptr+getStateVar' = case !getStateVar of+ Just s => pure s+ Nothing => initStateVar++stateCExists : Ptr -> Int -> IO Bool+stateCExists c n = do+ r <- mkForeign (FFun "typeof %0[%1]" [FPtr,FInt] FString) c n+ pure $ if r == "object" then True else False++incCount : Ptr -> IO Int+incCount c = do+ n <- mkForeign (FFun "%0.count" [FPtr] FInt) c+ mkForeign (FFun "%0.count++" [FPtr] FUnit) c+ pure n++infixl 5 =>>+public+(=>>) : IO (Maybe (State a)) -> (State a -> IO (Maybe b)) + -> IO (Maybe b)+s =>> f = do+ (Just s') <- s+ | Nothing => pure Nothing+ f s'++infixl 5 :=>+public+(:=>) : IO (Maybe (State a)) -> (State a -> IO ()) -> IO Bool+(:=>) s f = do+ (Just s') <- s+ | Nothing => pure False+ f s'+ pure True++public +access : Nat -> State (STList t) -> IO (Maybe (State t))+access n (MkState (STList t) p) = do+ r <- mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p (fromNat n)+ True <- isObj r+ | False => pure Nothing+ pure $ Just $ MkState t r++fromState' : State t -> IO (interpSTy t)+fromState' (MkState STInt p) = mkForeign (FFun "%0.val" [FPtr] FInt) p+fromState' (MkState STString p) = mkForeign (FFun "%0.val" [FPtr] FString) p+fromState' (MkState (STMaybe a) p) = do+ isNull <- (mkForeign (FFun "(%0.val == null).toString()" [FPtr] FString) p) + case isNull == "true" of+ True => pure Nothing+ False => pure $ Just !(fromState' (MkState a p))+fromState' (MkState (STList a) p) = do+ n <- mkForeign (FFun "%0.val.length" [FPtr] FInt) p+ ps <- sequence $ map + (\n => mkForeign (FFun "%0.val[%1]" [FPtr,FInt] FPtr) p n) [0..(n-1)]+ sequence $ map (\p' => fromState' (MkState a p')) ps+
+ test/reg051/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ reg051.idr --check+rm -f *.ibc
test/tutorial006/expected view
@@ -10,7 +10,7 @@ [92mplus[0m [95mn[0m [95mn[0m with [92mplus[0m [95mn[0m [95mm[0m-tutorial006b.idr:10:10:When elaborating right hand side of Main.parity:+tutorial006b.idr:10:10:When elaborating right hand side of with block in Main.parity: Can't unify [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)) with
+ test/unique001/expected view
@@ -0,0 +1,20 @@+19,18,17,16,15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,0,END+19,18,17,16,15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,0,END+38,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END+38,36,34,32,30,28,26,24,22,20,18,16,14,12,10,8,6,4,2,0,END+unique001a.idr:33:11:Can't convert+ [94mInt[0m -> [94mString[0m+with+ UniqueType ([94mInt[0m -> [94mString[0m)+unique001a.idr:44:12:Can't convert+ [94mInt[0m -> [94mString[0m+with+ UniqueType ([94mInt[0m -> [94mString[0m)+unique001a.idr:55:12:Can't convert+ UniqueType ([94mInt[0m -> [94mString[0m)+with+ [94mInt[0m -> [94mString[0m+unique001b.idr:16:7:Borrowed name xs must not be used on RHS+unique001c.idr:49:6:Unique name f is used more than once+unique001d.idr:3:7:Borrowed name x must not be used on RHS+unique001e.idr:4:11:Constructor Main.:: has a UniqueType, but the data type does not
+ test/unique001/run view
@@ -0,0 +1,9 @@+#!/usr/bin/env bash+idris $@ unique001.idr -o unique001+./unique001+idris $@ unique001a.idr --check+idris $@ unique001b.idr --check+idris $@ unique001c.idr --check+idris $@ unique001d.idr --check+idris $@ unique001e.idr --check+rm -f unique001 *.ibc
+ test/unique001/unique001.idr view
@@ -0,0 +1,32 @@+module Main++data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++umap : (a -> b) -> UList a -> UList b+umap f [] = []+umap f (x :: xs) = f x :: umap f xs++free : {a : UniqueType} -> a -> String+free xs = ""++showU : Show a => Borrowed (UList a) -> String+showU [] = "END"+showU (x :: xs) = show x ++ "," ++ showU xs++mkUList : Nat -> UList Int+mkUList Z = []+mkUList (S k) = cast k :: mkUList k++showStuff : UList Int -> IO ()+showStuff xs = do+ putStrLn (showU xs)+ putStrLn (showU xs)+ let xs' = umap (*2) xs+ putStrLn (showU xs')+ putStrLn (showU xs')++main : IO ()+main = showStuff (mkUList 20)+
+ test/unique001/unique001a.idr view
@@ -0,0 +1,62 @@+module Main++data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++umap : (a -> b) -> UList a -> UList b+umap f [] = []+umap f (x :: xs) = f x :: umap f xs++free : {a : UniqueType} -> a -> String+free xs = ""++showU : Show a => Borrowed (UList a) -> String+showU [] = "END"+showU (x :: xs) = show x ++ "," ++ showU xs++mkUList : Nat -> UList Int+mkUList Z = []+mkUList (S k) = cast k :: mkUList k++showIt : UList Int -> Int -> String+showIt xs x = let xs' = umap (*2) xs in ""++printThings : (Int -> String) -> IO ()+printThings f = do putStrLn (f 10)+ putStrLn (f 20)++double : Int -> Int+double x = x * 2++showStuff : UList Int -> IO ()+showStuff xs = do+ putStrLn (showU xs)+ putStrLn (showU xs)+ -- xsFn gets a unique type since we're in a unique context+ -- now, but function built has a non-unique type+ (\xsFn : Int -> String =>+ do putStrLn "Hello"+ putStrLn (xsFn 42))+ (\dummy => showU (umap double xs))++showStuff' : UList Int -> IO ()+showStuff' xs = do+ putStrLn (showU xs)+ putStrLn (showU xs)+ -- xsFn gets a unique type since we're in a unique context+ -- now, but function built has a non-unique type+ let xsFn = \dummy : Int => showU (umap double xs)+ putStrLn "Hello"+ putStrLn (xsFn 42)+ putStrLn (xsFn 42)++showThings : UList Int -> IO ()+showThings xs = do+ putStrLn (showU xs)+ putStrLn (showU xs)+ -- showIt has a unique type, printThings wants a non-unique+ -- type+ printThings (showIt xs)++
+ test/unique001/unique001b.idr view
@@ -0,0 +1,30 @@+module Main++data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++umap : (a -> b) -> UList a -> UList b+umap f [] = []+umap f (x :: xs) = f x :: umap f xs++free : {a : UniqueType} -> a -> String+free xs = ""++showU : Show a => Borrowed (UList a) -> String+showU [] = "END"+showU (x :: xs) = show x ++ "," ++ free xs++mkUList : Nat -> UList Int+mkUList Z = []+mkUList (S k) = cast k :: mkUList k++showStuff : UList Int -> IO ()+showStuff xs = do+ putStrLn (showU xs)+ let xs' = umap (*2) xs+ putStrLn (showU xs')++main : IO ()+main = showStuff (mkUList 20)+
+ test/unique001/unique001c.idr view
@@ -0,0 +1,53 @@++data UList : Type -> UniqueType where+ UNil : UList a+ UCons : {a : Type} -> a -> UList a -> UList a++uapp : UList a -> UList a -> UList a+uapp UNil xs = xs+uapp (UCons x xs) ys = UCons x (UCons x (uapp xs ys))++data UTree : UniqueType where+ ULeaf : UTree+ UNode : UTree -> Int -> UTree -> UTree++data UPair : UniqueType -> UniqueType -> UniqueType where+ MkUPair : {a,b:UniqueType} -> a -> b -> UPair a b++dup : UTree -> UPair UTree UTree+dup ULeaf = MkUPair ULeaf ULeaf+dup (UNode l y r) = let MkUPair l1 l2 = dup l+ MkUPair r1 r2 = dup r in+ MkUPair (UNode l1 y r1) (UNode l2 y r2)++data Tree : Type where+ Leaf : Tree+ Node : Tree -> Int -> Tree -> Tree++share : UTree -> Tree+share ULeaf = Leaf+share (UNode x y z) = Node (share x) y (share z)++class UFunctor (f : Type -> Type*) where+ fmap : (a -> b) -> f a -> f b++instance UFunctor List where+ fmap f [] = []+ fmap f (x :: xs) = f x :: fmap f xs++instance UFunctor UList where+ fmap f UNil = UNil+ fmap f (UCons x xs) = UCons (f x) (fmap f xs)++uconst : {a : Type*} -> a -> b -> a+uconst x y = x++data MPair : Type* -> Type* -> Type* where+ MkMPair : {a, b : Type*} -> a -> b -> MPair a b++ndup : {a : UniqueType} -> a -> UPair a a+ndup {a} x = (\f : Int -> a => MkUPair (f 0) (f 1)) (uconst x)++++
+ test/unique001/unique001d.idr view
@@ -0,0 +1,3 @@++steal : {a : UniqueType} -> Borrowed a -> a+steal (Read x) = x
+ test/unique001/unique001e.idr view
@@ -0,0 +1,4 @@++data BadList : UniqueType -> Type where+ Nil : {a : UniqueType} -> BadList a+ (::) : {a : UniqueType} -> a -> BadList a -> BadList a
+ test/unique002/expected view
@@ -0,0 +1,5 @@+unique002.idr:15:5:Unique name xs is used more than once+unique002a.idr:15:5:Can't convert+ [94mInt[0m -> [94mString[0m+with+ UniqueType ([94mInt[0m -> [94mString[0m)
+ test/unique002/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ unique002.idr --check+idris $@ unique002a.idr --check+rm -f *.ibc
+ test/unique002/unique002.idr view
@@ -0,0 +1,20 @@+data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++free : {a : UniqueType} -> a -> String+free xs = ""++showU : Show a => Borrowed (UList a) -> String+showU xs = "[" ++ showU' xs ++ "]" where+ showU' : Borrowed (UList a) -> String+ showU' [] = ""+ showU' (x :: xs) = show x ++ ", " ++ showU xs++foo : UList Int -> IO ()+foo xs = do -- let f = \x : Int => showU xs+ putStrLn $ free xs+ putStrLn $ f 42 xs+ return ()+ where f : Int -> Borrowed (UList Int) -> String+ f x xs = showU xs
+ test/unique002/unique002a.idr view
@@ -0,0 +1,18 @@+data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++free : {a : UniqueType} -> a -> String+free xs = ""++showU : Show a => Borrowed (UList a) -> String+showU xs = "[" ++ showU' xs ++ "]" where+ showU' : Borrowed (UList a) -> String+ showU' [] = ""+ showU' (x :: xs) = show x ++ ", " ++ showU xs++foo : UList Int -> IO ()+foo xs = do let f = \x : Int => showU xs+ putStrLn $ free xs+ putStrLn $ f 42+ return ()
+ test/unique003/expected view
@@ -0,0 +1,4 @@+unique003.idr:18:5:Can't convert+ [94mInt[0m -> [94mString[0m+with+ UniqueType ([94mInt[0m -> [94mString[0m)
+ test/unique003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ unique003.idr --check+rm -f *.ibc
+ test/unique003/unique003.idr view
@@ -0,0 +1,22 @@+module Main++data UList : Type -> UniqueType where+ Nil : UList a+ (::) : a -> UList a -> UList a++showU : Show a => Borrowed (UList a) -> String+showU xs = "[" ++ showU' xs ++ "]" where+ showU' : Borrowed (UList a) -> String+ showU' [] = ""+ showU' [x] = show x+ showU' (x :: xs) = show x ++ ", " ++ showU' xs++free : {a : UniqueType} -> a -> String+free xs = ""++foo : UList Int -> IO ()+foo xs = do let f = \x : Int => showU xs -- can't build this in unique context+ putStrLn (f 10) + putStrLn $ free xs+ putStrLn (f 10) + return ()