packages feed

idris 0.9.11.2 → 0.9.12

raw patch · 224 files changed

+6513/−3274 lines, 224 filesdep +cheapskatedep +lens

Dependencies added: cheapskate, lens

Files

Makefile view
@@ -39,7 +39,7 @@ 	$(CABAL) install $(CABALFLAGS)  linecount:-	wc -l src/Idris/*.hs src/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs+	wc -l src/Idris/*.hs src/Idris/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs  #Note: this doesn't yet link to Hackage properly doc: dist/setup-config
idris.cabal view
@@ -1,5 +1,5 @@ Name:           idris-Version:        0.9.11.2+Version:        0.9.12 License:        BSD3 License-file:   LICENSE Author:         Edwin Brady@@ -97,10 +97,10 @@                        libs/effects/Effect/*.idr                        libs/effects/*.idr -                       libs/neweffects/Makefile-                       libs/neweffects/neweffects.ipkg-                       libs/neweffects/Effect/*.idr-                       libs/neweffects/*.idr+                       libs/oldeffects/Makefile+                       libs/oldeffects/oldeffects.ipkg+                       libs/oldeffects/Effect/*.idr+                       libs/oldeffects/*.idr                         libs/javascript/*.idr                        libs/javascript/JavaScript/*.idr@@ -211,6 +211,22 @@                        test/reg033/run                        test/reg033/*.idr                        test/reg033/expected+                       test/reg034/run+                       test/reg034/*.idr+                       test/reg034/expected+                       test/reg035/run+                       test/reg035/*.idr+                       test/reg035/*.lidr+                       test/reg035/expected+                       test/reg036/run+                       test/reg036/*.idr+                       test/reg036/expected+                       test/reg037/run+                       test/reg037/*.idr+                       test/reg037/expected+                       test/reg038/run+                       test/reg038/*.idr+                       test/reg038/expected                         test/basic001/run                        test/basic001/*.idr@@ -289,11 +305,22 @@                        test/ffi004/theType                        test/ffi004/theOtherType                        test/ffi004/expected+                       test/ffi005/*.idr+                       test/ffi005/run+                       test/ffi005/expected                         test/interactive001/run                        test/interactive001/input                        test/interactive001/*.idr                        test/interactive001/expected+                       test/interactive002/run+                       test/interactive002/input+                       test/interactive002/*.idr+                       test/interactive002/expected+                       test/interactive003/run+                       test/interactive003/input+                       test/interactive003/*.idr+                       test/interactive003/expected                         test/io001/run                        test/io001/*.idr@@ -354,7 +381,32 @@                        test/totality003/run                        test/totality003/*.idr                        test/totality003/expected+                       test/totality004/run+                       test/totality004/*.idr+                       test/totality004/expected+                       test/totality005/run+                       test/totality005/*.idr+                       test/totality005/expected +                       test/tutorial001/run+                       test/tutorial001/*.idr+                       test/tutorial001/expected+                       test/tutorial002/run+                       test/tutorial002/*.idr+                       test/tutorial002/expected+                       test/tutorial003/run+                       test/tutorial003/*.idr+                       test/tutorial003/expected+                       test/tutorial004/run+                       test/tutorial004/*.idr+                       test/tutorial004/expected+                       test/tutorial005/run+                       test/tutorial005/*.idr+                       test/tutorial005/expected+                       test/tutorial006/run+                       test/tutorial006/*.idr+                       test/tutorial006/expected+ source-repository head   type:     git   location: git://github.com/idris-lang/Idris-dev.git@@ -403,6 +455,7 @@                  , Idris.AbsSyntax                 , Idris.AbsSyntaxTree+                , Idris.Apropos                 , Idris.CaseSplit                 , Idris.Chaser                 , Idris.Colours@@ -413,6 +466,7 @@                 , Idris.DeepSeq                 , Idris.Delaborate                 , Idris.Docs+                , Idris.Docstrings                 , Idris.ElabDecls                 , Idris.ElabTerm                 , Idris.Error@@ -422,6 +476,7 @@                 , Idris.IdeSlave                 , Idris.Imports                 , Idris.Inliner+                , Idris.Output                 , Idris.Parser                 , Idris.ParseHelpers                 , Idris.ParseOps@@ -479,12 +534,14 @@                 , ansi-wl-pprint                 , binary                 , bytestring+                , cheapskate                 , containers >= 0.5                 , directory                 , directory >= 1.2                 , filepath                 , haskeline >= 0.7                 , language-java >= 0.2.6+                , lens >= 4.1.1                 , mtl                 , parsers >= 0.9                 , pretty
jsrts/Runtime-common.js view
@@ -1,6 +1,3 @@-var __IDRRT__ZERO = __IDRRT__bigInt("0");-var __IDRRT__ONE = __IDRRT__bigInt("1");- /** @constructor */ var __IDRRT__Type = function(type) {   this.type = type;
jsrts/jsbn/jsbn.js view
@@ -1233,3 +1233,6 @@   return new BigInteger(val); } })();++var __IDRRT__ZERO = __IDRRT__bigInt("0");+var __IDRRT__ONE = __IDRRT__bigInt("1");
libs/Makefile view
@@ -2,7 +2,7 @@ 	$(MAKE) -C prelude build 	$(MAKE) -C base build 	$(MAKE) -C effects build-	$(MAKE) -C neweffects build+	$(MAKE) -C oldeffects build 	$(MAKE) -C javascript build  @@ -10,14 +10,14 @@ 	$(MAKE) -C prelude install 	$(MAKE) -C base install 	$(MAKE) -C effects install-	$(MAKE) -C neweffects install+	$(MAKE) -C oldeffects install 	$(MAKE) -C javascript install  clean: 	$(MAKE) -C prelude clean 	$(MAKE) -C base clean 	$(MAKE) -C effects clean-	$(MAKE) -C neweffects clean+	$(MAKE) -C oldeffects clean 	$(MAKE) -C javascript clean          .PHONY: build install clean
libs/base/Control/Isomorphism.idr view
@@ -1,11 +1,10 @@ module Control.Isomorphism  import Syntax.PreorderReasoning-import Uninhabited  %default total --- An isomorphism between two types+||| An isomorphism between two types data Iso : Type -> Type -> Type where   MkIso : (to : a -> b) ->           (from : b -> a) ->@@ -15,9 +14,11 @@  -- Isomorphism properties +||| Isomorphism is reflexive isoRefl : Iso a a isoRefl = MkIso id id (\x => refl) (\x => refl) +||| Isomorphism is transitive isoTrans : Iso a b -> Iso b c -> Iso a c isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') =   MkIso (\x => to' (to x))@@ -29,20 +30,23 @@                (from (to x))                ={ fromTo x              }=                x                            QED) +||| Isomorphism is symmetric isoSym : Iso a b -> Iso b a isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom  -- Isomorphisms over sums +||| Disjunction is commutative eitherComm : Iso (Either a b) (Either b a) eitherComm = MkIso swap swap swapSwap swapSwap-  where swap : Either a b -> Either b a+  where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!         swap (Left x) = Right x         swap (Right x) = Left x-        swapSwap : (e : Either a b) -> swap (swap e) = e+        swapSwap : (e : Either a' b') -> swap (swap e) = e         swapSwap (Left x) = refl         swapSwap (Right x) = refl +||| Disjunction is associative eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c)) eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2   where eitherAssoc1 : Either (Either a b) c -> Either a (Either b c)@@ -65,6 +69,7 @@         ok2 (Left (Right x)) = refl         ok2 (Right x) = refl +||| Disjunction with false is a no-op eitherBotLeft : Iso (Either _|_ a) a eitherBotLeft = MkIso to from ok1 ok2   where to : Either _|_ a -> a@@ -78,10 +83,11 @@         ok2 (Left x) = FalseElim x         ok2 (Right x) = refl +||| Disjunction with false is a no-op eitherBotRight : Iso (Either a _|_) a eitherBotRight = isoTrans eitherComm eitherBotLeft -+||| Isomorphism is a congruence with regards to disjunction eitherCong : Iso a a' -> Iso b b' -> Iso (Either a b) (Either a' b') eitherCong {a = a} {a' = a'} {b = b} {b' = b'}            (MkIso to from toFrom fromTo)@@ -97,20 +103,25 @@           ok2 (Left x)  = cong (fromTo x)           ok2 (Right x) = cong (fromTo' x) +||| Isomorphism is a congruence with regards to disjunction on the left eitherCongLeft : Iso a a' -> Iso (Either a b) (Either a' b) eitherCongLeft i = eitherCong i isoRefl +||| Isomorphism is a congruence with regards to disjunction on the right eitherCongRight : Iso b b' -> Iso (Either a b) (Either a b') eitherCongRight i = eitherCong isoRefl i  -- Isomorphisms over products+||| Conjunction is commutative pairComm : Iso (a, b) (b, a) pairComm = MkIso swap swap swapSwap swapSwap-  where swap : (a, b) -> (b, a)+  where swap : (a', b') -> (b', a')         swap (x, y) = (y, x)-        swapSwap : (x : (a, b)) -> swap (swap x) = x++        swapSwap : (x : (a', b')) -> swap (swap x) = x         swapSwap (x, y) = refl +||| Conjunction is associative pairAssoc : Iso (a, (b, c)) ((a, b), c) pairAssoc = MkIso to from ok1 ok2   where@@ -123,20 +134,25 @@     ok2 : (x : (a, (b, c))) -> from (to x) = x     ok2 (x, (y, z)) = refl +||| Conjunction with truth is a no-op pairUnitRight : Iso (a, ()) a pairUnitRight = MkIso fst (\x => (x, ())) (\x => refl) ok   where ok : (x : (a, ())) -> (fst x, ()) = x         ok (x, ()) = refl +||| Conjunction with truth is a no-op pairUnitLeft : Iso ((), a) a pairUnitLeft = isoTrans pairComm pairUnitRight +||| Conjunction preserves falsehood pairBotLeft : Iso (_|_, a) _|_ pairBotLeft = MkIso fst FalseElim (\x => FalseElim x) (\y => FalseElim (fst y)) +||| Conjunction preserves falsehood pairBotRight : Iso (a, _|_) _|_ pairBotRight = isoTrans pairComm pairBotLeft +||| Isomorphism is a congruence with regards to conjunction pairCong : Iso a a' -> Iso b b' -> Iso (a, b) (a', b') pairCong {a = a} {a' = a'} {b = b} {b' = b'}          (MkIso to from toFrom fromTo)@@ -155,13 +171,16 @@                         rewrite fromTo' y in                         refl +||| Isomorphism is a congruence with regards to conjunction on the left pairCongLeft : Iso a a' -> Iso (a, b) (a', b) pairCongLeft i = pairCong i isoRefl +||| Isomorphism is a congruence with regards to conjunction on the right pairCongRight : Iso b b' -> Iso (a, b) (a, b') pairCongRight = pairCong isoRefl  -- Distributivity of products over sums+||| Products distribute over sums distribLeft : Iso (Either a b, c) (Either (a, c) (b, c)) distribLeft = MkIso to from toFrom fromTo   where to : (Either a b, c) -> Either (a, c) (b, c)@@ -177,20 +196,24 @@         fromTo (Left x, y) = refl         fromTo (Right x, y) = refl +||| Products distribute over sums distribRight : Iso (a, Either b c) (Either (a, b) (a, c)) distribRight {a} {b} {c} = (pairComm `isoTrans` distribLeft) `isoTrans` eitherCong pairComm pairComm   -- Enable preorder reasoning syntax over isomorphisms+||| Used for preorder reasoning syntax. Not intended for direct use. qed : (a : Type) -> Iso a a qed a = isoRefl +||| Used for preorder reasoning syntax. Not intended for direct use. step : (a : Type) -> Iso a b -> Iso b c -> Iso a c step a iso1 iso2 = isoTrans iso1 iso2    -- Isomorphisms over Maybe+||| Isomorphism is a congruence with respect to Maybe maybeCong : Iso a b -> Iso (Maybe a) (Maybe b) maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1 ok2   where ok1 : (y : Maybe b) -> map to (map from y) = y@@ -200,6 +223,7 @@         ok2 Nothing = refl         ok2 (Just x) = (Just (from (to x))) ={ cong (fromTo x) }= (Just x) QED +||| `Maybe a` is the same as `Either a ()` maybeEither : Iso (Maybe a) (Either a ()) maybeEither = MkIso to from iso1 iso2   where to : Maybe a -> Either a ()@@ -215,6 +239,7 @@         iso2 Nothing = refl         iso2 (Just x) = refl +||| Maybe of void is just unit maybeVoidUnit : Iso (Maybe _|_) () maybeVoidUnit = (Maybe _|_)     ={ maybeEither   }=                 (Either _|_ ()) ={ eitherBotLeft }=
libs/base/Control/Monad/State.idr view
@@ -14,7 +14,7 @@  instance Functor f => Functor (StateT s f) where     map f (ST g) = ST (\st => map (mapFst f) (g st)) where-       mapFst : (a -> x) -> (a, b) -> (x, b)+       mapFst : (a -> x) -> (a, s) -> (x, s)        mapFst fn (a, b) = (fn a, b)  instance Monad f => Applicative (StateT s f) where
libs/base/Data/Buffer.idr view
@@ -23,7 +23,7 @@ --    and offset rather than storing the offset in Buffer itself, which --    would require exposing the offset argument of prim__appendBuffer --- A contiguous chunk of n bytes+||| A contiguous chunk of n bytes abstract record Buffer : Nat -> Type where   MkBuffer : ( offset : Nat ) -> ( realBuffer : prim__UnsafeBuffer ) -> Buffer n
libs/base/Data/Fun.idr view
@@ -1,8 +1,18 @@ module Data.Fun +%default total+ -------------------------------------------------------------------------------- -- Build an n-ary function type from a Vect of Types and a result type -------------------------------------------------------------------------------- Fun : Vect n Type -> Type -> Type Fun [] r = r Fun (t::ts) r = t -> Fun ts r++chain : {ts : Vect n Type} -> Fun [r] r' -> Fun ts r -> Fun ts r'+chain {ts = []} g r  = g r+chain {ts = (_::_)} g f = \ x => chain g (f x)++target : {ts : Vect n Type} -> Fun ts r -> Type+target {r} _ = r +
libs/base/Data/HVect.idr view
@@ -6,10 +6,12 @@ %default total  using (k : Nat, ts : Vect k Type)+  ||| Heterogeneous vectors where the type index gives, element-wise, the types of the contents   data HVect : Vect k Type -> Type where     Nil : HVect []     (::) : t -> HVect ts -> HVect (t::ts) +  ||| Extract an element from an HVect   index : (i : Fin k) -> HVect ts -> index i ts   index fZ (x::xs) = x   index (fS j) (x::xs) = index j xs@@ -17,6 +19,7 @@   deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us)   deleteAt fZ (x::xs) = xs   deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs+  deleteAt {l = Z}   (fS j) (x::xs) = absurd j   deleteAt _ [] impossible    replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts)@@ -49,6 +52,8 @@   instance (Shows k ts) => Show (HVect ts) where     show xs = show (shows xs) +  ||| Extract an arbitrary element of the correct type+  ||| @ t the goal type   get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t   get {p = Here} (x::xs) = x   get {p = There p'} (x::xs) = get {p = p'} xs
libs/base/Data/Sign.idr view
@@ -1,6 +1,8 @@ module Data.Sign +||| A representation of signs for signed datatypes such as `ZZ` data Sign = Plus | Minus +||| Discover the sign of some type class Signed t where   total sign : t -> Sign
libs/base/Data/SortedMap.idr view
@@ -183,11 +183,13 @@       Left t3' => Left (Branch3 t1 k1 t2 k2 t3')       Right t3' => Left (merge3 t1 k1 t2 k2 t3') --- FIXME: this is very inefficient treeToList : Ord k => Tree n k v -> List (k, v)-treeToList (Leaf k v) = [(k, v)]-treeToList (Branch2 t1 _ t2) = treeToList t1 ++ treeToList t2-treeToList (Branch3 t1 _ t2 _ t3) = treeToList t1 ++ treeToList t2 ++ treeToList t3+treeToList = treeToList' (:: [])+  where+    treeToList' : Ord k => ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)+    treeToList' cont (Leaf k v) = cont (k, v)+    treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1+    treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1  data SortedMap : Type -> Type -> Type where   Empty : SortedMap k v
libs/base/Data/Vect.idr view
@@ -10,11 +10,14 @@ --------------------------------------------------------------------------------  using (xs : Vect k a)+  ||| A proof that some element is found in a vector   data Elem : a -> Vect k a -> Type where     Here : Elem x (x::xs)     There : Elem x xs -> Elem x (y::xs) -findElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic+||| A tactic for discovering where, if anywhere, an element is in a vector+||| @ n how many elements to search before giving up+findElem : (n : Nat) -> List (TTName, Binder TT) -> TT -> Tactic findElem Z ctxt goal = Refine "Here" `Seq` Solve findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal)))
libs/base/Data/ZZ.idr view
@@ -7,8 +7,8 @@ %access public  --- | An integer is either a positive nat or the negated successor of a nat.--- Zero is chosen to be positive.+||| An integer is either a positive nat or the negated successor of a nat.+||| Zero is arbitrarily chosen to be positive. data ZZ = Pos Nat | NegS Nat  instance Signed ZZ where
libs/base/Debug/Trace.idr view
@@ -1,6 +1,9 @@ module Debug.Trace -trace : String -> a -> a+||| Print a message for debugging purposes as a side effect+||| @ msg what to print+||| @ result the final result+trace : (msg : String) -> (result : a) -> a trace x val = unsafePerformIO (do putStrLn x; return val)
libs/base/Decidable/Order.idr view
@@ -10,7 +10,7 @@ --------------------------------------------------------------------------------  ----------------------------------------------------------------------------------- Preorders and Posets+-- Preorders, Posets, total Orders, Equivalencies, Congruencies --------------------------------------------------------------------------------  class Preorder t (po : t -> t -> Type) where@@ -20,7 +20,43 @@ class (Preorder t po) => Poset t (po : t -> t -> Type) where   total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b +class (Poset t to) => Ordered t (to : t -> t -> Type) where+  total order : (a : t) -> (b : t) -> Either (to a b) (to b a)++class (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where+  total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a++class (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where+  total congruent : (a : t) -> +                    (b : t) -> +                    eq a b -> +                    eq (f a) (f b)++minimum : (Ordered t to) => t -> t -> t+minimum x y with (order x y)+  | Left _ = x+  | Right _ = y++maximum : (Ordered t to) => t -> t -> t+maximum x y with (order x y)+  | Left _ = y+  | Right _ = x+ --------------------------------------------------------------------------------+-- Syntactic equivalence (=)+--------------------------------------------------------------------------------++instance Preorder t ((=) {A = t} {B = t}) where+  transitive a b c = trans {a = a} {b = b} {c = c}+  reflexive a = refl++instance Equivalence t ((=) {A = t} {B = t}) where+  symmetric a b prf = sym prf++instance Congruence t f ((=) {A = t} {B = t}) where+  congruent a b = cong {a = a} {b = b} {f = f}++-------------------------------------------------------------------------------- -- Natural numbers -------------------------------------------------------------------------------- @@ -56,6 +92,10 @@ zeroNeverGreater {n} (nLTESm _) impossible zeroNeverGreater {n}  nEqn      impossible +total zeroAlwaysSmaller : {n : Nat} -> NatLTE Z n+zeroAlwaysSmaller {n = Z  } = nEqn+zeroAlwaysSmaller {n = S k} = nLTESm (zeroAlwaysSmaller {n = k}) + total nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_ nGTSm         disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm)@@ -74,5 +114,51 @@ instance Decidable [Nat,Nat] NatLTE where   decide = decideNatLTE +total lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n) lte m n = decide {ts = [Nat,Nat]} {p = NatLTE} m n++total+shift : (m : Nat) -> (n : Nat) -> NatLTE m n -> NatLTE (S m) (S n)+shift Z      Z        _            = nEqn+shift Z     (S Z)     _            = nLTESm nEqn+shift Z     (S (S j)) _            = nLTESm (shift Z (S j) zeroAlwaysSmaller)+shift (S k)  Z        prf          = FalseElim (zeroNeverGreater prf)+shift (S k) (S k)     nEqn         = nEqn+shift (S k) (S j)     (nLTESm prf) = nLTESm (shift (S k) j prf)++instance Ordered Nat NatLTE where+  order Z      n = Left zeroAlwaysSmaller+  order m      Z = Right zeroAlwaysSmaller+  order (S k) (S j) with (order k j)+    order (S k) (S j) | Left  prf = Left  (shift k j prf)+    order (S k) (S j) | Right prf = Right (shift j k prf)++--------------------------------------------------------------------------------+-- Finite numbers+--------------------------------------------------------------------------------++using (k : Nat)+  data FinLTE : Fin k -> Fin k -> Type where+    FromNatPrf : {m : Fin k} -> {n : Fin k} -> NatLTE (finToNat m) (finToNat n) -> FinLTE m n++  instance Preorder (Fin k) FinLTE where+    transitive m n o (FromNatPrf p1) (FromNatPrf p2) = +      FromNatPrf (NatLTEIsTransitive (finToNat m) (finToNat n) (finToNat o) p1 p2)+    reflexive n = FromNatPrf (NatLTEIsReflexive (finToNat n))++  instance Poset (Fin k) FinLTE where+    antisymmetric m n (FromNatPrf p1) (FromNatPrf p2) =+      finToNatInjective m n (NatLTEIsAntisymmetric (finToNat m) (finToNat n) p1 p2)+  +  instance Decidable [Fin k, Fin k] FinLTE where+    decide m n with (decideNatLTE (finToNat m) (finToNat n))+      | Yes prf    = Yes (FromNatPrf prf)+      | No  disprf = No (\ (FromNatPrf prf) => disprf prf)++  instance Ordered (Fin k) FinLTE where+    order m n =+      either (Left . FromNatPrf) +             (Right . FromNatPrf)+             (order (finToNat m) (finToNat n))+
libs/base/Language/Reflection.idr view
@@ -22,7 +22,7 @@             -- ^ explicit universe variable %name TTUExp uexp --- | Primitive constants+||| Primitive constants data Const = I Int | BI Integer | Fl Float | Ch Char | Str String            | IType | BIType | FlType   | ChType  | StrType            | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64@@ -66,7 +66,7 @@ reflectConstant = toConst  --- | Types of named references+||| Types of named references data NameType = Bound               -- ^ reference which is just bound, e.g. by intro               | Ref@@ -77,8 +77,8 @@               -- ^ type constructor with tag and number %name NameType nt, nt' --- | Types annotations for bound variables in different--- binding contexts+||| Types annotations for bound variables in different+||| binding contexts data Binder a = Lam a               | Pi a               | Let a a@@ -124,7 +124,7 @@   traverse f (PVTy x) = [| PVTy (f x) |]  --- | Reflection of the well typed core language+||| Reflection of the well typed core language data TT = P NameType TTName TT         -- ^ named binders         | V Int@@ -146,7 +146,7 @@  %name TT tm, tm' --- | Raw terms without types+||| Raw terms without types data Raw = Var TTName          | RBind TTName (Binder Raw) Raw          | RApp Raw Raw@@ -180,6 +180,8 @@             -- ^ invoke the reflected rep. of another tactic             | Reflect TT             -- ^ turn a value into its reflected representation+            | ByReflection TT+            -- ^ use a %reflection function             | Fill Raw             -- ^ turn a raw value back into a term             | Exact TT
libs/base/Language/Reflection/Errors.idr view
@@ -3,7 +3,7 @@ import Language.Reflection  data SourceLocation : Type where-  FileLoc : (filename : String) -> (line : Int) -> (col : Int) -> SourceLocation+  FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation  %name SourceLocation loc @@ -35,14 +35,12 @@          | AlreadyDefined TTName          | ProofSearchFail Err          | NoRewriting TT-         | At SourceLocation Err-         | Elaborating String TTName Err          | ProviderError String          | LoadingFailed String Err  %name Err err, e --- | Error reports are a list of report parts+||| Error reports are a list of report parts data ErrorReportPart = TextPart String                      | NamePart TTName                      | TermPart TT
libs/base/Language/Reflection/Utils.idr view
@@ -252,8 +252,6 @@   show (AlreadyDefined n) = "AlreadyDefined " ++ show n   show (ProofSearchFail err) = "ProofSearchFail " ++ show err   show (NoRewriting tm) = "NoRewriting " ++ show tm-  show (At loc err) = "At " ++ show loc ++ " " ++ show err-  show (Elaborating x n err) = "Elaborating " ++ show x ++ " " ++ show x ++ " " ++ show n ++ " (" ++ show err ++ ")"   show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""   show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"
libs/base/Providers.idr view
@@ -1,19 +1,36 @@ module Providers +||| Type providers must build one of these in an IO computation. public-data Provider a = Provide a | Error String+data Provider : (a : Type) -> Type where+  ||| Return a term to be spliced in+  ||| @ x the term to be spliced (i.e. the proof)+  Provide : (x : a) -> Provider a +  ||| Report an error to the user and stop compilation+  ||| @ msg the error message+  Error : (msg : String) -> Provider a++  ||| Postulate the goal type+  Postulate : Provider a+ -- instances instance Functor Provider where   map f (Provide a) = Provide (f a)   map f (Error err) = Error err+  map f Postulate   = Postulate  instance Applicative Provider where   (Provide f) <$> (Provide x) = Provide (f x)   (Provide f) <$> (Error err) = Error err-  (Error err) <$> _ = Error err+  (Provide f) <$> Postulate   = Postulate+  (Error err) <$> _           = Error err+  Postulate   <$> (Error err) = Error err+  Postulate   <$> _           = Postulate   pure = Provide +-- is this correct for Postulate? instance Monad Provider where   (Provide x) >>= f = f x   (Error err) >>= _ = Error err+  Postulate   >>= f = Postulate
libs/base/System.idr view
@@ -5,6 +5,7 @@ %default partial %access public +||| Get the command-line arguments that the program was called with. getArgs : IO (List String) getArgs = do n <- numArgs              ga' [] 0 n@@ -20,8 +21,8 @@                     do arg <- getArg i                        ga' (arg :: acc) (i+1) n --- Retrieves an value from the environment, if the given key is present,--- otherwise it returns Nothing.+||| Retrieves an value from the environment, if the given key is present,+||| otherwise it returns Nothing. getEnv : String -> IO (Maybe String) getEnv key = do     str_ptr <- getEnv'@@ -33,15 +34,15 @@     getEnv' : IO String     getEnv' = mkForeign (FFun "getenv" [FString] FString) key --- Sets an environment variable with a given value.--- Returns true if the operation was successful.+||| Sets an environment variable with a given value.+||| Returns true if the operation was successful. setEnv : String -> String -> IO Bool setEnv key value = do   ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1   return (ok == 0) --- Unsets an environment variable.--- Returns true if the variable was able to be unset.+||| Unsets an environment variable.+||| Returns true if the variable was able to be unset. unsetEnv : String -> IO Bool unsetEnv key = do   ok <- mkForeign (FFun "unsetenv" [FString] FInt) key@@ -68,8 +69,13 @@          then return $ reverse $ map splitEq acc          else getAllPairs (n + 1) (envPair :: acc) +||| Quit with a particular exit code exit : Int -> IO () exit code = mkForeign (FFun "exit" [FInt] FUnit) code++||| Get the Unix time+time : IO Int+time = mkForeign (FFun "idris_time" [] FInt)  usleep : Int -> IO () usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i
libs/base/System/Concurrency/Process.idr view
@@ -62,7 +62,7 @@   where get : IO (Ptr, msg)         get = getMsg -create : |(thread : Process msg ()) -> Process msg (ProcID msg)+create : Process msg () -> Process msg (ProcID msg) create (lift p) = do ptr <- lift (fork p)                      return (MkPID ptr)
− libs/base/Uninhabited.idr 
@@ -1,15 +0,0 @@-module Uninhabited--class Uninhabited t where-  total uninhabited : t -> _|_--instance Uninhabited (Fin Z) where-  uninhabited fZ impossible-  uninhabited (fS f) impossible--instance Uninhabited (Z = S n) where-  uninhabited refl impossible---- | Use an absurd assumption to discharge a proof obligation-absurd : Uninhabited t => t -> a-absurd t = FalseElim (uninhabited t)
libs/base/base.ipkg view
@@ -10,8 +10,6 @@            Decidable.Decidable, Decidable.Order, -          Uninhabited,-           Providers,            Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors,
+ libs/effects/Effect/Default.idr view
@@ -0,0 +1,44 @@+module Default++class Default a where+    default : a++instance Default Int where+    default = 0++instance Default Integer where+    default = 0++instance Default Float where+    default = 0++instance Default Nat where+    default = 0++instance Default Char where+    default = '\0'++instance Default String where+    default = ""++instance Default Bool where+    default = False++instance Default () where+    default = ()++instance (Default a, Default b) => Default (a, b) where+    default = (default, default)++instance Default (Maybe a) where+    default = Nothing++instance Default (List a) where+    default = []++instance Default a => Default (Vect n a) where+    default = mkDef _ where+      mkDef : (n : Nat) -> Vect n a+      mkDef Z = []+      mkDef (S k) = default :: mkDef k+
libs/effects/Effect/Exception.idr view
@@ -4,12 +4,15 @@ import System import Control.IOExcept -data Exception : Type -> Type -> Type -> Type -> Type where-     Raise : a -> Exception a () () b+data Exception : Type -> Effect where +     Raise : a -> { () } Exception a b  instance Handler (Exception a) Maybe where      handle _ (Raise e) k = Nothing +instance Handler (Exception a) List where+     handle _ (Raise e) k = []+ instance Show a => Handler (Exception a) IO where      handle _ (Raise e) k = do print e                                believe_me (exit 1)@@ -23,9 +26,8 @@ EXCEPTION : Type -> EFFECT EXCEPTION t = MkEff () (Exception t) -raise : a -> Eff m [EXCEPTION a] b+raise : a -> { [EXCEPTION a ] } Eff m b  raise err = Raise err-
libs/effects/Effect/File.idr view
@@ -1,69 +1,133 @@+-- -------------------------------------------------------- [ Effectful FileIO ] module Effect.File  import Effects import Control.IOExcept -data OpenFile : Mode -> Type where++||| A Dependent type to describe File Handles. File handles are+||| parameterised with the current state of the file: Closed; Open for+||| reading; and Open for writing.+||| +||| @ m The file mode. +data OpenFile : (m : Mode) -> Type where      FH : File -> OpenFile m +openOK : Mode -> Bool -> Type+openOK m True = OpenFile m+openOK m False = ()++-- ------------------------------------------------------------ [ The Protocol ]++||| Here the protocol for resource access is defined as an effect.+||| The state transitions diagram for the protocol is as follows:+||| +|||     digraph G {+||| +|||       empty; read; write; // States+||| +|||       empty -> read [label="Open R"];+|||       read -> empty [label="Close"];+|||       read -> read [label="ReadLine"];+|||       read -> read [label="EOF"];+|||           +|||       empty -> write [label="Open W"];+|||       write -> empty [label="Close"];+|||       write -> write [label="WriteLine"];+||| +|||     } data FileIO : Effect where-     Open  : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool-     Close :                         FileIO (OpenFile m) () ()+  ||| Open a file with the specified mode.+  ||| +  ||| Opening a file successful moves the state from 'empty' to the+  ||| specified mode. If not successful the state is still 'empty'.+  ||| +  ||| @ fname The file name to be opened.+  ||| @ m The file mode.+  Open : (fname: String)+         -> (m : Mode)+         -> {() ==> {res} if res+                             then OpenFile m+                             else ()} FileIO Bool -     ReadLine  :           FileIO (OpenFile Read)  (OpenFile Read) String-     WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()-     EOF       :           FileIO (OpenFile Read)  (OpenFile Read) Bool+  ||| Close a file.+  ||| +  ||| Closing a file moves the state from Open to closed.+  Close : {OpenFile m ==> ()} FileIO ()  +  ||| Read a line from the file.+  ||| +  ||| Only files that are open for reading can be read.+  ReadLine : {OpenFile Read}  FileIO String +  +  ||| Write a line to a file.+  ||| +  ||| Only file that are open for writing can be written to.+  WriteLine : String -> {OpenFile Write} FileIO () +  ||| End of file?+  ||| +  ||| Only files open for reading can be tested for EOF+  EOF : {OpenFile Read}  FileIO Bool++-- ------------------------------------------------------------ [ The Handlers ]++--- An implementation of the resource access protocol for the IO Context. instance Handler FileIO IO where     handle () (Open fname m) k = do h <- openFile fname m                                     valid <- validFile h-                                    if valid then k (Right (FH h)) True-                                             else k (Left ()) False+                                    if valid then k True (FH h) +                                             else k False ()     handle (FH h) Close      k = do closeFile h                                     k () ()     handle (FH h) ReadLine        k = do str <- fread h-                                         k (FH h) str+                                         k str (FH h)     handle (FH h) (WriteLine str) k = do fwrite h str-                                         k (FH h) ()+                                         k () (FH h)     handle (FH h) EOF             k = do e <- feof h-                                         k (FH h) e--instance Handler FileIO (IOExcept String) where-    handle () (Open fname m) k-       = do h <- ioe_lift (openFile fname m)-            valid <- ioe_lift (validFile h)-            if valid then k (Right (FH h)) True-                     else k (Left ()) False-    handle (FH h) Close           k = do ioe_lift (closeFile h); k () ()-    handle (FH h) ReadLine        k = do str <- ioe_lift (fread h)-                                         k (FH h) str-    handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)-                                         k (FH h) ()-    handle (FH h) EOF             k = do e <- ioe_lift (feof h)-                                         k (FH h) e+                                         k e (FH h) +-- -------------------------------------------------------------- [ The Effect ] FILE_IO : Type -> EFFECT FILE_IO t = MkEff t FileIO +-- ------------------------------------------------------------ [ The Bindings ]+--+-- Bind the IO context handlers to functions. These functions will run+-- in the IO context.+--++||| Open a file with the specified mode.+||| +||| @ fname The file name to be opened.+||| @ m The file mode. open : Handler FileIO e =>-       String -> (m : Mode) -> EffM e [FILE_IO ()]-                                      [FILE_IO (Either () (OpenFile m))] Bool+       (fname : String)+       -> (m : Mode)+       -> { [FILE_IO ()] ==> [FILE_IO (if result+                                          then OpenFile m+                                          else ())] } Eff e Bool open f m = Open f m ++||| Close a file. close : Handler FileIO e =>-        EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()+        { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e () close = Close -readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String+||| Read a line from the file.+readLine : Handler FileIO e => +           { [FILE_IO (OpenFile Read)] } Eff e String  readLine = ReadLine -writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()+||| Write a line to a file.+writeLine : Handler FileIO e => +            String -> { [FILE_IO (OpenFile Write)] } Eff e () writeLine str = WriteLine str -eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool+||| End of file?+eof : Handler FileIO e => +      { [FILE_IO (OpenFile Read)] } Eff e Bool  eof = EOF ---+-- --------------------------------------------------------------------- [ EOF ]
libs/effects/Effect/Memory.idr view
@@ -12,29 +12,30 @@ abstract data RawMemory : Effect where      Allocate   : (n : Nat) ->-                  RawMemory () (MemoryChunk n 0) ()-     Free       : RawMemory (MemoryChunk n i) () ()+                  RawMemory () () (\v => MemoryChunk n 0)+     Free       : RawMemory () (MemoryChunk n i) (\v => ())      Initialize : Bits8 ->                   (size : Nat) ->                   so (i + size <= n) ->-                  RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()+                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))      Peek       : (offset : Nat) ->                   (size : Nat) ->                   so (offset + size <= i) ->-                  RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)+                  RawMemory (Vect size Bits8)+                            (MemoryChunk n i) (\v => MemoryChunk n i)       Poke       :  (offset : Nat) ->                   (Vect size Bits8) ->                   so (offset <= i && offset + size <= n) ->-                  RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) ()+                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))       Move       : (src : MemoryChunk src_size src_init) ->                   (dst_offset : Nat) ->                   (src_offset : Nat) ->                   (size : Nat) ->                   so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->                   so (src_offset + size <= src_init) ->-                  RawMemory (MemoryChunk dst_size dst_init)-                            (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()-     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)+                  RawMemory () (MemoryChunk dst_size dst_init)+                            (\v => MemoryChunk dst_size (max dst_init (dst_offset + size))) +     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)   private do_malloc : Nat -> IOExcept String Ptr@@ -79,27 +80,28 @@ instance Handler RawMemory (IOExcept String) where   handle () (Allocate n) k     = do ptr <- do_malloc n-         k (CH ptr) ()-  handle (CH ptr) (Initialize {i} c size _) k-    = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()+         k () (CH ptr)+  handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k+    = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)   handle (CH ptr) (Free) k     = ioe_lift (do_free ptr) $> k () ()   handle (CH ptr) (Peek offset size _) k     = do res <- ioe_lift (do_peek ptr offset size)-         k (CH ptr) res+         k res (CH ptr)   handle (CH ptr) (Poke offset content _) k     = do ioe_lift (do_poke ptr offset content)-         k (CH ptr) ()+         k () (CH ptr)   handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k     = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)-         k (CH dest_ptr) ()+         k () (CH dest_ptr)   handle chunk (GetRawPtr) k     = k chunk chunk  RAW_MEMORY : Type -> EFFECT RAW_MEMORY t = MkEff t RawMemory -allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()+allocate : (n : Nat) -> +           Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)]) allocate size = Allocate size  initialize : {i : Nat} ->@@ -107,17 +109,18 @@              Bits8 ->              (size : Nat) ->              so (i + size <= n) ->-             EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()+             Eff m () [RAW_MEMORY (MemoryChunk n i)] +                       (\v => [RAW_MEMORY (MemoryChunk n (i + size))]) initialize c size prf = Initialize c size prf -free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()+free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()]) free = Free  peek : {i : Nat} ->        (offset : Nat) ->        (size : Nat) ->        so (offset + size <= i) ->-       Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)+       { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)  peek offset size prf = Peek offset size prf  poke : {n : Nat} ->@@ -125,11 +128,12 @@        (offset : Nat) ->        Vect size Bits8 ->        so (offset <= i && offset + size <= n) ->-       EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()+       Eff m () [RAW_MEMORY (MemoryChunk n i)] +              (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))]) poke offset content prf = Poke offset content prf  private-getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)+getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)  getRawPtr = GetRawPtr  private@@ -142,8 +146,8 @@         (size : Nat) ->         so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->         so (src_offset + size <= src_init) ->-        EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]-               [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()+        Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]+               (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))]) move' src_ptr dst_offset src_offset size dst_bounds src_bounds   = Move src_ptr dst_offset src_offset size dst_bounds src_bounds @@ -158,10 +162,12 @@        (size : Nat) ->        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->        so (src_offset + size <= src_init) ->-       EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)+       Eff m ()+              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)               , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]-              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))-              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()+              (\v =>+                [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))+                , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]) move dst_offset src_offset size dst_bounds src_bounds   = do src_ptr <- Src :- getRawPtr        Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds
libs/effects/Effect/Monad.idr view
@@ -5,17 +5,17 @@ -- Eff is a monad too, so we can happily use it in a monad transformer.  using (xs : List EFFECT, m : Type -> Type)-  instance Functor (EffM m xs xs) where+  instance Functor (\a => EffM m a xs (\v => xs)) where     map f prog = do t <- prog                     value (f t) -  instance Applicative (EffM m xs xs) where+  instance Applicative (\a => EffM m a xs (\v => xs)) where     pure = value     (<$>) f a = do f' <- f                    a' <- a                    value (f' a') -  instance Monad (EffM m xs xs) where-    (>>=) = ebind+  instance Monad (\a => Eff m a xs (\v => xs)) where+    (>>=) = Effects.(>>=)
libs/effects/Effect/Random.idr view
@@ -2,24 +2,32 @@  import Effects -data Random : Type -> Type -> Type -> Type where-     getRandom : Random Integer Integer Integer-     setSeed   : Integer -> Random Integer Integer ()+data Random : Effect where +     getRandom : { Integer } Random Integer +     setSeed   : Integer -> { Integer } Random ()   using (m : Type -> Type)   instance Handler Random m where      handle seed getRandom k               = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in                     k seed' seed'-     handle seed (setSeed n) k = k n ()+     handle seed (setSeed n) k = k () n  RND : EFFECT RND = MkEff Integer Random -rndInt : Integer -> Integer -> Eff m [RND] Integer+rndInt : Integer -> Integer -> { [RND] } Eff m Integer rndInt lower upper = do v <- getRandom                         return (v `prim__sremBigInt` (upper - lower) + lower) -srand : Integer -> Eff m [RND] ()+rndFin : (k : Nat) -> { [RND] } Eff m (Fin (S k))+rndFin k = do let v = !getRandom `prim__sremBigInt` (cast k)+              return (toFin v)+ where toFin : Integer -> Fin (S k) +       toFin x = case integerToFin x (S k) of+                      Just v => v+                      Nothing => toFin (assert_smaller x (x - cast (S k)))++srand : Integer -> { [RND] } Eff m () srand n = setSeed n
libs/effects/Effect/Select.idr view
@@ -3,21 +3,21 @@ import Effects  data Selection : Effect where-     Select : List a -> Selection () () a+     Select : List a -> { () } Selection a   instance Handler Selection Maybe where      handle _ (Select xs) k = tryAll xs where          tryAll [] = Nothing-         tryAll (x :: xs) = case k () x of+         tryAll (x :: xs) = case k x () of                                  Nothing => tryAll xs                                  Just v => Just v  instance Handler Selection List where-     handle r (Select xs) k = concatMap (k r) xs+     handle r (Select xs) k = concatMap (\x => k x r) xs  SELECT : EFFECT SELECT = MkEff () Selection -select : List a -> Eff m [SELECT] a+select : List a -> { [SELECT] } Eff m a  select xs = Select xs
libs/effects/Effect/State.idr view
@@ -5,33 +5,33 @@ %access public  data State : Effect where-     Get :      State a a a-     Put : b -> State a b ()+  Get :      { a }       State a+  Put : b -> { a ==> b } State ()   using (m : Type -> Type)   instance Handler State m where      handle st Get     k = k st st-     handle st (Put n) k = k n ()+     handle st (Put n) k = k () n  STATE : Type -> EFFECT STATE t = MkEff t State -get : Eff m [STATE x] x+get : { [STATE x] } Eff m x get = Get -put : x -> Eff m [STATE x] ()+put : x -> { [STATE x] } Eff m ()  put val = Put val -putM : y -> EffM m [STATE x] [STATE y] ()+putM : y -> { [STATE x] ==> [STATE y] } Eff m ()  putM val = Put val -update : (x -> x) -> Eff m [STATE x] ()+update : (x -> x) -> { [STATE x] } Eff m ()  update f = put (f !get) -updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()+updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m ()  updateM f = putM (f !get) -locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t+locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t  locally newst prog = do st <- get                         putM newst                         val <- prog
libs/effects/Effect/StdIO.idr view
@@ -4,57 +4,40 @@ import Control.IOExcept  data StdIO : Effect where-     PutStr : String -> StdIO () () ()-     GetStr : StdIO () () String+     PutStr : String -> { () } StdIO () +     GetStr : { () } StdIO String +     PutCh : Char -> { () } StdIO ()+     GetCh : { () } StdIO Char  instance Handler StdIO IO where     handle () (PutStr s) k = do putStr s; k () ()-    handle () GetStr     k = do x <- getLine; k () x+    handle () GetStr     k = do x <- getLine; k x ()+    handle () (PutCh c)  k = do putChar c; k () () +    handle () GetCh      k = do x <- getChar; k x ()  instance Handler StdIO (IOExcept a) where-    handle () (PutStr s) k = do ioe_lift (putStr s); k () ()-    handle () GetStr     k = do x <- ioe_lift getLine; k () x---- Handle effects in a pure way, for simulating IO for unit testing/proof--data IOStream a = MkStream (List String -> (a, List String))--instance Handler StdIO IOStream where-    handle () (PutStr s) k-       = MkStream (\x => case k () () of-                         MkStream f => let (res, str) = f x in-                                           (res, s :: str))-    handle {a} () GetStr k-       = MkStream (\x => case x of-                              [] => cont "" []-                              (t :: ts) => cont t ts)-        where-            cont : String -> List String -> (a, List String)-            cont t ts = case k () t of-                             MkStream f => f ts+    handle () (PutStr s) k = do ioe_lift $ putStr s; k () ()+    handle () GetStr     k = do x <- ioe_lift $ getLine; k x ()+    handle () (PutCh c)  k = do ioe_lift $ putChar c; k () () +    handle () GetCh      k = do x <- ioe_lift $ getChar; k x ()  --- The Effect and associated functions  STDIO : EFFECT STDIO = MkEff () StdIO -putStr : Handler StdIO e => String -> Eff e [STDIO] ()+putStr : Handler StdIO e => String -> { [STDIO] } Eff e () putStr s = PutStr s -putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()+putChar : Handler StdIO e => Char -> { [STDIO] } Eff e ()+putChar c = PutCh c++putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e () putStrLn s = putStr (s ++ "\n") -getStr : Handler StdIO e => Eff e [STDIO] String+getStr : Handler StdIO e => { [STDIO] } Eff e String getStr = GetStr -mkStrFn : Env IOStream xs ->-          Eff IOStream xs a ->-          List String -> (a, List String)-mkStrFn {a} env p input = case mkStrFn' of-                               MkStream f => f input-  where injStream : a -> IOStream a-        injStream v = MkStream (\x => (v, []))-        mkStrFn' : IOStream a-        mkStrFn' = runWith injStream env p-+getChar : Handler StdIO e => { [STDIO] } Eff e Char+getChar = GetCh
+ libs/effects/Effect/System.idr view
@@ -0,0 +1,38 @@+module Effect.System++-- Various system interaction features (this is not necessarily the right way+-- to split them up, I just need some of them now :))++import Effects+import System+import Control.IOExcept++data System : Effect where+     Args : { () } System (List String)+     Time : { () } System Int+     GetEnv : String -> { () } System (Maybe String)++instance Handler System IO where+    handle () Args k = do x <- getArgs; k x ()+    handle () Time k = do x <- time; k x ()+    handle () (GetEnv s) k = do x <- getEnv s; k x ()++instance Handler System (IOExcept a) where+    handle () Args k = do x <- ioe_lift getArgs; k x ()+    handle () Time k = do x <- ioe_lift time; k x ()+    handle () (GetEnv s) k = do x <- ioe_lift $ getEnv s; k x ()++--- The Effect and associated functions++SYSTEM : EFFECT+SYSTEM = MkEff () System++getArgs : Handler System e => { [SYSTEM] } Eff e (List String)+getArgs = Args++time : Handler System e => { [SYSTEM] } Eff e Int+time = Time++getEnv : Handler System e => String -> { [SYSTEM] } Eff e (Maybe String)+getEnv s = GetEnv s+
libs/effects/Effects.idr view
@@ -2,23 +2,59 @@  import Language.Reflection import Control.Catchable--%access public+import Effect.Default ----- Effects+--- Effectful computations are described as algebraic data types that+--- explain how an effect is interpreted in some underlying context. +%access public+-- ----------------------------------------------------------------- [ Effects ]+||| The Effect type describes effectful computations.+||| +||| This type is parameterised by:+||| + The input resource.+||| + The return type of the computation.+||| + The computation to run on the resource. Effect : Type-Effect = Type -> Type -> Type -> Type+Effect = (x : Type) -> Type -> (x -> Type) -> Type +||| The `EFFECT` Data type describes how to promote the Effect+||| description into a concrete effect. %error_reverse data EFFECT : Type where      MkEff : Type -> Effect -> EFFECT +||| Handler classes describe how an effect `e` is translated to the+||| underlying computation context `m` for execution. class Handler (e : Effect) (m : Type -> Type) where-     handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a+  ||| How to handle the effect.+  ||| +  ||| @ r The resource being handled.+  ||| @ eff The effect to be applied.+  ||| @ ctxt The context in which to handle the effect.+  handle : (r : res) -> (eff : e t res resk) -> +           (ctxt : ((x : t) -> resk x -> m a)) -> m a ----- Properties and proof construction+||| Get the resource type (handy at the REPL to find out about an effect)+resourceType : EFFECT -> Type+resourceType (MkEff t e) = t +-- --------------------------------------------------------- [ Syntactic Sugar ]++-- A bit of syntactic sugar ('syntax' is not very flexible so we only go+-- up to a small number of parameters...)++-- No state transition+syntax "{" [inst] "}" [eff] = eff inst (\result => inst)++-- The state transition is dependent on a result `b`, a bound variable.+syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff] +       = eff inst (\b => outst)++--- A simple state transition+syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)++-- --------------------------------------- [ Properties and Proof Construction ] using (xs : List a, ys : List a)   data SubList : List a -> List a -> Type where        SubNil : SubList {a} [] []@@ -29,16 +65,17 @@   subListId {xs = Nil} = SubNil   subListId {xs = x :: xs} = Keep subListId -data Env  : (m : Type -> Type) -> List EFFECT -> Type where-     Nil  : Env m Nil-     (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)--data EffElem : (Type -> Type -> Type -> Type) -> Type ->+namespace Env+  data Env  : (m : Type -> Type) -> List EFFECT -> Type where+       Nil  : Env m Nil+       (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)+       +data EffElem : Effect -> Type ->                List EFFECT -> Type where      Here : EffElem x a (MkEff a x :: xs)      There : EffElem x a xs -> EffElem x a (y :: xs) --- make an environment corresponding to a sub-list+||| make an environment corresponding to a sub-list dropEnv : Env m ys -> SubList xs ys -> Env m xs dropEnv [] SubNil = [] dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest@@ -52,7 +89,7 @@ updateWith (y :: ys) []        SubNil      = y :: ys updateWith []        (x :: xs) (Keep rest) = [] --- put things back, replacing old with new in the sub-environment+||| Put things back, replacing old with new in the sub-environment rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->              Env m xs -> Env m (updateWith ys' xs prf) rebuildEnv []        SubNil      env = env@@ -60,8 +97,7 @@ rebuildEnv xs        (Drop rest) (y :: env) = y :: rebuildEnv xs rest env rebuildEnv (x :: xs) SubNil      [] = x :: xs ----- The Effect EDSL itself -----+-- -------------------------------------------------- [ The Effect EDSL itself ] -- some proof automation  %reflection@@ -79,7 +115,7 @@  %reflection reflectSubList : List a -> Tactic-reflectSubList [] = Refine "SubNil" `Seq` Solve+reflectSubList [] = Refine "subListId" `Seq` Solve reflectSubList (x :: xs)      = Try (Refine "subListId" `Seq` Solve)            (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))@@ -88,21 +124,33 @@ reflectSubList _ = Refine "subListId" `Seq` Solve  %reflection+reflectDefaultList : List a -> Tactic+reflectDefaultList [] = Refine "enil" `Seq` Solve+reflectDefaultList (x :: xs)+     = Refine "econs" `Seq` +         (Solve `Seq`+           (Instance `Seq` +         (Refine "default" `Seq`+           (Solve `Seq`+             (Instance `Seq`+              (reflectDefaultList xs))))))+reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve+reflectDefaultList _ = Refine "Nil" `Seq` Solve++%reflection reflectEff : (P : Type) -> Tactic reflectEff (EffElem m a xs)      = reflectListEffElem xs `Seq` Solve reflectEff (SubList xs ys)      = reflectSubList ys `Seq` Solve+reflectEff (Env m xs)+     = reflectDefaultList xs `Seq` Solve -updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->+updateResTy : (val : t) ->+              (xs : List EFFECT) -> EffElem e a xs -> e t a b ->               List EFFECT-updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs-updateResTy (x :: xs)        (There p) n = x :: updateResTy xs p n--updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->-                 List EFFECT-updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs-updateResTyImm (x :: xs)    (There p) b = x :: updateResTyImm xs p b+updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs+updateResTy     val (x :: xs)    (There p) n = x :: updateResTy val xs p n  infix 5 :::, :-, := @@ -110,164 +158,103 @@      (:=) : (x : lbl) -> res -> LRes x res  (:::) : lbl -> EFFECT -> EFFECT-(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff+(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e +using (lbl : Type)+  instance Default a => Default (LRes lbl a) where+    default = lbl := default+ private unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x] unlabel {m} {x = MkEff a eff} [l := v] = [v]  private-relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]-relabel {x = MkEff a eff} l [v] = [l := v]---- the language of Effects--data EffM : (m : Type -> Type) ->-            List EFFECT -> List EFFECT -> Type -> Type where-     value   : a -> EffM m xs xs a-     ebind   : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b-     effect  : (prf : EffElem e a xs) ->-               (eff : e a b t) ->-               EffM m xs (updateResTy xs prf eff) t-     lift    : (prf : SubList ys xs) ->-               EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t-     new     : Handler e m =>-               res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->-               EffM m xs xs' a-     test    : (prf : EffElem e (Either l r) xs) ->-               EffM m (updateResTyImm xs prf l) xs' t ->-               EffM m (updateResTyImm xs prf r) xs' t ->-               EffM m xs xs' t-     test_lbl : {x : lbl} ->-                (prf : EffElem e (LRes x (Either l r)) xs) ->-                EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->-                EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->-                EffM m xs xs' t-     catch   : Catchable m err =>-               EffM m xs xs' a -> (err -> EffM m xs xs' a) ->-               EffM m xs xs' a-     (:-)    : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t--syntax [tag] ":!" [val] = !(tag :- val)----   Eff : List (EFFECT m) -> Type -> Type--implicit-lift' : EffM m ys ys' t ->-        {default tactics { byReflection reflectEff; }-           prf : SubList ys xs} ->-        EffM m xs (updateWith ys' xs prf) t-lift' e {prf} = lift prf e--implicit-effect' : {a, b: _} -> {e : Effect} ->-          (eff : e a b t) ->-          {default tactics { byReflection reflectEff; }-             prf : EffElem e a xs} ->-         EffM m xs (updateResTy xs prf eff) t-effect' e {prf} = effect prf e---- For making proofs implicitly for 'test' and 'test_lbl'--syntax if_valid then [e] else [t] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_valid [lbl] then [e] else [t] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e--syntax if_error then [t] else [e] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_error [lbl] then [t] else [e] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e---- These may read better in some contexts--syntax if_right then [e] else [t] =-  test (tactics { byReflection reflectEff; }) t e--syntax if_right [lbl] then [e] else [t] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e+relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)+relabel {xs = []} l [] = []+relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs -syntax if_left then [t] else [e] =-  test (tactics { byReflection reflectEff; }) t e+-- ------------------------------------------------- [ The Language of Effects ]+||| Definition of an Effect.+||| +||| @ m The computation context+||| @ x The return type of the result.+||| @ es The list of allowed side-effects.+||| @ ce Function to compute a new list of allowed side-effects.+data Eff : (m : Type -> Type)+           -> (x : Type)+           -> (es : List EFFECT)+           -> (ce : x -> List EFFECT) -> Type where+     value    : a -> Eff m a xs (\v => xs)+     with_val : (val : a) -> Eff m () xs (\v => xs' val) ->+                Eff m a xs xs'+     ebind    : Eff m a xs xs' -> +                ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''+     effect   : (prf : EffElem e a xs) ->+                (eff : e t a b) ->+                Eff m t xs (\v => updateResTy v xs prf eff) -syntax if_left [lbl] then [t] else [e] =-  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e+     lift     : (prf : SubList ys xs) ->+                Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)+     newInit  : Handler e m =>+                res -> +                Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->+                Eff m a xs (\v => xs')+     catch    : Catchable m err =>+                Eff m a xs xs' -> (err -> Eff m a xs xs') ->+                Eff m a xs xs' +     (:-)     : (l : ty) -> +                Eff m t [x] xs' -> -- [x] (\v => xs) -> +                Eff m t [l ::: x] (\v => map (l :::) (xs' v)) --- for 'do' notation+(>>=)   : Eff m a xs xs' -> +          ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''+(>>=) = ebind  -return : a -> EffM m xs xs a+return : a -> Eff m a xs (\v => xs) return x = value x -(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b-(>>=) = ebind---- for idiom brackets+-- ------------------------------------------------------ [ for idiom brackets ]  infixl 2 <$> -pure : a -> EffM m xs xs a+pure : a -> Eff m a xs (\v => xs) pure = value -(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b+syntax pureM [val] = with_val val (pure ())++(<$>) : Eff m (a -> b) xs (\v => xs) -> +        Eff m a xs (\v => xs) -> Eff m b xs (\v => xs) (<$>) prog v = do fn <- prog                   arg <- v                   return (fn arg) --- an interpreter+-- ---------------------------------------------------------- [ an interpreter ]  private execEff : Env m xs -> (p : EffElem e res xs) ->-          (eff : e res b a) ->-          (Env m (updateResTy xs p eff) -> a -> m t) -> m t+          (eff : e a res resk) ->+          ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t execEff (val :: env) Here eff' k-    = handle val eff' (\res, v => k (res :: env) v)-execEff (val :: env) (There p) eff k-    = execEff env p eff (\env', v => k (val :: env') v)--private-testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->-          (Env m (updateResTyImm xs p l) -> m b) ->-          (Env m (updateResTyImm xs p r) -> m b) ->-          m b-testEff (Left err :: env) Here lk rk = lk (err :: env)-testEff (Right ok :: env) Here lk rk = rk (ok :: env)-testEff (val :: env) (There p) lk rk-   = testEff env p (\envk => lk (val :: envk))-                   (\envk => rk (val :: envk))--private-testEffLbl : {x : lbl} ->-             Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->-             (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->-             (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->-             m b-testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)-testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)-testEffLbl (val :: env) (There p) lk rk-   = testEffLbl env p (\envk => lk (val :: envk))-                      (\envk => rk (val :: envk))+    = handle val eff' (\v, res => k v (res :: env))+-- FIXME: Teach the elaborator to propagate parameters here+execEff {e} {a} {res} {resk} (val :: env) (There p) eff k+    = execEff {e} {a} {res} {resk} env p eff (\v, env' => k v (val :: env'))  -- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state -- updates can be propagated even through failing computations? -eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b-eff env (value x) k = k env x+eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b+eff env (value x) k = k x env+eff env (with_val x prog) k = eff env prog (\p', env' => k x env')  eff env (prog `ebind` c) k-   = eff env prog (\env', p' => eff env' (c p') k)+   = eff env prog (\p', env' => eff env' (c p') k) eff env (effect prf effP) k = execEff env prf effP k eff env (lift prf effP) k    = let env' = dropEnv env prf in-         eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')-eff env (new r prog) k-   = let env' = r :: env in-         eff env' prog (\(v :: envk), p' => k envk p')-eff env (test prf l r) k-   = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)-eff env (test_lbl prf l r) k-   = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)+         eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))+eff env (newInit r prog) k+   = eff (r :: env) prog (\p' => \ (v :: envk) => k p' envk) eff env (catch prog handler) k    = catch (eff env prog k)            (\e => eff env (handler e) k)@@ -277,32 +264,79 @@ -- end so that everything is in scope when it needs to be. eff {xs = [l ::: x]} env (l :- prog) k    = let env' = unlabel env in-         eff env' prog (\envk, p' => k (relabel l envk) p')+         eff env' prog (\p', envk => k p' (relabel l envk)) -run : Applicative m => Env m xs -> EffM m xs xs' a -> m a-run env prog = eff env prog (\env, r => pure r)+-- yuck :) Haven't got type class instances working nicely in tactic+-- proofs yet, so just brute force it.+syntax MkDefaultEnv = with Env+                       (| [], [default], [default, default],+                          [default, default, default],+                          [default, default, default, default],+                          [default, default, default, default, default],+                          [default, default, default, default, default, default],+                          [default, default, default, default, default, default, default],+                          [default, default, default, default, default, default, default, default] |) -runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)-runEnv env prog = eff env prog (\env, r => pure (env, r))+implicit+lift' : Eff m t ys ys' ->+        {default tactics { byReflection reflectEff; }+           prf : SubList ys xs} ->+        Eff m t xs (\v => updateWith (ys' v) xs prf)+lift' e {prf} = lift prf e -runPure : Env id xs -> EffM id xs xs' a -> a-runPure env prog = eff env prog (\env, r => r)+implicit+effect' : {a, b: _} -> {e : Effect} ->+          (eff : e t a b) ->+          {default tactics { byReflection reflectEff; }+             prf : EffElem e a xs} ->+         Eff m t xs (\v => updateResTy v xs prf eff)+effect' e {prf} = effect prf e -runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)-runPureEnv env prog = eff env prog (\env, r => (env, r))+new : Handler e m =>+      {default default r : res} -> +      Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->+      Eff m a xs (\v => xs')+new {r} e = newInit r e -runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a-runWith inj env prog = eff env prog (\env, r => inj r)+-- --------------------------------------------------------- [ Running Effects ] -Eff : (Type -> Type) -> List EFFECT -> Type -> Type-Eff m xs t = EffM m xs xs t+||| Run an effectful program+run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a+run {env} prog = eff env prog (\r, env => pure r) --- some higher order things+runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a+runPure {env} prog = eff env prog (\r, env => r) -mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)+runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a+runInit env prog = eff env prog (\r, env => pure r)++runPureInit : Env id xs -> Eff id a xs xs' -> a+runPureInit env prog = eff env prog (\r, env => r)++runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a+runWith inj env prog = eff env prog (\r, env => inj r)++runEnv : Applicative m => Env m xs -> Eff m a xs xs' -> +         m (x : a ** Env m (xs' x))+runEnv env prog = eff env prog (\r, env => pure (r ** env))++-- ----------------------------------------------- [ some higher order things ]++mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b) mapE f []        = pure [] mapE f (x :: xs) = [| f x :: mapE f xs |] -when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()++mapVE : Applicative m => +          (a -> {xs} Eff m b) -> +          Vect n a -> +          {xs} Eff m (Vect n b)+mapVE f []        = pure []+mapVE f (x :: xs) = [| f x :: mapVE f xs |]+++when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m () when True  e = e when False e = pure ()++-- --------------------------------------------------------------------- [ EOF ]
libs/effects/effects.ipkg view
@@ -1,8 +1,9 @@ package effects  opts    = "--nobasepkgs -i ../prelude -i ../base"-modules = Effects, +modules = Effects, Effect.Default,+           Effect.Exception, Effect.File, Effect.State,           Effect.Random, Effect.StdIO, Effect.Select,-          Effect.Memory, Effect.Monad+          Effect.Memory, Effect.System
libs/javascript/JavaScript/JSON.idr view
@@ -36,8 +36,6 @@ index fZ     (JSArray (x :: xs)) = x index (fS i) (JSArray (x :: xs)) = index i (JSArray xs) -infixl 8 ++- (++) : JSON (JSONArray m ts1) ->        JSON (JSONArray n ts2) ->        JSON (JSONArray (m + n) (ts1 ++ ts2))
− libs/neweffects/Effect/Default.idr 
@@ -1,44 +0,0 @@-module Default--class Default a where-    default : a--instance Default Int where-    default = 0--instance Default Integer where-    default = 0--instance Default Float where-    default = 0--instance Default Nat where-    default = 0--instance Default Char where-    default = '\0'--instance Default String where-    default = ""--instance Default Bool where-    default = False--instance Default () where-    default = ()--instance (Default a, Default b) => Default (a, b) where-    default = (default, default)--instance Default (Maybe a) where-    default = Nothing--instance Default (List a) where-    default = []--instance Default a => Default (Vect n a) where-    default = mkDef _ where-      mkDef : (n : Nat) -> Vect n a-      mkDef Z = []-      mkDef (S k) = default :: mkDef k-
− libs/neweffects/Effect/Exception.idr 
@@ -1,39 +0,0 @@-module Effect.Exception--import Effects-import System-import Control.IOExcept--data Exception : Type -> Effect where -     Raise : a -> { () } Exception a b--instance Handler (Exception a) Maybe where-     handle _ (Raise e) k = Nothing--instance Show a => Handler (Exception a) IO where-     handle _ (Raise e) k = do print e-                               believe_me (exit 1)--instance Handler (Exception a) (IOExcept a) where-     handle _ (Raise e) k = ioM (return (Left e))--instance Handler (Exception a) (Either a) where-     handle _ (Raise e) k = Left e--EXCEPTION : Type -> EFFECT-EXCEPTION t = MkEff () (Exception t)--raise : a -> { [EXCEPTION a ] } Eff m b -raise err = Raise err--------- TODO: Catching exceptions mid program?--- probably need to invoke a new interpreter---- possibly add a 'handle' to the Eff language so that an alternative--- handler can be introduced mid interpretation?-
− libs/neweffects/Effect/File.idr 
@@ -1,62 +0,0 @@-module Effect.File--import Effects-import Control.IOExcept--data OpenFile : Mode -> Type where-     FH : File -> OpenFile m--openOK : Mode -> Bool -> Type-openOK m True = OpenFile m-openOK m False = ()--data FileIO : Effect where-     Open  : String -> (m : Mode) -> -             {() ==> {res} if res then OpenFile m else ()} FileIO Bool-     Close : {OpenFile m ==> ()}               FileIO () --     ReadLine  :           {OpenFile Read}  FileIO String -     WriteLine : String -> {OpenFile Write} FileIO ()-     EOF       :           {OpenFile Read}  FileIO Bool--instance Handler FileIO IO where-    handle () (Open fname m) k = do h <- openFile fname m-                                    valid <- validFile h-                                    if valid then k True (FH h) -                                             else k False ()-    handle (FH h) Close      k = do closeFile h-                                    k () ()-    handle (FH h) ReadLine        k = do str <- fread h-                                         k str (FH h)-    handle (FH h) (WriteLine str) k = do fwrite h str-                                         k () (FH h)-    handle (FH h) EOF             k = do e <- feof h-                                         k e (FH h)--FILE_IO : Type -> EFFECT-FILE_IO t = MkEff t FileIO--open : Handler FileIO e =>-       String -> (m : Mode) -> -       { [FILE_IO ()] ==> [FILE_IO (if result then OpenFile m else ())] } Eff e Bool-open f m = Open f m--close : Handler FileIO e =>-        { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()-close = Close--readLine : Handler FileIO e => -           { [FILE_IO (OpenFile Read)] } Eff e String -readLine = ReadLine--writeLine : Handler FileIO e => -            String -> { [FILE_IO (OpenFile Write)] } Eff e ()-writeLine str = WriteLine str--eof : Handler FileIO e => -      { [FILE_IO (OpenFile Read)] } Eff e Bool -eof = EOF----
− libs/neweffects/Effect/Memory.idr 
@@ -1,175 +0,0 @@-module Effect.Memory--import Effects-import Control.IOExcept--%access public--abstract-data MemoryChunk : Nat -> Nat -> Type where-     CH : Ptr -> MemoryChunk size initialized--abstract-data RawMemory : Effect where-     Allocate   : (n : Nat) ->-                  RawMemory () () (\v => MemoryChunk n 0)-     Free       : RawMemory () (MemoryChunk n i) (\v => ())-     Initialize : Bits8 ->-                  (size : Nat) ->-                  so (i + size <= n) ->-                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))-     Peek       : (offset : Nat) ->-                  (size : Nat) ->-                  so (offset + size <= i) ->-                  RawMemory (Vect size Bits8)-                            (MemoryChunk n i) (\v => MemoryChunk n i) -     Poke       :  (offset : Nat) ->-                  (Vect size Bits8) ->-                  so (offset <= i && offset + size <= n) ->-                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size))) -     Move       : (src : MemoryChunk src_size src_init) ->-                  (dst_offset : Nat) ->-                  (src_offset : Nat) ->-                  (size : Nat) ->-                  so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-                  so (src_offset + size <= src_init) ->-                  RawMemory () (MemoryChunk dst_size dst_init)-                            (\v => MemoryChunk dst_size (max dst_init (dst_offset + size))) -     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i) --private-do_malloc : Nat -> IOExcept String Ptr-do_malloc size with (fromInteger (cast size) == size)-  | True  = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)-               fail  <- ioe_lift $ nullPtr ptr-               if fail then ioe_fail "Cannot allocate memory"-               else return ptr-  | False = ioe_fail "The target architecture does not support adressing enough memory"--private-do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()-do_memset ptr offset c size-  = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)-              ptr (fromInteger $ cast offset) c (fromInteger $ cast size)--private-do_free : Ptr -> IO ()-do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr--private-do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()-do_memmove dest src dest_offset src_offset size-  = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)-              dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)--private-do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)-do_peek _   _       Z = return (Prelude.Vect.Nil)-do_peek ptr offset (S n)-  = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)-       bs <- do_peek ptr (S offset) n-       Prelude.Monad.return (Prelude.Vect.(::) b bs)--private-do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()-do_poke _   _      []     = return ()-do_poke ptr offset (b::bs)-  = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b-       do_poke ptr (S offset) bs--instance Handler RawMemory (IOExcept String) where-  handle () (Allocate n) k-    = do ptr <- do_malloc n-         k () (CH ptr)-  handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k-    = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)-  handle (CH ptr) (Free) k-    = ioe_lift (do_free ptr) $> k () ()-  handle (CH ptr) (Peek offset size _) k-    = do res <- ioe_lift (do_peek ptr offset size)-         k res (CH ptr)-  handle (CH ptr) (Poke offset content _) k-    = do ioe_lift (do_poke ptr offset content)-         k () (CH ptr)-  handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k-    = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)-         k () (CH dest_ptr)-  handle chunk (GetRawPtr) k-    = k chunk chunk--RAW_MEMORY : Type -> EFFECT-RAW_MEMORY t = MkEff t RawMemory--allocate : (n : Nat) -> -           Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])-allocate size = Allocate size--initialize : {i : Nat} ->-             {n : Nat} ->-             Bits8 ->-             (size : Nat) ->-             so (i + size <= n) ->-             Eff m () [RAW_MEMORY (MemoryChunk n i)] -                       (\v => [RAW_MEMORY (MemoryChunk n (i + size))])-initialize c size prf = Initialize c size prf--free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])-free = Free--peek : {i : Nat} ->-       (offset : Nat) ->-       (size : Nat) ->-       so (offset + size <= i) ->-       { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8) -peek offset size prf = Peek offset size prf--poke : {n : Nat} ->-       {i : Nat} ->-       (offset : Nat) ->-       Vect size Bits8 ->-       so (offset <= i && offset + size <= n) ->-       Eff m () [RAW_MEMORY (MemoryChunk n i)] -              (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])-poke offset content prf = Poke offset content prf--private-getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i) -getRawPtr = GetRawPtr--private-move' : {dst_size : Nat} ->-        {dst_init : Nat} ->-        {src_init : Nat} ->-        (src_ptr : MemoryChunk src_size src_init) ->-        (dst_offset : Nat) ->-        (src_offset : Nat) ->-        (size : Nat) ->-        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-        so (src_offset + size <= src_init) ->-        Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]-               (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])-move' src_ptr dst_offset src_offset size dst_bounds src_bounds-  = Move src_ptr dst_offset src_offset size dst_bounds src_bounds--data MoveDescriptor = Dst | Src--move : {dst_size : Nat} ->-       {dst_init : Nat} ->-       {src_size : Nat} ->-       {src_init : Nat} ->-       (dst_offset : Nat) ->-       (src_offset : Nat) ->-       (size : Nat) ->-       so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->-       so (src_offset + size <= src_init) ->-       Eff m ()-              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)-              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]-              (\v =>-                [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))-                , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])-move dst_offset src_offset size dst_bounds src_bounds-  = do src_ptr <- Src :- getRawPtr-       Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds-       return () -
− libs/neweffects/Effect/Monad.idr 
@@ -1,21 +0,0 @@-module Effect.Monad--import Effects---- Eff is a monad too, so we can happily use it in a monad transformer.--using (xs : List EFFECT, m : Type -> Type)-  instance Functor (\a => EffM m a xs (\v => xs)) where-    map f prog = do t <- prog-                    value (f t)--  instance Applicative (\a => EffM m a xs (\v => xs)) where-    pure = value-    (<$>) f a = do f' <- f-                   a' <- a-                   value (f' a')--  instance Monad (\a => Eff m a xs (\v => xs)) where-    (>>=) = Effects.(>>=)--
− libs/neweffects/Effect/Random.idr 
@@ -1,25 +0,0 @@-module Effect.Random--import Effects--data Random : Effect where -     getRandom : { Integer } Random Integer -     setSeed   : Integer -> { Integer } Random () --using (m : Type -> Type)-  instance Handler Random m where-     handle seed getRandom k-              = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in-                    k seed' seed'-     handle seed (setSeed n) k = k () n--RND : EFFECT-RND = MkEff Integer Random--rndInt : Integer -> Integer -> { [RND] } Eff m Integer-rndInt lower upper = do v <- getRandom-                        return (v `prim__sremBigInt` (upper - lower) + lower)--srand : Integer -> { [RND] } Eff m ()-srand n = setSeed n-
− libs/neweffects/Effect/Select.idr 
@@ -1,23 +0,0 @@-module Effect.Select--import Effects--data Selection : Effect where-     Select : List a -> { () } Selection a --instance Handler Selection Maybe where-     handle _ (Select xs) k = tryAll xs where-         tryAll [] = Nothing-         tryAll (x :: xs) = case k x () of-                                 Nothing => tryAll xs-                                 Just v => Just v--instance Handler Selection List where-     handle r (Select xs) k = concatMap (\x => k x r) xs--SELECT : EFFECT-SELECT = MkEff () Selection--select : List a -> { [SELECT] } Eff m a -select xs = Select xs-
− libs/neweffects/Effect/State.idr 
@@ -1,40 +0,0 @@-module Effect.State--import Effects--%access public--data State : Effect where-  Get :      { a }       State a-  Put : b -> { a ==> b } State () --using (m : Type -> Type)-  instance Handler State m where-     handle st Get     k = k st st-     handle st (Put n) k = k () n--STATE : Type -> EFFECT-STATE t = MkEff t State--get : { [STATE x] } Eff m x-get = Get--put : x -> { [STATE x] } Eff m () -put val = Put val--putM : y -> { [STATE x] ==> [STATE y] } Eff m () -putM val = Put val--update : (x -> x) -> { [STATE x] } Eff m () -update f = put (f !get)--updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m () -updateM f = putM (f !get)--locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t -locally newst prog = do st <- get-                        putM newst-                        val <- prog-                        putM st-                        return val-
− libs/neweffects/Effect/StdIO.idr 
@@ -1,37 +0,0 @@-module Effect.StdIO--import Effects-import Control.IOExcept--data StdIO : Effect where-     PutStr : String -> { () } StdIO () -     GetStr : { () } StdIO String -     PutCh : Char -> { () } StdIO ()-     GetCh : { () } StdIO Char--instance Handler StdIO IO where-    handle () (PutStr s) k = do putStr s; k () ()-    handle () GetStr     k = do x <- getLine; k x ()-    handle () (PutCh c)  k = do putChar c; k () () -    handle () GetCh      k = do x <- getChar; k x ()----- The Effect and associated functions--STDIO : EFFECT-STDIO = MkEff () StdIO--putStr : Handler StdIO e => String -> { [STDIO] } Eff e ()-putStr s = PutStr s--putChar : Handler StdIO e => Char -> { [STDIO] } Eff e ()-putChar c = PutCh c--putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e ()-putStrLn s = putStr (s ++ "\n")--getStr : Handler StdIO e => { [STDIO] } Eff e String-getStr = GetStr--getChar : Handler StdIO e => { [STDIO] } Eff e Char-getChar = GetCh-
− libs/neweffects/Effects.idr 
@@ -1,292 +0,0 @@-module Effects--import Language.Reflection-import Control.Catchable-import Effect.Default--%access public------ Effects--Effect : Type-Effect = (x : Type) -> Type -> (x -> Type) -> Type--%error_reverse-data EFFECT : Type where-     MkEff : Type -> Effect -> EFFECT--class Handler (e : Effect) (m : Type -> Type) where-     handle : res -> (eff : e t res resk) -> -              ((x : t) -> resk x -> m a) -> m a---- A bit of syntactic sugar ('syntax' is not very flexible so we only go--- up to a small number of parameters...)--syntax "{" [inst] "}" [eff] = eff inst (\result => inst)-syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff] -       = eff inst (\b => outst)-syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)------ Properties and proof construction--using (xs : List a, ys : List a)-  data SubList : List a -> List a -> Type where-       SubNil : SubList {a} [] []-       Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)-       Drop   : SubList xs ys -> SubList xs (x :: ys)--  subListId : SubList xs xs-  subListId {xs = Nil} = SubNil-  subListId {xs = x :: xs} = Keep subListId--namespace Env-  data Env  : (m : Type -> Type) -> List EFFECT -> Type where-       Nil  : Env m Nil-       (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)-       -data EffElem : Effect -> Type ->-               List EFFECT -> Type where-     Here : EffElem x a (MkEff a x :: xs)-     There : EffElem x a xs -> EffElem x a (y :: xs)---- make an environment corresponding to a sub-list-dropEnv : Env m ys -> SubList xs ys -> Env m xs-dropEnv [] SubNil = []-dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest-dropEnv (v :: vs) (Drop rest) = dropEnv vs rest--updateWith : (ys' : List a) -> (xs : List a) ->-             SubList ys xs -> List a-updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest-updateWith ys        (x :: xs) (Drop rest) = x :: updateWith ys xs rest-updateWith []        []        SubNil      = []-updateWith (y :: ys) []        SubNil      = y :: ys-updateWith []        (x :: xs) (Keep rest) = []---- put things back, replacing old with new in the sub-environment-rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->-             Env m xs -> Env m (updateWith ys' xs prf)-rebuildEnv []        SubNil      env = env-rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env-rebuildEnv xs        (Drop rest) (y :: env) = y :: rebuildEnv xs rest env-rebuildEnv (x :: xs) SubNil      [] = x :: xs------ The Effect EDSL itself -------- some proof automation--%reflection-reflectListEffElem : List a -> Tactic-reflectListEffElem [] = Refine "Here" `Seq` Solve-reflectListEffElem (x :: xs)-     = Try (Refine "Here" `Seq` Solve)-           (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))--- TMP HACK! FIXME!--- The evaluator needs a 'function case' to know its a reflection function--- until we propagate that information! Without this, the _ case won't get--- matched. -reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve-reflectListEffElem _ = Refine "Here" `Seq` Solve--%reflection-reflectSubList : List a -> Tactic-reflectSubList [] = Refine "subListId" `Seq` Solve-reflectSubList (x :: xs)-     = Try (Refine "subListId" `Seq` Solve)-           (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))-                (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))-reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve-reflectSubList _ = Refine "subListId" `Seq` Solve--%reflection-reflectDefaultList : List a -> Tactic-reflectDefaultList [] = Refine "enil" `Seq` Solve-reflectDefaultList (x :: xs)-     = Refine "econs" `Seq` -         (Solve `Seq`-           (Instance `Seq` -         (Refine "default" `Seq`-           (Solve `Seq`-             (Instance `Seq`-              (reflectDefaultList xs))))))-reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve-reflectDefaultList _ = Refine "Nil" `Seq` Solve--%reflection-reflectEff : (P : Type) -> Tactic-reflectEff (EffElem m a xs)-     = reflectListEffElem xs `Seq` Solve-reflectEff (SubList xs ys)-     = reflectSubList ys `Seq` Solve-reflectEff (Env m xs)-     = reflectDefaultList xs `Seq` Solve--updateResTy : (val : t) ->-              (xs : List EFFECT) -> EffElem e a xs -> e t a b ->-              List EFFECT-updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs-updateResTy     val (x :: xs)    (There p) n = x :: updateResTy val xs p n---- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->---                  List EFFECT--- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs--- updateResTyImm (x :: xs)    (There p) b = x :: updateResTyImm xs p b--infix 5 :::, :-, :=--data LRes : lbl -> Type -> Type where-     (:=) : (x : lbl) -> res -> LRes x res--(:::) : lbl -> EFFECT -> EFFECT-(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e--using (lbl : Type)-  instance Default a => Default (LRes lbl a) where-    default = lbl := default--private-unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]-unlabel {m} {x = MkEff a eff} [l := v] = [v]--private-relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)-relabel {xs = []} l [] = []-relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs---- the language of Effects--data Eff : (m : Type -> Type) ->-           (x : Type) ->-           List EFFECT -> (x -> List EFFECT) -> Type where-     value   : a -> Eff m a xs (\v => xs)-     ebind   : Eff m a xs xs' -> -               ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''-     effect  : (prf : EffElem e a xs) ->-               (eff : e t a b) ->-               Eff m t xs (\v => updateResTy v xs prf eff)--     lift    : (prf : SubList ys xs) ->-               Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)-     new     : Handler e m =>-               res -> -               Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->-               Eff m a xs (\v => xs')-     catch   : Catchable m err =>-               Eff m a xs xs' -> (err -> Eff m a xs xs') ->-               Eff m a xs xs'--     (:-)    : (l : ty) -> -               Eff m t [x] xs' -> -- [x] (\v => xs) -> -               Eff m t [l ::: x] (\v => map (l :::) (xs' v))--(>>=)   : Eff m a xs xs' -> -          ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''-(>>=) = ebind --implicit-lift' : Eff m t ys ys' ->-        {default tactics { byReflection reflectEff; }-           prf : SubList ys xs} ->-        Eff m t xs (\v => updateWith (ys' v) xs prf)-lift' e {prf} = lift prf e--implicit-effect' : {a, b: _} -> {e : Effect} ->-          (eff : e t a b) ->-          {default tactics { byReflection reflectEff; }-             prf : EffElem e a xs} ->-         Eff m t xs (\v => updateResTy v xs prf eff)-effect' e {prf} = effect prf e--return : a -> Eff m a xs (\v => xs)-return x = value x---- for idiom brackets--infixl 2 <$>--pure : a -> Eff m a xs (\v => xs)-pure = value--(<$>) : Eff m (a -> b) xs (\v => xs) -> -        Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)-(<$>) prog v = do fn <- prog-                  arg <- v-                  return (fn arg)---- an interpreter--private-execEff : Env m xs -> (p : EffElem e res xs) ->-          (eff : e a res resk) ->-          ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t-execEff (val :: env) Here eff' k-    = handle val eff' (\v, res => k v (res :: env))-execEff (val :: env) (There p) eff k-    = execEff env p eff (\v, env' => k v (val :: env'))---- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state--- updates can be propagated even through failing computations?--eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b-eff env (value x) k = k x env-eff env (prog `ebind` c) k-   = eff env prog (\p', env' => eff env' (c p') k)-eff env (effect prf effP) k = execEff env prf effP k-eff env (lift prf effP) k-   = let env' = dropEnv env prf in-         eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))-eff env (new r prog) k-   = let env' = r :: env in-         eff env' prog (\p' => \ (v :: envk) => k p' envk)-eff env (catch prog handler) k-   = catch (eff env prog k)-           (\e => eff env (handler e) k)--- FIXME:--- xs is needed explicitly because otherwise the pattern binding for--- 'l' appears too late. Solution seems to be to reorder patterns at the--- end so that everything is in scope when it needs to be.-eff {xs = [l ::: x]} env (l :- prog) k-   = let env' = unlabel env in-         eff env' prog (\p', envk => k p' (relabel l envk))---- yuck :) Haven't got type class instances working nicely in tactic--- proofs yet, so just brute force it.-syntax MkDefaultEnv = with Env-                       (| [], [default], [default, default],-                          [default, default, default],-                          [default, default, default, default],-                          [default, default, default, default, default],-                          [default, default, default, default, default, default],-                          [default, default, default, default, default, default, default],-                          [default, default, default, default, default, default, default, default] |)--run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a-run {env} prog = eff env prog (\r, env => pure r)--runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a-runPure {env} prog = eff env prog (\r, env => r)--runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a-runInit env prog = eff env prog (\r, env => pure r)--runPureInit : Env id xs -> Eff id a xs xs' -> a-runPureInit env prog = eff env prog (\r, env => r)--runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a-runWith inj env prog = eff env prog (\r, env => inj r)--runEnv : Applicative m => Env m xs -> Eff m a xs xs' -> -         m (x : a ** Env m (xs' x))-runEnv env prog = eff env prog (\r, env => pure (r ** env))---- some higher order things--mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)-mapE f []        = pure []-mapE f (x :: xs) = [| f x :: mapE f xs |]--when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()-when True  e = e-when False e = pure ()-
− libs/neweffects/Makefile 
@@ -1,14 +0,0 @@-IDRIS     := idris--build:-	$(IDRIS) --build neweffects.ipkg--clean:-	$(IDRIS) --clean neweffects.ipkg--install:-	$(IDRIS) --install neweffects.ipkg--rebuild: clean build--.PHONY: build clean install rebuild
− libs/neweffects/neweffects.ipkg 
@@ -1,9 +0,0 @@-package neweffects--opts    = "--nobasepkgs -i ../prelude -i ../base"-modules = Effects, Effect.Default,--          Effect.Exception, Effect.File, Effect.State,-          Effect.Random, Effect.StdIO, Effect.Select,-          Effect.Memory-
+ libs/oldeffects/Effect/Exception.idr view
@@ -0,0 +1,40 @@+module Effect.Exception++import Effects+import System+import Control.IOExcept++data Exception : Type -> Type -> Type -> Type -> Type where+     Raise : a -> Exception a () () b++instance Handler (Exception a) Maybe where+     handle _ (Raise e) k = Nothing++instance Show a => Handler (Exception a) IO where+     handle _ (Raise e) k = do print e+                               believe_me (exit 1)++instance Handler (Exception a) (IOExcept a) where+     handle _ (Raise e) k = ioM (return (Left e))++instance Handler (Exception a) (Either a) where+     handle _ (Raise e) k = Left e++EXCEPTION : Type -> EFFECT+EXCEPTION t = MkEff () (Exception t)++raise : a -> Eff m [EXCEPTION a] b+raise err = Raise err++++++++-- TODO: Catching exceptions mid program?+-- probably need to invoke a new interpreter++-- possibly add a 'handle' to the Eff language so that an alternative+-- handler can be introduced mid interpretation?+
+ libs/oldeffects/Effect/File.idr view
@@ -0,0 +1,69 @@+module Effect.File++import Effects+import Control.IOExcept++data OpenFile : Mode -> Type where+     FH : File -> OpenFile m++data FileIO : Effect where+     Open  : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool+     Close :                         FileIO (OpenFile m) () ()++     ReadLine  :           FileIO (OpenFile Read)  (OpenFile Read) String+     WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()+     EOF       :           FileIO (OpenFile Read)  (OpenFile Read) Bool+++instance Handler FileIO IO where+    handle () (Open fname m) k = do h <- openFile fname m+                                    valid <- validFile h+                                    if valid then k (Right (FH h)) True+                                             else k (Left ()) False+    handle (FH h) Close      k = do closeFile h+                                    k () ()+    handle (FH h) ReadLine        k = do str <- fread h+                                         k (FH h) str+    handle (FH h) (WriteLine str) k = do fwrite h str+                                         k (FH h) ()+    handle (FH h) EOF             k = do e <- feof h+                                         k (FH h) e++instance Handler FileIO (IOExcept String) where+    handle () (Open fname m) k+       = do h <- ioe_lift (openFile fname m)+            valid <- ioe_lift (validFile h)+            if valid then k (Right (FH h)) True+                     else k (Left ()) False+    handle (FH h) Close           k = do ioe_lift (closeFile h); k () ()+    handle (FH h) ReadLine        k = do str <- ioe_lift (fread h)+                                         k (FH h) str+    handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)+                                         k (FH h) ()+    handle (FH h) EOF             k = do e <- ioe_lift (feof h)+                                         k (FH h) e++FILE_IO : Type -> EFFECT+FILE_IO t = MkEff t FileIO++open : Handler FileIO e =>+       String -> (m : Mode) -> EffM e [FILE_IO ()]+                                      [FILE_IO (Either () (OpenFile m))] Bool+open f m = Open f m++close : Handler FileIO e =>+        EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()+close = Close++readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String+readLine = ReadLine++writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()+writeLine str = WriteLine str++eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool+eof = EOF++++
+ libs/oldeffects/Effect/Memory.idr view
@@ -0,0 +1,169 @@+module Effect.Memory++import Effects+import Control.IOExcept++%access public++abstract+data MemoryChunk : Nat -> Nat -> Type where+     CH : Ptr -> MemoryChunk size initialized++abstract+data RawMemory : Effect where+     Allocate   : (n : Nat) ->+                  RawMemory () (MemoryChunk n 0) ()+     Free       : RawMemory (MemoryChunk n i) () ()+     Initialize : Bits8 ->+                  (size : Nat) ->+                  so (i + size <= n) ->+                  RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()+     Peek       : (offset : Nat) ->+                  (size : Nat) ->+                  so (offset + size <= i) ->+                  RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)+     Poke       :  (offset : Nat) ->+                  (Vect size Bits8) ->+                  so (offset <= i && offset + size <= n) ->+                  RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) ()+     Move       : (src : MemoryChunk src_size src_init) ->+                  (dst_offset : Nat) ->+                  (src_offset : Nat) ->+                  (size : Nat) ->+                  so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->+                  so (src_offset + size <= src_init) ->+                  RawMemory (MemoryChunk dst_size dst_init)+                            (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()+     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)++private+do_malloc : Nat -> IOExcept String Ptr+do_malloc size with (fromInteger (cast size) == size)+  | True  = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)+               fail  <- ioe_lift $ nullPtr ptr+               if fail then ioe_fail "Cannot allocate memory"+               else return ptr+  | False = ioe_fail "The target architecture does not support adressing enough memory"++private+do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()+do_memset ptr offset c size+  = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)+              ptr (fromInteger $ cast offset) c (fromInteger $ cast size)++private+do_free : Ptr -> IO ()+do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr++private+do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()+do_memmove dest src dest_offset src_offset size+  = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)+              dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)++private+do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)+do_peek _   _       Z = return (Prelude.Vect.Nil)+do_peek ptr offset (S n)+  = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)+       bs <- do_peek ptr (S offset) n+       Prelude.Monad.return (Prelude.Vect.(::) b bs)++private+do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()+do_poke _   _      []     = return ()+do_poke ptr offset (b::bs)+  = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b+       do_poke ptr (S offset) bs++instance Handler RawMemory (IOExcept String) where+  handle () (Allocate n) k+    = do ptr <- do_malloc n+         k (CH ptr) ()+  handle (CH ptr) (Initialize {i} c size _) k+    = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()+  handle (CH ptr) (Free) k+    = ioe_lift (do_free ptr) $> k () ()+  handle (CH ptr) (Peek offset size _) k+    = do res <- ioe_lift (do_peek ptr offset size)+         k (CH ptr) res+  handle (CH ptr) (Poke offset content _) k+    = do ioe_lift (do_poke ptr offset content)+         k (CH ptr) ()+  handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k+    = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)+         k (CH dest_ptr) ()+  handle chunk (GetRawPtr) k+    = k chunk chunk++RAW_MEMORY : Type -> EFFECT+RAW_MEMORY t = MkEff t RawMemory++allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()+allocate size = Allocate size++initialize : {i : Nat} ->+             {n : Nat} ->+             Bits8 ->+             (size : Nat) ->+             so (i + size <= n) ->+             EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()+initialize c size prf = Initialize c size prf++free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()+free = Free++peek : {i : Nat} ->+       (offset : Nat) ->+       (size : Nat) ->+       so (offset + size <= i) ->+       Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)+peek offset size prf = Peek offset size prf++poke : {n : Nat} ->+       {i : Nat} ->+       (offset : Nat) ->+       Vect size Bits8 ->+       so (offset <= i && offset + size <= n) ->+       EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()+poke offset content prf = Poke offset content prf++private+getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)+getRawPtr = GetRawPtr++private+move' : {dst_size : Nat} ->+        {dst_init : Nat} ->+        {src_init : Nat} ->+        (src_ptr : MemoryChunk src_size src_init) ->+        (dst_offset : Nat) ->+        (src_offset : Nat) ->+        (size : Nat) ->+        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->+        so (src_offset + size <= src_init) ->+        EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]+               [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()+move' src_ptr dst_offset src_offset size dst_bounds src_bounds+  = Move src_ptr dst_offset src_offset size dst_bounds src_bounds++data MoveDescriptor = Dst | Src++move : {dst_size : Nat} ->+       {dst_init : Nat} ->+       {src_size : Nat} ->+       {src_init : Nat} ->+       (dst_offset : Nat) ->+       (src_offset : Nat) ->+       (size : Nat) ->+       so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->+       so (src_offset + size <= src_init) ->+       EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)+              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]+              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))+              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()+move dst_offset src_offset size dst_bounds src_bounds+  = do src_ptr <- Src :- getRawPtr+       Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds+       return () +
+ libs/oldeffects/Effect/Monad.idr view
@@ -0,0 +1,21 @@+module Effect.Monad++import Effects++-- Eff is a monad too, so we can happily use it in a monad transformer.++using (xs : List EFFECT, m : Type -> Type)+  instance Functor (EffM m xs xs) where+    map f prog = do t <- prog+                    value (f t)++  instance Applicative (EffM m xs xs) where+    pure = value+    (<$>) f a = do f' <- f+                   a' <- a+                   value (f' a')++  instance Monad (EffM m xs xs) where+    (>>=) = ebind++
+ libs/oldeffects/Effect/Random.idr view
@@ -0,0 +1,25 @@+module Effect.Random++import Effects++data Random : Type -> Type -> Type -> Type where+     getRandom : Random Integer Integer Integer+     setSeed   : Integer -> Random Integer Integer ()++using (m : Type -> Type)+  instance Handler Random m where+     handle seed getRandom k+              = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in+                    k seed' seed'+     handle seed (setSeed n) k = k n ()++RND : EFFECT+RND = MkEff Integer Random++rndInt : Integer -> Integer -> Eff m [RND] Integer+rndInt lower upper = do v <- getRandom+                        return (v `prim__sremBigInt` (upper - lower) + lower)++srand : Integer -> Eff m [RND] ()+srand n = setSeed n+
+ libs/oldeffects/Effect/Select.idr view
@@ -0,0 +1,23 @@+module Effect.Select++import Effects++data Selection : Effect where+     Select : List a -> Selection () () a++instance Handler Selection Maybe where+     handle _ (Select xs) k = tryAll xs where+         tryAll [] = Nothing+         tryAll (x :: xs) = case k () x of+                                 Nothing => tryAll xs+                                 Just v => Just v++instance Handler Selection List where+     handle r (Select xs) k = concatMap (k r) xs++SELECT : EFFECT+SELECT = MkEff () Selection++select : List a -> Eff m [SELECT] a+select xs = Select xs+
+ libs/oldeffects/Effect/State.idr view
@@ -0,0 +1,40 @@+module Effect.State++import Effects++%access public++data State : Effect where+     Get :      State a a a+     Put : b -> State a b ()++using (m : Type -> Type)+  instance Handler State m where+     handle st Get     k = k st st+     handle st (Put n) k = k n ()++STATE : Type -> EFFECT+STATE t = MkEff t State++get : Eff m [STATE x] x+get = Get++put : x -> Eff m [STATE x] ()+put val = Put val++putM : y -> EffM m [STATE x] [STATE y] ()+putM val = Put val++update : (x -> x) -> Eff m [STATE x] ()+update f = put (f !get)++updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()+updateM f = putM (f !get)++locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t+locally newst prog = do st <- get+                        putM newst+                        val <- prog+                        putM st+                        return val+
+ libs/oldeffects/Effect/StdIO.idr view
@@ -0,0 +1,60 @@+module Effect.StdIO++import Effects+import Control.IOExcept++data StdIO : Effect where+     PutStr : String -> StdIO () () ()+     GetStr : StdIO () () String++instance Handler StdIO IO where+    handle () (PutStr s) k = do putStr s; k () ()+    handle () GetStr     k = do x <- getLine; k () x++instance Handler StdIO (IOExcept a) where+    handle () (PutStr s) k = do ioe_lift (putStr s); k () ()+    handle () GetStr     k = do x <- ioe_lift getLine; k () x++-- Handle effects in a pure way, for simulating IO for unit testing/proof++data IOStream a = MkStream (List String -> (a, List String))++instance Handler StdIO IOStream where+    handle () (PutStr s) k+       = MkStream (\x => case k () () of+                         MkStream f => let (res, str) = f x in+                                           (res, s :: str))+    handle {a} () GetStr k+       = MkStream (\x => case x of+                              [] => cont "" []+                              (t :: ts) => cont t ts)+        where+            cont : String -> List String -> (a, List String)+            cont t ts = case k () t of+                             MkStream f => f ts++--- The Effect and associated functions++STDIO : EFFECT+STDIO = MkEff () StdIO++putStr : Handler StdIO e => String -> Eff e [STDIO] ()+putStr s = PutStr s++putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()+putStrLn s = putStr (s ++ "\n")++getStr : Handler StdIO e => Eff e [STDIO] String+getStr = GetStr++mkStrFn : Env IOStream xs ->+          Eff IOStream xs a ->+          List String -> (a, List String)+mkStrFn {a} env p input = case mkStrFn' of+                               MkStream f => f input+  where injStream : a -> IOStream a+        injStream v = MkStream (\x => (v, []))+        mkStrFn' : IOStream a+        mkStrFn' = runWith injStream env p++
+ libs/oldeffects/Effects.idr view
@@ -0,0 +1,308 @@+module Effects++import Language.Reflection+import Control.Catchable++%access public++---- Effects++Effect : Type+Effect = Type -> Type -> Type -> Type++%error_reverse+data EFFECT : Type where+     MkEff : Type -> Effect -> EFFECT++class Handler (e : Effect) (m : Type -> Type) where+     handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a++---- Properties and proof construction++using (xs : List a, ys : List a)+  data SubList : List a -> List a -> Type where+       SubNil : SubList {a} [] []+       Keep   : SubList xs ys -> SubList (x :: xs) (x :: ys)+       Drop   : SubList xs ys -> SubList xs (x :: ys)++  subListId : SubList xs xs+  subListId {xs = Nil} = SubNil+  subListId {xs = x :: xs} = Keep subListId++data Env  : (m : Type -> Type) -> List EFFECT -> Type where+     Nil  : Env m Nil+     (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)++data EffElem : (Type -> Type -> Type -> Type) -> Type ->+               List EFFECT -> Type where+     Here : EffElem x a (MkEff a x :: xs)+     There : EffElem x a xs -> EffElem x a (y :: xs)++-- make an environment corresponding to a sub-list+dropEnv : Env m ys -> SubList xs ys -> Env m xs+dropEnv [] SubNil = []+dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest+dropEnv (v :: vs) (Drop rest) = dropEnv vs rest++updateWith : (ys' : List a) -> (xs : List a) ->+             SubList ys xs -> List a+updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest+updateWith ys        (x :: xs) (Drop rest) = x :: updateWith ys xs rest+updateWith []        []        SubNil      = []+updateWith (y :: ys) []        SubNil      = y :: ys+updateWith []        (x :: xs) (Keep rest) = []++-- put things back, replacing old with new in the sub-environment+rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->+             Env m xs -> Env m (updateWith ys' xs prf)+rebuildEnv []        SubNil      env = env+rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env+rebuildEnv xs        (Drop rest) (y :: env) = y :: rebuildEnv xs rest env+rebuildEnv (x :: xs) SubNil      [] = x :: xs++---- The Effect EDSL itself ----++-- some proof automation++%reflection+reflectListEffElem : List a -> Tactic+reflectListEffElem [] = Refine "Here" `Seq` Solve+reflectListEffElem (x :: xs)+     = Try (Refine "Here" `Seq` Solve)+           (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))+-- TMP HACK! FIXME!+-- The evaluator needs a 'function case' to know its a reflection function+-- until we propagate that information! Without this, the _ case won't get+-- matched. +reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve+reflectListEffElem _ = Refine "Here" `Seq` Solve++%reflection+reflectSubList : List a -> Tactic+reflectSubList [] = Refine "SubNil" `Seq` Solve+reflectSubList (x :: xs)+     = Try (Refine "subListId" `Seq` Solve)+           (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))+                (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))+reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve+reflectSubList _ = Refine "subListId" `Seq` Solve++%reflection+reflectEff : (P : Type) -> Tactic+reflectEff (EffElem m a xs)+     = reflectListEffElem xs `Seq` Solve+reflectEff (SubList xs ys)+     = reflectSubList ys `Seq` Solve++updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->+              List EFFECT+updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs+updateResTy (x :: xs)        (There p) n = x :: updateResTy xs p n++updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->+                 List EFFECT+updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs+updateResTyImm (x :: xs)    (There p) b = x :: updateResTyImm xs p b++infix 5 :::, :-, :=++data LRes : lbl -> Type -> Type where+     (:=) : (x : lbl) -> res -> LRes x res++(:::) : lbl -> EFFECT -> EFFECT+(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff++private+unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]+unlabel {m} {x = MkEff a eff} [l := v] = [v]++private+relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]+relabel {x = MkEff a eff} l [v] = [l := v]++-- the language of Effects++data EffM : (m : Type -> Type) ->+            List EFFECT -> List EFFECT -> Type -> Type where+     value   : a -> EffM m xs xs a+     ebind   : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b+     effect  : (prf : EffElem e a xs) ->+               (eff : e a b t) ->+               EffM m xs (updateResTy xs prf eff) t+     lift    : (prf : SubList ys xs) ->+               EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t+     new     : Handler e m =>+               res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->+               EffM m xs xs' a+     test    : (prf : EffElem e (Either l r) xs) ->+               EffM m (updateResTyImm xs prf l) xs' t ->+               EffM m (updateResTyImm xs prf r) xs' t ->+               EffM m xs xs' t+     test_lbl : {x : lbl} ->+                (prf : EffElem e (LRes x (Either l r)) xs) ->+                EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->+                EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->+                EffM m xs xs' t+     catch   : Catchable m err =>+               EffM m xs xs' a -> (err -> EffM m xs xs' a) ->+               EffM m xs xs' a+     (:-)    : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t++syntax [tag] ":!" [val] = !(tag :- val)++--   Eff : List (EFFECT m) -> Type -> Type++-- For making proofs implicitly for 'test' and 'test_lbl'++syntax if_valid then [e] else [t] =+  test (tactics { byReflection reflectEff; }) t e++syntax if_valid [lbl] then [e] else [t] =+  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e++syntax if_error then [t] else [e] =+  test (tactics { byReflection reflectEff; }) t e++syntax if_error [lbl] then [t] else [e] =+  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e++-- These may read better in some contexts++syntax if_right then [e] else [t] =+  test (tactics { byReflection reflectEff; }) t e++syntax if_right [lbl] then [e] else [t] =+  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e++syntax if_left then [t] else [e] =+  test (tactics { byReflection reflectEff; }) t e++syntax if_left [lbl] then [t] else [e] =+  test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e+++-- for 'do' notation++return : a -> EffM m xs xs a+return x = value x++(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b+(>>=) = ebind++-- for idiom brackets++infixl 2 <$>++pure : a -> EffM m xs xs a+pure = value++(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b+(<$>) prog v = do fn <- prog+                  arg <- v+                  return (fn arg)++-- an interpreter++private+execEff : Env m xs -> (p : EffElem e res xs) ->+          (eff : e res b a) ->+          (Env m (updateResTy xs p eff) -> a -> m t) -> m t+execEff (val :: env) Here eff' k+    = handle val eff' (\res, v => k (res :: env) v)+execEff {e} {res} {b} {a} (val :: env) (There p) eff k+    = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)++private+testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->+          (Env m (updateResTyImm xs p l) -> m b) ->+          (Env m (updateResTyImm xs p r) -> m b) ->+          m b+testEff (Left err :: env) Here lk rk = lk (err :: env)+testEff (Right ok :: env) Here lk rk = rk (ok :: env)+testEff (val :: env) (There p) lk rk+   = testEff env p (\envk => lk (val :: envk))+                   (\envk => rk (val :: envk))++private+testEffLbl : {x : lblTy} ->+             Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->+             (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->+             (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->+             m b+testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)+testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)+testEffLbl (val :: env) (There p) lk rk+   = testEffLbl env p (\envk => lk (val :: envk))+                      (\envk => rk (val :: envk))++-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state+-- updates can be propagated even through failing computations?++eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b+eff env (value x) k = k env x+eff env (prog `ebind` c) k+   = eff env prog (\env', p' => eff env' (c p') k)+eff env (effect prf effP) k = execEff env prf effP k+eff env (lift prf effP) k+   = let env' = dropEnv env prf in+         eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')+eff env (new r prog) k+   = eff (r :: env) prog (\(v :: envk), p' => k envk p')+eff env (test prf l r) k+   = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)+eff env (test_lbl prf l r) k+   = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)+eff env (catch prog handler) k+   = catch (eff env prog k)+           (\e => eff env (handler e) k)+-- FIXME:+-- xs is needed explicitly because otherwise the pattern binding for+-- 'l' appears too late. Solution seems to be to reorder patterns at the+-- end so that everything is in scope when it needs to be.+eff {xs = [l ::: x]} env (l :- prog) k+   = let env' = unlabel env in+         eff env' prog (\envk, p' => k (relabel l envk) p')++implicit+lift' : EffM m ys ys' t ->+        {default tactics { byReflection reflectEff; }+           prf : SubList ys xs} ->+        EffM m xs (updateWith ys' xs prf) t+lift' e {prf} = lift prf e++implicit+effect' : {a, b: _} -> {e : Effect} ->+          (eff : e a b t) ->+          {default tactics { byReflection reflectEff; }+             prf : EffElem e a xs} ->+         EffM m xs (updateResTy xs prf eff) t+effect' e {prf} = effect prf e+++run : Applicative m => Env m xs -> EffM m xs xs' a -> m a+run env prog = eff env prog (\env, r => pure r)++runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)+runEnv env prog = eff env prog (\env, r => pure (env, r))++runPure : Env id xs -> EffM id xs xs' a -> a+runPure env prog = eff env prog (\env, r => r)++-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)+-- runPureEnv env prog = eff env prog (\env, r => (env, r))++runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a+runWith inj env prog = eff env prog (\env, r => inj r)++Eff : (Type -> Type) -> List EFFECT -> Type -> Type+Eff m xs t = EffM m xs xs t++-- some higher order things++mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)+mapE f []        = pure []+mapE f (x :: xs) = [| f x :: mapE f xs |]++when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()+when True  e = e+when False e = pure ()
+ libs/oldeffects/Makefile view
@@ -0,0 +1,14 @@+IDRIS     := idris++build:+	$(IDRIS) --build oldeffects.ipkg++clean:+	$(IDRIS) --clean oldeffects.ipkg++install:+	$(IDRIS) --install oldeffects.ipkg++rebuild: clean build++.PHONY: build clean install rebuild
+ libs/oldeffects/oldeffects.ipkg view
@@ -0,0 +1,8 @@+package oldeffects++opts    = "--nobasepkgs -i ../prelude -i ../base"+modules = Effects, +          Effect.Exception, Effect.File, Effect.State,+          Effect.Random, Effect.StdIO, Effect.Select,+          Effect.Memory, Effect.Monad+
libs/prelude/Builtins.idr view
@@ -3,57 +3,91 @@ %access public %default total +||| Dependent pairs, in their internal representation+||| @ a the type of the witness+||| @ P the type of the proof data Exists : (a : Type) -> (P : a -> Type) -> Type where     Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists a P +||| The first projection from a dependent pair getWitness : {P : a -> Type} -> Exists a P -> a getWitness (a ** v) = a +||| The second projection from a dependent pair getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s) getProof (a ** v) = v  FalseElim : _|_ -> a --- For 'symbol syntax. 'foo becomes Symbol_ "foo"+||| For 'symbol syntax. 'foo becomes Symbol_ "foo" data Symbol_ : String -> Type where  -- ------------------------------------------------------ [ For rewrite tactic ]+||| Perform substitution in a term according to some equality.+|||+||| This is used by the `rewrite` tactic and term. replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y replace refl prf = prf +||| Symmetry of propositional equality sym : {l:a} -> {r:a} -> l = r -> r = l sym refl = refl +||| Transitivity of propositional equality trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c trans refl refl = refl  lazy : a -> a lazy x = x -- compiled specially -par : |(thunk:a) -> a-par x = x -- compiled specially+force : a -> a+force x = x -- compiled specially +data LazyType = LazyCodata | LazyEval++data Lazy' : LazyType -> Type -> Type where+     Delay : {t, a : _} -> (val : a) -> Lazy' t a++Force : {t, a : _} -> Lazy' t a -> a+Force (Delay x) = x++Lazy : Type -> Type+Lazy t = Lazy' LazyEval t++Inf : Type -> Type+Inf t = Lazy' LazyCodata t++par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type+                  -- is better in any case?+par (Delay x) = x + malloc : Int -> a -> a malloc size x = x -- compiled specially  trace_malloc : a -> a trace_malloc x = x -- compiled specially --- Assert to the totality checker than y is always structureally smaller than--- x (which is typically a pattern argument)-assert_smaller : a -> a -> a+||| Assert to the totality checker than y is always structurally smaller than+||| x (which is typically a pattern argument)+||| @ x the larger value (typically a pattern argument)+||| @ y the smaller value (typically an argument to a recursive call)+assert_smaller : (x, y : a) -> a assert_smaller x y = y --- Assert to the totality checker than the given expression will always--- terminate.+||| Assert to the totality checker than the given expression will always+||| terminate. assert_total : a -> a assert_total x = x +||| Subvert the type checker. This function is abstract, so it will not reduce in+||| the type checker. Use it with care - it can result in segfaults or worse! abstract %assert_total -- need to pretend-believe_me : a -> b -- compiled specially as id, use with care!+believe_me : a -> b believe_me x = prim__believe_me _ _ x -public %assert_total -- reduces at compile time, use with extreme care!+||| Subvert the type checker. This function *will*  reduce in the type checker.+||| Use it with extreme care - it can result in segfaults or worse!+public %assert_total really_believe_me : a -> b really_believe_me x = prim__believe_me _ _ x
libs/prelude/Decidable/Equality.idr view
@@ -12,6 +12,7 @@ -- Utility lemmas -------------------------------------------------------------------------------- +||| The negation of equality is symmetric (follows from symmetry of equality) total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_) negEqSym p h = p (sym h) @@ -20,7 +21,9 @@ -- Decidable equality -------------------------------------------------------------------------------- +||| Decision procedures for propositional equality class DecEq t where+  ||| Decide whether two elements of `t` are propositionally equal   total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)  --------------------------------------------------------------------------------@@ -33,7 +36,6 @@ -------------------------------------------------------------------------------- -- Booleans --------------------------------------------------------------------------------- total trueNotFalse : True = False -> _|_ trueNotFalse refl impossible @@ -122,13 +124,13 @@ lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl  instance (DecEq a, DecEq b) => DecEq (a, b) where-  decEq (a, b) (a', b') with (decEq a a')-    decEq (a, b) (a, b') | (Yes refl) with (decEq b b')-      decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl-      decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)-    decEq (a, b) (a', b') | (No p) with (decEq b b')-      decEq (a, b) (a', b) | (No p) | (Yes refl) =  No (\eq => lemma_fst_neq_snd_eq p refl eq)-      decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)+  decEq (a, b) (a', b')     with (decEq a a')+    decEq (a, b) (a, b')    | (Yes refl) with (decEq b b')+      decEq (a, b) (a, b)   | (Yes refl) | (Yes refl) = Yes refl+      decEq (a, b) (a, b')  | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)+    decEq (a, b) (a', b')   | (No p)     with (decEq b b')+      decEq (a, b) (a', b)  | (No p)     | (Yes refl) =  No (\eq => lemma_fst_neq_snd_eq p refl eq)+      decEq (a, b) (a', b') | (No p)     | (No p') = No (\eq => lemma_both_neq p p' eq)   --------------------------------------------------------------------------------@@ -188,39 +190,44 @@ --------------------------------------------------------------------------------  instance DecEq Int where-    decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)-                          else No (really_believe_me _|_)+    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+       where postulate primitiveEq : x = y+             postulate primitiveNotEq : x = y -> _|_  -------------------------------------------------------------------------------- -- Char --------------------------------------------------------------------------------  instance DecEq Char where-    decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)-                          else No (really_believe_me _|_)+    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+       where postulate primitiveEq : x = y+             postulate primitiveNotEq : x = y -> _|_  -------------------------------------------------------------------------------- -- Integer --------------------------------------------------------------------------------  instance DecEq Integer where-    decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)-                          else No (really_believe_me _|_)+    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+       where postulate primitiveEq : x = y+             postulate primitiveNotEq : x = y -> _|_  -------------------------------------------------------------------------------- -- Float --------------------------------------------------------------------------------  instance DecEq Float where-    decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)-                          else No (really_believe_me _|_)+    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+       where postulate primitiveEq : x = y+             postulate primitiveNotEq : x = y -> _|_  -------------------------------------------------------------------------------- -- String --------------------------------------------------------------------------------  instance DecEq String where-    decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)-                          else No (really_believe_me _|_)+    decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq+       where postulate primitiveEq : x = y+             postulate primitiveNotEq : x = y -> _|_
libs/prelude/IO.idr view
@@ -4,8 +4,10 @@  %access public +||| Idris's primitive IO, for building abstractions on top of abstract data PrimIO a = prim__IO a +||| A token representing the world, for use in `IO` abstract data World = TheWorld  abstract WorldRes : Type -> Type@@ -26,12 +28,16 @@ prim_io_return : a -> PrimIO a prim_io_return x = prim__IO x +||| Descriptions of the various sorts of Ints that Idris supports data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2++||| Types available for foreign function calls data FTy = FIntT IntTy          | FFunction FTy FTy          | FFloat          | FString          | FPtr+         | FManagedPtr          | FAny Type          | FUnit @@ -74,6 +80,7 @@ FBits64x2 : FTy FBits64x2 = FIntT IT64x2 +||| Interpret an FFI type as the type of the Idris function that it will become interpFTy : FTy -> Type interpFTy (FIntT ITNative) = Int interpFTy (FIntT ITChar)   = Char@@ -85,6 +92,7 @@ interpFTy FFloat           = Float interpFTy FString          = String interpFTy FPtr             = Ptr+interpFTy FManagedPtr      = ManagedPtr interpFTy (FIntT IT8x16)   = Bits8x16 interpFTy (FIntT IT16x8)   = Bits16x8 interpFTy (FIntT IT32x4)   = Bits32x4@@ -93,7 +101,10 @@  interpFTy (FFunction a b) = interpFTy a -> interpFTy b -ForeignTy : (xs:List FTy) -> (t:FTy) -> Type+||| Type signatures for foreign functions+||| @ xs the argument types+||| @ t the return type+ForeignTy : (xs : List FTy) -> (t : FTy) -> Type ForeignTy Nil     rt = World -> PrimIO (interpFTy rt) ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt @@ -106,6 +117,9 @@ mkLazyForeignPrim : Foreign x -> x -- mkForeign and mkLazyForeign compiled as primitives +registerPtr : Ptr -> Int -> ManagedPtr+registerPtr = prim__registerPtr+ abstract io_bind : IO a -> (a -> IO b) -> IO b io_bind (MkIO fn) k@@ -131,10 +145,10 @@  -- io_bind v (\v' => io_return v') -prim_fork : |(thread:PrimIO ()) -> PrimIO Ptr+prim_fork : PrimIO () -> PrimIO Ptr prim_fork x = prim_io_return prim__vm -- compiled specially -fork : |(thread:IO ()) -> IO Ptr+fork : IO () -> IO Ptr fork (MkIO f) = MkIO (\w => prim_io_bind                               (prim_fork (prim_io_bind (f w)                                    (\ x => prim_io_return x)))@@ -148,4 +162,7 @@ unsafePerformIO (MkIO f) = unsafePerformPrimIO         (prim_io_bind (f TheWorld) (\ b => prim_io_return b)) ++forceGC : IO ()+forceGC = mkForeign (FFun "idris_forceGC" [FPtr] FUnit) prim__vm
libs/prelude/Prelude.idr view
@@ -20,6 +20,7 @@ import Prelude.Traversable import Prelude.Bits import Prelude.Stream+import Prelude.Uninhabited  import Decidable.Equality @@ -391,13 +392,15 @@   succ n = n + 1   toNat n = cast n   fromNat n = cast n+  enumFromTo n m =+    if n <= m+       then go [] (cast {to = Nat} (m - n)) m+       else []+       where+         go : List Int -> Nat -> Int -> List Int+         go acc Z     m = m :: acc+         go acc (S k) m = go (m :: acc) k (m - 1)   enumFromThen n inc = n :: enumFromThen (inc + n) inc-  enumFromTo n m = if n <= m-                   then go (natRange (S (cast {to = Nat} (m - n))))-                   else []-    where go : List Nat -> List Int-          go [] = []-          go (x :: xs) = n + cast x :: go xs   enumFromThenTo _ 0   _ = []   enumFromThenTo n inc m = go (natRange (S (cast {to=Nat} (abs (m - n)) `div` cast {to=Nat} (abs inc))))     where go : List Nat -> List Int@@ -436,26 +439,32 @@  ---- some basic io +||| Output a string to stdout without a trailing newline partial putStr : String -> IO () putStr x = mkForeign (FFun "putStr" [FString] FUnit) x +||| Output a string to stdout with a trailing newline partial putStrLn : String -> IO () putStrLn x = putStr (x ++ "\n") +||| Output something showable to stdout, with a trailing newline partial print : Show a => a -> IO () print x = putStrLn (show x) +||| Read one line of input from stdin partial getLine : IO String getLine = prim_fread prim__stdin +||| Write a single character to stdout partial putChar : Char -> IO () putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c) +||| Read a single character from stdin partial getChar : IO Char getChar = map cast $ mkForeign (FFun "getchar" [] FInt)@@ -465,21 +474,30 @@ abstract data File = FHandle Ptr +||| Standard input partial stdin : File stdin = FHandle prim__stdin +||| Call the RTS's file opening function do_fopen : String -> String -> IO Ptr do_fopen f m    = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m -fopen : String -> String -> IO File+||| Open a file+||| @ f the filename+||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)+fopen : (f : String) -> (m : String) -> IO File fopen f m = do h <- do_fopen f m                return (FHandle h) +||| Modes for opening files data Mode = Read | Write | ReadWrite +||| Open a file+||| @ f the filename+||| @ m the mode partial-openFile : String -> Mode -> IO File+openFile : (f : String) -> (m : Mode) -> IO File openFile f m = fopen f (modeStr m) where   modeStr Read  = "r"   modeStr Write = "w"@@ -497,6 +515,32 @@ do_fread : Ptr -> IO String do_fread h = prim_fread h +fgetc : File -> IO Char+fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))++fgetc' : File -> IO (Maybe Char)+fgetc' (FHandle h) +   = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h+        if (x < 0) then return Nothing +                   else return (Just (cast x))++fflush : File -> IO ()+fflush (FHandle h) = mkForeign (FFun "fflush" [FPtr] FUnit) h++do_popen : String -> String -> IO Ptr+do_popen f m = mkForeign (FFun "do_popen" [FString, FString] FPtr) f m++popen : String -> Mode -> IO File+popen f m = do ptr <- do_popen f (modeStr m)+               return (FHandle ptr)+  where+    modeStr Read  = "r"+    modeStr Write = "w"+    modeStr ReadWrite = "r+"++pclose : File -> IO ()+pclose (FHandle h) = mkForeign (FFun "pclose" [FPtr] FUnit) h+ -- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String)) --                        prim__vm h @@ -529,27 +573,34 @@ ferror (FHandle h) = do err <- do_ferror h                         return (not (err == 0)) +fpoll : File -> IO Bool+fpoll (FHandle h) = do p <- mkForeign (FFun "fpoll" [FPtr] FInt) h+                       return (p > 0)+ partial nullPtr : Ptr -> IO Bool nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p                return (ok /= 0) +||| Check if a supposed string was actually a null pointer partial nullStr : String -> IO Bool nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p                return (ok /= 0) +||| Pointer equality eqPtr : Ptr -> Ptr -> IO Bool eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y                return (eq /= 0) +||| Check whether a file handle is actually a null pointer partial validFile : File -> IO Bool validFile (FHandle h) = do x <- nullPtr h                            return (not x)  partial -- obviously-while : |(test : IO Bool) -> |(body : IO ()) -> IO ()+while : (test : IO Bool) -> (body : IO ()) -> IO () while t b = do v <- t                if v then do b                             while t b
libs/prelude/Prelude/Applicative.idr view
@@ -1,6 +1,8 @@ module Prelude.Applicative  import Builtins+import Prelude.Basics+import Prelude.Classes import Prelude.Functor  ---- Applicative functors/Idioms@@ -19,12 +21,15 @@ ($>) : Applicative f => f a -> f b -> f b a $> b = map (const id) a <$> b +||| Lift a function to an applicative liftA : Applicative f => (a -> b) -> f a -> f b liftA f a = pure f <$> a +||| Lift a two-argument function to an applicative liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 f a b = (map f a) <$> b +||| Lift a three-argument function to an applicative liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftA3 f a b c = (map f a) <$> b <$> c
libs/prelude/Prelude/Basics.idr view
@@ -3,44 +3,55 @@ Not : Type -> Type Not a = a -> _|_ --- | Identity function.+||| Identity function. id : a -> a id x = x --- | Manually assign a type to an expression.-the : (a : Type) -> a -> a+||| Manually assign a type to an expression.+||| @ a the type to assign+||| @ x the element to get the type+the : (a : Type) -> (x : a) -> a the _ = id --- | Constant function.+||| Constant function. Ignores its second argument. const : a -> b -> a const x = \v => x --- | Return the first element of a pair.+||| Return the first element of a pair. fst : (s, t) -> s fst (x, y) = x --- | Return the second element of a pair.+||| Return the second element of a pair. snd : (a, b) -> b snd (x, y) = y  infixl 9 . --- | Function composition+||| Function composition (.) : (b -> c) -> (a -> b) -> a -> c (.) f g x = f (g x) --- | Takes in the first two arguments in reverse order.-flip : (a -> b -> c) -> b -> a -> c+||| Takes in the first two arguments in reverse order.+||| @ f the function to flip+flip : (f : a -> b -> c) -> b -> a -> c flip f x y = f y x --- | Function application.+||| Function application. apply : (a -> b) -> a -> b apply f a = f a +||| Equality is a congruence. cong : {f : t -> u} -> (a = b) -> f a = f b cong refl = refl +||| Decidability. A decidable property either holds or is a contradiction. data Dec : Type -> Type where-    Yes : {A : Type} -> A          -> Dec A-    No  : {A : Type} -> (A -> _|_) -> Dec A++  ||| The case where the property holds+  ||| @ prf the proof+  Yes : {A : Type} -> (prf : A) -> Dec A++  ||| The case where the property holding would be a contradiction+  ||| @ contra a demonstration that A would be a contradiction+  No  : {A : Type} -> (contra : A -> _|_) -> Dec A
libs/prelude/Prelude/Bits.idr view
@@ -2,32 +2,25 @@  import Prelude.Strings import Prelude.Vect+import Prelude.Bool  %access public %default total  -private-toHexDigit : Fin 16 -> Char-toHexDigit n = index n hexVect where-  hexVect : Vect 16 Char-  hexVect = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',-             'A', 'B', 'C', 'D', 'E', 'F']- b8ToString : Bits8 -> String-b8ToString c = pack [c1, c2] where-  %assert_total -- We will only supply numbers that can fit in 4 bits-  toFin16 : Bits8 -> Fin 16-  toFin16 n = if n == 0-                 then fZ-                 else believe_me (fS (toFin16 (n-1)))-  c1 = toHexDigit upper where-    upper : Fin 16-    upper = toFin16 (prim__lshrB8 c 4)-  c2 = toHexDigit lower where-    lower : Fin 16-    lower = toFin16 (prim__andB8 c 0xf)+b8ToString c = pack (with List [c1, c2])+  where getDigit : Bits8 -> Char+        getDigit b = let n = prim__zextB8_Int b in+                     if n >= 0 && n <= 9+                        then '0' `prim__addChar` cast n+                        else if n >= 10 && n <= 15+                                then 'A' `prim__addChar` cast (n - 10)+                                else '?' -- this is for totality - it should not happen+        c1 = getDigit (prim__andB8 (prim__lshrB8 c 4) 15)+        c2 = getDigit (prim__andB8 c 15) + b16ToString : Bits16 -> String b16ToString c = c1 ++ c2 where   c1 = b8ToString upper where@@ -41,7 +34,7 @@ b32ToString c = c1 ++ c2 where   c1 = b16ToString upper where     upper : Bits16-    upper = prim__truncB32_B16 (prim__lshrB32 c 16)+    upper = prim__truncB32_B16 (prim__andB32 (prim__lshrB32 c 16) 0x0000ffff)   c2 = b16ToString lower where     lower : Bits16     lower = prim__truncB32_B16 c@@ -50,7 +43,7 @@ b64ToString c = c1 ++ c2 where   c1 = b32ToString upper where     upper : Bits32-    upper = prim__truncB64_B32 (prim__lshrB64 c 32)+    upper = prim__truncB64_B32 (prim__andB64 (prim__lshrB64 c 32) 0x00000000ffffffff)   c2 = b32ToString lower where     lower : Bits32     lower = prim__truncB64_B32 c
libs/prelude/Prelude/Bool.idr view
@@ -1,33 +1,38 @@ module Prelude.Bool --- | Boolean Data Type+import Builtins++||| Boolean Data Type data Bool = False | True --- | Boolean elimination-boolElim : Bool -> |(t : a) -> |(f : a) -> a+||| The underlying implementation of the if ... then ... else ... syntax+||| @ b the condition on the if+||| @ t the value if b is true+||| @ e the falue if b is false+boolElim : (b : Bool) -> (t : Lazy a) -> (e : Lazy a) -> a boolElim True  t e = t boolElim False t e = e --- | Defines a predicate on Bool which guarantees that the value is true.+||| Defines a predicate on Bool which guarantees that the value is true. data so : Bool -> Type where oh : so True --- Syntaxtic sugar for boolean elimination.-syntax if [test] then [t] else [e] = boolElim test t e+-- Syntactic sugar for boolean elimination.+syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)  -- Boolean Operator Precedence infixl 4 &&, || --- | Boolean OR+||| Boolean OR (||) : Bool -> Bool -> Bool (||) False x = x (||) True _  = True --- | Boolean AND+||| Boolean AND (&&) : Bool -> Bool -> Bool (&&) True x  = x (&&) False _ = False --- | Boolean NOT+||| Boolean NOT not : Bool -> Bool not True = False not False = True
libs/prelude/Prelude/Chars.idr view
@@ -1,69 +1,72 @@--- | Functions operating over Char's module Prelude.Char+-- Functions operating over Chars +import Prelude.Bool+import Prelude.Classes+import Prelude.List import Builtins --- | Return the ASCII representation of the character.+||| Return the ASCII representation of the character. chr : Int -> Char chr x = prim__intToChar x --- | Convert the number to its ASCII equivalent.+||| Convert the number to its ASCII equivalent. ord : Char -> Int ord x = prim__charToInt x --- | Returns true if the character is in the range [A-Z].+||| Returns true if the character is in the range [A-Z]. isUpper : Char -> Bool isUpper x = x >= 'A' && x <= 'Z' --- | Returns true if the character is in the range [a-z]+||| Returns true if the character is in the range [a-z] isLower : Char -> Bool isLower x = x >= 'a' && x <= 'z' --- | Returns true if the character is in the ranges [A-Z][a-z].+||| Returns true if the character is in the ranges [A-Z][a-z]. isAlpha : Char -> Bool isAlpha x = isUpper x || isLower x --- | Returns true if the character is in the range [0-9]+||| Returns true if the character is in the range [0-9] isDigit : Char -> Bool isDigit x = (x >= '0' && x <= '9') --- | Returns true if the character is in the ranges [A-Z][a-z][0-9]+||| Returns true if the character is in the ranges [A-Z][a-z][0-9] isAlphaNum : Char -> Bool isAlphaNum x = isDigit x || isAlpha x --- | Returns true if the character is a whitespace character.+||| Returns true if the character is a whitespace character. isSpace : Char -> Bool isSpace x = x == ' '  || x == '\t' || x == '\r' ||             x == '\n' || x == '\f' || x == '\v' ||             x == '\xa0' --- | Returns true if the character represents a new line.+||| Returns true if the character represents a new line. isNL : Char -> Bool isNL x = x == '\r' || x == '\n' --- | Convert a letter to the corresponding upper-case letter, if any.--- Non-letters are ignored.+||| Convert a letter to the corresponding upper-case letter, if any.+||| Non-letters are ignored. toUpper : Char -> Char toUpper x = if (isLower x)                then (prim__intToChar (prim__charToInt x - 32))                else x --- | Convert a letter to the corresponding lower-case letter, if any.--- Non-letters are ignored.+||| Convert a letter to the corresponding lower-case letter, if any.+||| Non-letters are ignored. toLower : Char -> Char toLower x = if (isUpper x)                then (prim__intToChar (prim__charToInt x + 32))                else x --- | Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F]+||| Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F] isHexDigit : Char -> Bool isHexDigit x = elem (toUpper x) hexChars where   hexChars : List Char   hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',               'A', 'B', 'C', 'D', 'E', 'F'] --- | Returns true if the character is an octal digit.+||| Returns true if the character is an octal digit. isOctDigit : Char -> Bool isOctDigit x = (x >= '0' && x <= '7') --- --------------------------------------------------------------------- [ EOF ]+
libs/prelude/Prelude/Classes.idr view
@@ -20,7 +20,7 @@ boolOp op x y = intToBool (op x y)  -- ---------------------------------------------------------- [ Equality Class ]--- | The Eq class defines inequality and equality.+||| The Eq class defines inequality and equality. class Eq a where     (==) : a -> a -> Bool     (/=) : a -> a -> Bool@@ -28,6 +28,9 @@     x /= y = not (x == y)     x == y = not (x /= y) +instance Eq () where+  () == () = True+ instance Eq Int where     (==) = boolOp prim__eqInt @@ -62,7 +65,7 @@     GT == GT = True     _  == _  = False --- | The Ord class defines comparison operations on ordered data types.+||| The Ord class defines comparison operations on ordered data types. class Eq a => Ord a where     compare : a -> a -> Ordering @@ -88,6 +91,8 @@     min : a -> a -> a     min x y = if (x < y) then x else y +instance Ord () where+    compare () () = EQ  instance Ord Int where     compare x y = if (x == y) then EQ else@@ -126,14 +131,14 @@       else compare xr yr  -- --------------------------------------------------------- [ Numerical Class ]--- | The Num class defines basic numerical arithmetic.+||| The Num class defines basic numerical arithmetic. class Num a where     (+) : a -> a -> a     (-) : a -> a -> a     (*) : a -> a -> a-    -- | Absolute value+    ||| Absolute value     abs : a -> a-    -- | Conversion from Integer.+    ||| Conversion from Integer.     fromInteger : Integer -> a  instance Num Integer where@@ -237,10 +242,38 @@                 else if l > r then GT                      else EQ +-- ------------------------------------------------------------- [ Bounded ] +class MinBound b where+  ||| The lower bound for the type+  minBound : b++class MaxBound b where+  ||| The upper bound for the type+  maxBound : b++instance MinBound Bits16 where+  minBound = 0x0++instance MaxBound Bits16 where+  maxBound = 0xffff++instance MinBound Bits32 where+  minBound = 0x0++instance MaxBound Bits32 where+  maxBound = 0xffffffff++instance MinBound Bits64 where+  minBound = 0x0++instance MaxBound Bits64 where+  maxBound = 0xffffffffffffffff++ -- ------------------------------------------------------------- [ Fractionals ] --- | Fractional division of two Floats.+||| Fractional division of two Floats. (/) : Float -> Float -> Float (/) = prim__divFloat
libs/prelude/Prelude/Either.idr view
@@ -1,22 +1,27 @@-module Prelude.Either+ module Prelude.Either  import Builtins  import Prelude.Maybe import Prelude.List -data Either a b-  = Left a-  | Right b+||| A sum type+data Either a b =+  ||| One possibility of the sum, conventionally used to represent errors+  Left a |+  ||| The other possibility, conventionally used to represent success+  Right b  -------------------------------------------------------------------------------- -- Syntactic tests -------------------------------------------------------------------------------- +||| True if the argument is Left, False otherwise isLeft : Either a b -> Bool isLeft (Left l)  = True isLeft (Right r) = False +||| True if the argument is Right, False otherwise isRight : Either a b -> Bool isRight (Left l)  = False isRight (Right r) = True@@ -25,14 +30,20 @@ -- Misc. -------------------------------------------------------------------------------- +||| Perform a case analysis on a Boolean, providing clients with a `so` proof choose : (b : Bool) -> Either (so b) (so (not b)) choose True  = Left oh choose False = Right oh -either : (a -> c) -> (b -> c) -> Either a b -> c+||| Simply-typed eliminator for Either+||| @ f the action to take on Left+||| @ g the action to take on Right+||| @ e the sum to analyze+either : (f : a -> c) -> (g : b -> c) -> (e : Either a b) -> c either l r (Left x)  = l x either l r (Right x) = r x +||| Keep the payloads of all Left constructors in a list of Eithers lefts : List (Either a b) -> List a lefts []      = [] lefts (x::xs) =@@ -40,6 +51,7 @@     Left  l => l :: lefts xs     Right r => lefts xs +||| Keep the payloads of all Right constructors in a list of Eithers rights : List (Either a b) -> List b rights []      = [] rights (x::xs) =@@ -47,9 +59,11 @@     Left  l => rights xs     Right r => r :: rights xs +||| Split a list of Eithers into a list of the left elements and a list of the right elements partitionEithers : List (Either a b) -> (List a, List b) partitionEithers l = (lefts l, rights l) +||| Remove a "useless" Either by collapsing the case distinction fromEither : Either a a -> a fromEither (Left l)  = l fromEither (Right r) = r@@ -58,7 +72,9 @@ -- Conversions -------------------------------------------------------------------------------- -maybeToEither : e -> Maybe a -> Either e a+||| Convert a Maybe to an Either by using a default value in case of Nothing+||| @ e the default value+maybeToEither : (def : e) -> Maybe a -> Either e a maybeToEither def (Just j) = Right j maybeToEither def Nothing  = Left  def @@ -78,10 +94,12 @@ -- Injectivity of constructors -------------------------------------------------------------------------------- +||| Left is injective total leftInjective : {b : Type} -> {x : a} -> {y : a}                     -> (Left {b = b} x = Left {b = b} y) -> (x = y) leftInjective refl = refl +||| Right is injective total rightInjective : {a : Type} -> {x : b} -> {y : b}                      -> (Right {a = a} x = Right {a = a} y) -> (x = y) rightInjective refl = refl
libs/prelude/Prelude/Fin.idr view
@@ -2,13 +2,23 @@  import Prelude.Nat import Prelude.Either+import Prelude.Uninhabited  %default total -data Fin : Nat -> Type where+||| Numbers strictly less than some bound.  The name comes from "finite sets"+||| @ n the upper bound+data Fin : (n : Nat) -> Type where     fZ : Fin (S k)     fS : Fin k -> Fin (S k) +instance Uninhabited (Fin Z) where+  uninhabited fZ impossible+  uninhabited (fS f) impossible++fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n+fSInjective left _ refl = refl+ instance Eq (Fin n) where     (==) fZ fZ = True     (==) (fS k) (fS k') = k == k'@@ -24,6 +34,13 @@ finToNat fZ = Z finToNat (fS k) = S (finToNat k) +finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn+finToNatInjective fZ     fZ     refl = refl+finToNatInjective (fS m) fZ     refl impossible+finToNatInjective fZ     (fS n) refl impossible+finToNatInjective (fS m) (fS n) prf  =+  cong (finToNatInjective m n (succInjective (finToNat m) (finToNat n) prf)) + instance Cast (Fin n) Nat where     cast x = finToNat x @@ -34,14 +51,18 @@ instance Cast (Fin n) Integer where     cast x = finToInteger x +||| Weaken the bound on a Fin by 1 weaken : Fin n -> Fin (S n) weaken fZ     = fZ weaken (fS k) = fS (weaken k) +||| Weaken the bound on a Fin by some amount weakenN : (n : Nat) -> Fin m -> Fin (m + n) weakenN n fZ = fZ weakenN n (fS f) = fS (weakenN n f) +||| Attempt to tighten the bound on a Fin.+||| Return `Left` if the bound could not be tightened, or `Right` if it could. strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n) strengthen {n = S k} fZ = Right fZ strengthen {n = S k} (fS i) with (strengthen i)@@ -49,10 +70,14 @@   strengthen (fS k) | Right x  = Right (fS x) strengthen f = Left f +||| Add some natural number to a Fin, extending the bound accordingly+||| @ n the previous bound+||| @ m the number to increase the Fin by shift : (m : Nat) -> Fin n -> Fin (m + n) shift Z f = f shift {n=n} (S m) f = fS {k = (m + n)} (shift m f) +||| The largest element of some Fin type last : Fin (S n) last {n=Z} = fZ last {n=S _} = fS last@@ -61,6 +86,31 @@ fSinjective refl = refl  +instance MinBound (Fin (S n)) where+  minBound = fZ++instance MaxBound (Fin (S n)) where+  maxBound = last+++||| Add two Fins, extending the bound+(+) : Fin n -> Fin m -> Fin (n + m)+(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f')+(+) (fS f) f' = fS (f + f')++||| Substract two Fins, keeping the bound of the minuend+(-) : Fin n -> Fin m -> Fin n+fZ - _ = fZ+f - fZ = f+(fS f) - (fS f') = weaken $ f - f'++||| Multiply two Fins, extending the bound+(*) : Fin n -> Fin m -> Fin (n * m)+(*) {n=Z} f f' = FinZElim f+(*) {m=Z} f f' = FinZElim f'+(*) {n=S n} {m=S m} fZ     f' = fZ+(*) {n=S n} {m=S m} (fS f) f' = f' + (f * f')+ -- Construct a Fin from an integer literal which must fit in the given Fin  natToFin : Nat -> (n : Nat) -> Maybe (Fin n)@@ -74,11 +124,12 @@ integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing  data IsJust : Maybe a -> Type where-     ItIsJust : IsJust {a} (Just x)+  ItIsJust : IsJust {a} (Just x)  fromInteger : (x : Integer) ->-        {default ItIsJust-             prf : (IsJust (integerToFin x n))} -> Fin n+              {default ItIsJust+               prf : (IsJust (integerToFin x n))} ->+              Fin n fromInteger {n} x {prf} with (integerToFin x n)   fromInteger {n} x {prf = ItIsJust} | Just y = y
libs/prelude/Prelude/Functor.idr view
@@ -1,4 +1,9 @@ module Prelude.Functor +||| Functors+||| @ f the action of the functor on objects class Functor (f : Type -> Type) where-    map : (a -> b) -> f a -> f b+    ||| The action of the functor on morphisms+    ||| @ f the functor+    ||| @ m the morphism+    map : (m : a -> b) -> f a -> f b
libs/prelude/Prelude/List.idr view
@@ -12,8 +12,7 @@ %access public %default total -infixr 7 ::-infixl 8 +++infixr 7 ::,++  %elim data List a   = Nil@@ -35,9 +34,27 @@ isCons (x::xs) = True  --------------------------------------------------------------------------------+-- Length+--------------------------------------------------------------------------------++length : List a -> Nat+length []      = 0+length (x::xs) = 1 + length xs++-------------------------------------------------------------------------------- -- Indexing into lists -------------------------------------------------------------------------------- +index : (n : Nat) -> (l : List a) -> (lt n (length l) = True) -> a+index Z     (x::xs) p    = x+index (S n) (x::xs) p    = index n xs ?indexTailProof+index _     []      refl   impossible++index' : (n : Nat) -> (l : List a) -> Maybe a+index' Z     (x::xs) = Just x+index' (S n) (x::xs) = index' n xs+index' _     []      = Nothing+ head : (l : List a) -> (isCons l = True) -> a head []      refl   impossible head (x::xs) p    = x@@ -112,10 +129,6 @@ list nil cons []      = nil list nil cons (x::xs) = cons x xs -length : List a -> Nat-length []      = 0-length (x::xs) = 1 + length xs- -------------------------------------------------------------------------------- -- Building (bigger) lists --------------------------------------------------------------------------------@@ -223,9 +236,12 @@ -- Folds -------------------------------------------------------------------------------- +total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc+foldrImpl f e go [] = go e+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs+ instance Foldable List where-  foldr f e []      = e-  foldr f e (x::xs) = f x (foldr f e xs)+  foldr f e xs = foldrImpl f e id xs  -------------------------------------------------------------------------------- -- Special folds@@ -256,6 +272,23 @@ intercalate : List a -> List (List a) -> List a intercalate sep l = concat $ intersperse sep l +||| Transposes rows and columns of a list of lists.+|||+||| > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]+|||+||| This also works for non square scenarios, thus+||| involution does not always hold:+|||+||| > transpose [[], [1, 2]] = [[1], [2]]+||| > transpose (transpose [[], [1, 2]]) = [[1, 2]]+|||+||| TODO: Solution which satisfies the totality checker?+%assert_total+transpose : List (List a) -> List (List a)+transpose [] = []+transpose ([] :: xss) = transpose xss+transpose ((x::xs) :: xss) = (x :: (mapMaybe head' xss)) :: (transpose (xs :: (map (drop 1) xss)))+ -------------------------------------------------------------------------------- -- Membership tests --------------------------------------------------------------------------------@@ -389,6 +422,14 @@     (chunk, [])          => [chunk]     (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest) +||| A tuple where the first element is a List of the n first elements and+||| the second element is a List of the remaining elements of the list+||| It is equivalent to (take n xs, drop n xs)+||| @ n   the index to split at+||| @ xs  the list to split in two+splitAt : (n : Nat) -> (xs : List a) -> (List a, List a)+splitAt n xs = (take n xs, drop n xs)+ partition : (a -> Bool) -> List a -> (List a, List a) partition p []      = ([], []) partition p (x::xs) =@@ -538,6 +579,12 @@ -------------------------------------------------------------------------------- -- Proofs --------------------------------------------------------------------------------++indexTailProof = proof {+  intros;+  rewrite sym p;+  trivial;+}  lengthAppendStepCase = proof {     intros;
libs/prelude/Prelude/Maybe.idr view
@@ -28,11 +28,11 @@ -- Misc -------------------------------------------------------------------------------- -maybe : |(def : b) -> (a -> b) -> Maybe a -> b+maybe : Lazy b -> (a -> b) -> Maybe a -> b maybe n j Nothing  = n maybe n j (Just x) = j x -fromMaybe : |(def: a) -> Maybe a -> a+fromMaybe : (Lazy a) -> Maybe a -> a fromMaybe def Nothing  = def fromMaybe def (Just j) = j @@ -64,7 +64,7 @@   (Just _) == Nothing  = False   (Just a) == (Just b) = a == b --- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to+-- Lift a semigroup into 'Maybe' forming a 'Monoid' according to -- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be -- turned into a monoid simply by adjoining an element i not in S -- and defining i+i = i and i+s = s = s+i for all s in S."
libs/prelude/Prelude/Monad.idr view
@@ -13,8 +13,11 @@ class Applicative m => Monad (m : Type -> Type) where     (>>=)  : m a -> (a -> m b) -> m b +||| Also called `join` or mu flatten : Monad m => m (m a) -> m a flatten a = a >>= id +||| For compatibility with Haskell. Note that monads are **not** free to+||| define `return` and `pure` differently! return : Monad m => a -> m a return = pure
libs/prelude/Prelude/Nat.idr view
@@ -6,17 +6,24 @@ import Prelude.Bool import Prelude.Cast import Prelude.Classes+import Prelude.Uninhabited  %access public %default total -%elim data Nat-  = Z-  | S Nat+||| Unary natural numbers+%elim data Nat =+  ||| Zero+  Z |+  ||| Successor+  S Nat  -- name hints for interactive editing %name Nat k,j,i,n,m +instance Uninhabited (Z = S n) where+  uninhabited refl impossible+ -------------------------------------------------------------------------------- -- Syntactic tests --------------------------------------------------------------------------------@@ -33,14 +40,19 @@ -- Basic arithmetic functions -------------------------------------------------------------------------------- -total plus : Nat -> Nat -> Nat+||| Add two natural numbers.+||| @ n the number to case-split on+||| @ m the other number+total plus : (n, m : Nat) -> Nat plus Z right        = right plus (S left) right = S (plus left right) +||| Multiply natural numbers total mult : Nat -> Nat -> Nat mult Z right        = Z mult (S left) right = plus right $ mult left right +||| Convert an Integer to a Nat, mapping negative numbers to 0 fromIntegerNat : Integer -> Nat fromIntegerNat 0 = Z fromIntegerNat n =@@ -49,15 +61,18 @@   else     Z +||| Convert a Nat to an Integer toIntegerNat : Nat -> Integer toIntegerNat Z = 0 toIntegerNat (S k) = 1 + toIntegerNat k +||| Subtract natural numbers. If the second number is larger than the first, return 0. total minus : Nat -> Nat -> Nat minus Z        right     = Z minus left     Z         = left minus (S left) (S right) = minus left right +||| Exponentiation of natural numbers total power : Nat -> Nat -> Nat power base Z       = S Z power base (S exp) = mult base $ power base exp@@ -74,33 +89,46 @@ -- Comparisons -------------------------------------------------------------------------------- -data LTE  : Nat -> Nat -> Type where+||| Proofs that `n` is less than or equal to `m`+||| @ n the smaller number+||| @ m the larger number+data LTE  : (n, m : Nat) -> Type where+  ||| Zero is the smallest Nat   lteZero : LTE Z    right+  ||| If n <= m, then n + 1 <= m + 1   lteSucc : LTE left right -> LTE (S left) (S right) +||| Greater than or equal to total GTE : Nat -> Nat -> Type GTE left right = LTE right left +||| Strict less than total LT : Nat -> Nat -> Type LT left right = LTE (S left) right +||| Strict greater than total GT : Nat -> Nat -> Type GT left right = LT right left +||| Boolean test than one Nat is less than or equal to another total lte : Nat -> Nat -> Bool lte Z        right     = True lte left     Z         = False lte (S left) (S right) = lte left right +||| Boolean test than one Nat is greater than or equal to another total gte : Nat -> Nat -> Bool gte left right = lte right left +||| Boolean test than one Nat is strictly less than another total lt : Nat -> Nat -> Bool lt left right = lte (S left) right +||| Boolean test than one Nat is strictly greater than another total gt : Nat -> Nat -> Bool gt left right = lt right left +||| Find the least of two natural numbers total minimum : Nat -> Nat -> Nat minimum left right =   if lte left right then@@ -108,6 +136,7 @@   else     right +||| Find the greatest of two natural numbers total maximum : Nat -> Nat -> Nat maximum left right =   if lte left right then@@ -142,12 +171,17 @@    fromInteger = fromIntegerNat +instance MinBound Nat where+  minBound = Z+ instance Cast Integer Nat where   cast = fromInteger +||| A wrapper for Nat that specifies the semigroup and monad instances that use (+) record Multiplicative : Type where   getMultiplicative : Nat -> Multiplicative +||| A wrapper for Nat that specifies the semigroup and monad instances that use (*) record Additive : Type where   getAdditive : Nat -> Additive @@ -207,6 +241,7 @@ -- Auxilliary notions -------------------------------------------------------------------------------- +||| The predecessor of a natural number. `pred Z` is `Z`. total pred : Nat -> Nat pred Z     = Z pred (S n) = n@@ -215,11 +250,13 @@ -- Fibonacci and factorial -------------------------------------------------------------------------------- +||| Fibonacci numbers total fib : Nat -> Nat fib Z         = Z fib (S Z)     = S Z fib (S (S n)) = fib (S n) + fib n +||| Factorial function total fact : Nat -> Nat fact Z     = S Z fact (S n) = (S n) * fact n@@ -280,10 +317,13 @@ --------------------------------------------------------------------------------  -- Succ++||| S preserves equality total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->   S left = S right eqSucc left _ refl = refl +||| S is injective total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->   left = right succInjective left _ refl = refl
libs/prelude/Prelude/Stream.idr view
@@ -6,46 +6,64 @@ %access public %default total +||| An infinite stream codata Stream : Type -> Type where   (::) : a -> Stream a -> Stream a +-- Hints for interactive editing+%name Stream xs,ys,zs,ws+ instance Functor Stream where     map f (x::xs) = f x :: map f xs +||| The first element of an infinite stream head : Stream a -> a head (x::xs) = x +||| All but the first element tail : Stream a -> Stream a tail (x::xs) = xs -take : (n : Nat) -> Stream a -> Vect n a+||| Take precisely n elements from the stream+||| @ n how many elements to take+||| @ xs the stream+take : (n : Nat) -> (xs : Stream a) -> Vect n a take Z _ = [] take (S n) (x :: xs) = x :: (take n xs)  %assert_total drop : Nat -> Stream a -> Stream a-drop Z xs = xs+drop Z     xs = xs drop (S k) (x::xs) = drop k xs +||| An infinite stream of repetitions of the same thing repeat : a -> Stream a repeat x = x :: repeat x -iterate : (a -> a) -> a -> Stream a+||| Generate an infinite stream by repeatedly applying a function+||| @ f the function to iterate+||| @ x the initial value that will be the head of the stream+iterate : (f : a -> a) -> (x : a) -> Stream a iterate f x = x :: iterate f (f x) +||| Get the nth element of a stream index : Nat -> Stream a -> a-index Z (x::xs) = x+index Z     (x::xs) = x index (S k) (x::xs) = index k xs +||| Combine two streams element-wise using a function zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys +||| Create a stream of pairs from two streams zip : Stream a -> Stream b -> Stream (a, b) zip = zipWith (\x,y => (x,y)) +||| Create a pair of streams from a stream of pairs unzip : Stream (a, b) -> (Stream a, Stream b) unzip xs = (map fst xs, map snd xs) +||| Return the diagonal elements of a stream of streams diag : Stream (Stream a) -> Stream a diag ((x::xs)::xss) = x :: diag (map tail xss)
libs/prelude/Prelude/Strings.idr view
@@ -7,30 +7,30 @@ import Prelude.Either import Prelude.Foldable --- | Appends two strings together.+||| Appends two strings together. (++) : String -> String -> String (++) = prim__concat --- | Returns the first character in the specified string.+||| Returns the first character in the specified string. partial strHead : String -> Char strHead = prim__strHead --- | Returns the characters specified after the head of the string.+||| Returns the characters specified after the head of the string. partial strTail : String -> String strTail = prim__strTail --- | Adds a character to the from of the specified string.+||| Adds a character to the from of the specified string. strCons : Char -> String -> String strCons = prim__strCons --- | Returns the nth character (starting from 0) of the specified string.+||| Returns the nth character (starting from 0) of the specified string. partial strIndex : String -> Int -> Char strIndex = prim__strIndex --- | Reverses the elements within a String.+||| Reverses the elements within a String. reverse : String -> String reverse = prim__strRev
+ libs/prelude/Prelude/Uninhabited.idr view
@@ -0,0 +1,16 @@+module Prelude.Uninhabited++import Builtins++||| A canonical proof that some type is empty+class Uninhabited t where+  ||| If I have a t, I've had a contradiction+  ||| @ t the uninhabited type+  total uninhabited : t -> _|_++||| Use an absurd assumption to discharge a proof obligation+||| @ t some empty type+||| @ a the goal type+||| @ h the contradictory hypothesis+absurd : Uninhabited t => (h : t) -> a+absurd h = FalseElim (uninhabited h)
libs/prelude/Prelude/Vect.idr view
@@ -4,7 +4,10 @@ import Prelude.Foldable import Prelude.Functor import Prelude.List+import Prelude.Classes import Prelude.Nat+import Prelude.Bool+import Prelude.Uninhabited  %access public %default total@@ -19,68 +22,152 @@ %name Vect xs,ys,zs,ws  --------------------------------------------------------------------------------+-- Length+--------------------------------------------------------------------------------++||| Calculate the length of a `Vect`.+|||+||| **Note**: this is only useful if you don't already statically know the length+||| and you want to avoid matching the implicit argument for erasure reasons.+||| @ n the length (provably equal to the return value)+||| @ xs the vector+length : (xs : Vect n a) -> Nat+length [] = 0+length (x::xs) = 1 + length xs++||| Show that the length function on vectors in fact calculates the length+private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n+lengthCorrect Z [] = refl+lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in refl++-------------------------------------------------------------------------------- -- Indexing into vectors -------------------------------------------------------------------------------- +||| All but the first element of the vector tail : Vect (S n) a -> Vect n a tail (x::xs) = xs +||| Only the first element of the vector head : Vect (S n) a -> a head (x::xs) = x +||| The last element of the vector last : Vect (S n) a -> a last (x::[])    = x last (x::y::ys) = last $ y::ys +||| All but the last element of the vector init : Vect (S n) a -> Vect n a init (x::[])    = [] init (x::y::ys) = x :: init (y::ys) +||| Extract a particular element from a vector index : Fin n -> Vect n a -> a index fZ     (x::xs) = x index (fS k) (x::xs) = index k xs index fZ     [] impossible +||| Construct a new vector consisting of all but the indicated element deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a deleteAt           fZ     (x::xs) = xs deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs+deleteAt {n = Z}   (fS k) (x::xs) = absurd k deleteAt           _      [] impossible +||| Replace an element at a particlar index with another replaceAt : Fin n -> t -> Vect n t -> Vect n t-replaceAt fZ y (x::xs) = y::xs+replaceAt fZ     y (x::xs) = y :: xs replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs +||| Replace the element at a particular index with the result of applying a function to it+||| @ i the index to replace at+||| @ f the update function+||| @ xs the vector to replace in+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t+updateAt fZ     f (x::xs) = f x :: xs+updateAt (fS k) f (x::xs) = x :: updateAt k f xs+ -------------------------------------------------------------------------------- -- Subvectors -------------------------------------------------------------------------------- +||| Get the first m elements of a Vect+||| @ m the number of elements to take take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a take (fS k) []      = FinZElim k take fZ     _       = [] take (fS k) (x::xs) = x :: take k xs +||| Remove the first m elements of a Vect+||| @ m the number of elements to remove drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a drop (fS k) []      = FinZElim k drop fZ     xs      ?= xs drop (fS k) (x::xs) = drop k xs  --------------------------------------------------------------------------------+-- Transformations+--------------------------------------------------------------------------------++||| Reverse the order of the elements of a vector+total reverse : {n : Nat} -> Vect n a -> Vect n a+reverse {n} xs = reverse' [] (plusZeroRightNeutral n) xs+  where+    total reverse' : {m, j, l : Nat} ->+                     Vect m a -> (j + m = l) -> Vect j a -> Vect l a+    reverse' {m} {j = Z  } {l} acc prf []      ?= acc+    reverse' {m} {j = S k} {l} acc prf (x::xs)  =+      let prf1 : (m + (S k) = l) = rewrite plusCommutative m (S k) in prf in+      let prf2 : (S (m + k) = l) = rewrite plusSuccRightSucc m k in prf1 in+      let prf3 : (S (k + m) = l) = rewrite plusCommutative k m in prf2 in+      let prf4 : (k + (S m) = l) = rewrite sym $ plusSuccRightSucc k m in prf3 in+      reverse' (x::acc) prf4 xs++||| Alternate an element between the other elements of a vector+||| @ sep the element to intersperse+||| @ xs the vector to separate with `sep`+intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a+intersperse sep []      = []+intersperse sep (x::xs) = x :: intersperse' sep xs+  where+    intersperse' : a -> Vect n a -> Vect (n + n) a+    intersperse' sep []      = []+    intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs++-------------------------------------------------------------------------------- -- Conversion from list (toList is provided by Foldable) -------------------------------------------------------------------------------- ++fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a+fromList' ys [] = ys+fromList' {n} ys (x::xs) =+  rewrite (plusSuccRightSucc (length xs) n) ==> +          Vect (plus (length xs) (S n)) a in+  fromList' (x::ys) xs++||| Convert a list to a vector.+|||+||| The length of the list should be statically known. fromList : (l : List a) -> Vect (length l) a-fromList []      = []-fromList (x::xs) = x :: fromList xs+fromList l =+  rewrite (sym $ plusZeroRightNeutral (length l)) in+  reverse $ fromList' [] l  -------------------------------------------------------------------------------- -- Building (bigger) vectors -------------------------------------------------------------------------------- +||| Append two vectors (++) : Vect m a -> Vect n a -> Vect (m + n) a (++) []      ys = ys (++) (x::xs) ys = x :: xs ++ ys -replicate : (n : Nat) -> a -> Vect n a+||| Repeate some value n times+||| @ n the number of times to repeat it+||| @ x the value to repeat+replicate : (n : Nat) -> (x : a) -> Vect n a replicate Z     x = [] replicate (S k) x = x :: replicate k x @@ -88,18 +175,21 @@ -- Zips and unzips -------------------------------------------------------------------------------- +||| Combine two equal-length vectors pairwise with some function zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c zipWith f []      []      = [] zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys +||| Combine two equal-length vectors pairwise zip : Vect n a -> Vect n b -> Vect n (a, b) zip = zipWith (\x => \y => (x,y)) +||| Convert a vector of pairs to a pair of vectors unzip : Vect n (a, b) -> (Vect n a, Vect n b) unzip []           = ([], []) unzip ((l, r)::xs) with (unzip xs)   | (lefts, rights) = (l::lefts, r::rights)-  + -------------------------------------------------------------------------------- -- Equality --------------------------------------------------------------------------------@@ -148,65 +238,66 @@ -- Folds -------------------------------------------------------------------------------- +total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc+foldrImpl f e go [] = go e+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs+ instance Foldable (Vect n) where-  foldr f e []      = e-  foldr f e (x::xs) = f x (foldr f e xs)+  foldr f e xs = foldrImpl f e id xs  -------------------------------------------------------------------------------- -- Special folds -------------------------------------------------------------------------------- +||| Flatten a vector of equal-length vectors concat : Vect m (Vect n a) -> Vect (m * n) a concat []      = [] concat (v::vs) = v ++ concat vs  ----------------------------------------------------------------------------------- Transformations-----------------------------------------------------------------------------------total reverse : Vect n a -> Vect n a-reverse = reverse' []-  where-    total reverse' : Vect m a -> Vect n a -> Vect (m + n) a-    reverse' acc []      ?= acc-    reverse' acc (x::xs) ?= reverse' (x::acc) xs--intersperse : a -> Vect n a -> Vect (n + pred n) a-intersperse sep []      = []-intersperse sep (x::xs) = x :: intersperse' sep xs-  where-    intersperse' : a -> Vect n a -> Vect (n + n) a-    intersperse' sep []      = []-    intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs---------------------------------------------------------------------------------- -- Membership tests -------------------------------------------------------------------------------- -elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool+||| Search for an item using a user-provided test+||| @ p the equality test+||| @ e the item to search for+||| @ xs the vector to search in+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool elemBy p e []      = False elemBy p e (x::xs) with (p e x)   | True  = True   | False = elemBy p e xs -elem : Eq a => a -> Vect n a -> Bool+||| Use the default Boolean equality on elements to search for an item+||| @ x what to search for+||| @ xs where to search+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool elem = elemBy (==) -lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b+||| Find the association of some key with a user-provided comparison+||| @ p the comparison operator for keys (True if they match)+||| @ e the key to look for+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b lookupBy p e []           = Nothing lookupBy p e ((l, r)::xs) with (p e l)   | True  = Just r   | False = lookupBy p e xs +||| Find the assocation of some key using the default Boolean equality test lookup : Eq a => a -> Vect n (a, b) -> Maybe b lookup = lookupBy (==) -hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool+||| Check if any element of xs is found in elems by a user-provided comparison+||| @ p the comparison operator+||| @ elems the vector to search+||| @ xs what to search for+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool hasAnyBy p elems []      = False hasAnyBy p elems (x::xs) with (elemBy p x elems)   | True  = True   | False = hasAnyBy p elems xs +||| Check if any element of xs is found in elems using the default Boolean equality test hasAny : Eq a => Vect m a -> Vect n a -> Bool hasAny = hasAnyBy (==) @@ -214,12 +305,15 @@ -- Searching with a predicate -------------------------------------------------------------------------------- -find : (a -> Bool) -> Vect n a -> Maybe a+||| Find the first element of the vector that satisfies some test+||| @ p the test to satisfy+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a find p []      = Nothing find p (x::xs) with (p x)   | True  = Just x   | False = find p xs +||| Find the index of the first element of the vector that satisfies some test findIndex : (a -> Bool) -> Vect n a -> Maybe Nat findIndex = findIndex' 0   where@@ -229,6 +323,7 @@       | True  = Just cnt       | False = findIndex' (S cnt) p xs +||| Find the indices of all elements that satisfy some test total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat) findIndices = findIndices' 0   where@@ -257,6 +352,7 @@ -- Filters -------------------------------------------------------------------------------- +||| Find all elements of a vector that satisfy some test total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) filter p [] = ( _ ** [] ) filter p (x::xs) with (filter p xs)@@ -266,6 +362,7 @@     else       (_ ** tail) +||| Make the elements of some vector unique by some test nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) nubBy = nubBy' []   where@@ -276,6 +373,7 @@       | False with (nubBy' (x::acc) p xs)         | (_ ** tail) = (_ ** x::tail) +||| Make the elements of some vector unique by the default Boolean equality nub : Eq a => Vect n a -> (p ** Vect p a) nub = nubBy (==) @@ -283,6 +381,14 @@ -- Splitting and breaking lists -------------------------------------------------------------------------------- +||| A tuple where the first element is a Vect of the n first elements and+||| the second element is a Vect of the remaining elements of the original Vect+||| It is equivalent to (take n xs, drop n xs)+||| @ m   the index to split at+||| @ xs  the Vect to split in two+splitAt : {n : Nat} -> (m : Fin (S n)) -> (xs : Vect n a) -> (Vect (cast m) a, Vect (n - cast m) a)+splitAt n xs = (take n xs, drop n xs)+ -------------------------------------------------------------------------------- -- Predicates --------------------------------------------------------------------------------@@ -343,14 +449,9 @@   trivial; } -Prelude.Vect.reverse'_lemma_2 = proof {-    intros;-    rewrite (plusSuccRightSucc m n1);-    exact value;-}- Prelude.Vect.reverse'_lemma_1 = proof {     intros;+    rewrite prf;     rewrite sym (plusZeroRightNeutral m);     exact value; }
libs/prelude/prelude.ipkg view
@@ -1,13 +1,14 @@ package prelude  opts = "--nobuiltins --total"-modules = Builtins, Prelude, IO, +modules = Builtins, Prelude, IO,            Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,           Prelude.Classes, Prelude.Nat, Prelude.Fin, Prelude.List,           Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,           Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor,           Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,+          Prelude.Uninhabited,            Decidable.Equality
main/Main.hs view
@@ -92,10 +92,10 @@            map (\x -> '-') usagemsghdr ++ "\n" ++              "idris [OPTIONS] [FILE]\n\n" ++            "Common flags:\n" ++-           "\t    --install=IPKG          Install package\n" ++-           "\t    --clean=IPKG            Clean package\n" ++-           "\t    --build=IPKG            Build package\n" ++-           "\t    --exec=EXPR             Execute as idris\n" +++           "\t    --install IPKG          Install package\n" +++           "\t    --clean IPKG            Clean package\n" +++           "\t    --build IPKG            Build package\n" +++           "\t    --exec EXPR             Execute as idris\n" ++            "\t    --libdir                Display library directory\n" ++            "\t    --link                  Display link directory\n" ++            "\t    --include               Display the includes directory\n" ++@@ -104,7 +104,7 @@            "\t    --nocolor, --nocolour   Disable coloured output\n" ++            "\t    --errorcontent          Undocumented\n" ++            "\t    --nocoverage            Undocumented\n" ++-           "\t -o --output=FILE           Specify output file\n" +++           "\t -o --output FILE           Specify output file\n" ++            "\t    --check                 Undocumented\n" ++            "\t    --total                 Require functions to be total by default\n" ++            "\t    --partial               Undocumented\n" ++@@ -115,22 +115,22 @@            "\t    --nobasepkgs            Undocumented\n" ++            "\t    --noprelude             Undocumented\n" ++            "\t    --nobuiltins            Undocumented\n" ++-           "\t -O --level=LEVEL           Undocumented\n" ++-           "\t -i --idrispath=DIR         Add directory to the list of import paths\n" ++-           "\t    --package=ITEM          Undocumented\n" ++-           "\t    --ibcsubdir=FILE        Write IBC files into sub directory\n" ++-           "\t    --codegen=TARGET        Select code generator: C, Java, bytecode,\n" +++           "\t -O --level LEVEL           Undocumented\n" +++           "\t -i --idrispath DIR         Add directory to the list of import paths\n" +++           "\t    --package ITEM          Undocumented\n" +++           "\t    --ibcsubdir FILE        Write IBC files into sub directory\n" +++           "\t    --codegen TARGET        Select code generator: C, Java, bytecode,\n" ++            "\t                            javascript, node, or llvm\n" ++            "\t    --mvn                   Create a maven project (for Java codegen)\n" ++-           "\t    --cpu=CPU               Select tartget CPU e.g. corei7 or cortex-m3\n" +++           "\t    --cpu=CPU               Select target CPU e.g. corei7 or cortex-m3\n" ++            "\t                            (for LLVM codegen)\n" ++            "\t    --target=TRIPLE         Select target triple (for llvm codegen)\n" ++            "\t -S --codegenonly           Do no further compilation of code generator output\n" ++            "\t -c --compileonly           Compile to object files rather than an executable\n" ++-           "\t -X --extension=ITEM        Undocumented\n" +++           "\t -X --extension EXT         Turn on langage extension (TypeProviders or ErrorReflection)\n" ++            "\t    --dumpdefuns            Undocumented\n" ++            "\t    --dumpcases             Undocumented\n" ++-           "\t    --log=LEVEL --loglevel  Debugging log level\n" +++           "\t    --log LEVEL --loglevel  Debugging log level\n" ++            "\t    --ideslave              Undocumented\n" ++            "\t    --client                Undocumented\n" ++            "\t -h --help                  Display help message\n" ++
rts/Makefile view
@@ -1,11 +1,19 @@ include ../config.mk -OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o \-       idris_bitstring.o idris_net.o idris_opts.o idris_stats.o mini-gmp.o-HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_stdfgn.h \-       idris_bitstring.h idris_net.h idris_opts.h idris_stats.h mini-gmp.h+OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \+       idris_opts.o idris_stats.o mini-gmp.o+HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \+       idris_opts.h idris_stats.h mini-gmp.h CFLAGS:=-fPIC $(CFLAGS) CFLAGS += $(GMP_INCLUDE_DIR) $(GMP)++ifeq ($(OS), windows)+	OBJS += windows/idris_stdfgn.o windows/idris_net.o+	HDRS += windows/idris_stdfgn.h windows/idris_net.h+else+	OBJS += idris_stdfgn.o idris_net.o+	HDRS += idris_stdfgn.h idris_net.h+endif  LIBTARGET = libidris_rts.a
rts/idris_gc.c view
@@ -36,6 +36,9 @@     case PTR:         cl = MKPTRc(vm, x->info.ptr);         break;+    case MANAGEDPTR:+        cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);+        break;     case BITS8:         cl = idris_b8CopyForGC(vm, x);         break;
rts/idris_net.c view
@@ -75,7 +75,7 @@ }  char* idrnet_sockaddr_ipv4(void* sockaddr) {-    struct sockaddr_in* addr = (struct sockaddr_in*) addr;+    struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;     char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);     inet_ntop(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);     return ip_addr;
rts/idris_net.h view
@@ -9,6 +9,7 @@ #include <string.h> #include <sys/types.h> #include <sys/socket.h>+#include <netinet/in.h>  typedef struct idrnet_recv_result {     int result;
rts/idris_rts.c view
@@ -37,9 +37,18 @@     vm->inbox_ptr = vm->inbox;     vm->inbox_write = vm->inbox; +    // The allocation lock must be reentrant. The lock exists to ensure that+    // no memory is allocated during the message sending process, but we also+    // check the lock in calls to allocate.+    // The problem comes when we use requireAlloc to guarantee a chunk of memory+    // first: this sets the lock, and since it is not reentrant, we get a deadlock.+    pthread_mutexattr_t rec_attr;+    pthread_mutexattr_init(&rec_attr);+    pthread_mutexattr_settype(&rec_attr, PTHREAD_MUTEX_RECURSIVE);+     pthread_mutex_init(&(vm->inbox_lock), NULL);     pthread_mutex_init(&(vm->inbox_block), NULL);-    pthread_mutex_init(&(vm->alloc_lock), NULL);+    pthread_mutex_init(&(vm->alloc_lock), &rec_attr);     pthread_cond_init(&(vm->inbox_waiting), NULL);      vm->max_threads = max_threads;@@ -72,14 +81,14 @@     }      int lock = vm->processes > 0;-    if (lock) { // not message passing+    if (lock) { // We only need to lock if we're in concurrent mode        pthread_mutex_lock(&vm->alloc_lock);      } }  void idris_doneAlloc(VM* vm) {     int lock = vm->processes > 0;-    if (lock) { // not message passing+    if (lock) { // We only need to lock if we're in concurrent mode        pthread_mutex_unlock(&vm->alloc_lock);      } }@@ -178,6 +187,17 @@     return cl; } +VAL MKMPTR(VM* vm, void* ptr, int size) {+    Closure* cl = allocate(vm, sizeof(Closure) ++                               sizeof(ManagedPtr) + size, 0);+    SETTY(cl, MANAGEDPTR);+    cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));+    cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);+    memcpy(cl->info.mptr->data, ptr, size); +    cl->info.mptr->size = size;+    return cl;+}+ VAL MKFLOATc(VM* vm, double val) {     Closure* cl = allocate(vm, sizeof(Closure), 1);     SETTY(cl, FLOAT);@@ -202,6 +222,17 @@     return cl; } +VAL MKMPTRc(VM* vm, void* ptr, int size) {+    Closure* cl = allocate(vm, sizeof(Closure) ++                               sizeof(ManagedPtr) + size, 1);+    SETTY(cl, MANAGEDPTR);+    cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));+    cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);+    memcpy(cl->info.mptr->data, ptr, size); +    cl->info.mptr->size = size;+    return cl;+}+ VAL MKB8(VM* vm, uint8_t bits8) {     Closure* cl = allocate(vm, sizeof(Closure), 1);     SETTY(cl, BITS8);@@ -794,6 +825,9 @@         break;     case PTR:         cl = MKPTRc(vm, x->info.ptr);+        break;+    case MANAGEDPTR:+        cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);         break;     case BITS8:         cl = idris_b8CopyForGC(vm, x);
rts/idris_rts.h view
@@ -17,7 +17,7 @@ typedef enum {     CON, INT, BIGINT, FLOAT, STRING, STROFFSET,     BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,-    BUFFER+    MANAGEDPTR, BUFFER } ClosureType;  typedef struct Closure *VAL;@@ -40,6 +40,11 @@     unsigned char store[]; } Buffer; +// A foreign pointer, managed by the idris GC+typedef struct {+    size_t size;+    void* data;+} ManagedPtr;  typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in@@ -57,6 +62,7 @@         uint32_t bits32;         uint64_t bits64;         Buffer* buf;+        ManagedPtr* mptr;     } info; } Closure; @@ -112,6 +118,7 @@  #define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x)) #define GETPTR(x) (((VAL)(x))->info.ptr) +#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)) )@@ -163,6 +170,7 @@ VAL MKFLOAT(VM* vm, double val); VAL MKSTR(VM* vm, const char* str); VAL MKPTR(VM* vm, void* ptr);+VAL MKMPTR(VM* vm, void* ptr, int size); VAL MKB8(VM* vm, uint8_t b); VAL MKB16(VM* vm, uint16_t b); VAL MKB32(VM* vm, uint32_t b);@@ -173,6 +181,7 @@ VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr);+VAL MKMPTRc(VM* vm, void* ptr, int size); VAL MKBUFFERc(VM* vm, Buffer* buf);  char* GETSTROFF(VAL stroff);
rts/idris_stdfgn.c view
@@ -1,5 +1,10 @@ #include "idris_stdfgn.h" #include "idris_rts.h"+#include "idris_gc.h"+#include <sys/select.h>+#include <fcntl.h>+#include <stdio.h>+#include <time.h>  extern char** environ; @@ -32,6 +37,29 @@     fputs(str, f); } +int fpoll(void* h)+{+    FILE* f = (FILE*)h;+    fd_set x;+    struct timeval timeout;+    timeout.tv_sec = 1;+    timeout.tv_usec = 0;+    int fd = fileno(f);++    FD_ZERO(&x);+    FD_SET(fd, &x);++    int r = select(fd+1, &x, 0, 0, &timeout);+    return r;+}++void* do_popen(const char* cmd, const char* mode) {+    FILE* f = popen(cmd, mode);+//    int d = fileno(f);+//    fcntl(d, F_SETFL, O_NONBLOCK);+    return f;+}+ int isNull(void* ptr) {     return ptr==NULL; }@@ -46,4 +74,13 @@  char* getEnvPair(int i) {     return *(environ + i);+}++int idris_time() {+    time_t t = time(NULL);+    return (int)t;+}++void idris_forceGC(void* vm) {+   idris_gc((VM*)vm);  }
rts/idris_stdfgn.h view
@@ -12,10 +12,17 @@ int fileError(void* h); void fputStr(void*h, char* str); +void* do_popen(const char* cmd, const char* mode);+int fpoll(void* h);+ int idris_eqPtr(void* x, void* y); int isNull(void* ptr); void* idris_stdin();  char* getEnvPair(int i);++int idris_time();++void idris_forceGC();  #endif
src/IRTS/CodegenC.hs view
@@ -20,16 +20,32 @@ import System.FilePath ((</>), (<.>)) import Control.Monad -codegenC :: [(Name, SDecl)] ->-            String -> -- output file name-            OutputType ->   -- generate executable if True, only .o if False-            [FilePath] -> -- include files-            String -> -- extra object files-            String -> -- extra compiler flags (libraries)-            String -> -- extra compiler flags (anything)-            DbgLevel ->-            IO ()-codegenC defs out exec incs objs libs flags dbg+codegenC :: CodeGenerator+codegenC ci = codegenC' (simpleDecls ci)+                        (outputFile ci)+                        (outputType ci)+                        (includes ci)+                        (concatMap mkObj (compileObjs ci))+                        (concatMap mkLib (compileLibs ci) +++                            concatMap incdir (importDirs ci))+                        (concatMap mkFlag (compilerFlags ci))+                        (debugLevel ci)++  where mkObj f = f ++ " "+        mkLib l = "-l" ++ l ++ " "+        mkFlag l = l ++ " "+        incdir i = "-I" ++ i ++ " "++codegenC' :: [(Name, SDecl)] ->+             String -> -- output file name+             OutputType ->   -- generate executable if True, only .o if False+             [FilePath] -> -- include files+             String -> -- extra object files+             String -> -- extra compiler flags (libraries)+             String -> -- extra compiler flags (anything)+             DbgLevel ->+             IO ()+codegenC' defs out exec incs objs libs flags dbg     = do -- print defs          let bc = map toBC defs          let h = concatMap toDecl (map fst bc)@@ -132,10 +148,10 @@     mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"     mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"     mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"-    mkConst (B8  x) = "idris_b8const(vm, "  ++ show x ++ ")"-    mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"-    mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"-    mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"+    mkConst (B8  x) = "idris_b8const(vm, "  ++ show x ++ "U)"+    mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"+    mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"+    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)@@ -262,6 +278,7 @@ c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")" c_irts FUnit l x = x c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"+c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")" c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")" c_irts FAny l x = l ++ x @@ -272,6 +289,7 @@ irts_c FString x = "GETSTR(" ++ x ++ ")" irts_c FUnit x = x irts_c FPtr x = "GETPTR(" ++ x ++ ")"+irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")" irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")" irts_c FAny x = x @@ -470,6 +488,8 @@ doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)" doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"+doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ +                                  "), GETINT(" ++ creg i ++ "))"  doOp v (LChInt ITNative) args = v ++ creg (last args) doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args doOp v (LIntCh ITNative) args = v ++ creg (last args)
src/IRTS/CodegenCommon.hs view
@@ -2,8 +2,11 @@  import Idris.Core.TT import IRTS.Simplified+import IRTS.Defunctionalise+import IRTS.Lang  import Control.Exception+import Data.Word import System.Environment  data DbgLevel = NONE | DEBUG | TRACE deriving Eq@@ -13,3 +16,25 @@ environment x = Control.Exception.catch (do e <- getEnv x                                             return (Just e))                           (\y-> do return (y::SomeException);  return Nothing)++-- Everything which might be needed in a code generator - a CG can choose which+-- level of Decls to generate code from (simplified, defunctionalised or merely+-- lambda lifted) and has access to the list of object files, libraries, etc.++data CodegenInfo = CodegenInfo { outputFile :: String,+                                 outputType :: OutputType,+                                 targetTriple :: String,+                                 targetCPU :: String,+                                 optimisation :: Word,+                                 includes :: [FilePath],+                                 importDirs :: [FilePath],+                                 compileObjs :: [String],+                                 compileLibs :: [String],+                                 compilerFlags :: [String],+                                 debugLevel :: DbgLevel,+                                 simpleDecls :: [(Name, SDecl)],+                                 defunDecls :: [(Name, DDecl)],+                                 liftDecls :: [(Name, LDecl)] +                               } ++type CodeGenerator = CodegenInfo -> IO ()
src/IRTS/CodegenJava.hs view
@@ -34,14 +34,19 @@  ----------------------------------------------------------------------- -- Main function-codegenJava :: [(Name, SExp)] -> -- initialization of globals-               [(Name, SDecl)] -> -- decls-               FilePath -> -- output file name-               [String] -> -- headers-               [String] -> -- libs-               OutputType ->-               IO ()-codegenJava globalInit defs out hdrs libs exec =+codegenJava :: CodeGenerator+codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg)+                                 (includes cg) (compileLibs cg)+                                 (outputType cg)++codegenJava' :: [(Name, SExp)] -> -- initialization of globals+                [(Name, SDecl)] -> -- decls+                FilePath -> -- output file name+                [String] -> -- headers+                [String] -> -- libs+                OutputType ->+                IO ()+codegenJava' globalInit defs out hdrs libs exec =   withTgtDir exec out (codegenJava' exec)   where     codegenJava' :: OutputType -> FilePath -> IO ()@@ -365,17 +370,11 @@  addMainMethod :: [Decl] -> [Decl] addMainMethod decls-  | findMain decls = mkMainMethod : decls+  | findMainMethod decls = mkMainMethod : decls   | otherwise = decls   where-    findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)-      | name == mangle' (sUN "Main") = findMainMethod body-    findMain (_:decls) = findMain decls-    findMain [] = False--    innerMainMethod = (either error id $ mangle (sUN "main"))     findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)-      | name == mangle' (sUN "main") = True+      | name == mangle' (sMN 0 "runMain") = True     findMainMethod (_:decls) = findMainMethod decls     findMainMethod [] = False @@ -707,6 +706,7 @@ mkConstant c@(AType    x) = ClassLit (Just $ box (constType c)) mkConstant c@(StrType   ) = ClassLit (Just $ stringType) mkConstant c@(PtrType   ) = ClassLit (Just $ objectType)+mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType) mkConstant c@(VoidType  ) = ClassLit (Just $ voidType) mkConstant c@(Forgot    ) = ClassLit (Just $ objectType)
src/IRTS/CodegenJavaScript.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where+module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where  import Idris.AbsSyntax hiding (TypeCase) import IRTS.Bytecode@@ -14,11 +14,13 @@ import Control.Arrow import Control.Applicative ((<$>), (<*>), pure) import Data.Char+import Numeric import Data.List import Data.Maybe import System.IO import System.Directory + idrNamespace :: String idrNamespace    = "__IDR__" idrRTNamespace  = "__IDRRT__"@@ -51,6 +53,13 @@            deriving Eq  +data JSAnnotation = JSConstructor deriving Eq+++instance Show JSAnnotation where+  show JSConstructor = "constructor"++ data JS = JSRaw String         | JSIdent String         | JSFunction [String] JS@@ -71,7 +80,6 @@         | JSFalse         | JSArray [JS]         | JSString String-        | JSChar String         | JSNum JSNum         | JSAssign JS JS         | JSAlloc String (Maybe JS)@@ -80,10 +88,56 @@         | JSTernary JS JS JS         | JSParens JS         | JSWhile JS JS+        | JSFFI String [JS]+        | JSAnnotation JSAnnotation JS+        | JSNoop         deriving Eq  +data FFI = FFICode Char | FFIArg Int | FFIError String+++ffi :: String -> [String] -> String+ffi code args = let parsed = ffiParse code in+                    case ffiError parsed of+                         Just err -> error err+                         Nothing  -> renderFFI parsed args+  where+    ffiParse :: String -> [FFI]+    ffiParse ""           = []+    ffiParse ['%']        = [FFIError $ "FFI - Invalid positional argument"]+    ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss+    ffiParse ('%':s:ss)+      | isDigit s =+         FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)+      | otherwise =+          [FFIError $ "FFI - Invalid positional argument"]+    ffiParse (s:ss) = FFICode s : ffiParse ss+++    ffiError :: [FFI] -> Maybe String+    ffiError []                 = Nothing+    ffiError ((FFIError s):xs)  = Just s+    ffiError (x:xs)             = ffiError xs+++    renderFFI :: [FFI] -> [String] -> String+    renderFFI [] _ = ""+    renderFFI ((FFICode c) : fs) args = c : renderFFI fs args+    renderFFI ((FFIArg i) : fs) args+      | i < length args && i >= 0 = args !! i ++ renderFFI fs args+      | otherwise = error "FFI - Argument index out of bounds"++ compileJS :: JS -> String+compileJS JSNoop = ""++compileJS (JSAnnotation annotation js) =+  "/** @" ++ show annotation ++ " */\n" ++ compileJS js++compileJS (JSFFI raw args) =+  ffi raw (map compileJS args)+ compileJS (JSRaw code) =   code @@ -129,6 +183,9 @@ compileJS (JSBinOp op lhs rhs) =   compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs +compileJS (JSPreOp op val) =+  op ++ compileJS val+ compileJS (JSProj obj field)   | JSFunction {} <- obj =     concat ["(", compileJS obj, ").", field]@@ -156,10 +213,7 @@   "[" ++ intercalate "," (map compileJS elems) ++ "]"  compileJS (JSString str) =-  show str--compileJS (JSChar chr) =-  chr+  "\"" ++ str ++ "\""  compileJS (JSNum num)   | JSInt i                <- num = show i@@ -180,7 +234,7 @@ compileJS (JSCond branches) =   intercalate " else " $ map createIfBlock branches   where-    createIfBlock (JSTrue, e) =+    createIfBlock (JSNoop, e) =          "{\n"       ++ compileJS e       ++ ";\n}"@@ -231,6 +285,10 @@ jsAnd = JSBinOp "&&"  +jsOr :: JS -> JS -> JS+jsOr = JSBinOp "||"++ jsType :: JS jsType = JSIdent $ idrRTNamespace ++ "Type" @@ -309,6 +367,10 @@           add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds       | JSWhile cond body    <- js =           add (tr js) $ add (fold cond) (fold body)+      | JSFFI raw args       <- js =+          add (tr js) $ foldl' add acc $ map fold args+      | JSAnnotation a js    <- js =+          add (tr js) $ fold js       | otherwise                  =           tr js @@ -335,7 +397,9 @@       | JSCond conds         <- js = JSCond $ map (tr *** tr) conds       | JSTernary c t f      <- js = JSTernary (tr c) (tr t) (tr f)       | JSParens val         <- js = JSParens $ tr val-      | JSWhile cond body    <- js = JSWhile(tr cond) (tr body)+      | JSWhile cond body    <- js = JSWhile (tr cond) (tr body)+      | JSFFI raw args       <- js = JSFFI raw (map tr args)+      | JSAnnotation a js    <- js = JSAnnotation a (tr js)       | otherwise                  = js  @@ -343,6 +407,9 @@ moveJSDeclToTop decl js = move ([], js)   where     move :: ([JS], [JS]) -> [JS]+    move (front, js@(JSAnnotation _ (JSAlloc name _)):back)+      | name == decl = js : front ++ back+     move (front, js@(JSAlloc name _):back)       | name == decl = js : front ++ back @@ -410,7 +477,6 @@ isJSConstant :: JS -> Bool isJSConstant js   | JSString _   <- js = True-  | JSChar _     <- js = True   | JSNum _      <- js = True   | JSType _     <- js = True   | JSNull       <- js = True@@ -428,7 +494,8 @@       all (isJSConstantConstructor constants) vals   | JSNew "__IDRRT__Con" args <- js =       all (isJSConstantConstructor constants) args-  | JSIndex (JSProj (JSIdent _) "vars") (JSNum _) <- js =+  | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js+  , name `elem` constants =       True   | JSIdent name <- js   , name `elem` constants =@@ -437,82 +504,101 @@   inlineJS :: JS -> JS-inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err-inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =-  inlineJS $ jsSubst (JSIdent "cse") val body+inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet+  where+    inlineJSLet :: JS -> JS+    inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])+      | opt <- inlineJSLet val =+          inlineJS $ jsSubst (JSIdent arg) opt ret +    inlineJSLet js = transformJS inlineJSLet js -inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =-  inlineJS $ JSSeq [ JSAlloc arg (Just val)-                   , cond-                   ] -inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [-    JSThis,JSProj var "vars"-  ])-  | var /= JSIdent "cse" =-      inlineJS $ inlineApply args body 0-  where-    inlineApply []     body _ = inlineJS body-    inlineApply (a:as) body n =-      inlineApply as (-        jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body-      ) (n + 1)+    inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))+      | opt <- inlineCaseMatch val =+          inlineCaseMatch $ jsSubst (JSIdent "cse") opt body -inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])-  | isJSConstant val = val+    inlineCaseMatch js = transformJS inlineCaseMatch js -inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [-    JSFunction [] (JSReturn val)-  ])-  | isJSConstant val = val -inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])-  | JSNew con [tag, vals] <- ret-  , opt <- inlineJS val =-      inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]+    inlineApply js+      | JSApp (+          JSProj (JSFunction args (JSReturn body)) "apply"+        ) [JSThis, JSProj var "vars"] <- js =+          inlineApply $ inlineApply' var args body 0+      | JSReturn (JSApp  (+          JSProj (JSFunction args body@(JSCond _)) "apply"+        ) [JSThis, JSProj var "vars"]) <- js =+          inlineApply $ inlineApply' var args body 0+      where+        inlineApply' _   []     body _ = body+        inlineApply' var (a:as) body n =+          inlineApply' var as (+            jsSubst (JSIdent a) (+              JSIndex (JSProj var "vars") (JSNum (JSInt n))+            ) body+          ) (n + 1) -  | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret-  , opt <- inlineJS val =-      inlineJS $ JSNew con [JSFunction [] (-        JSReturn (-          JSApp (-            inlineJS $ jsSubst (JSIdent arg) opt fun-          ) (-            map (inlineJS . jsSubst (JSIdent arg) opt) vars-          )-        )-      )]+    inlineApply js = transformJS inlineApply js -  | JSApp (JSProj obj field) args <- ret-  , opt <- inlineJS val =-      inlineJS $ JSApp (-        inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field-      ) (-        map (inlineJS . jsSubst (JSIdent arg) opt) args-      ) -  | JSIndex (JSProj obj field) idx <- ret-  , opt <- inlineJS val =-      inlineJS $ JSIndex (JSProj (-          inlineJS $ jsSubst (JSIdent arg) opt obj-        ) field-      ) (inlineJS $ jsSubst (JSIdent arg) opt idx)+    inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =+      inlineError error -  | JSBinOp op lhs rhs <- ret-  , opt <- inlineJS val =-      inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $-        (inlineJS $ jsSubst (JSIdent arg) opt rhs)+    inlineError js = transformJS inlineError js -  | JSApp (JSIdent fun) args <- ret-  , opt <- inlineJS val =-      inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args -inlineJS js = transformJS inlineJS js+    inlineAssign (JSAssign lhs rhs)+      | JSVar _ <- lhs+      , JSVar _ <- rhs+      , lhs == rhs =+          lhs +    inlineAssign (JSAssign lhs rhs)+      | JSIdent _ <- lhs+      , JSIdent _ <- rhs+      , lhs == rhs =+          lhs +    inlineAssign js = transformJS inlineAssign js+++removeEval :: [JS] -> [JS]+removeEval js =+  let (ret, isReduced) = checkEval js in+      if isReduced+          then removeEvalApp ret+          else ret+  where+    removeEvalApp js = catMaybes (map removeEvalApp' js)+      where+        removeEvalApp' :: JS -> Maybe JS+        removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing+        removeEvalApp' js = Just $ transformJS match js+          where+            match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val+            match js = transformJS match js++    checkEval :: [JS] -> ([JS], Bool)+    checkEval js = foldr f ([], False) $ map checkEval' js+      where+        f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)+        f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)+        f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)+++        checkEval' :: JS -> (Maybe JS, Bool)+        checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (+            JSSeq [ _+                  , JSReturn (JSIdent "t")+                  ]+          )) []))) = (Nothing, True)++        checkEval' js = (Just js, False)++ reduceJS :: [JS] -> [JS]-reduceJS js = reduceLoop [] ([], js)+reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)   funName :: JS -> String@@ -636,7 +722,7 @@   inlineHelper ([], js)   where     inlineHelper :: ([JS], [JS]) -> [JS]-    inlineHelper (front , (JSAlloc fun (Just (JSFunction  args body))):back)+    inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)       | countAll fun front + countAll fun back == 0 =          inlineHelper (front, back)       | Just new <- inlineAble (@@ -713,16 +799,31 @@   reduceContinuations :: JS -> JS-reduceContinuations = transformJS reduceHelper+reduceContinuations = inlineTC . reduceJS   where-    reduceHelper :: JS -> JS-    reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (+    reduceJS :: JS -> JS+    reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (         JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])-      )]) = js+      )]) = reduceJS js -    reduceHelper js = transformJS reduceHelper js+    reduceJS js = transformJS reduceJS js  +    inlineTC :: JS -> JS+    inlineTC js+      | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+            JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (+              JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (+                  JSReturn (JSNew "__IDRRT__Cont" _)+              )])+            )])+          )] <- js = inlineTC ret++    inlineTC js = transformJS inlineTC js++++ reduceConstant :: JS -> JS reduceConstant   (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (@@ -811,19 +912,16 @@      optTC tc@"__IDRRT__APPLYTC" =       JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (-        JSSeq [ JSAlloc "ev" $ Just (JSApp-                  (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]-                )-              , JSAlloc "ret" $ Just (+        JSSeq [ JSAlloc "ret" $ Just (                   JSTernary (-                    (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`-                    (hasProp "__IDRLT__APPLY" "ev")+                    (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`+                    (hasProp "__IDRLT__APPLY" "fn0")                   ) (JSApp                       (JSIndex                         (JSIdent "__IDRLT__APPLY")-                        (JSProj (JSIdent "ev") "tag")+                        (JSProj (JSIdent "fn0") "tag")                       )-                      [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]+                      [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]                   ) JSNull                 )               , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (@@ -850,23 +948,129 @@   where     adaptRuntime :: [JS] -> [JS]     adaptRuntime =-      adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval+      adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon  -    adaptApply var = map (jsSubst (-        JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")-      ) (JSProj (JSIdent var) "app"))+    adaptApply :: [JS] -> [JS]+    adaptApply js = adaptApply' [] js+      where+        adaptApply' :: [JS] -> [JS] -> [JS]+        adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =+          front ++ (new:back) +        adaptApply' front (next:back) =+          adaptApply' (front ++ [next]) back -    adaptEval = map (jsSubst (-        JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")-      ) (JSProj (JSIdent "arg0") "eval"))+        adaptApply' front [] = front +        new =+          JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $+              JSTernary (+                (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`+                (JSProj (JSIdent "mfn0") "app")+              ) (JSApp+                  (JSProj (JSIdent "mfn0") "app")+                  [JSIdent "mfn0", JSIdent "marg0"]+              ) JSNull+            )+          ) ++    adaptApplyTC :: [JS] -> [JS]+    adaptApplyTC js = adaptApplyTC' [] js+      where+        adaptApplyTC' :: [JS] -> [JS] -> [JS]+        adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =+          front ++ (new:back)++        adaptApplyTC' front (next:back) =+          adaptApplyTC' (front ++ [next]) back++        adaptApplyTC' front [] = front++        new =+          JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (+            JSSeq [ JSAlloc "ret" $ Just (+                      JSTernary (+                        (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`+                        (JSProj (JSIdent "mfn0") "app")+                      ) (JSApp+                          (JSProj (JSIdent "mfn0") "app")+                          [JSIdent "mfn0", JSIdent "marg0"]+                      ) JSNull+                    )+                  , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (+                      JSAssign (JSIdent "ret") (+                        JSApp (JSProj (JSIdent "ret") "k") []+                      )+                    )+                  , JSReturn $ JSIdent "ret"+                  ]+          ))+++    adaptEval :: [JS] -> [JS]+    adaptEval js = adaptEval' [] js+      where+        adaptEval' :: [JS] -> [JS] -> [JS]+        adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =+          front ++ (new:back)++        adaptEval' front (next:back) =+          adaptEval' (front ++ [next]) back++        adaptEval' front [] = front++        new =+          JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $+              JSTernary (+                (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`+                (JSProj (JSIdent "marg0") "eval")+              ) (JSApp+                  (JSProj (JSIdent "marg0") "eval")+                  [JSIdent "marg0"]+              ) (JSIdent "marg0")+            )+          )+++    adaptEvalTC :: [JS] -> [JS]+    adaptEvalTC js = adaptEvalTC' [] js+      where+        adaptEvalTC' :: [JS] -> [JS] -> [JS]+        adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =+          front ++ (new:back)++        adaptEvalTC' front (next:back) =+          adaptEvalTC' (front ++ [next]) back++        adaptEvalTC' front [] = front++        new =+          JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (+            JSSeq [ JSAlloc "ret" $ Just (+                      JSTernary (+                        (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`+                        (JSProj (JSIdent "marg0") "eval")+                      ) (JSApp+                          (JSProj (JSIdent "marg0") "eval")+                          [JSIdent "marg0"]+                      ) (JSIdent "marg0")+                    )+                  , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (+                      JSAssign (JSIdent "ret") (+                        JSApp (JSProj (JSIdent "ret") "k") []+                      )+                    )+                  , JSReturn $ JSIdent "ret"+                  ]+          ))++     adaptCon js =       adaptCon' [] js       where-        adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =+        adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =           front ++ (new:back)          adaptCon' front (next:back) =@@ -876,11 +1080,12 @@           new =-          JSAlloc "__IDRRT__Con" (Just $-            JSFunction newArgs (-              JSSeq (map newVar newArgs)+          JSAnnotation JSConstructor $+            JSAlloc "__IDRRT__Con" (Just $+              JSFunction newArgs (+                JSSeq (map newVar newArgs)+              )             )-          )           where             newVar var = JSAssign (JSProj JSThis var) (JSIdent var)             newArgs = ["tag", "eval", "app", "vars"]@@ -930,6 +1135,7 @@             | fun == lt = (js, front ++ back)            extractLT' (front, js:back) = extractLT' (front ++ [js], back)+          extractLT' (front, back)    = (JSNoop, front ++ back)       expandLT :: String -> JS -> [(Int, JS)]@@ -943,7 +1149,9 @@              expandEntry js = Nothing +    expandLT lt JSNoop = [] + removeInstanceChecks :: JS -> JS removeInstanceChecks (JSCond conds) =   JSCond $ eliminateDeadBranches $ map (@@ -956,8 +1164,8 @@     removeHelper js = js  -    eliminateDeadBranches (e@(JSTrue, _):_) = [e]-    eliminateDeadBranches [(_, js)]         = [(JSTrue, js)]+    eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]+    eliminateDeadBranches [(_, js)]         = [(JSNoop, js)]     eliminateDeadBranches (x:xs)            = x : eliminateDeadBranches xs     eliminateDeadBranches []                = [] @@ -1008,15 +1216,6 @@         reduceCall funs js = transformJS (reduceCall funs) js  -optimizeJS :: JS -> JS-optimizeJS = inlineLoop-  where inlineLoop :: JS -> JS-        inlineLoop js-          | opt <- inlineJS js-          , opt /= js = inlineLoop opt-          | otherwise = js-- extractLocalConstructors :: [JS] -> [JS] extractLocalConstructors js =   concatMap extractLocalConstructors' js@@ -1027,7 +1226,7 @@      extractLocalConstructors' :: JS -> [JS]     extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =-      map allocCon cons ++ [foldr (uncurry jsSubst) js (reverse cons)]+      addCons cons [foldr (uncurry jsSubst) js (reverse cons)]       where         cons :: [(JS, JS)]         cons = zipWith genName (foldJS match (++) [] body) [1..]@@ -1043,6 +1242,24 @@               | otherwise           = []  +        addCons :: [(JS, JS)] -> [JS] -> [JS]+        addCons [] js = js+        addCons (con@(_, name):cons) js+          | sum (map (countOccur name) js) > 0 =+              addCons cons ((allocCon con) : js)+          | otherwise =+              addCons cons js+++        countOccur :: JS -> JS -> Int+        countOccur ident js = foldJS match (+) 0 js+          where+            match :: JS -> Int+            match js+              | js == ident = 1+              | otherwise   = 0++         allocCon :: (JS, JS) -> JS         allocCon (js, JSIdent name) =           JSAlloc name (Just js)@@ -1169,27 +1386,37 @@           []  -codegenJavaScript+getIncludes :: [FilePath] -> IO [String]+getIncludes = mapM readFile++codegenJavaScript :: CodeGenerator+codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)+                              (includes ci) (outputFile ci) (outputType ci)++codegenNode :: CodeGenerator+codegenNode ci = codegenJS_all Node (simpleDecls ci)+                        (includes ci) (outputFile ci) (outputType ci)++codegenJS_all   :: JSTarget   -> [(Name, SDecl)]+  -> [FilePath]   -> FilePath   -> OutputType   -> IO ()-codegenJavaScript target definitions filename outputType = do-  let (header, runtime) = case target of+codegenJS_all target definitions includes filename outputType = do+  let (header, rt) = case target of                                Node ->                                  ("#!/usr/bin/env node\n", "-node")                                JavaScript ->                                  ("", "-browser")+  included   <- getIncludes includes   path       <- (++) <$> getDataDir <*> (pure "/jsrts/")   idrRuntime <- readFile $ path ++ "Runtime-common.js"-  tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]+  tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]   jsbn       <- readFile $ path ++ "jsbn/jsbn.js"   writeFile filename $ header ++ (-    intercalate "\n" $ [ jsbn-                       , idrRuntime-                       , tgtRuntime-                       ] ++ functions+      intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions     )    setPermissions filename (emptyPermissions { readable   = True@@ -1201,18 +1428,36 @@     def = map (first translateNamespace) definitions  -    functions :: [String]-    functions = translate >>> optimize >>> compile $ def+    checkForBigInt :: [JS] -> Bool+    checkForBigInt js = occur       where+        occur :: Bool+        occur = or $ map (foldJS match (||) False) js++        match :: JS -> Bool+        match (JSIdent "__IDRRT__bigInt") = True+        match (JSNum (JSInteger _))       = True+        match js                          = False+++    runtime :: String -> String -> String -> [String]+    runtime jsbn idrRuntime tgtRuntime =+      if checkForBigInt optimized+         then [jsbn, idrRuntime, tgtRuntime]+         else [idrRuntime, tgtRuntime]+++    optimized :: [JS]+    optimized = translate >>> optimize $ def+      where         translate p =           prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]         optimize p  =           foldl' (flip ($)) p opt-        compile     =-           map compileJS          opt =-          [ map optimizeJS+          [ removeEval+          , map inlineJS           , removeIDs           , reduceJS           , map reduceConstants@@ -1230,16 +1475,21 @@           , evalCons           ] +    functions :: [String]+    functions = map compileJS optimized+     prelude :: [JS]     prelude =-      [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (-          JSAssign (JSProj JSThis "k") (JSIdent "k")-        ))-      , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (-          JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")-                , JSAssign (JSProj JSThis "vars") (JSIdent "vars")-                ]-        ))+      [ JSAnnotation JSConstructor $+          JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (+            JSAssign (JSProj JSThis "k") (JSIdent "k")+          ))+      , JSAnnotation JSConstructor $+          JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (+            JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")+                  , JSAssign (JSProj JSThis "vars") (JSIdent "vars")+                  ]+          ))       ]      mainLoop :: JS@@ -1247,17 +1497,25 @@       JSAlloc "main" $ Just $ JSFunction [] (         case target of              Node       -> mainFun-             JavaScript -> jsMeth (JSIdent "window") "addEventListener" [+             JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [                  JSString "DOMContentLoaded", JSFunction [] (                    mainFun                  ), JSFalse-               ]+               ])]       )       where         mainFun :: JS         mainFun = jsTailcall $ jsCall runMain []  +        isReady :: JS+        isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"+++        readyState :: JS+        readyState = JSProj (JSIdent "document") "readyState"++         runMain :: String         runMain = idrNamespace ++ translateName (sMN 0 "runMain") @@ -1360,11 +1618,8 @@ translateConstant :: Const -> JS translateConstant (I i)                    = JSNum (JSInt i) translateConstant (Fl f)                   = JSNum (JSFloat f)-translateConstant (Ch '\DEL')              = JSChar "'\\u007F'"-translateConstant (Ch '\a')                = JSChar "'\\u0007'"-translateConstant (Ch '\SO')               = JSChar "'\\u000E'"-translateConstant (Ch c)                   = JSString [c]-translateConstant (Str s)                  = JSString s+translateConstant (Ch c)                   = JSString $ translateChar c+translateConstant (Str s)                  = JSString $ concatMap translateChar s translateConstant (AType (ATInt ITNative)) = JSType JSIntTy translateConstant StrType                  = JSType JSStringTy translateConstant (AType (ATInt ITBig))    = JSType JSIntegerTy@@ -1377,44 +1632,72 @@   jsError $ "Unimplemented Constant: " ++ show c  +translateChar :: Char -> String+translateChar ch+  | '\a'   <- ch       = "\\u0007"+  | '\b'   <- ch       = "\\b"+  | '\f'   <- ch       = "\\f"+  | '\n'   <- ch       = "\\n"+  | '\r'   <- ch       = "\\r"+  | '\t'   <- ch       = "\\t"+  | '\v'   <- ch       = "\\v"+  | '\SO'  <- ch       = "\\u000E"+  | '\DEL' <- ch       = "\\u007F"+  | '\\'   <- ch       = "\\\\"+  | '\"'   <- ch       = "\\\""+  | '\''   <- ch       = "\\\'"+  | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")+  | otherwise          = [ch]+  where+    fill :: String -> String+    fill s = if length s == 1+                then '0' : s+                else s++    asciiTab =+      ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',+       '\BS',  '\HT',  '\LF',  '\VT',  '\FF',  '\CR',  '\SO',  '\SI',+       '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',+       '\CAN', '\EM',  '\SUB', '\ESC', '\FS',  '\GS',  '\RS',  '\US']++ translateDeclaration :: (String, SDecl) -> [JS] translateDeclaration (path, SFun name params stackSize body)   | (MN _ ap)             <- name-  , (SLet var val next)   <- body-  , (SChkCase cvar cases) <- next+  , (SChkCase var cases) <- body   , ap == txt "APPLY" =-    let lvar     = translateVariableName var-        lookup t = (JSApp-            (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))-            [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in-        [ lookupTable "APPLY" [(var, "chk")] var cases-        , jsDecl $ JSFunction ["fn0", "arg0"] (-            JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")-                  , JSAlloc (translateVariableName var) (-                      Just $ translateExpression val-                    )-                  , JSReturn $ (JSTernary (-                       (JSVar var `jsInstanceOf` jsCon) `jsAnd`-                       (hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))-                    ) (lookup (idrLTNamespace ++ "APPLY")) JSNull)-                  ]-          )-        ]+      [ lookupTable "APPLY" [] var cases+      , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $+          JSTernary (+            (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`+            (hasProp (idrLTNamespace ++ "APPLY") "mfn0")+          ) (JSApp+              (JSIndex+                (JSIdent (idrLTNamespace ++ "APPLY"))+                (JSProj (JSIdent "mfn0") "tag")+              )+              [JSIdent "mfn0", JSIdent "marg0"]+          ) JSNull+        )+      ]    | (MN _ ev)            <- name   , (SChkCase var cases) <- body   , ev == txt "EVAL" =-    [ lookupTable "EVAL" [] var cases-    , jsDecl $ JSFunction ["arg0"] (JSReturn $-        JSTernary (-          (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-          (hasProp (idrLTNamespace ++ "EVAL") "arg0")-        ) (JSApp-            (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))-            [JSIdent "arg0"]-        ) (JSIdent "arg0")-      )-    ]+      [ lookupTable "EVAL" [] var cases+      , jsDecl $ JSFunction ["marg0"] (JSReturn $+          JSTernary (+            (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`+            (hasProp (idrLTNamespace ++ "EVAL") "marg0")+          ) (JSApp+              (JSIndex+                (JSIdent (idrLTNamespace ++ "EVAL"))+                (JSProj (JSIdent "marg0") "tag")+              )+              [JSIdent "marg0"]+          ) (JSIdent "marg0")+        )+      ]   | otherwise =     let fun = translateExpression body in         [jsDecl $ jsFun fun]@@ -1593,7 +1876,7 @@   | (LASHR _)   <- op   , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs   | (LCompl _)  <- op-  , (arg:_)     <- vars = JSRaw $ '~' : translateVariableName arg+  , (arg:_)     <- vars = JSPreOp "~" (JSVar arg)    | LStrConcat  <- op   , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs@@ -1662,7 +1945,10 @@   , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)   | LStrTail    <- op   , (arg:_)     <- vars = let v = translateVariableName arg in-                              JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"+                              JSApp (JSProj (JSIdent v) "substr") [+                                JSNum (JSInt 1),+                                JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))+                              ]   | LNullPtr    <- op   , (_)         <- vars = JSNull @@ -1680,17 +1966,30 @@ translateExpression (SForeign _ _ "putStr" [(FString, var)]) =   jsCall (idrRTNamespace ++ "print") [JSVar var] +translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =+  JSBinOp "==" (JSVar var) JSNull++translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =+  JSBinOp "==" (JSVar lhs) (JSVar rhs)++translateExpression (SForeign _ _ "idris_time" []) =+  JSRaw "(new Date()).getTime()"+ translateExpression (SForeign _ _ fun args) =-  ffi fun (map generateWrapper args)+  JSFFI fun (map generateWrapper args)   where     generateWrapper (ffunc, name)       | FFunction   <- ffunc =-        idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"+          JSApp (+            JSIdent $ idrRTNamespace ++ "ffiWrap"+          ) [JSIdent $ translateVariableName name]       | FFunctionIO <- ffunc =-        idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"+          JSApp (+            JSIdent $ idrRTNamespace ++ "ffiWrap"+          ) [JSIdent $ translateVariableName name]      generateWrapper (_, name) =-      translateVariableName name+      JSIdent $ translateVariableName name  translateExpression patterncase   | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"@@ -1731,41 +2030,6 @@  translateExpression e =   jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)---data FFI = FFICode Char | FFIArg Int | FFIError String---ffi :: String -> [String] -> JS-ffi code args = let parsed = ffiParse code in-                    case ffiError parsed of-                         Just err -> jsError err-                         Nothing  -> JSRaw $ renderFFI parsed args-  where-    ffiParse :: String -> [FFI]-    ffiParse ""           = []-    ffiParse ['%']        = [FFIError "Invalid positional argument"]-    ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss-    ffiParse ('%':s:ss)-      | isDigit s =-         FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)-      | otherwise =-          [FFIError "Invalid positional argument"]-    ffiParse (s:ss) = FFICode s : ffiParse ss---    ffiError :: [FFI] -> Maybe String-    ffiError []                 = Nothing-    ffiError ((FFIError s):xs)  = Just s-    ffiError (x:xs)             = ffiError xs---    renderFFI :: [FFI] -> [String] -> String-    renderFFI [] _ = ""-    renderFFI ((FFICode c) : fs) args = c : renderFFI fs args-    renderFFI ((FFIArg i) : fs) args-      | i < length args && i >= 0 = args !! i ++ renderFFI fs args-      | otherwise = "Argument index out of bounds"   data CaseType = ConCase Int
src/IRTS/CodegenLLVM.hs view
@@ -58,14 +58,19 @@  data Target = Target { triple :: String, dataLayout :: DataLayout } -codegenLLVM :: [(TT.Name, SDecl)] ->-               String -> -- target triple-               String -> -- target CPU-               Word -> -- Optimization degree-               FilePath -> -- output file name-               OutputType ->-               IO ()-codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do+codegenLLVM :: CodeGenerator+codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)+                              (targetCPU ci) (optimisation ci)+                              (outputFile ci) (outputType ci)++codegenLLVM' :: [(TT.Name, SDecl)] ->+                String -> -- target triple+                String -> -- target CPU+                Word -> -- Optimization degree+                FilePath -> -- output file name+                OutputType ->+                IO ()+codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do   initializeAllTargets   (target, _) <- failInIO $ lookupTarget Nothing triple   withTargetOptions $ \options ->@@ -524,7 +529,7 @@            terminate $ CondBr isNull endBBN notNullBBN []            newBlock notNullBBN            ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []-           flag <- inst $ loadInv ptr+           flag <- inst $ Load False ptr Nothing 0 []            isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []            conBBN <- getName "constructor"            terminate $ CondBr isVal endBBN conBBN []@@ -551,7 +556,7 @@                   , ConstantOperand (C.Int 32 1)                   , ConstantOperand (C.Int 32 (fromIntegral idx))                   ] []-           Just <$> inst (loadInv ptr)+           Just <$> inst (Load False ptr Nothing 0 []) cgExpr (SConst c) = Just <$> cgConst c cgExpr (SForeign LANG_C rty fname args) = do   func <- ensureCDecl fname rty (map fst args)@@ -630,7 +635,7 @@                  SConstCase (TT.Ch _)  _ -> IntegerType 32   realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []   valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []-  caseVal <- inst $ loadInv valPtr+  caseVal <- inst $ Load False valPtr Nothing 0 []   defBlockName <- getName "default"   exitBlockName <- getName "caseExit"   namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts@@ -643,7 +648,7 @@ cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) cgConCase con defExp alts = do   tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []-  tag <- inst $ loadInv tagPtr+  tag <- inst $ Load False tagPtr Nothing 0 []   defBlockName <- getName "default"   exitBlockName <- getName "caseExit"   namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts@@ -729,7 +734,7 @@                       do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)                                                               , ConstantOperand (C.Int 32 1)                                                               , ConstantOperand (C.Int 32 i)] []-                         Just <$> ninst argName (loadInv ptr)+                         Just <$> ninst argName (Load False ptr Nothing 0 [])   altVal <- binds locals $ cgExpr exp   altEnv <- gets lexenv   altBlock <- gets currentBlockName@@ -783,7 +788,7 @@ unbox fty bval = do   val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []   fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []-  inst $ loadInv fvalptr+  inst $ Load False fvalptr Nothing 0 []  cgConst' :: TT.Const -> C.Constant cgConst' (TT.I i) = C.Int 32 (fromIntegral i)@@ -1124,7 +1129,7 @@  cgOp LStrHead [c] = do   s <- unbox FString c-  c <- inst $ loadInv s+  c <- inst $ Load False s Nothing 0 []   c' <- inst $ ZExt c (IntegerType 32) []   box (FArith (ATInt ITChar)) c' @@ -1132,7 +1137,7 @@   ns <- unbox FString s   ni <- unbox (FArith (ATInt (ITFixed IT32))) i   p <- inst $ GetElementPtr True ns [ni] []-  c <- inst $ loadInv p+  c <- inst $ Load False p Nothing 0 []   c' <- inst $ ZExt c (IntegerType 32) []   box (FArith (ATInt ITChar)) c'
src/IRTS/Compiler.hs view
@@ -71,25 +71,22 @@         case dumpDefun of             Nothing -> return ()             Just f -> runIO $ writeFile f (dumpDefuns defuns)-        triple <- targetTriple-        cpu <- targetCPU-        optimize <- optLevel+        triple <- Idris.AbsSyntax.targetTriple+        cpu <- Idris.AbsSyntax.targetCPU+        optimise <- optLevel         iLOG "Building output"+         case checked of-            OK c -> runIO $ case codegen of-                              ViaC ->-                                  codegenC c f outty hdrs-                                    (concatMap mkObj objs)-                                    (concatMap mkLib libs)-                                    (concatMap mkFlag flags ++-                                     concatMap incdir impdirs) NONE-                              ViaJava ->-                                  codegenJava [] c f hdrs libs outty-                              ViaJavaScript ->-                                  codegenJavaScript JavaScript c f outty-                              ViaNode ->-                                  codegenJavaScript Node c f outty-                              ViaLLVM -> codegenLLVM c triple cpu optimize f outty+            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             Error e -> ierror e   where checkMVs = do i <- getIState@@ -99,13 +96,7 @@         inDir d h = do let f = d </> h                        ex <- doesFileExist f                        if ex then return f else return h-        mkObj f = f ++ " "-        mkLib l = "-l" ++ l ++ " "-        mkFlag l = l ++ " " -        incdir i = "-I" ++ i ++ " "-- irMain :: TT Name -> Idris LDecl irMain tm = do i <- ir tm                return $ LFun [] (sMN 0 "runMain") [] (LForce i)@@ -163,7 +154,7 @@             return (declArgs [] (case_inlinable ci) n e) mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a-mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))+mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run  instance ToIR (TT Name) where     ir tm = ir' [] tm where@@ -178,10 +169,25 @@           | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,             r == txt "replace"               = ir' env arg+          -- Laziness, the old way           | (P _ (UN l) _, [_, arg]) <- unApply tm,             l == txt "lazy"               = do arg' <- ir' env arg+                   error "lazy has crept in somehow"+--                    return $ LLazyExp arg'+          | (P _ (UN l) _, [_, arg]) <- unApply tm,+            l == txt "force"+              = do arg' <- ir' env arg+                   return $ LForce arg'+          -- Laziness, the new way+          | (P _ (UN l) _, [arg]) <- unApply tm,+            l == txt "Delay"+              = do arg' <- ir' env arg                    return $ LLazyExp arg'+          | (P _ (UN l) _, [_, _, arg]) <- unApply tm,+            l == txt "Force"+              = do arg' <- ir' env arg+                   return $ LForce arg'           | (P _ (UN a) _, [_, _, arg]) <- unApply tm,             a == txt "assert_smaller"               = ir' env arg@@ -205,9 +211,16 @@             tm == txt "trace_malloc"               = do t' <- ir' env t                    return t' -- TODO---           | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm---               = do k' <- ir' env k---                    return (LOp LBPlus [k', LConst (BI 1)])+          -- This case is here until we get more general inlining. It's just+          -- a really common case, and the laziness hurts...+          | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),+                                            (App (P _ (UN d') _) e)]) <- unApply tm,+            be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"+               = do x' <- ir' env x+                    t' <- ir' env t+                    e' <- ir' env e+                    return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',+                                      LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])           | (P (DCon t a) n _, args) <- unApply tm               = irCon env t a n args           | (P (TCon t a) n _, args) <- unApply tm@@ -327,6 +340,7 @@ mkIty "FBits64"     = mkIntIty "IT64" mkIty "FString"     = FString mkIty "FPtr"        = FPtr+mkIty "FManagedPtr" = FManagedPtr mkIty "FUnit"       = FUnit mkIty "FFunction"   = FFunction mkIty "FFunctionIO" = FFunctionIO
src/IRTS/Defunctionalise.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternGuards #-}+ module IRTS.Defunctionalise(module IRTS.Defunctionalise,                             module IRTS.Lang) where @@ -41,11 +43,14 @@ defunctionalise nexttag defs      = let all = toAlist defs            -- sort newcons so that EVAL and APPLY cons get sequential tags-           (allD, enames) = runState (mapM (addApps defs) all) []-           newcons = sortBy conord $ concatMap (toCons enames) (getFn all)-           eval = mkEval newcons-           app = mkApply newcons-           condecls = declare nexttag newcons in+           (allD, (enames, anames)) = runState (mapM (addApps defs) all) ([], [])+           anames' = sort (nub anames)+           enames' = nub enames+           newecons = sortBy conord $ concatMap (toCons enames') (getFn all)+           newacons = sortBy conord $ concatMap (toConsA anames') (getFn all)+           eval = mkEval newecons+           app = mkApply newacons+           condecls = declare nexttag (newecons ++ newacons) in            addAlist (eval : app : condecls ++ allD) emptyContext    where conord (n, _, _) (n', _, _) = compare n n' @@ -67,17 +72,16 @@ -- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY -- 8 Add explicit EVAL to case, primitives, and foreign calls -addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)+addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl) addApps defs o@(n, LConstructor _ t a)     = return (n, DConstructor n t a) addApps defs (n, LFun _ _ args e)     = do e' <- aa args e          return (n, DFun n args e')   where-    aa :: [Name] -> LExp -> State [Name] DExp+    aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp     aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n)                          | otherwise = aa env (LApp False (LV (Glob n)) [])---     aa env e@(LApp tc (MN 0 "EVAL") [a]) = e     aa env (LApp tc (LV (Glob n)) args)        = do args' <- mapM (aa env) args             case lookupCtxtExact n defs of@@ -98,22 +102,22 @@     aa env (LCon i n args) = liftM (DC 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 (eEVAL t')) i+                            return $ DProj (DUpdate n t') i     aa env (LProj t i) = do t' <- aa env t-                            return $ DProj (eEVAL t') i+                            return $ DProj t' i     aa env (LCase e alts) = do e' <- aa env e                                alts' <- mapM (aaAlt env) alts-                               return $ DCase (eEVAL e') alts'+                               return $ DCase 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)     aa env (LOp f args) = do args' <- mapM (aa env) args-                             return $ DOp f (map eEVAL args')+                             return $ DOp f args'     aa env LNothing = return DNothing     aa env (LError e) = return $ DError e      aaF env (t, e) = do e' <- aa env e-                        return (t, eEVAL e')+                        return (t, e')      aaAlt env (LConCase i n args e)          = liftM (DConCase i n args) (aa (args ++ env) e)@@ -124,20 +128,22 @@         | length args == ar              = return $ DApp tc n args         | length args < ar-             = do ns <- get-                  put $ nub (n : ns)+             = do (ens, ans) <- get+                  let alln = map (\x -> (n, x)) [length args .. ar] +                  put (ens, alln ++ ans)                   return $ DApp tc (mkUnderCon n (ar - length args)) args         | length args > ar              = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)      fixLazyApply n args ar         | length args == ar-             = do ns <- get-                  put $ nub (n : ns)+             = do (ens, ans) <- get+                  put (n : ens, ans)                   return $ DApp False (mkFnCon n) args         | length args < ar-             = do ns <- get-                  put $ nub (n : ns)+             = do (ens, ans) <- get+                  let alln = map (\x -> (n, x)) [length args .. ar] +                  put (ens, alln ++ ans)                   return $ DApp False (mkUnderCon n (ar - length args)) args         | length args > ar              = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)@@ -150,7 +156,7 @@      preEval [] t = t     preEval (x : xs) t-       | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t)+       | needsEval x t = DLet x (DV (Glob x)) (preEval xs t)        | otherwise = preEval xs t      needsEval x (DApp _ _ args) = or (map (needsEval x) args)@@ -175,7 +181,6 @@  data EvalApply a = EvalCase (Name -> a)                  | ApplyCase a---     deriving Show  -- For a function name, generate a list of -- data constuctors, and whether to handle them in EVAL or APPLY@@ -187,11 +192,23 @@           EvalCase (\tlarg ->             (DConCase (-1) (mkFnCon n) (take i (genArgs 0))               (dupdate tlarg-                (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))))-          : mkApplyCase n 0 i+                (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))+          : [] -- mkApplyCase n 0 i     | otherwise = []   where dupdate tlarg x = x +toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]+toConsA ns (n, i)+    | Just ar <- lookup n ns+--       = (mkFnCon n, i,+--           EvalCase (\tlarg ->+--             (DConCase (-1) (mkFnCon n) (take i (genArgs 0))+--               (dupdate tlarg+--                 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))+          = mkApplyCase n ar i+    | otherwise = []+  where dupdate tlarg x = x+ mkApplyCase fname n ar | n == ar = [] mkApplyCase fname n ar         = let nm = mkUnderCon fname (ar - n) in@@ -216,8 +233,7 @@                                 [] -> DNothing                                 cases ->                                     mkBigCase (sMN 0 "APPLY") 256-                                              (DApp False (sMN 0 "EVAL")-                                               [DV (Glob (sMN 0 "fn"))])+                                               (DV (Glob (sMN 0 "fn")))                                               (cases ++                                     [DDefaultCase DNothing])))   where
src/IRTS/Lang.hs view
@@ -66,6 +66,7 @@                    -- core or another machine. 'id' is a valid implementation             | LVMPtr             | LNullPtr+            | LRegisterPtr             | LNoOp   deriving (Show, Eq) @@ -83,6 +84,7 @@            | FString            | FUnit            | FPtr+           | FManagedPtr            | FAny   deriving (Show, Eq)
src/Idris/AbsSyntax.hs view
@@ -9,7 +9,8 @@ import Idris.Core.Typecheck import Idris.AbsSyntaxTree import Idris.Colours-import Idris.IdeSlave+import Idris.Docstrings+import Idris.IdeSlave hiding (Opt(..)) import IRTS.CodegenCommon import Util.DynamicLinker @@ -87,6 +88,10 @@ addHdr :: Codegen -> String -> Idris () addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i } +addImported :: FilePath -> Idris ()+addImported f = do i <- getIState+                   putIState $ i { idris_imported = nub $ f : idris_imported i }+ addLangExt :: LanguageExt -> Idris () addLangExt TypeProviders = do i <- getIState                               putIState $ i {@@ -262,10 +267,10 @@ addCoercion n = do i <- getIState                    putIState $ i { idris_coercions = nub $ n : idris_coercions i } -addDocStr :: Name -> String -> Idris ()-addDocStr n doc+addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris ()+addDocStr n doc args    = do i <- getIState-        putIState $ i { idris_docstrings = addDef n doc (idris_docstrings i) }+        putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) }  addNameHint :: Name -> Name -> Idris () addNameHint ty n@@ -356,15 +361,18 @@ getHdrs :: Codegen -> Idris [String] getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i) -setErrLine :: Int -> Idris ()-setErrLine x = do i <- getIState;-                  case (errLine i) of-                      Nothing -> putIState $ i { errLine = Just x }+getImported ::  Idris [FilePath]+getImported = do i <- getIState; return (idris_imported i)++setErrSpan :: FC -> Idris ()+setErrSpan x = do i <- getIState;+                  case (errSpan i) of+                      Nothing -> putIState $ i { errSpan = Just x }                       Just _ -> return ()  clearErr :: Idris () clearErr = do i <- getIState-              putIState $ i { errLine = Nothing }+              putIState $ i { errSpan = Nothing }  getSO :: Idris (Maybe String) getSO = do i <- getIState@@ -391,6 +399,8 @@              putIState $ (i { idris_name = idx + 1 })              return idx +-- InternalApp keeps track of the real function application for making case splits from, not the application the+-- programmer wrote, which doesn't have the whole context in any case other than top level definitions addInternalApp :: FilePath -> Int -> PTerm -> Idris () addInternalApp fp l t     = do i <- getIState@@ -460,6 +470,7 @@ addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type, Bool))] -> Idris () addDeferred' nt ns   = do mapM_ (\(n, (i, _, t, _)) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns+       mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns        i <- getIState        putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++                                             idris_metavars i }@@ -475,12 +486,23 @@ solveDeferred n = do i <- getIState                      putIState $ i { idris_metavars =                                        filter (\(n', _) -> n/=n')-                                          (idris_metavars i) }+                                          (idris_metavars i),+                                     ibc_write =+                                       filter (notMV n) (ibc_write i)+                                          }+    where notMV n (IBCMetavar n') = not (n == n')+          notMV n _ = True  getUndefined :: Idris [Name] getUndefined = do i <- getIState                   return (map fst (idris_metavars i) \\ primDefs) +isMetavarName :: Name -> IState -> Bool+isMetavarName n ist+     = case lookupNames n (tt_ctxt ist) of+            (t:_) -> isJust $ lookup t (idris_metavars ist)+            _     -> False+ getWidth :: Idris ConsoleWidth getWidth = fmap idris_consolewidth getIState @@ -496,135 +518,16 @@                    AutomaticWidth -> runIO getScreenWidth  -iRender :: Doc a -> Idris (SimpleDoc a)-iRender d = do w <- getWidth-               ist <- getIState-               let ideSlave = case idris_outputmode ist of-                                IdeSlave _ -> True-                                _          -> False-               case w of-                 InfinitelyWide -> return $ renderPretty 1.0 1000000000 d-                 ColsWide n -> return $-                               if n < 1-                                 then renderPretty 1.0 1000000000 d-                                 else renderPretty 0.8 n d-                 AutomaticWidth | ideSlave  -> return $ renderPretty 1.0 1000000000 d-                                | otherwise -> do width <- runIO getScreenWidth-                                                  return $ renderPretty 0.8 width d -ihPrintResult :: Handle -> String -> Idris ()-ihPrintResult h s = do i <- getIState-                       case idris_outputmode i of-                         RawOutput -> case s of-                                        "" -> return ()-                                        s  -> runIO $ hPutStrLn h s-                         IdeSlave n ->-                             let good = SexpList [SymbolAtom "ok", toSExp s] in-                             runIO $ hPutStrLn h $ convSExp "return" good n---- | Write a pretty-printed term to the console with semantic coloring-consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris ()-consoleDisplayAnnotated h output = do ist <- getIState-                                      rendered <- iRender $ output-                                      runIO . hPutStrLn h .-                                        displayDecorated (consoleDecorate ist) $-                                        rendered----- | Write pretty-printed output to IDESlave with semantic annotations-ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()-ideSlaveReturnAnnotated n h out = do ist <- getIState-                                     (str, spans) <- fmap displaySpans .-                                                     iRender .-                                                     fmap (fancifyAnnots ist) $-                                                     out-                                     let good = [SymbolAtom "ok", toSExp str, toSExp spans]-                                     runIO . hPutStrLn h $ convSExp "return" good n--ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()-ihPrintTermWithType h tm ty = do ist <- getIState-                                 let output = tm <+> colon <+> ty-                                 case idris_outputmode ist of-                                   RawOutput -> consoleDisplayAnnotated h output-                                   IdeSlave n -> ideSlaveReturnAnnotated n h output---- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name-ihPrintFunTypes :: Handle -> Name -> [(Name, PTerm)] -> Idris ()-ihPrintFunTypes h n []        = ihPrintError h $ "No such variable " ++ show n-ihPrintFunTypes h n overloads = do imp <- impShow-                                   ist <- getIState-                                   let output = vsep (map (uncurry (ppOverload imp)) overloads)-                                   case idris_outputmode ist of-                                     RawOutput -> consoleDisplayAnnotated h output-                                     IdeSlave n -> ideSlaveReturnAnnotated n h output-  where fullName n = annotate (AnnName n Nothing Nothing) $ text (show n)-        ppOverload imp n tm = fullName n <+> colon <+> align (prettyImp imp tm)--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--fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation-fancifyAnnots ist annot@(AnnName n _ _) =-  do let ctxt = tt_ctxt ist-     case () of-       _ | isDConName n ctxt -> AnnName n (Just DataOutput) Nothing-       _ | isFnName   n ctxt -> AnnName n (Just FunOutput) Nothing-       _ | isTConName n ctxt -> AnnName n (Just TypeOutput) Nothing-       _ | otherwise         -> annot-fancifyAnnots _ annot = annot- type1Doc :: Doc OutputAnnotation type1Doc = (annotate AnnConstType $ text "Type 1") -ihPrintError :: Handle -> String -> Idris ()-ihPrintError h s = do i <- getIState-                      case idris_outputmode i of-                        RawOutput -> case s of-                                          "" -> return ()-                                          s  -> runIO $ hPutStrLn h s-                        IdeSlave n ->-                          let good = SexpList [SymbolAtom "error", toSExp s] in-                          runIO . hPutStrLn h $ convSExp "return" good n -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 = 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-                                   _ -> return ()---- this needs some typing magic and more structured output towards emacs-iputGoal :: SimpleDoc OutputAnnotation -> Idris ()-iputGoal g = do i <- getIState-                case idris_outputmode i of-                  RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)-                  IdeSlave n -> runIO . putStrLn $-                                convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n- isetPrompt :: String -> Idris () isetPrompt p = do i <- getIState                   case idris_outputmode i of                     IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n -ihWarn :: Handle -> FC -> String -> Idris ()-ihWarn h fc err = do i <- getIState-                     case idris_outputmode i of-                       RawOutput -> runIO $ hPutStrLn h (show fc ++ ":" ++ err)-                       IdeSlave n -> runIO $ hPutStrLn h $ convSExp "warning" (fc_fname fc, fc_line fc, fc_column fc, err) n- setLogLevel :: Int -> Idris () setLogLevel l = do i <- getIState                    let opts = idris_options i@@ -688,6 +591,12 @@                       let opt' = opts { opt_origerr = b }                       putIState $ i { idris_options = opt' } +setAutoSolve :: Bool -> Idris ()+setAutoSolve b = do i <- getIState+                    let opts = idris_options i+                    let opt' = opts { opt_autoSolve = b }+                    putIState $ i { idris_options = opt' }+ setNoBanner :: Bool -> Idris () setNoBanner n = do i <- getIState                    let opts = idris_options i@@ -874,7 +783,7 @@  noErrors :: Idris Bool noErrors = do i <- getIState-              case errLine i of+              case errSpan i of                 Nothing -> return True                 _       -> return False @@ -919,18 +828,19 @@                      PLet n' (en ty) (en v) (en (shadow n n' s))        | otherwise = PLet n (en ty) (en v) (en s)     -- FIXME: Should only do this in a type signature!-    en (PDPair f (PRef f' n) t r)+    en (PDPair f p (PRef f' n) t r)        | n `elem` (map fst ps ++ ns) && t /= Placeholder            = let n' = mkShadow n in-                 PDPair f (PRef f' n') (en t) (en (shadow n n' r))+                 PDPair f p (PRef f' n') (en t) (en (shadow n n' r))     en (PEq f l r) = PEq f (en l) (en r)     en (PRewrite f l r g) = PRewrite f (en l) (en r) (fmap en g)     en (PTyped l r) = PTyped (en l) (en r)     en (PPair f p l r) = PPair f p (en l) (en r)-    en (PDPair f l t r) = PDPair f (en l) (en t) (en r)+    en (PDPair f p l t r) = PDPair f p (en l) (en t) (en r)     en (PAlternative a as) = PAlternative a (map en as)     en (PHidden t) = PHidden (en t)     en (PUnifyLog t) = PUnifyLog (en t)+    en (PDisamb ds t) = PDisamb ds (en t)     en (PNoImplicits t) = PNoImplicits (en t)     en (PDoBlock ds) = PDoBlock (map (fmap en) ds)     en (PProof ts)   = PProof (map (fmap en) ts)@@ -973,12 +883,12 @@ expandParamsD :: Bool -> -- True = RHS only                  IState ->                  (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl-expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty)+expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n ty)     = if n `elem` ns && (not rhsonly)          then -- trace (show (n, expandParams dec ps ns ty)) $-              PTy doc syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))+              PTy doc argdocs syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))          else --trace (show (n, expandParams dec ps ns ty)) $-              PTy doc syn fc o n (expandParams dec ps ns [] ty)+              PTy doc argdocs syn fc o n (expandParams dec ps ns [] ty) expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)     = if n `elem` ns && (not rhsonly)          then -- trace (show (n, expandParams dec ps ns ty)) $@@ -1021,11 +931,11 @@     bnames (PRef _ n) = [n]     bnames (PApp _ _ args) = concatMap bnames (map getTm args)     bnames (PPair _ _ l r) = bnames l ++ bnames r-    bnames (PDPair _ l Placeholder r) = bnames l ++ bnames r+    bnames (PDPair _ _ l Placeholder r) = bnames l ++ bnames r     bnames _ = [] -expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)-    = PData doc syn fc co (expandPData pd)+expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)+    = PData doc argDocs syn fc co (expandPData pd)   where     -- just do the type decl, leave constructors alone (parameters will be     -- added implicitly)@@ -1034,8 +944,15 @@             then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))                            (map econ cons)             else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)-    econ (doc, n, t, fc, fs)-       = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)+    econ (doc, argDocs, n, t, fc, fs)+       = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)+expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)+   = if tn `elem` ns+        then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))+                     cdoc (dec cn) conty+        else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)+                     cdoc (dec cn) conty+   where conty = piBindp expl ps (expandParams dec ps ns [] cty) expandParamsD rhs ist dec ps ns (PParams f params pds)    = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)                (map (expandParamsD True ist dec ps ns) pds)@@ -1086,12 +1003,13 @@     pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))     pri (PTyped l r) = pri l     pri (PPair _ _ l r) = max 1 (max (pri l) (pri r))-    pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))+    pri (PDPair _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))     pri (PAlternative a as) = maximum (map pri as)     pri (PConstant _) = 0     pri Placeholder = 1     pri _ = 3 + addStatics :: Name -> Term -> PTerm -> Idris () addStatics n tm ptm =     do let (statics, dynamics) = initStatics tm ptm@@ -1125,8 +1043,8 @@     -- if a name appears in a type class or tactic implicit index, it doesn't     -- affect its 'uniquely inferrable' from a static status since these are     -- resolved by searching.-    searchArg (Constraint _ _ _) = True-    searchArg (TacImp _ _ _ _) = True+    searchArg (Constraint _ _) = True+    searchArg (TacImp _ _ _) = True     searchArg _ = False      staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc@@ -1153,14 +1071,14 @@          -- if all of args in ns, then add it          doAdd (UConstraint c args : cs) ns t              | all (\n -> elem n ns) args-                   = PPi (Constraint [] Dynamic "") (sMN 0 "cu")+                   = PPi (Constraint [] Dynamic) (sMN 0 "cu")                          (mkConst c args) (doAdd cs ns t)              | otherwise = doAdd cs ns t           mkConst c args = PApp fc (PRef fc c)-                             (map (\n -> PExp 0 [] (PRef fc n) "") args)+                             (map (\n -> PExp 0 [] (PRef fc n)) args) -         getConstraints (PPi (Constraint _ _ _) _ c sc)+         getConstraints (PPi (Constraint _ _) _ c sc)              = getcapp c ++ getConstraints sc          getConstraints (PPi _ _ c sc) = getConstraints sc          getConstraints _ = []@@ -1170,7 +1088,7 @@                   return (UConstraint c ns)          getcapp _ = [] -         getName (PExp _ _ (PRef _ n) _) = return n+         getName (PExp _ _ (PRef _ n)) = return n          getName _ = []  -- Add implicit Pi bindings for any names in the term which appear in an@@ -1216,38 +1134,44 @@                       | otherwise   = x : dropAll xs ys     dropAll [] ys = [] +    -- Find names in argument position in a type, suitable for implicit+    -- binding+    -- Not the function position, but do everything else...+    implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)+    implNamesIn uv t = namesIn uv ist t+     imps top env (PApp _ f as)        = do (decls, ns) <- get             let isn = concatMap (namesIn uvars ist) (map getTm as)             put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))-    imps top env (PPi (Imp l _ doc _) n ty sc)-        = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]+    imps top env (PPi (Imp l _ _) n ty sc)+        = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]              (decls , ns) <- get-             put (PImp (getPriority ist ty) True l n Placeholder doc : decls,+             put (PImp (getPriority ist ty) True l n Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (Exp l _ doc _) n ty sc)-        = do let isn = nub (namesIn uvars ist ty ++ case sc of+    imps top env (PPi (Exp l _ _) n ty sc)+        = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])              (decls, ns) <- get -- ignore decls in HO types-             put (PExp (getPriority ist ty) l Placeholder doc : decls,+             put (PExp (getPriority ist ty) l Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (Constraint l _ doc) n ty sc)-        = do let isn = nub (namesIn uvars ist ty ++ case sc of+    imps top env (PPi (Constraint l _) n ty sc)+        = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])              (decls, ns) <- get -- ignore decls in HO types-             put (PConstraint 10 l Placeholder doc : decls,+             put (PConstraint 10 l Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc-    imps top env (PPi (TacImp l _ scr doc) n ty sc)-        = do let isn = nub (namesIn uvars ist ty ++ case sc of+    imps top env (PPi (TacImp l _ scr) n ty sc)+        = do let isn = nub (implNamesIn uvars ty ++ case sc of                             (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]                             _ -> [])              (decls, ns) <- get -- ignore decls in HO types-             put (PTacImplicit 10 l n scr Placeholder doc : decls,+             put (PTacImplicit 10 l n scr Placeholder : decls,                   nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))              imps True (n:env) sc     imps top env (PEq _ l r)@@ -1264,11 +1188,11 @@         = do (decls, ns) <- get              let isn = namesIn uvars ist l ++ namesIn uvars ist r              put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))-    imps top env (PDPair _ (PRef _ n) t r)+    imps top env (PDPair _ _ (PRef _ n) t r)         = do (decls, ns) <- get              let isn = nub (namesIn uvars ist t ++ namesIn uvars ist r) \\ [n]              put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls)))))-    imps top env (PDPair _ l t r)+    imps top env (PDPair _ _ l t r)         = do (decls, ns) <- get              let isn = namesIn uvars ist l ++ namesIn uvars ist t ++                        namesIn uvars ist r@@ -1288,8 +1212,8 @@     pibind using []     sc = sc     pibind using (n:ns) sc       = case lookup n using of-            Just ty -> PPi (Imp [] Dynamic "" False) n ty (pibind using ns sc)-            Nothing -> PPi (Imp [] Dynamic "" False) n Placeholder+            Just ty -> PPi (Imp [] Dynamic False) n ty (pibind using ns sc)+            Nothing -> PPi (Imp [] Dynamic False) n Placeholder                                    (pibind using ns sc)  -- Add implicit arguments in function calls@@ -1334,11 +1258,11 @@       = let l' = ai env ds l             r' = ai env ds r in             PPair fc p l' r'-    ai env ds (PDPair fc l t r)+    ai env ds (PDPair fc p l t r)          = let l' = ai env ds l                t' = ai env ds t                r' = ai env ds r in-           PDPair fc l' t' r'+           PDPair fc p l' t' r'     ai env ds (PAlternative a as)             = let as' = map (ai env ds) as in                  PAlternative a as'@@ -1405,7 +1329,7 @@ --                            any constructor alts || any allImp ialts))                         then aiFn inpat False ist fc f ds [] -- use it as a constructor                         else Right $ PPatvar fc f-    where imp (PExp _ _ _ _) = False+    where imp (PExp _ _ _) = False           imp _ = True --           allImp [] = False           allImp xs = all imp xs@@ -1454,30 +1378,30 @@       insertImpl :: [PArg] -> [PArg] -> [PArg]-    insertImpl (PExp p l ty _ : ps) (PExp _ _ tm d : given) =-                                 PExp p l tm d : insertImpl ps given-    insertImpl (PConstraint p l ty _ : ps) (PConstraint _ _ tm d : given) =-                                 PConstraint p l tm d : insertImpl ps given-    insertImpl (PConstraint p l ty d : ps) given =-                 PConstraint p l (PResolveTC fc) d : insertImpl ps given-    insertImpl (PImp p _ l n ty d : ps) given =+    insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) =+                                 PExp p l tm : insertImpl ps given+    insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) =+                                 PConstraint p l tm : insertImpl ps given+    insertImpl (PConstraint p l ty : ps) given =+                 PConstraint p l (PResolveTC fc) : insertImpl ps given+    insertImpl (PImp p _ l n ty : ps) given =         case find n given [] of-            Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'-            Nothing ->           PImp p True l n Placeholder "" : insertImpl ps given-    insertImpl (PTacImplicit p l n sc' ty d : ps) given =+            Just (tm, given') -> PImp p False l n tm : insertImpl ps given'+            Nothing ->           PImp p True l n Placeholder : insertImpl ps given+    insertImpl (PTacImplicit p l n sc' ty : ps) given =       let sc = addImpl ist sc' in         case find n given [] of-            Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'+            Just (tm, given') -> PTacImplicit p l n sc tm : insertImpl ps given'             Nothing -> if inpat-                          then PTacImplicit p l n sc Placeholder "" : insertImpl ps given-                          else PTacImplicit p l n sc sc "" : insertImpl ps given+                          then PTacImplicit p l n sc Placeholder : insertImpl ps given+                          else PTacImplicit p l n sc sc : insertImpl ps given     insertImpl expected [] = []     insertImpl _        given  = given      find n []               acc = Nothing-    find n (PImp _ _ _ n' t _ : gs) acc+    find n (PImp _ _ _ n' t : gs) acc          | n == n' = Just (t, reverse acc ++ gs)-    find n (PTacImplicit _ _ n' _ t _ : gs) acc+    find n (PTacImplicit _ _ n' _ t : gs) acc          | n == n' = Just (t, reverse acc ++ gs)     find n (g : gs) acc = find n gs (g : acc) @@ -1502,19 +1426,21 @@                              then return Placeholder                              else do put (f : ns)                                      return (PPatvar fc f)-    sl (PApp fc fn args) = do fn' <- sl fn+    sl t@(PAlternative _ (a : as)) = do sl a+                                        return t+    sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var                                args' <- mapM slA args-                              return $ PApp fc fn' args'-       where slA (PImp p m l n t d) = do t' <- sl t-                                         return $ PImp p m l n t' d-             slA (PExp p l t d) = do t' <- sl t-                                     return $ PExp p l t' d-             slA (PConstraint p l t d)+                              return $ PApp fc fn args'+       where slA (PImp p m l n t) = do t' <- sl t+                                       return $ PImp p m l n t'+             slA (PExp p l t) = do t' <- sl t+                                   return $ PExp p l t'+             slA (PConstraint p l t)                                 = do t' <- sl t-                                     return $ PConstraint p l t' d-             slA (PTacImplicit p l n sc t d)+                                     return $ PConstraint p l t'+             slA (PTacImplicit p l n sc t)                                 = do t' <- sl t-                                     return $ PTacImplicit p l n sc t' d+                                     return $ PTacImplicit p l n sc t'     sl x = return x  -- Remove functions which aren't applied to anything, which must then@@ -1534,7 +1460,7 @@              if null alts' then Placeholder                            else PAlternative b alts'     su (PPair fc p l r) = PPair fc p (su l) (su r)-    su (PDPair fc l t r) = PDPair fc (su l) (su t) (su r)+    su (PDPair fc p l t r) = PDPair fc p (su l) (su t) (su r)     su t = t stripUnmatchable i tm = tm @@ -1614,8 +1540,6 @@             = do mf <- match' f f'                  ms <- zipWithM matchArg args args'                  return (mf ++ concat ms)---     match (PRef _ n) (PRef _ n') | n == n' = return []---                                  | otherwise = Nothing     match (PRef f n) (PApp _ x []) = match (PRef f n) x     match (PPatvar f n) xr = match (PRef f n) xr     match xr (PPatvar f n) = match xr (PRef f n)@@ -1625,7 +1549,10 @@           (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))                  || tm == Placeholder)             = return [(n, tm)]-        | n == n' = return []+        -- if one namespace is missing, drop the other+        | n == n' || n == dropNS n' || dropNS n == n' = return []+       where dropNS (NS n _) = n+             dropNS n = n     match (PRef _ n) tm         | not names && (not (isConName n (tt_ctxt i) ||                              isFnName n (tt_ctxt i)) || tm == Placeholder)@@ -1645,10 +1572,10 @@     match (PPair _ _ l r) (PPair _ _ l' r') = do ml <- match' l l'                                                  mr <- match' r r'                                                  return (ml ++ mr)-    match (PDPair _ l t r) (PDPair _ l' t' r') = do ml <- match' l l'-                                                    mt <- match' t t'-                                                    mr <- match' r r'-                                                    return (ml ++ mt ++ mr)+    match (PDPair _ _ l t r) (PDPair _ _ l' t' r') = do ml <- match' l l'+                                                        mt <- match' t t'+                                                        mr <- match' r r'+                                                        return (ml ++ mt ++ mr)     match (PAlternative a as) (PAlternative a' as')         = do ms <- zipWithM match' as as'              return (concat ms)@@ -1726,7 +1653,7 @@                                            (fmap (sm xs) tm)     sm xs (PTyped x y) = PTyped (sm xs x) (sm xs y)     sm xs (PPair f p x y) = PPair f p (sm xs x) (sm xs y)-    sm xs (PDPair f x t y) = PDPair f (sm xs x) (sm xs t) (sm xs y)+    sm xs (PDPair f p x t y) = PDPair f p (sm xs x) (sm xs t) (sm xs y)     sm xs (PAlternative a as) = PAlternative a (map (sm xs) as)     sm xs (PHidden x) = PHidden (sm xs x)     sm xs (PUnifyLog x) = PUnifyLog (sm xs x)@@ -1749,7 +1676,7 @@     sm (PRewrite f x y tm) = PRewrite f (sm x) (sm y) (fmap sm tm)     sm (PTyped x y) = PTyped (sm x) (sm y)     sm (PPair f p x y) = PPair f p (sm x) (sm y)-    sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)+    sm (PDPair f p x t y) = PDPair f p (sm x) (sm t) (sm y)     sm (PAlternative a as) = PAlternative a (map sm as)     sm (PTactics ts) = PTactics (map (fmap sm) ts)     sm (PProof ts) = PProof (map (fmap sm) ts)@@ -1768,6 +1695,12 @@   mkUniqA arg = do t' <- mkUniq (getTm arg)                    return (arg { getTm = t' }) +  -- Initialise the unique name with the environment length (so we're not+  -- looking for too long...)+  initN (UN n) l = UN $ txt (str n ++ show l)+  initN (MN i s) l = MN (i+l) s+  initN n l = n+   -- FIXME: Probably ought to do this for completeness! It's fine as   -- long as there are no bindings inside tactics though.   mkUniqT tac = return tac@@ -1777,7 +1710,8 @@          = do env <- get               (n', sc') <-                     if n `elem` env-                       then do let n' = uniqueName n (env ++ inScope)+                       then do let n' = uniqueName (initN n (length env))+                                                   (env ++ inScope)                                return (n', shadow n n' sc)                        else return (n, sc)               put (n' : env)@@ -1788,7 +1722,8 @@          = do env <- get               (n', sc') <-                     if n `elem` env-                       then do let n' = uniqueName n (env ++ inScope)+                       then do let n' = uniqueName (initN n (length env))+                                                   (env ++ inScope)                                return (n', shadow n n' sc)                        else return (n, sc)               put (n' : env)@@ -1799,7 +1734,8 @@          = do env <- get               (n', sc') <-                     if n `elem` env-                       then do let n' = uniqueName n (env ++ inScope)+                       then do let n' = uniqueName (initN n (length env))+                                                   (env ++ inScope)                                return (n', shadow n n' sc)                        else return (n, sc)               put (n' : env)@@ -1822,7 +1758,7 @@   mkUniq (PPair fc p l r)          = do l' <- mkUniq l; r' <- mkUniq r               return $! PPair fc p l' r'-  mkUniq (PDPair fc (PRef fc' n) t sc)+  mkUniq (PDPair fc p (PRef fc' n) t sc)       | t /= Placeholder          = do env <- get               (n', sc') <- if n `elem` env@@ -1832,10 +1768,10 @@               put (n' : env)               t' <- mkUniq t               sc'' <- mkUniq sc'-              return $! PDPair fc (PRef fc' n') t' sc''-  mkUniq (PDPair fc l t r)+              return $! PDPair fc p (PRef fc' n') t' sc''+  mkUniq (PDPair fc p l t r)          = do l' <- mkUniq l; t' <- mkUniq t; r' <- mkUniq r-              return $! PDPair fc l' t' r'+              return $! PDPair fc p l' t' r'   mkUniq (PAlternative b as)          = liftM (PAlternative b) (mapM mkUniq as)   mkUniq (PHidden t) = liftM PHidden (mkUniq t)
src/Idris/AbsSyntaxTree.hs view
@@ -7,6 +7,7 @@ import Idris.Core.Evaluate import Idris.Core.Elaborate hiding (Tactic(..)) import Idris.Core.Typecheck+import Idris.Docstrings import IRTS.Lang import IRTS.CodegenCommon import Util.Pretty@@ -53,7 +54,8 @@                          opt_cpu        :: String,                          opt_optLevel   :: Word,                          opt_cmdline    :: [Opt], -- remember whole command line-                         opt_origerr    :: Bool+                         opt_origerr    :: Bool,+                         opt_autoSolve  :: Bool -- ^ automatically apply "solve" tactic in prover                        }     deriving (Show, Eq) @@ -76,6 +78,7 @@                       , opt_optLevel   = 2                       , opt_cmdline    = []                       , opt_origerr    = False+                      , opt_autoSolve  = True                       }  data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)@@ -88,11 +91,6 @@                   | ColsWide Int -- ^ Manually specified - must be positive                   | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise --- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e--- without typechecking).--- This will include all the functions and data declarations, plus fixity declarations--- and syntax macros.- -- | The global state used in the Idris monad data IState = IState {     tt_ctxt :: Context, -- ^ All the currently defined names and their terms@@ -111,7 +109,7 @@     idris_flags :: Ctxt [FnOpt],     idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos     idris_calledgraph :: Ctxt [Name],-    idris_docstrings :: Ctxt String,+    idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),     idris_tyinfodata :: Ctxt TIData,     idris_totcheck :: [(FC, Name)], -- names to check totality on      idris_defertotcheck :: [(FC, Name)], -- names to check at the end@@ -131,11 +129,14 @@     idris_libs :: [(Codegen, String)],     idris_cgflags :: [(Codegen, String)],     idris_hdrs :: [(Codegen, String)],+    idris_imported :: [FilePath], -- ^ Imported ibc file names     proof_list :: [(Name, [String])],-    errLine :: Maybe Int,+    errSpan :: Maybe FC,+    parserWarnings :: [(FC, Err)],     lastParse :: Maybe Name,     indent_stack :: [Int],     brace_stack :: [Maybe Int],+    lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?     hide_list :: [(Name, Maybe Accessibility)],     default_access :: Accessibility,     default_total :: Bool,@@ -188,6 +189,7 @@               | IBCDSL Name               | IBCData Name               | IBCOpt Name+              | IBCMetavar Name               | IBCSyntax Syntax               | IBCKeyword String               | IBCImport FilePath@@ -219,7 +221,7 @@                    emptyContext emptyContext emptyContext emptyContext                    emptyContext emptyContext                    [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []-                   [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput+                   [] [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput                    True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty                    AutomaticWidth @@ -286,6 +288,7 @@              | ColourOff              | ListErrorHandlers              | SetConsoleWidth ConsoleWidth+             | Apropos String  data Opt = Filename String          | Ver@@ -334,6 +337,7 @@          | Client String          | ShowOrigErr          | AutoWidth -- ^ Automatically adjust terminal width+         | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover     deriving (Show, Eq)  -- Parsed declarations@@ -379,19 +383,15 @@ -- Mark bindings with their explicitness, and laziness data Plicity = Imp { pargopts :: [ArgOpt],                      pstatic :: Static,-                     pdocstr :: String,                      pparam :: Bool }              | Exp { pargopts :: [ArgOpt],                      pstatic :: Static,-                     pdocstr :: String,                      pparam :: Bool }              | Constraint { pargopts :: [ArgOpt],-                            pstatic :: Static,-                            pdocstr :: String }+                            pstatic :: Static }              | TacImp { pargopts :: [ArgOpt],                         pstatic :: Static,-                        pscript :: PTerm,-                        pdocstr :: String }+                        pscript :: PTerm }   deriving (Show, Eq)  plazy :: Plicity -> Bool@@ -402,14 +402,14 @@ deriving instance NFData Plicity !-} -impl = Imp [Lazy] Dynamic "" False-expl = Exp [] Dynamic "" False-expl_param = Exp [] Dynamic "" True-constraint = Constraint [] Dynamic ""-tacimpl t = TacImp [] Dynamic t ""+impl = Imp [Lazy] Dynamic False+expl = Exp [] Dynamic False+expl_param = Exp [] Dynamic True+constraint = Constraint [] Dynamic+tacimpl t = TacImp [] Dynamic t  data FnOpt = Inlinable -- always evaluate when simplifying-           | TotalFn | PartialFn+           | TotalFn | PartialFn | CoveringFn            | Coinductive | AssertTotal            | Dictionary -- type class dictionary, eval only when                         -- a function argument, and further evaluation resutls@@ -442,19 +442,25 @@  type DataOpts = [DataOpt] +-- | Type provider - what to provide+data ProvideWhat = ProvTerm      -- ^ only allow providing terms+                 | ProvPostulate -- ^ only allow postulates+                 | ProvAny       -- ^ either is ok+    deriving (Show, Eq)+ -- | Top-level declarations such as compiler directives, definitions, -- datatypes and typeclasses. data PDecl' t    = PFix     FC Fixity [String] -- ^ Fixity declaration-   | PTy      String SyntaxInfo FC FnOpts Name t   -- ^ Type declaration-   | PPostulate String SyntaxInfo FC FnOpts Name t -- ^ Postulate+   | PTy      Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t   -- ^ Type declaration+   | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate    | PClauses FC FnOpts Name [PClause' t]   -- ^ Pattern clause    | PCAF     FC Name t -- ^ Top level constant-   | PData    String SyntaxInfo FC DataOpts (PData' t)  -- ^ Data declaration.+   | PData    Docstring [(Name, Docstring)] SyntaxInfo FC DataOpts (PData' t)  -- ^ Data declaration.    | PParams  FC [(Name, t)] [PDecl' t] -- ^ Params block    | PNamespace String [PDecl' t] -- ^ New namespace-   | PRecord  String SyntaxInfo FC Name t String Name t  -- ^ Record declaration-   | PClass   String SyntaxInfo FC+   | PRecord  Docstring SyntaxInfo FC Name t Docstring Name t  -- ^ Record declaration+   | PClass   Docstring SyntaxInfo FC               [t] -- constraints               Name               [(Name, t)] -- parameters@@ -473,7 +479,7 @@    | PSyntax  FC Syntax -- ^ Syntax definition    | PMutual  FC [PDecl' t] -- ^ Mutual block    | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.-   | PProvider SyntaxInfo FC Name t t -- ^ Type provider. The first t is the type, the second is the term+   | PProvider SyntaxInfo FC ProvideWhat Name t t -- ^ Type provider. The first t is the type, the second is the term    | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If                             -- bool is True, lhs and rhs must be convertible  deriving Functor@@ -508,7 +514,7 @@ -- | Data declaration data PData' t  = PDatadecl { d_name :: Name, -- ^ The name of the datatype                              d_tcon :: t, -- ^ Type constructor-                             d_cons :: [(String, Name, t, FC, [Name])] -- ^ Constructors+                             d_cons :: [(Docstring, [(Name, Docstring)], Name, t, FC, [Name])] -- ^ Constructors                            }                  -- ^ Data declaration                | PLaterdecl { d_name :: Name, d_tcon :: t }@@ -530,13 +536,13 @@  declared :: PDecl -> [Name] declared (PFix _ _ _) = []-declared (PTy _ _ _ _ n t) = [n]+declared (PTy _ _ _ _ _ n t) = [n] declared (PPostulate _ _ _ _ n t) = [n] declared (PClauses _ _ n _) = [] -- not a declaration declared (PCAF _ n _) = [n]-declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts-   where fstt (_, a, _, _, _) = a-declared (PData _ _ _ _ (PLaterdecl n _)) = [n]+declared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _) = a+declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n] declared (PParams _ _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds declared (PRecord _ _ _ n _ _ c _) = [n, c]@@ -550,12 +556,12 @@ -- get the names declared, not counting nested parameter blocks tldeclared :: PDecl -> [Name] tldeclared (PFix _ _ _) = []-tldeclared (PTy _ _ _ _ n t) = [n]+tldeclared (PTy _ _ _ _ _ n t) = [n] tldeclared (PPostulate _ _ _ _ n t) = [n] tldeclared (PClauses _ _ n _) = [] -- not a declaration tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]-tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts-   where fstt (_, a, _, _, _) = a+tldeclared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _) = a tldeclared (PParams _ _ ds) = [] tldeclared (PMutual _ ds) = concatMap tldeclared ds tldeclared (PNamespace _ ds) = concatMap tldeclared ds@@ -565,13 +571,13 @@  defined :: PDecl -> [Name] defined (PFix _ _ _) = []-defined (PTy _ _ _ _ n t) = []+defined (PTy _ _ _ _ _ n t) = [] defined (PPostulate _ _ _ _ n t) = [] defined (PClauses _ _ n _) = [n] -- not a declaration defined (PCAF _ n _) = [n]-defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts-   where fstt (_, a, _, _, _) = a-defined (PData _ _ _ _ (PLaterdecl n _)) = []+defined (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+   where fstt (_, _, a, _, _, _) = a+defined (PData _ _ _ _ _ (PLaterdecl n _)) = [] defined (PParams _ _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds defined (PRecord _ _ _ n _ _ c _) = [n, c]@@ -626,7 +632,7 @@            | PEq FC PTerm PTerm            | PRewrite FC PTerm PTerm (Maybe PTerm)            | PPair FC PunInfo PTerm PTerm-           | PDPair FC PTerm PTerm PTerm+           | PDPair FC PunInfo PTerm PTerm PTerm            | PAlternative Bool [PTerm] -- True if only one may work            | PHidden PTerm -- ^ Irrelevant or hidden pattern            | PType@@ -666,7 +672,7 @@   mpt (PEq fc l r) = PEq fc (mapPT f l) (mapPT f r)   mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)   mpt (PPair fc p l r) = PPair fc p (mapPT f l) (mapPT f r)-  mpt (PDPair fc l t r) = PDPair fc (mapPT f l) (mapPT f t) (mapPT f r)+  mpt (PDPair fc p l t r) = PDPair fc p (mapPT f l) (mapPT f t) (mapPT f r)   mpt (PAlternative a as) = PAlternative a (map (mapPT f) as)   mpt (PHidden t) = PHidden (mapPT f t)   mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)@@ -686,7 +692,7 @@                 | MatchRefine Name                 | LetTac Name t | LetTacTy Name t t                 | Exact t | Compute | Trivial | TCInstance-                | ProofSearch (Maybe Name) Name [Name]+                | ProofSearch (Maybe Name) [Name]                 | Solve                 | Attack                 | ProofState | ProofTerm | Undo@@ -697,6 +703,8 @@                 | Reflect t                 | Fill t                 | GoalType String (PTactic' t)+                | TCheck t+                | TEval t                 | Qed | Abandon     deriving (Show, Eq, Functor) {-!@@ -731,7 +739,7 @@  data PDo' t = DoExp  FC t             | DoBind FC Name t-            | DoBindP FC t t+            | DoBindP FC t t [(t,t)]             | DoLet  FC Name t t             | DoLetP FC t t     deriving (Eq, Functor)@@ -743,7 +751,7 @@ instance Sized a => Sized (PDo' a) where   size (DoExp fc t) = 1 + size fc + size t   size (DoBind fc nm t) = 1 + size fc + size nm + size t-  size (DoBindP fc l r) = 1 + size fc + size l + size r+  size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts   size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r   size (DoLetP fc l r) = 1 + size fc + size l + size r @@ -756,22 +764,18 @@ data PArg' t = PImp { priority :: Int,                       machine_inf :: Bool, -- true if the machine inferred it                       argopts :: [ArgOpt],-                      pname :: Name, getTm :: t,-                      pargdoc :: String }+                      pname :: Name, getTm :: t }              | PExp { priority :: Int,                       argopts :: [ArgOpt],-                      getTm :: t,-                      pargdoc :: String }+                      getTm :: t }              | PConstraint { priority :: Int,                              argopts :: [ArgOpt],-                             getTm :: t,-                             pargdoc :: String }+                             getTm :: t }              | PTacImplicit { priority :: Int,                               argopts :: [ArgOpt],                               pname :: Name,                               getScript :: t,-                              getTm :: t,-                              pargdoc :: String }+                              getTm :: t }     deriving (Show, Eq, Functor)  data ArgOpt = Lazy | HideDisplay@@ -781,20 +785,20 @@ lazyarg tm = Lazy `elem` argopts tm  instance Sized a => Sized (PArg' a) where-  size (PImp p _ l nm trm _) = 1 + size nm + size trm-  size (PExp p l trm _) = 1 + size trm-  size (PConstraint p l trm _) = 1 + size trm-  size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm+  size (PImp p _ l nm trm) = 1 + size nm + size trm+  size (PExp p l trm) = 1 + size trm+  size (PConstraint p l trm) = 1 + size trm+  size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm  {-! deriving instance Binary PArg' deriving instance NFData PArg' !-} -pimp n t mach = PImp 1 mach [Lazy] n t ""-pexp t = PExp 1 [] t ""-pconst t = PConstraint 1 [] t ""-ptacimp n s t = PTacImplicit 2 [Lazy] n s t ""+pimp n t mach = PImp 1 mach [Lazy] n t+pexp t = PExp 1 [] t+pconst t = PConstraint 1 [] t+ptacimp n s t = PTacImplicit 2 [Lazy] n s t  type PArg = PArg' PTerm @@ -946,9 +950,9 @@ inferCon  = sMN 0 "__infer" inferDecl = PDatadecl inferTy                       PType-                      [("", inferCon, PPi impl (sMN 0 "iType") PType (-                                  PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))-                                  (PRef bi inferTy)), bi, [])]+                      [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (+                                                   PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))+                                                   (PRef bi inferTy)), bi, [])] inferOpts = []  infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]@@ -976,7 +980,7 @@ unitTy   = sMN 0 "__Unit" unitCon  = sMN 0 "__II" unitDecl = PDatadecl unitTy PType-                     [("", unitCon, PRef bi unitTy, bi, [])]+                     [(emptyDocstring, [], unitCon, PRef bi unitTy, bi, [])] unitOpts = [DefaultEliminator]  falseTy   = sMN 0 "__False"@@ -986,12 +990,12 @@ pairTy    = sMN 0 "__Pair" pairCon   = sMN 0 "__MkPair" pairDecl  = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)-            [("", pairCon, PPi impl (n "A") PType (-                       PPi impl (n "B") PType (-                       PPi expl (n "a") (PRef bi (n "A")) (-                       PPi expl (n "b") (PRef bi (n "B"))-                           (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),-                                                pexp (PRef bi (n "B"))])))), bi, [])]+            [(emptyDocstring, [], pairCon, PPi impl (n "A") PType (+                                       PPi impl (n "B") PType (+                                       PPi expl (n "a") (PRef bi (n "A")) (+                                       PPi expl (n "b") (PRef bi (n "B"))+                                           (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),+                                                                pexp (PRef bi (n "B"))])))), bi, [])]     where n a = sMN 0 a pairOpts = [] @@ -1000,21 +1004,21 @@ eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),                                  (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]                                  PType)-                [("", eqCon, PPi impl (n "A") PType (-                         PPi impl (n "x") (PRef bi (n "A"))-                           (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,-                                                    pimp (n "B") Placeholder False,-                                                    pexp (PRef bi (n "x")),-                                                    pexp (PRef bi (n "x"))])), bi, [])]+                [(emptyDocstring, [], eqCon, PPi impl (n "A") PType (+                                         PPi impl (n "x") (PRef bi (n "A"))+                                           (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,+                                                                    pimp (n "B") Placeholder False,+                                                                    pexp (PRef bi (n "x")),+                                                                    pexp (PRef bi (n "x"))])), bi, [])]     where n a = sMN 0 a eqOpts = []  elimName       = sUN "__Elim" elimMethElimTy = sUN "__elimTy" elimMethElim   = sUN "elim"-elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]-                     [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,-                      PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]+                     [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,+                      PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]  -- Defined in builtins.idr sigmaTy   = sUN "Exists"@@ -1059,27 +1063,33 @@                                    in colouriseType theme consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist) consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)-consoleDecorate ist (AnnName n _ _) = let ctxt  = tt_ctxt ist-                                          theme = idris_colourTheme ist-                                      in case () of-                                           _ | isDConName n ctxt -> colouriseData theme-                                           _ | isFnName n ctxt   -> colouriseFun theme-                                           _ | isTConName n ctxt -> colouriseType theme-                                           _ | otherwise         -> id -- don't colourise unknown names+consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)+consoleDecorate ist (AnnName n _ _ _) = let ctxt  = tt_ctxt ist+                                            theme = idris_colourTheme ist+                                        in case () of+                                             _ | isDConName n ctxt -> colouriseData theme+                                             _ | isFnName n ctxt   -> colouriseFun theme+                                             _ | isTConName n ctxt -> colouriseType theme+                                             _ | otherwise         -> id -- don't colourise unknown names consoleDecorate ist (AnnFC _) = id+consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)+  where colour BoldText      = IdrisColour Nothing True False True False+        colour UnderlineText = IdrisColour Nothing True True False False+        colour ItalicText    = IdrisColour Nothing True False False True  -- | Pretty-print a high-level closed Idris term prettyImp :: Bool -- ^^ whether to show implicits           -> PTerm -- ^^ the term to pretty-print           -> Doc OutputAnnotation-prettyImp impl = pprintPTerm impl []+prettyImp impl = pprintPTerm impl [] []  -- | Pretty-print a high-level Idris term in some bindings context pprintPTerm :: Bool -- ^^ whether to show implicits             -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit+            -> [Name] -- ^^ names to always show in pi, even if not used             -> PTerm -- ^^ the term to pretty-print             -> Doc OutputAnnotation-pprintPTerm impl bnd = prettySe 10 bnd+pprintPTerm impl bnd docArgs = prettySe 10 bnd   where     prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation     prettySe p bnd (PQuote r) =@@ -1095,11 +1105,11 @@       prettySe 10 ((n, False):bnd) sc     prettySe p bnd (PLet n ty v sc) =       bracket p 2 $-      text "let" <+> bindingOf n False <+> text "=" </>-      prettySe 10 bnd v <+> text "in" </>+      kwd "let" <+> bindingOf n False <+> text "=" </>+      prettySe 10 bnd v <+> kwd "in" </>       prettySe 10 ((n, False):bnd) sc-    prettySe p bnd (PPi (Exp l s _ _) n ty sc)-      | n `elem` allNamesIn sc || impl =+    prettySe p bnd (PPi (Exp l s _) n ty sc)+      | n `elem` allNamesIn sc || impl || n `elem` docArgs =           let open = if Lazy `elem` l then text "|" <> lparen else lparen in             bracket p 2 . group $             enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>@@ -1112,7 +1122,7 @@           case s of             Static -> text "[static]" <> space             _      -> empty-    prettySe p bnd (PPi (Imp l s _ _) n ty sc)+    prettySe p bnd (PPi (Imp l s _) n ty sc)       | impl =           let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in             bracket p 2 $@@ -1124,24 +1134,35 @@           case s of             Static -> text "[static]" <> space             _      -> empty-    prettySe p bnd (PPi (Constraint _ _ _) n ty sc) =+    prettySe p bnd (PPi (Constraint _ _) n ty sc) =       bracket p 2 $       prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc-    prettySe p bnd (PPi (TacImp _ _ s _) n ty sc) =+    prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =       bracket p 2 $-      lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>+      lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>       rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc-    prettySe p bnd (PApp _ (PRef _ f) [])-      | not impl = prettyName impl bnd f+    prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args+      | UN nm <- basename f+      , not impl && null (getExps args) = if isAlpha (thead nm)+                                            then prettyName impl bnd f+                                            else enclose lparen rparen $+                                                 prettyName impl bnd f     prettySe p bnd (PAppBind _ (PRef _ f) [])       | not impl = text "!" <> prettyName impl bnd f     prettySe p bnd (PApp _ (PRef _ op) args)       | UN nm <- basename op       , not (tnull nm) &&-        length (getExps args) == 2 && (not impl) && (not $ isAlpha (thead nm)) =-          let [l, r] = getExps args in-            bracket p 1 . align . group $-            (prettySe 1 bnd l <+> prettyName impl bnd op) <$> group (prettySe 0 bnd r)+        (not impl) && (not $ isAlpha (thead nm)) =+          case getExps args of+            [] -> enclose lparen rparen opName+            [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))+            [l,r] -> bracket p 1 $ inFix l r+            (l:r:rest) -> bracket p 1 $+                          enclose lparen rparen (inFix l r) <+>+                          align (group (vsep (map (prettyArgSe bnd) rest)))+          where opName = prettyName impl bnd op+                inFix l r = align . group $+                            (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)     prettySe p bnd (PApp _ hd@(PRef fc f) [tm])       | PConstant (Idris.Core.TT.Str str) <- getTm tm,         f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))@@ -1158,43 +1179,55 @@                    then fp                    else fp <+> align (vsep (map (prettyArgSe bnd) args))     prettySe p bnd (PCase _ scr opts) =-      text "case" <+> prettySe 10 bnd scr <+> text "of" <> prettyBody+      kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody       where         prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts          sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r     prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm-    prettySe p bnd (PRefl _ _) = annotate (AnnName eqCon Nothing Nothing) $ text "refl"+    prettySe p bnd (PRefl _ _) = annName eqCon $ text "refl"     prettySe p bnd (PResolveTC _) = text "resolvetc"-    prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()"-    prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()"+    prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"+    prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"     prettySe p bnd (PTrue _ TypeOrTerm) = text "()"-    prettySe p bnd (PFalse _) = annotate (AnnName falseTy Nothing Nothing) $ text "_|_"+    prettySe p bnd (PFalse _) = annName falseTy $ text "_|_"     prettySe p bnd (PEq _ l r) =       bracket p 2 . align . group $       prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)-      where eq = annotate (AnnName eqTy Nothing Nothing) (text "=")+      where eq = annName eqTy (text "=")     prettySe p bnd (PRewrite _ l r _) =       bracket p 2 $       text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r     prettySe p bnd (PTyped l r) =       lparen <> prettySe 10 bnd l <+> colon <+> prettySe 10 bnd r <> rparen-    prettySe p bnd (PPair _ TypeOrTerm l r) =-      lparen <> prettySe 10 bnd l <> text "," <+> prettySe 10 bnd r <> rparen-    prettySe p bnd (PPair _ IsType l r) =-      annotate (AnnName pairTy Nothing Nothing) lparen <>-      prettySe 10 bnd l <>-      annotate (AnnName pairTy Nothing Nothing) comma <+>+    prettySe p bnd pair@(PPair _ pun _ _) -- flatten tuples to the right, like parser+      | Just elts <- pairElts pair = enclose (ann lparen) (ann rparen) .+                                     align . group . vsep . punctuate (ann comma) $+                                     map (prettySe 10 bnd) elts+        where ann = case pun of+                      TypeOrTerm -> id+                      IsType -> annName pairTy+                      IsTerm -> annName pairCon+    prettySe p bnd (PDPair _ TypeOrTerm l t r) =+      lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen+    prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =+      annName sigmaTy lparen <>+      bindingOf n False <+>+      annName sigmaTy (text "**") <+>+      prettySe 10 ((n, False):bnd) r <>+      annName sigmaTy rparen+    prettySe p bnd (PDPair _ IsType l t r) =+      annName sigmaTy lparen <>+      prettySe 10 bnd l <+>+      annName sigmaTy (text "**") <+>       prettySe 10 bnd r <>-      annotate (AnnName pairTy Nothing Nothing) rparen-    prettySe p bnd (PPair _ IsTerm l r) =-      annotate (AnnName pairCon Nothing Nothing) lparen <>-      prettySe 10 bnd l <>-      annotate (AnnName pairCon Nothing Nothing) comma <+>+      annName sigmaTy rparen+    prettySe p bnd (PDPair _ IsTerm l t r) =+      annName existsCon lparen <>+      prettySe 10 bnd l <+>+      annName existsCon (text "**") <+>       prettySe 10 bnd r <>-      annotate (AnnName pairCon Nothing Nothing) rparen-    prettySe p bnd (PDPair _ l t r) =-      lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen+      annName existsCon rparen     prettySe p bnd (PAlternative a as) =       lparen <> text "|" <> prettyAs <> text "|" <> rparen         where@@ -1213,24 +1246,27 @@     prettySe p bnd (PTactics ts) =       text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace     prettySe p bnd (PMetavar n) = text "?" <> pretty n-    prettySe p bnd (PReturn f) = text "return"-    prettySe p bnd PImpossible = text "impossible"+    prettySe p bnd (PReturn f) = kwd "return"+    prettySe p bnd PImpossible = kwd "impossible"     prettySe p bnd Placeholder = text "_"     prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"     prettySe p bnd (PElabError s) = pretty s      prettySe p bnd _ = text "test" -    prettyArgS bnd (PImp _ _ _ n tm _) = prettyArgSi bnd (n, tm)-    prettyArgS bnd (PExp _ _ tm _)   = prettyArgSe bnd tm-    prettyArgS bnd (PConstraint _ _ tm _) = prettyArgSc bnd tm-    prettyArgS bnd (PTacImplicit _ _ n _ tm _) = prettyArgSti bnd (n, tm)+    prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)+    prettyArgS bnd (PExp _ _ tm)   = prettyArgSe bnd tm+    prettyArgS bnd (PConstraint _ _ tm) = prettyArgSc bnd tm+    prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)      prettyArgSe bnd arg = prettySe 0 bnd arg     prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace     prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace-    prettyArgSti bnd (n, val) = lbrace <> text "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace+    prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace +    annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation+    annName n = annotate (AnnName n Nothing Nothing Nothing)+     basename :: Name -> Name     basename (NS n _) = basename n     basename n = n@@ -1263,6 +1299,11 @@             comma = (annotate AnnConstData (text ","))     slist _ _ _ = Nothing +    pairElts :: PTerm -> Maybe [PTerm]+    pairElts (PPair _ _ x y) | Just elts <- pairElts y = Just (x:elts)+                             | otherwise = Just [x, y]+    pairElts _ = Nothing+     natns = "Prelude.Nat."      snat p (PRef _ z)@@ -1277,6 +1318,8 @@       | inner > outer = lparen <> doc <> rparen       | otherwise     = doc +    kwd = annotate AnnKeyword . text+ -- | Pretty-printer helper for the binding site of a name bindingOf :: Name -- ^^ the bound name           -> Bool -- ^^ whether the name is implicit@@ -1289,11 +1332,11 @@            -> Name -- ^^ the name to pprint            -> Doc OutputAnnotation prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))-                        | otherwise = annotate (AnnName n Nothing Nothing) (text (strName n))+                        | otherwise = annotate (AnnName n Nothing Nothing Nothing) (text (strName n))   where strName (UN n) = T.unpack n         strName (NS n ns) | showNS    = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n                           | otherwise = strName n-        strName (MN i s) = T.unpack s+        strName (MN i s) = T.unpack s          strName other = show other  @@ -1315,16 +1358,16 @@ showDImp :: Bool -> PData -> Doc OutputAnnotation showDImp impl (PDatadecl n ty cons)  = text "data" <+> text (show n) <+> colon <+> prettyImp impl ty <+> text "where" <$>-    (indent 2 $ vsep (map (\ (_, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons))+    (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons))  showDecls :: Bool -> [PDecl] -> Doc OutputAnnotation showDecls i ds = vsep (map (showDeclImp i) ds)  showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))-showDeclImp i (PTy _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp i t+showDeclImp i (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp i t showDeclImp i (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>                                       indent 2 (vsep (map (showCImp i) cs))-showDeclImp _ (PData _ _ _ _ d) = showDImp True d+showDeclImp _ (PData _ _ _ _ _ d) = showDImp True d showDeclImp i (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls i ps <> line) showDeclImp i (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls i ps <> line) showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)@@ -1340,17 +1383,17 @@  getImps :: [PArg] -> [(Name, PTerm)] getImps [] = []-getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs getImps (_ : xs) = getImps xs  getExps :: [PArg] -> [PTerm] getExps [] = []-getExps (PExp _ _ tm _ : xs) = tm : getExps xs+getExps (PExp _ _ tm : xs) = tm : getExps xs getExps (_ : xs) = getExps xs  getConsts :: [PArg] -> [PTerm] getConsts [] = []-getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs+getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs getConsts (_ : xs) = getConsts xs  getAll :: [PArg] -> [PTerm]@@ -1413,7 +1456,7 @@   size (PEq fc left right) = 1 + size left + size right   size (PRewrite fc left right _) = 1 + size left + size right   size (PPair fc _ left right) = 1 + size left + size right-  size (PDPair fs left ty right) = 1 + size left + size ty + size right+  size (PDPair fs _ left ty right) = 1 + size left + size ty + size right   size (PAlternative a alts) = 1 + size alts   size (PHidden hidden) = size hidden   size (PUnifyLog tm) = size tm@@ -1452,8 +1495,8 @@     ni env (PRewrite _ l r _) = ni env l ++ ni env r     ni env (PTyped l r)    = ni env l ++ ni env r     ni env (PPair _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ (PRef _ n) t r)  = ni env t ++ ni (n:env) r-    ni env (PDPair _ l t r)  = ni env l ++ ni env t ++ ni env r+    ni env (PDPair _ _ (PRef _ n) t r)  = ni env t ++ ni (n:env) r+    ni env (PDPair _ _ l t r)  = ni env l ++ ni env t ++ ni env r     ni env (PAlternative a ls) = concatMap (ni env) ls     ni env (PUnifyLog tm)    = ni env tm     ni env (PDisamb _ tm)    = ni env tm@@ -1474,8 +1517,8 @@     ni (PRewrite _ l r _) = ni l ++ ni r     ni (PTyped l r)    = ni l ++ ni r     ni (PPair _ _ l r)   = ni l ++ ni r-    ni (PDPair _ (PRef _ n) t r) = ni t ++ ni r-    ni (PDPair _ l t r) = ni l ++ ni t ++ ni r+    ni (PDPair _ _ (PRef _ n) t r) = ni t ++ ni r+    ni (PDPair _ _ l t r) = ni l ++ ni t ++ ni r     ni (PAlternative a as) = concatMap (ni) as     ni (PHidden tm)    = ni tm     ni (PUnifyLog tm)    = ni tm@@ -1501,8 +1544,8 @@     ni env (PRewrite _ l r _) = ni env l ++ ni env r     ni env (PTyped l r)    = ni env l ++ ni env r     ni env (PPair _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r-    ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r+    ni env (PDPair _ _ (PRef _ n) t r) = ni env t ++ ni (n:env) r+    ni env (PDPair _ _ l t r) = ni env l ++ ni env t ++ ni env r     ni env (PAlternative a as) = concatMap (ni env) as     ni env (PHidden tm)    = ni env tm     ni env (PUnifyLog tm)    = ni env tm@@ -1529,8 +1572,8 @@     ni env (PRewrite _ l r _) = ni env l ++ ni env r     ni env (PTyped l r)    = ni env l ++ ni env r     ni env (PPair _ _ l r)   = ni env l ++ ni env r-    ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r-    ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r+    ni env (PDPair _ _ (PRef _ n) t r) = ni env t ++ ni (n:env) r+    ni env (PDPair _ _ l t r) = ni env l ++ ni env t ++ ni env r     ni env (PAlternative a as) = concatMap (ni env) as     ni env (PHidden tm)    = ni env tm     ni env (PUnifyLog tm)    = ni env tm
+ src/Idris/Apropos.hs view
@@ -0,0 +1,87 @@+module Idris.Apropos where++import Idris.AbsSyntax+import Idris.Core.Evaluate (ctxtAlist, Def(..))+import Idris.Core.TT (Name(..), Type, TT(..), NameType(..), Binder(..), Const(..),+                      lookupCtxtExact, toAlist)+import Idris.Docstrings (Docstring, containsText)++import Data.List (nub)+import qualified Data.Text as T++-- | Find definitions that are relevant to some string. Relevance is one or+-- more of the following:+--+-- * the string is a substring of the name+--+-- * the string occurs in the documentation string+--+-- * the type of the definition is apropos+apropos :: IState -> T.Text -> [Name]+apropos ist what = let defs = ctxtAlist (tt_ctxt ist)+                       docs = toAlist (idris_docstrings ist)+                   in nub (map fst (filter (isApropos what) defs) +++                           map fst (filter (isApropos what) docs))++textIn :: T.Text -> T.Text -> Bool+textIn a b = T.isInfixOf (T.toLower a) (T.toLower b)++class Apropos a where+  isApropos :: T.Text -> a -> Bool++instance Apropos Name where+  isApropos str (UN n)     = textIn str n+  isApropos str (NS n' ns) = isApropos str n' || any (textIn str) ns+  -- Handle special names from stdlib+  isApropos str n | (n == unitTy || n == unitCon) && str == T.pack "()" = True+                  | n == falseTy && str == T.pack "_|_" = True+                  | (n == pairTy || n == pairCon) && str == T.pack "," = True+                  | n == eqTy && str == T.pack "=" = True+                  | n == eqCon && (T.toLower str) == T.pack "refl" = True+                  | (n == sigmaTy || n == existsCon) && str == T.pack "**" = True+  isApropos _   _          = False -- we don't care about case blocks, MNs, etc++instance Apropos Def where+  isApropos str (Function ty tm) = isApropos str ty+  isApropos str (TyDecl _ ty) = isApropos str ty+  isApropos str (Operator ty _ _) = isApropos str ty+  isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty++instance Apropos (Binder (TT Name)) where+  isApropos str (Lam ty)      = isApropos str ty+  isApropos str (Pi ty)       = isApropos str ty+  isApropos str (Let ty val)  = isApropos str ty || isApropos str val+  isApropos str (NLet ty val) = isApropos str ty || isApropos str val+  isApropos str _             = False -- these shouldn't occur in defined libraries++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 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+  isApropos str (Constant const)    = isApropos str const+  isApropos str _                   = False++instance Apropos Const where+  isApropos str c = textIn str (T.pack (show c))++instance Apropos Docstring where+  isApropos str d = containsText str d++instance (Apropos a, Apropos b) => Apropos (a, b) where+  isApropos str (x, y) = isApropos str x || isApropos str y++instance (Apropos a) => Apropos (Maybe a) where+  isApropos str (Just x) = isApropos str x+  isApropos _   Nothing  = False++instance (Apropos a) => Apropos [a] where+  isApropos str xs = any (isApropos str) xs++defType :: Def -> Type+defType (Function t _) = t+defType (TyDecl _ t) = t+defType (Operator t _ _) = t+defType (CaseOp _ t _ _ _ _) = t
src/Idris/CaseSplit.hs view
@@ -14,6 +14,7 @@ import Idris.Delaborate import Idris.Parser import Idris.Error+import Idris.Output  import Idris.Core.TT import Idris.Core.Typecheck@@ -51,6 +52,8 @@ split :: Name -> PTerm -> Idris [[(Name, PTerm)]] split n t'    = do ist <- getIState+        -- Make sure all the names in the term are accessible+        mapM_ (\n -> setAccessibility n Public) (allNamesIn t')         (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')         logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats) --         iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))@@ -94,6 +97,8 @@                         MN i n | not (tnull n) && thead n == '_'                                -> mkSupply (supp ++ varlist)                         MN i n -> mkSupply (UN n : supp ++ varlist)+                        UN n | thead n == '_'+                               -> mkSupply (supp ++ varlist)                         x -> mkSupply (x : supp)        let badnames = map snd (namemap ms) ++ map snd (invented ms) ++                       explicit ms@@ -148,7 +153,7 @@    where mergeArg x (y, t)               = do tm' <- mergePat ist (getTm x) (getTm y) t                    case x of-                        (PImp _ _ _ _ _ _) ->+                        (PImp _ _ _ _ _) ->                              return (y { machine_inf = machine_inf x,                                          getTm = tm' })                         _ -> return (y { getTm = tm' })@@ -316,10 +321,14 @@                        let ap = mkApp ist ty []                        return (show fn ++ " " ++ ap ++                                    "= ?" ++ show fn ++ "_rhs")-   where mkApp i (PPi (Exp _ _ _ False) (MN _ _) ty sc) used+   where mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used                = let n = getNameFrom i used ty in                      show n ++ " " ++ mkApp i sc (n : used) -         mkApp i (PPi (Exp _ _ _ False) n _ sc) used +         mkApp i (PPi (Exp _ _ False) (UN n) ty sc) used+            | thead n == '_'+               = let n = getNameFrom i used ty in+                     show n ++ " " ++ mkApp i sc (n : used) +         mkApp i (PPi (Exp _ _ False) n _ sc) used                 = show n ++ " " ++ mkApp i sc (n : used)           mkApp i (PPi _ _ _ sc) used = mkApp i sc used          mkApp i _ _ = ""
src/Idris/Chaser.hs view
@@ -132,6 +132,8 @@             file_in <- runIO $ readFile f             file <- if lit then tclift $ unlit f file_in else return file_in             (_, modules, _) <- parseImports f file+            -- The chaser should never report warnings from sub-modules+            clearParserWarnings             ms <- mapM (btree done) [realName | (realName, alias, fc) <- modules]             return (concat ms)            else return [] -- IBC with no source available
src/Idris/Colours.hs view
@@ -3,9 +3,8 @@   ColourTheme(..),   defaultTheme,   colouriseKwd, colouriseBound, colouriseImplicit,-  colouriseType, colouriseFun, colouriseData,-  colourisePrompt,-  ColourType(..)) where+  colouriseType, colouriseFun, colouriseData, colouriseKeyword,+  colourisePrompt, colourise, ColourType(..)) where  import System.Console.ANSI @@ -30,8 +29,9 @@                                }                    deriving (Eq, Show) +-- | Idris's default console colour theme defaultTheme :: ColourTheme-defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False+defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False                            , boundVarColour = mkColour Magenta                            , implicitColour = IdrisColour (Just Magenta) True True False False                            , functionColour = mkColour Green@@ -40,7 +40,7 @@                            , promptColour = IdrisColour Nothing True False True False                            } --- Set the colour of a string using POSIX escape codes+-- | Set the colour of a string using POSIX escape codes colourise :: IdrisColour -> String -> String colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]     where sgr = fg c ++@@ -71,6 +71,8 @@ colourisePrompt :: ColourTheme -> String -> String colourisePrompt t = colourise (promptColour t) +colouriseKeyword :: ColourTheme -> String -> String+colouriseKeyword t = colourise (keywordColour t)  data ColourType = KeywordColour                 | BoundVarColour
src/Idris/Completion.hs view
@@ -45,8 +45,12 @@              , ("fill", Just ExprTArg)              , ("try", Just AltsTArg)              , ("induction", Just NameTArg)+             , (":t", Just ExprTArg)+             , (":type", Just ExprTArg)+             , (":e", Just ExprTArg)+             , (":eval", Just ExprTArg)              ] ++ map (\x -> (x, Nothing)) [-              "intros", "compute", "trivial", "solve", "attack",+              "intros", "compute", "trivial", "search", "solve", "attack",               "state", "term", "undo", "qed", "abandon", ":q"              ] tactics = map fst tacticArgs@@ -104,7 +108,11 @@  completeOption :: CompletionFunc Idris completeOption = completeWord Nothing " \t" completeOpt-    where completeOpt = return . completeWith ["errorcontext", "showimplicits", "originalerrors"]+    where completeOpt = return . completeWith [ "errorcontext"+                                              , "showimplicits"+                                              , "originalerrors"+                                              , "autosolve"+                                              ]  completeConsoleWidth :: CompletionFunc Idris completeConsoleWidth = completeWord Nothing " \t" completeW@@ -168,7 +176,8 @@   completeTactic :: [String] -> String -> CompletionFunc Idris-completeTactic as tac (prev, next) = fromMaybe completeTacName $ fmap completeArg $ lookup tac tacticArgs+completeTactic as tac (prev, next) = fromMaybe completeTacName . fmap completeArg $+                                     lookup tac tacticArgs     where completeTacName = return $ ("", completeWith tactics tac)           completeArg Nothing           = noCompletion (prev, next)           completeArg (Just NameTArg)   = noCompletion (prev, next) -- this is for binding new names!
src/Idris/Core/CaseTree.hs view
@@ -150,12 +150,18 @@  -- Find names which are used directly (i.e. not in a function call) in a term -directUse :: Eq n => TT n -> [n]+directUse :: TT Name -> [Name] directUse (P _ n _) = [n] directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])                                         ++ directUse t directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n]) directUse fn@(App f a)+    | (P Ref (UN pfk) _, [App e w]) <- unApply fn,+         pfk == txt "prim_fork"+             = directUse e ++ directUse w -- HACK so that fork works+    | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,+         fce == txt "Force"+             = directUse a -- forcing a value counts as a use     | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them     | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime      | otherwise = nub $ directUse f ++ directUse a@@ -574,6 +580,10 @@     = let alts' = filter notErased (map pruneAlt alts) in           case alts' of             [] -> ImpossibleCase+            as@(ConCase (UN delay) i [arg] sc : _)+                | delay == txt "Delay"+                   -> if proj then mkForce n arg sc+                              else Case n as             as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc                                                  else Case n as             as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc @@ -593,6 +603,31 @@           notErased (DefaultCase (STerm Erased)) = False           notErased (DefaultCase ImpossibleCase) = False           notErased _ = True++          mkForce n arg (Case x alts)+                | x == arg = ProjCase (forceArg n)+                                      (map (mkForceAlt n arg) alts)+                | otherwise = Case x (map (mkForceAlt n arg) alts)+          mkForce n arg (ProjCase t alts)+             = ProjCase (forceTm n arg t) (map (mkForceAlt n arg) alts)+          mkForce n arg (STerm t) = STerm (forceTm n arg t)+          mkForce n arg c = c++          mkForceAlt n arg (ConCase cn t args rhs)+             = ConCase cn t args (mkForce n arg rhs)+          mkForceAlt n arg (FnCase cn args rhs)+             = FnCase cn args (mkForce n arg rhs)+          mkForceAlt n arg (ConstCase t rhs)+             = ConstCase t (mkForce n arg rhs)+          mkForceAlt n arg (SucCase sn rhs)+             = SucCase sn (mkForce n arg rhs)+          mkForceAlt n arg (DefaultCase rhs)+             = DefaultCase (mkForce n arg rhs)+         +          forceTm n arg t = subst arg (forceArg n) t++          forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)+                           (P Bound n Erased)            mkProj n i []       sc = prune proj sc           mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc)
src/Idris/Core/DeepSeq.hs view
@@ -19,6 +19,7 @@         rnf (MethodN x1) = rnf x1 `seq` ()         rnf (CaseN x1) = rnf x1 `seq` ()         rnf (ElimN x1) = rnf x1 `seq` ()+        rnf (InstanceCtorN x1) = rnf x1 `seq` ()  instance NFData Raw where         rnf (Var x1) = rnf x1 `seq` ()
src/Idris/Core/Elaborate.hs view
@@ -131,14 +131,17 @@ 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                  put (ES (ps, f a) l p) +-- | Get the auxiliary state getAux :: Elab' aux aux getAux = do ES (ps, a) _ _ <- get             return $! a +-- | Set whether to show the unifier log unifyLog :: Bool -> Elab' aux () unifyLog log = do ES (ps, a) l p <- get                   put (ES (ps { unifylog = log }, a) l p)@@ -147,11 +150,28 @@ getUnifyLog = do ES (ps, a) l p <- get                  return (unifylog ps) +-- | Process a tactic within the current elaborator state+processTactic' :: Tactic -> Elab' aux () processTactic' t = do ES (p, a) logs prev <- get                       (p', log) <- lift $ processTactic t p                       put (ES (p', a) (logs ++ log) prev)                       return $! () +updatePS :: (ProofState -> ProofState) -> Elab' aux ()+updatePS f = do ES (ps, a) logs prev <- get+                put $ ES (f ps, a) logs prev++now_elaborating :: FC -> Name -> Name -> Elab' aux ()+now_elaborating fc f a = updatePS (nowElaboratingPS fc f a)+done_elaborating_app :: Name -> Elab' aux ()+done_elaborating_app f = updatePS (doneElaboratingAppPS f)+done_elaborating_arg :: Name -> Name -> Elab' aux ()+done_elaborating_arg f a = updatePS (doneElaboratingArgPS f a)+elaborating_app :: Elab' aux [(FC, Name, Name)]+elaborating_app = do ES (ps, _) _ _ <- get+                     return $ map (\ (FailContext x y z) -> (x, y, z))+                                  (while_elaborating ps)+ -- Some handy gadgets for pulling out bits of state  -- get the global context@@ -182,6 +202,10 @@ get_env = do ES p _ _ <- get              lift $ envAtFocus (fst p) +get_inj :: Elab' aux [Name]+get_inj = do ES p _ _ <- get+             return $! (injective (fst p))+ get_holes :: Elab' aux [Name] get_holes = do ES p _ _ <- get                return $! (holes (fst p))@@ -368,8 +392,8 @@ movelast :: Name -> Elab' aux () movelast n = processTactic' (MoveLast n) -matchProblems :: Elab' aux ()-matchProblems = processTactic' MatchProblems+matchProblems :: Bool -> Elab' aux ()+matchProblems all = processTactic' (MatchProblems all)  unifyProblems :: Elab' aux () unifyProblems = processTactic' UnifyProblems@@ -591,10 +615,10 @@        hs <- get_holes        env <- get_env        -- We don't need a and b in the hole queue any more since they were-       -- just for checking f, so discard them if they are still there.-       -- If they haven't been solved, regret will fail-       when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)-       when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)+       -- just for checking f, so move them to the end. If they never end up+       -- getting solved, we'll get an 'Incomplete term' error.+       when (a `elem` hs) $ do movelast a+       when (b `elem` hs) $ do movelast b        end_unify   where regretWith err = try regret                              (lift $ tfail err)@@ -621,22 +645,40 @@             ps' <- get_probs             if (length ps' > length ps) then                case reverse ps' of-                    ((x,y,env,err) : _) ->+                    ((x, y, env, inerr, while, _) : _) ->                        let env' = map (\(x, b) -> (x, binderTy b)) env in-                                  lift $ tfail $ CantUnify False x y err env' 0+                                  lift $ tfail $ +                                         case err of+                                              Nothing -> CantUnify False x y inerr env' 0+                                              Just e -> e                else return $! ()  -- Try a tactic, if it fails, try another try :: Elab' aux a -> Elab' aux a -> Elab' aux a try t1 t2 = try' t1 t2 False +handleError :: (Err -> Bool) -> Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a+handleError p t1 t2 proofSearch+          = do s <- get+               ps <- get_probs+               case runStateT t1 s of+                    OK (v, s') -> do put s'+                                     return $! v+                    Error e1 -> if p e1 then+                                   do case runStateT t2 s of+                                         OK (v, s') -> do put s'; return $! v+                                         Error e2 -> if score e1 >= score e2+                                                        then lift (tfail e1)+                                                        else lift (tfail e2)+                                   else lift (tfail e1)+ try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a try' t1 t2 proofSearch           = do s <- get                ps <- get_probs                case prunStateT 999999 False ps t1 s of-                    OK ((v, _), s') -> do put s'-                                          return $! v+                    OK ((v, _, _), s') -> do put s'+                                             return $! v                     Error e1 -> if recoverableErr e1 then                                    do case runStateT t2 s of                                          OK (v, s') -> do put s'; return $! v@@ -649,6 +691,8 @@                r || proofSearch         recoverableErr (CantSolveGoal _ _) = False         recoverableErr (ProofSearchFail _) = False+        recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e+        recoverableErr (At _ e) = recoverableErr e         recoverableErr _ = True  tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a@@ -658,7 +702,7 @@  -- Try a selection of tactics. Exactly one must work, all others must fail tryAll :: [(Elab' aux a, String)] -> Elab' aux a-tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)+tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs   where     cantResolve :: Elab' aux a     cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)@@ -666,24 +710,24 @@     tryAll' :: [Elab' aux a] -> -- successes                Int -> -- most problems                (Elab' aux a, Int) -> -- smallest failure-               [Elab' aux a] -> -- still to try+               [(Elab' aux a, String)] -> -- still to try                Elab' aux a     tryAll' [res] pmax _   [] = res     tryAll' (_:_) pmax _   [] = cantResolve     tryAll' [] pmax (f, _) [] = f-    tryAll' cs pmax f (x:xs)+    tryAll' cs pmax f ((x, msg):xs)        = do s <- get             ps <- get_probs             case prunStateT pmax True ps x s of-                OK ((v, newps), s') ->+                OK ((v, newps, probs), s') ->                     do let cs' = if (newps < pmax)                                     then [do put s'; return $! v]                                     else (do put s'; return $! v) : cs                        tryAll' cs' newps f xs                 Error err -> do put s-                                if (score err) < 100-                                    then tryAll' cs pmax (better err f) xs-                                    else tryAll' [] pmax (better err f) xs -- give up+--                                 if (score err) < 100+                                tryAll' cs pmax (better err f) xs+--                                     else tryAll' [] pmax (better err f) xs -- give up       better err (f, i) = let s = score err in@@ -697,12 +741,12 @@                      newpmax = if newps < 0 then 0 else newps in                  if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))                     then case reverse (problems p) of-                            ((_,_,_,e):_) -> Error e-                    else OK ((v, newpmax), s')+                            ((_,_,_,e,_,_):_) -> Error e+                    else OK ((v, newpmax, problems p), s')              Error e -> Error e  qshow :: Fails -> String-qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)+qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)  dumpprobs [] = "" dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es
src/Idris/Core/Evaluate.hs view
@@ -100,6 +100,8 @@ simplify :: Context -> Env -> TT Name -> TT Name simplify ctxt env t    = evalState (do val <- eval False ctxt [(sUN "lazy", 0),+                                           (sUN "force", 0),+                                           (sUN "Force", 0),                                            (sUN "assert_smaller", 0),                                            (sUN "assert_total", 0),                                            (sUN "par", 0),@@ -113,6 +115,8 @@ rt_simplify :: Context -> Env -> TT Name -> TT Name rt_simplify ctxt env t    = evalState (do val <- eval False ctxt [(sUN "lazy", 0),+                                           (sUN "force", 0),+                                           (sUN "Force", 0),                                            (sUN "par", 0),                                            (sUN "prim__syntactic_eq", 0),                                            (sUN "prim_fork", 0)]@@ -253,11 +257,24 @@                 return $ VBind True n (Let t' v') (\x -> return sc')     ev ntimes stk top env (Bind n b sc)            = do b' <- vbind env b-                let n' = uniqueName n (map fst env)+                let n' = uniqueName n (map fst genv ++ map fst env)                 return $ VBind True -- (vinstances 0 sc < 2)-                               n' b' (\x -> ev ntimes stk False ((n, x):env) sc)+                               n' b' (\x -> ev ntimes stk False ((n', x):env) sc)        where vbind env t                      = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t+    -- block reduction immediately under codata (and not forced)+    ev ntimes stk top env +              (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)+       | dly == txt "Delay" && lco == txt "LazyCodata" && not simpl+            = do let (f, _) = unApply arg+                 let ntimes' = case f of+                                    P _ fn _ -> (fn, 0) : ntimes+                                    _ -> ntimes+                 d' <- ev ntimes' stk False env d+                 l' <- ev ntimes' stk False env l+                 t' <- ev ntimes' stk False env t+                 arg' <- ev ntimes' stk False env arg+                 evApply ntimes' stk top env [l',t',arg'] d'     -- Treat "assert_total" specially, as long as it's defined!     ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)        | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,@@ -305,7 +322,7 @@     apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)          = do a' <- sc a               app <- apply ntimes stk top env a' as-              wknV (-1) app+              wknV 1 app     apply ntimes_in stk top env f@(VP Ref n ty) args       | not top && hnf = case args of                             [] -> return f@@ -509,19 +526,20 @@     quote i (VTmp x)       = return $ V (i - x - 1)  wknV :: Int -> Value -> Eval Value-wknV i (VV x)         = return $ VV (x + i)+wknV i (VV x) | x >= i = return $ VV (x - 1) wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b                                return $ VBind red n b' (\x -> do x' <- sc x-                                                                 wknV i x')+                                                                 wknV (i + 1) x') wknV i (VApp f a)     = liftM2 VApp (wknV i f) (wknV i a) wknV i t              = return t -convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])+convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, []) -convEq :: Context -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool-convEq ctxt = ceq [] where+convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool+convEq ctxt holes = ceq [] where     ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool     ceq ps (P xt x _) (P yt y _)+        | x `elem` holes || y `elem` holes = return True         | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True         | otherwise = sameDefs ps x y     ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y@@ -531,8 +549,10 @@     ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y         | n == n' = ceq ps x y     ceq ps (V x)      (V y)      = return (x == y)-    ceq ps (Bind _ xb xs) (Bind _ yb ys)-                             = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)+    ceq ps (V x)      (P _ y _)  = return (fst (ps!!x) == y)+    ceq ps (P _ x _)  (V y)      = return (x == snd (ps!!y))+    ceq ps (Bind n xb xs) (Bind n' yb ys)+                             = liftM2 (&&) (ceqB ps xb yb) (ceq ((n,n'):ps) xs ys)         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')@@ -544,7 +564,7 @@                                               return True     ceq ps Erased _ = return True     ceq ps _ Erased = return True-    ceq ps _ _ = return False+    ceq ps x y = return False      caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs'       where@@ -869,12 +889,12 @@  isFnName :: Name -> Context -> Bool isFnName n ctxt-     = or $ do def <- lookupCtxt n (definitions ctxt)-               case tfst def of-                    (Function _ _) -> return True-                    (Operator _ _ _) -> return True-                    (CaseOp _ _ _ _ _ _) -> return True-                    _ -> return False+     = let def = lookupCtxtExact n (definitions ctxt) in+          case def of+               Just (Function _ _, _, _, _) -> True+               Just (Operator _ _ _, _, _, _) -> True+               Just (CaseOp _ _ _ _ _ _, _, _, _) -> True+               _ -> False  lookupP :: Name -> Context -> [Term] lookupP n ctxt
src/Idris/Core/Execute.hs view
@@ -320,6 +320,13 @@            = let res = ioWrap . EConstant . I $ 0                  in execApp' env ctxt res (tail rest) +-- Right now, there's no way to send command-line arguments to the executor,+-- so just return 0.+execApp' env ctxt (EP _ fp _) (_:fn:rest)+    | fp == mkfprim,+      Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn+           = let res = ioWrap . EConstant . I $ 0+             in execApp' env ctxt res (tail rest) -- Throw away the 'World' argument to the foreign function  execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim
src/Idris/Core/ProofState.hs view
@@ -5,8 +5,8 @@    evaluation/checking inside the proof system, etc. --}  module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,-                  Tactic(..), Goal(..), processTactic,-                  dropGiven, keepGiven) where+                  Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,+                  doneElaboratingArgPS, dropGiven, keepGiven) where  import Idris.Core.Typecheck import Idris.Core.Evaluate@@ -15,6 +15,7 @@  import Control.Monad.State.Strict import Control.Applicative hiding (empty)+import Control.Arrow (first) import Data.List import Debug.Trace @@ -38,7 +39,8 @@                        context  :: Context,                        plog     :: String,                        unifylog :: Bool,-                       done     :: Bool+                       done     :: Bool,+                       while_elaborating :: [FailContext]                      }  data Goal = GD { premises :: Env,@@ -79,7 +81,7 @@             | Instance Name             | SetInjective Name             | MoveLast Name-            | MatchProblems+            | MatchProblems Bool             | UnifyProblems             | ProofState             | Undo@@ -89,9 +91,9 @@ -- Some utilites on proof and tactic states  instance Show ProofState where-    show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)+    show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)           = show nm ++ ": no more goals"-    show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)+    show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)           = let OK g = goal (Just h) tm                 wkenv = premises g in                 "Other goals: " ++ show hs ++ "\n" ++@@ -114,9 +116,9 @@                showG ps b = showEnv ps (binderTy b)  instance Pretty ProofState OutputAnnotation where-  pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =+  pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =     pretty nm <+> colon <+> text " no more goals."-  pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) =+  pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) =     let OK g  = goal (Just h) tm in     let wkEnv = premises g in       text "Other goals" <+> colon <+> pretty hs <+>@@ -147,35 +149,59 @@ holeName i = sMN i "hole"  qshow :: Fails -> String-qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)+qshow fs = show (map (\ (x, y, _, _, _, t) -> (t, x, y)) fs)  match_unify' :: Context -> Env -> TT Name -> TT Name ->                 StateT TState TC [(Name, TT Name)] match_unify' ctxt env topx topy =    do ps <- get+      let while = while_elaborating ps       let dont = dontunify ps-      u <- lift $ match_unify ctxt env topx topy dont (holes ps)-      let (h, ns) = unified ps-      put (ps { unified = (h, u ++ ns) })-      return u+      let inj = injective ps+      traceWhen (unifylog ps)+                ("Matching " ++ show (topx, topy) ++ +                 " in " ++ show env +++                 "\nHoles: " ++ show (holes ps)+                  ++ "\n" +                  ++ "\n" ++ show (pterm ps) ++ "\n\n"+                 ) $+       case match_unify ctxt env topx topy inj (holes ps) while of+            OK u -> do let (h, ns) = unified ps+                       put (ps { unified = (h, u ++ ns) })+                       return u+            Error e -> do put (ps { problems = (topx, topy, env, e, while, Match) :+                                                  problems ps })+                          return []+--       traceWhen (unifylog ps)+--             ("Matched " ++ show (topx, topy) ++ " without " ++ show dont +++--              "\nSolved: " ++ show u +--              ++ "\nCurrent problems:\n" ++ qshow (problems ps)+-- --              ++ show (pterm ps)+--              ++ "\n----------") $  unify' :: Context -> Env -> TT Name -> TT Name ->           StateT TState TC [(Name, TT Name)] unify' ctxt env topx topy =    do ps <- get+      let while = while_elaborating ps       let dont = dontunify ps+      let inj = injective ps       (u, fails) <- traceWhen (unifylog ps)                         ("Trying " ++ show (topx, topy) +++                         "\nNormalised " ++ show (normalise ctxt env topx,+                                                  normalise ctxt env topy) ++                          " in " ++ show env ++-                         "\nHoles: " ++ show (holes ps) ++ "\n") $-                     lift $ unify ctxt env topx topy dont (holes ps)+                         "\nHoles: " ++ show (holes ps)+                         ++ "\nInjective: " ++ show (injective ps)+                         ++ "\n") $+                     lift $ unify ctxt env topx topy inj (holes ps) while       let notu = filter (\ (n, t) -> case t of                                         P _ _ _ -> False                                         _ -> n `elem` dont) u       traceWhen (unifylog ps)             ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++              "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails-             ++ "\nNot unified:\n" ++ show (notunified ps) +             ++ "\nNot unified:\n" ++ show (notunified ps)              ++ "\nCurrent problems:\n" ++ qshow (problems ps) --              ++ show (pterm ps)              ++ "\n----------") $@@ -187,9 +213,35 @@                                               (holes ps)            put (ps { problems = probs',                      unified = (h, ns'),+                     injective = updateInj u (injective ps),                      notunified = notu ++ notunified ps })            return u+  where updateInj ((n, a) : us) inj+              | (P _ n' _, _) <- unApply a,+                n `elem` inj = updateInj us (n':inj)+              | (P _ n' _, _) <- unApply a,+                n' `elem` inj = updateInj us (n:inj)+        updateInj (_ : us) inj = updateInj us inj+        updateInj [] inj = inj +nowElaboratingPS :: FC -> Name -> Name -> ProofState -> ProofState+nowElaboratingPS fc f arg ps = ps { while_elaborating = FailContext fc f arg : while_elaborating ps }++dropUntil :: (a -> Bool) -> [a] -> [a]+dropUntil p [] = []+dropUntil p (x:xs) | p x       = xs+                   | otherwise = dropUntil p xs++doneElaboratingAppPS :: Name -> ProofState -> ProofState+doneElaboratingAppPS f ps = let while = while_elaborating ps+                                while' = dropUntil (\ (FailContext _ f' _) -> f == f') while+                            in ps { while_elaborating = while' }++doneElaboratingArgPS :: Name -> Name -> ProofState -> ProofState+doneElaboratingArgPS f x ps = let while = while_elaborating ps+                                  while' = dropUntil (\ (FailContext _ f' x') -> f == f' && x == x') while+                              in ps { while_elaborating = while' }+ getName :: Monad m => String -> StateT TState m Name getName tag = do ps <- get                  let n = nextname ps@@ -200,6 +252,10 @@ action a = do ps <- get               put (a ps) +query :: Monad m => (ProofState -> r) -> StateT TState m r+query q = do ps <- get+             return $ q ps+ addLog :: Monad m => String -> StateT TState m () addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" }) @@ -210,7 +266,7 @@                             (P Bound h ty')) ty [] (h, []) []                             Nothing [] []                             [] []-                            Nothing ctxt "" False False+                            Nothing ctxt "" False False []  type TState = ProofState -- [TacticAction]) type RunTactic = Context -> Env -> Term -> StateT TState TC Term@@ -358,10 +414,10 @@          return (Bind x (Hole t) sc)  setinj :: Name -> RunTactic-setinj n ctxt env (Bind x (Hole t) sc)+setinj n ctxt env (Bind x b sc)     = do action (\ps -> let is = injective ps in                             ps { injective = n : is })-         return (Bind x (Hole t) sc)+         return (Bind x b sc)  defer :: Name -> RunTactic defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =@@ -391,7 +447,7 @@                   Nothing -> error ("deferType can't find " ++ show n)  regret :: RunTactic-regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =+regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =      do action (\ps -> let hs = holes ps in                           ps { holes = hs \\ [x] })        return sc@@ -458,22 +514,24 @@  solve :: RunTactic solve ctxt env (Bind x (Guess ty val) sc)-   | True         = do ps <- get-                       let (uh, uns) = unified ps-                       case lookup x (notunified ps) of-                           Just tm -> unify' ctxt env tm val-                           _ -> return []-                       action (\ps -> ps { holes = holes ps \\ [x],-                                           solved = Just (x, val),-                                           instances = instances ps \\ [x] })-                       let tm' = subst x val sc in -                           return tm'-   | otherwise    = lift $ tfail $ IncompleteTerm val+   = do ps <- get+        let (uh, uns) = unified ps+        case lookup x (notunified ps) of+            Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $+                         match_unify' ctxt env tm val+            _ -> return []+        action (\ps -> ps { holes = holes ps \\ [x],+                            solved = Just (x, val),+                            notunified = updateNotunified [(x,val)]+                                           (notunified ps),+                            instances = instances ps \\ [x] })+        let tm' = subst x val sc in +            return tm' solve _ _ h@(Bind x t sc)-            = do ps <- get-                 case findType x sc of-                      Just t -> lift $ tfail (CantInferType (show t))-                      _ -> fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)+   = do ps <- get+        case findType x sc of+             Just t -> lift $ tfail (CantInferType (show t))+             _ -> fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)    where findType x (Bind n (Let t v) sc)               = findType x v `mplus` findType x sc          findType x (Bind n t sc) @@ -526,8 +584,13 @@  patvar :: Name -> RunTactic patvar n ctxt env (Bind x (Hole t) sc) =-    do action (\ps -> ps { holes = holes ps \\ [x] })+    do action (\ps -> ps { holes = holes ps \\ [x],+                           notunified = updateNotunified [(x,P Bound n t)]+                                          (notunified ps),+                           injective = addInj n x (injective ps) })        return $ Bind n (PVar t) (subst x (P Bound n t) sc)+  where addInj n x ps | x `elem` ps = n : ps+                      | otherwise = ps patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm  letbind :: Name -> Raw -> Raw -> RunTactic@@ -601,10 +664,11 @@              let scr      = last $ tail args'              let indxnames = makeIndexNames indicies              prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t-             let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))-                                                        (params ++ [prop] ++ map makeConsArg consargs ++ indicies ++ [tmv])))+             consargs' <- query (\ps -> map (first $ flip (uniqueNameCtxt (context ps)) (holes ps)) consargs)+             let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))+                                                        (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))              action (\ps -> ps {holes = holes ps \\ [x]})-             mapM_ addConsHole (reverse consargs)+             mapM_ addConsHole (reverse consargs')              let res' = forget $ res              (scv, sct) <- lift $ check ctxt env res'              let scv' = specialise ctxt env [] scv@@ -697,7 +761,6 @@        action (\ps -> ps { holes = holes ps \\ map fst unify })        action (\ps -> ps { pterm = updateSolved unify (pterm ps) })        return (updateSolved unify tm)-  where  dropGiven du [] hs = [] dropGiven du ((n, P Bound t ty) : us) hs@@ -753,33 +816,40 @@   up ((n, t) : nus) = let t' = updateSolved ns t in                           ((n, t') : up nus) +updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]+               -> ([(Name, TT Name)], Fails) updateProblems ctxt [] ps inj holes = ([], ps) updateProblems ctxt ns ps inj holes = up ns ps where   up ns [] = (ns, [])-  up ns ((x, y, env, err) : ps) =+  up ns ((x, y, env, err, while, um) : ps) =     let x' = updateSolved ns x         y' = updateSolved ns y         err' = updateError ns err         env' = updateEnv ns env in-        case unify ctxt env' x' y' inj holes of+--         trace ("Updating " ++ show (x',y')) $ +          case unify ctxt env' x' y' inj holes while of             OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $                                up (ns ++ v) ps-            _ -> let (ns', ps') = up ns ps in-                     (ns', (x',y',env',err') : ps')+            e -> -- trace ("Failed " ++ show e) $+                  let (ns', ps') = up ns ps in+                     (ns', (x',y',env',err', while, um) : ps')  -- attempt to solve remaining problems with match_unify-matchProblems ctxt ps inj holes = up [] ps where+matchProblems all ns ctxt ps inj holes = up ns ps where   up ns [] = (ns, [])-  up ns ((x, y, env, err) : ps) =+  up ns ((x, y, env, err, while, um) : ps)+       | all || um == Match =     let x' = updateSolved ns x         y' = updateSolved ns y         err' = updateError ns err         env' = updateEnv ns env in-        case match_unify ctxt env' x' y' inj holes of+        case match_unify ctxt env' x' y' inj holes while of             OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $                                up (ns ++ v) ps             _ -> let (ns', ps') = up ns ps in-                     (ns', (x',y',env',err') : ps')+                     (ns', (x', y', env', err', while, um) : ps')+  up ns (p : ps) = let (ns', ps') = up ns ps in+                       (ns', p : ps')  processTactic :: Tactic -> ProofState -> TC (ProofState, String) processTactic QED ps = case holes ps of@@ -819,23 +889,29 @@                    previous = Just ps, plog = "",                    notunified = updateNotunified ns' (notunified ps),                    holes = holes ps \\ (map fst ns') }, plog ps)-processTactic MatchProblems ps-    = let (ns', probs') = matchProblems (context ps)-                                        (problems ps)-                                        (injective ps)-                                        (holes ps)-          pterm' = updateSolved ns' (pterm ps) in-      return (ps { pterm = pterm', solved = Nothing, problems = probs',+processTactic (MatchProblems all) ps+    = let (ns', probs') = matchProblems all [] (context ps)+                                            (problems ps)+                                            (injective ps)+                                            (holes ps)+          (ns'', probs'') = matchProblems all ns' (context ps)+                                           probs'+                                           (injective ps)+                                           (holes ps)+          pterm' = updateSolved ns'' (pterm ps) in+        return (ps { pterm = pterm', solved = Nothing, problems = probs'',                    previous = Just ps, plog = "",-                   notunified = updateNotunified ns' (notunified ps),-                   holes = holes ps \\ (map fst ns') }, plog ps)+                   notunified = updateNotunified ns'' (notunified ps),+                   holes = holes ps \\ (map fst ns'') }, plog ps) processTactic t ps     = case holes ps of         [] -> fail "Nothing to fill in."         (h:_)  -> do ps' <- execStateT (process t h) ps                      let (ns', probs')                                 = case solved ps' of-                                    Just s -> updateProblems (context ps')+                                    Just s -> traceWhen (unifylog ps')+                                                ("SOLVED " ++ show s) $+                                               updateProblems (context ps')                                                       [s] (problems ps')                                                       (injective ps')                                                       (holes ps')
src/Idris/Core/TT.hs view
@@ -44,8 +44,8 @@  -- | Source location. These are typically produced by the parser 'Idris.Parser.getFC' data FC = FC { fc_fname :: String, -- ^ Filename-               fc_line :: Int, -- ^ Line number-               fc_column :: Int -- ^ Column number+               fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span+               fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span              }  -- | Ignore source location equality (so deriving classes do not compare FCs)@@ -57,7 +57,7 @@  instance Eq FC' where   FC' fc == FC' fc' = fcEq fc fc'-    where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c'+    where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'  -- | Empty source location emptyFC :: FC@@ -65,7 +65,7 @@  -- | Source location with file only fileFC :: String -> FC-fileFC s = FC s 0 0+fileFC s = FC s (0, 0) (0, 0)  {-! deriving instance Binary FC@@ -73,20 +73,30 @@ !-}  instance Sized FC where-  size (FC f l c) = 1 + length f+  size (FC f s e) = 4 + length f  instance Show FC where-    show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c+    show (FC f s e) = f ++ ":" ++ showLC s e+      where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc+                                     | sl == el             = show sl ++ ":" ++ show sc ++ "-" ++ show ec+                                     | otherwise            = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec  -- | Output annotation for pretty-printed name - decides colour-data NameOutput = TypeOutput | FunOutput | DataOutput+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput +-- | Text formatting output+data TextFormatting = BoldText | ItalicText | UnderlineText+ -- | Output annotations for pretty-printing-data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)+data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)+                        -- ^^ The name, classification, docs overview, and pretty-printed type                       | AnnBoundName Name Bool+                        -- ^^ The name and whether it is implicit                       | AnnConstData                       | AnnConstType+                      | AnnKeyword                       | AnnFC FC+                      | AnnTextFmt TextFormatting  -- | Used for error reflection data ErrorReportPart = TextPart String@@ -132,6 +142,7 @@           | NoRewriting t           | At FC (Err' t)           | Elaborating String Name (Err' t)+          | ElaboratingArg Name Name [(Name, Name)] (Err' t)           | ProviderError String           | LoadingFailed String (Err' t)           | ReflectionError [[ErrorReportPart]] (Err' t)@@ -162,6 +173,7 @@   size ProgramLineComment = 1   size (At fc err) = size fc + size err   size (Elaborating _ n err) = size err+  size (ElaboratingArg _ _ _ err) = size err   size (ProviderError msg) = length msg   size (LoadingFailed fn e) = 1 + length fn + size e   size _ = 1@@ -186,6 +198,9 @@     show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e     show ProgramLineComment = "Program line next to comment"     show (At f e) = show f ++ ":" ++ show e+    show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " +++                                       show x ++ ": " ++ show e+    show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e     show _ = "Error"  instance Pretty Err OutputAnnotation where@@ -279,6 +294,7 @@                  | MethodN Name                  | CaseN Name                  | ElimN Name+                 | InstanceCtorN Name   deriving (Eq, Ord) {-! deriving instance Binary SpecialName@@ -298,11 +314,11 @@   size _ = 1  instance Pretty Name OutputAnnotation where-  pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n')-  pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un-  pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $+  pretty n@(UN n') = annotate (AnnName n Nothing Nothing Nothing) $ text (T.unpack n')+  pretty n@(NS un s) = annotate (AnnName n Nothing Nothing Nothing) . noAnnotate $ pretty un+  pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $                       lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace-  pretty n@(SN s) = annotate (AnnName n Nothing Nothing) $ text (show s)+  pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)  instance Pretty [Name] OutputAnnotation where   pretty = encloseSep empty empty comma . map pretty@@ -322,6 +338,7 @@     show (ParentN p c) = show p ++ "#" ++ T.unpack c     show (CaseN n) = "case block in " ++ show n     show (ElimN n) = "<<" ++ show n ++ " eliminator>>"+    show (InstanceCtorN n) = "constructor of " ++ show n  -- Show a name in a way decorated for code generation, not human reading showCG :: Name -> String@@ -475,7 +492,7 @@            | B8V (Vector Word8) | B16V (Vector Word16)            | B32V (Vector Word32) | B64V (Vector Word64)            | AType ArithTy | StrType-           | PtrType | BufferType | VoidType | Forgot+           | PtrType | ManagedPtrType | BufferType | VoidType | Forgot   deriving (Eq, Ord) {-! deriving instance Binary Const@@ -495,6 +512,7 @@   pretty StrType = text "String"   pretty BufferType = text "prim__UnsafeBuffer"   pretty PtrType = text "Ptr"+  pretty ManagedPtrType = text "Ptr"   pretty VoidType = text "Void"   pretty Forgot = text "Forgot"   pretty (B8 w) = text . show $ w@@ -1041,6 +1059,7 @@     show StrType = "String"     show BufferType = "prim__UnsafeBuffer"     show PtrType = "Ptr"+    show ManagedPtrType = "ManagedPtr"     show VoidType = "Void"  showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String
src/Idris/Core/Typecheck.hs view
@@ -16,11 +16,12 @@ -- indexed with 'finalise'  convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC ()-convertsC ctxt env x y-  = do c1 <- convEq ctxt x y+convertsC ctxt env x y =+    do let hs = map fst (filter isHole env)+       c1 <- convEq ctxt hs x y        if c1 then return ()          else-            do c2 <- convEq ctxt (finalise (normalise ctxt env x))+            do c2 <- convEq ctxt hs (finalise (normalise ctxt env x))                          (finalise (normalise ctxt env y))                if c2 then return ()                  else lift $ tfail (CantConvert@@ -29,14 +30,18 @@  converts :: Context -> Env -> Term -> Term -> TC () converts ctxt env x y-     = case convEq' ctxt x y of+     = let hs = map fst (filter isHole env) in+       case convEq' ctxt hs x y of           OK True -> return ()-          _ -> case convEq' ctxt (finalise (normalise ctxt env x))-                                 (finalise (normalise ctxt env y)) of+          _ -> case convEq' ctxt hs (finalise (normalise ctxt env x))+                                    (finalise (normalise ctxt env y)) of                 OK True -> return ()                 _ -> tfail (CantConvert                            (finalise (normalise ctxt env x))                            (finalise (normalise ctxt env y)) (errEnv env))++isHole (n, Hole _) = True+isHole _ = False  errEnv = map (\(x, b) -> (x, binderTy b))
src/Idris/Core/Unify.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} -module Idris.Core.Unify(match_unify, unify, Fails) where+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where  import Idris.Core.TT import Idris.Core.Evaluate@@ -18,8 +18,17 @@ -- terms which need to be injective, with the things we're trying to unify -- at the time +data FailAt = Match | Unify+     deriving (Show, Eq)++data FailContext = FailContext { fail_sourceloc :: FC,+                                 fail_fn        :: Name,+                                 fail_param     :: Name+                               }+  deriving (Eq, Show)+ type Injs = [(TT Name, TT Name, TT Name)]-type Fails = [(TT Name, TT Name, Env, Err)]+type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]  data UInfo = UI Int Fails      deriving Show@@ -28,17 +37,26 @@                | UPartOK a                | UFail Err +-- | Smart constructor for unification errors that takes into account the FailContext+cantUnify :: [FailContext] -> Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t+cantUnify [] r t1 t2 e ctxt i = CantUnify r t1 t2 e ctxt i+cantUnify (FailContext fc f x : prev) r t1 t2 e ctxt i =+  At fc (ElaboratingArg f x+          (map (\(FailContext _ f' x') -> (f', x')) prev)+          (CantUnify r t1 t2 e ctxt i))+ -- Solve metavariables by matching terms against each other -- Not really unification, of course! -match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->+match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->                TC [(Name, TT Name)]-match_unify ctxt env topx topy dont holes =-     case runStateT (un [] topx topy) (UI 0 []) of+match_unify ctxt env topx topy inj holes from =+     case runStateT (un [] (renameBindersTm env topx)+                           (renameBindersTm env topy)) (UI 0 []) of         OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))         res ->-               let topxn = normalise ctxt env topx-                   topyn = normalise ctxt env topy in+               let topxn = renameBindersTm env (normalise ctxt env topx)+                   topyn = renameBindersTm env (normalise ctxt env topy) in                      case runStateT (un [] topxn topyn)         	  	        (UI 0 []) of                        OK (v, UI _ fails) ->@@ -60,25 +78,30 @@         | holeIn env y || y `elem` holes             = do sc 1; checkCycle names (y, tm)     un bnames (V i) (P _ x _)-        | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []+        | length bnames > i, +          fst (fst (bnames!!i)) == x || +          snd (fst (bnames!!i)) == x = do sc 1; return []     un bnames (P _ x _) (V i)-        | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []+        | length bnames > i,+          fst (fst (bnames!!i)) == x || +          snd (fst (bnames!!i)) == x = do sc 1; return []     un bnames (Bind x bx sx) (Bind y by sy)         = do h1 <- uB bnames bx by-             h2 <- un ((x, y) : bnames) sx sy+             h2 <- un (((x, y), binderTy bx) : bnames) sx sy              combine bnames h1 h2     un names (App fx ax) (App fy ay)         = do hf <- un names fx fy              ha <- un names ax ay              combine names hf ha     un names x y-        | OK True <- convEq' ctxt x y = do sc 1; return []+        | OK True <- convEq' ctxt holes x y = do sc 1; return []         | otherwise = do UI s f <- get-                         let r = recoverable x y-                         let err = CantUnify r-                                     topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s+                         let r = recoverable (normalise ctxt env x) +                                             (normalise ctxt env y)+                         let err = cantUnify from r+                                     topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s                          if (not r) then lift $ tfail err-                           else do put (UI s ((x, y, env, err) : f))+                           else do put (UI s ((x, y, env, err, from, Match) : f))                                    lift $ tfail err  @@ -88,11 +111,12 @@     uB bnames (Lam tx) (Lam 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 (binderTy x) (binderTy y)-                       let err = CantUnify r topx topy-                                  (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s)-                                  (errEnv env) s-                       put (UI s ((binderTy x, binderTy y, env, err) : f))+                       let r = recoverable (normalise ctxt env (binderTy x)) +                                           (normalise ctxt env (binderTy y))+                       let err = cantUnify from r topx topy+                                   (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)+                                   (errEnv env) s+                       put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))                        return []      -- TODO: there's an annoying amount of repetition between this and the@@ -102,10 +126,11 @@               put (UI (s+i) f)      unifyFail x y = do UI s f <- get-                       let r = recoverable x y-                       let err = CantUnify r-                                   topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s-                       put (UI s ((x, y, env, err) : f))+                       let r = recoverable (normalise ctxt env x) +                                           (normalise ctxt env y)+                       let err = cantUnify from r+                                   topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+                       put (UI s ((x, y, env, err, from, Match) : f))                        lift $ tfail err     combine bnames as [] = return as     combine bnames as ((n, t) : bs)@@ -123,24 +148,37 @@         | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))      checkScope ns (x, tm) =-          case boundVs (envPos x 0 env) tm of-               [] -> return [(x, tm)]-               (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))-                                     (inst ns tm) (errEnv env))+--           case boundVs (envPos x 0 env) tm of+--                [] -> return [(x, tm)]+--                (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))+--                                      (inst ns tm) (errEnv env))+        let v = highV (-1) tm in+            if v >= length ns+               then lift $ tfail (Msg "SCOPE ERROR")+               else return [(x, bind v ns tm)]       where inst [] tm = tm             inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)++    bind i ns tm +      | i < 0 = tm+      | otherwise = let ((x,y),ty) = ns!!i in+                        App (Bind y (Lam ty) (bind (i-1) ns tm))+                            (P Bound x ty)     -renameBinders :: Env -> (Name, TT Name) -> (Name, TT Name)-renameBinders env (x, tm) = (x, uniqueBinders tm)+renameBinders env (x, t) = (x, renameBindersTm env t)++renameBindersTm :: Env -> TT Name -> TT Name+renameBindersTm env tm = uniqueBinders (map fst env) tm   where-    uniqueBinders (Bind n b sc)-        | n `elem` map fst env -             = let n' = uniqueName n (map fst env) in-                   Bind n' (fmap uniqueBinders b)-                           (uniqueBinders (rename n n' sc))-        | otherwise = Bind n (fmap uniqueBinders b) (uniqueBinders sc)-    uniqueBinders (App f a) = App (uniqueBinders f) (uniqueBinders a)-    uniqueBinders t = t+    uniqueBinders env (Bind n b sc)+        | n `elem` env +             = let n' = uniqueName n env in+                   Bind n' (fmap (uniqueBinders env) b)+                           (uniqueBinders (n':env) (rename n n' sc))+        | otherwise = Bind n (fmap (uniqueBinders (n:env)) b) +                             (uniqueBinders (n:env) sc)+    uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a)+    uniqueBinders env t = t      rename n n' (P nt x ty) | n == x = P nt n' ty     rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)@@ -167,17 +205,18 @@         = doSubst env tm  -unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->+unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->          TC ([(Name, TT Name)], Fails)-unify ctxt env topx topy dont holes =+unify ctxt env topx topy inj holes from = --      trace ("Unifying " ++ show (topx, topy)) $              -- don't bother if topx and topy are different at the head-      case runStateT (un False [] topx topy) (UI 0 []) of+      case runStateT (un False [] (renameBindersTm env topx) +                                  (renameBindersTm env topy)) (UI 0 []) of         OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),                                    [])         res ->-               let topxn = normalise ctxt env topx-                   topyn = normalise ctxt env topy in+               let topxn = renameBindersTm env (normalise ctxt env topx)+                   topyn = renameBindersTm env (normalise ctxt env topy) in --                     trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $                      case runStateT (un False [] topxn topyn)         	  	        (UI 0 []) of@@ -198,12 +237,20 @@     injective (App f a)          = injective f -- && injective a     injective _                  = False +--     injectiveVar (P _ (MN _ _) _) = True -- TMP HACK +    injectiveVar (P _ n _)        = n `elem` inj +    injectiveVar (App f a)        = injectiveVar f -- && injective a+    injectiveVar _ = False++    injectiveApp x = injective x || injectiveVar x+     notP (P _ _ _) = False     notP _ = True      sc i = do UI s f <- get               put (UI (s+i) f) +    errors :: StateT UInfo TC Bool     errors = do UI s f <- get                 return (not (null f)) @@ -214,7 +261,7 @@                         then return r                         else do put (UI s f); u2 -    un :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->+    un :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name ->           StateT UInfo           TC [(Name, TT Name)]     un = un'@@ -225,7 +272,7 @@ --                   uplus (un' fn names x y) --                         (un' fn names (hnf ctxt env x) (hnf ctxt env y)) -    un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->+    un' :: Bool -> [((Name, Name), TT Name)] -> TT Name -> TT Name ->            StateT UInfo            TC [(Name, TT Name)]     un' fn names x y | x == y = return [] -- shortcut@@ -242,7 +289,7 @@     un' fn names topx@(P (TCon _ _) x _) topy@(Constant _)                 = unifyFail topx topy     un' fn bnames tx@(P _ x _) ty@(P _ y _)-        | (x,y) `elem` bnames || x == y = do sc 1; return []+        | (x,y) `elem` map fst bnames || x == y = do sc 1; return []         | injective tx && not (holeIn env y || y `elem` holes)              = unifyTmpFail tx ty         | injective ty && not (holeIn env x || x `elem` holes)@@ -251,29 +298,42 @@         | holeIn env x || x `elem` holes                        = do UI s f <- get                             -- injectivity check+                            x <- checkCycle bnames (x, tm)                             if (notP tm && fn) --                               trace (show (x, tm, normalise ctxt env tm)) $ --                                 put (UI s ((tm, topx, topy) : i) f)                                  then unifyTmpFail xtm tm                                  else do sc 1-                                         checkCycle bnames (x, tm)-        | not (injective xtm) && injective tm = unifyTmpFail xtm tm+                                         return x+        | not (injective xtm) && injective tm +                       = do checkCycle bnames (x, tm)+                            unifyTmpFail xtm tm     un' fn bnames tm ytm@(P _ y _)         | holeIn env y || y `elem` holes                        = do UI s f <- get                             -- injectivity check+                            x <- checkCycle bnames (y, tm)                             if (notP tm && fn) --                               trace (show (y, tm, normalise ctxt env tm)) $ --                                 put (UI s ((tm, topx, topy) : i) f)                                  then unifyTmpFail tm ytm                                  else do sc 1-                                         checkCycle bnames (y, tm)-        | not (injective ytm) && injective tm = unifyTmpFail tm ytm+                                         return x+        | not (injective ytm) && injective tm +                       = do checkCycle bnames (y, tm)+                            unifyTmpFail tm ytm     un' fn bnames (V i) (P _ x _)-        | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []+        | length bnames > i,+          fst ((map fst bnames)!!i) == x || +          snd ((map fst bnames)!!i) == x = do sc 1; return []     un' fn bnames (P _ x _) (V i)-        | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []+        | length bnames > i,+          fst ((map fst bnames)!!i) == x || +          snd ((map fst bnames)!!i) == x = do sc 1; return [] +    un' fn names topx@(Bind n (Hole t) sc) y = unifyTmpFail topx y+    un' fn names x topy@(Bind n (Hole t) sc) = unifyTmpFail x topy+     un' fn bnames appx@(App _ _) appy@(App _ _)         = unApp fn bnames appx appy --         = uplus (unApp fn bnames appx appy)@@ -296,30 +356,44 @@     -- class resolution for type classes over functions.      un' fn bnames (App f x) (Bind n (Pi t) y)-      | noOccurrence n y && x == y-        = un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) -                                   (Bind n (Pi t) (V 1)))+      | 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)))+             combine bnames ux uf              +    un' fn bnames (Bind n (Pi t) 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+             combine bnames ux uf+                  un' fn bnames (Bind x bx sx) (Bind y by sy)-        = do h1 <- uB bnames bx by-             h2 <- un' False ((x,y):bnames) sx sy-             combine bnames h1 h2+        | sameBinder bx by+           = do h1 <- uB bnames bx by+                h2 <- un' False (((x,y),binderTy bx):bnames) sx sy+                combine bnames h1 h2+      where sameBinder (Lam _) (Lam _) = True+            sameBinder (Pi _) (Pi _) = True+            sameBinder _ _ = False     un' fn bnames x y-        | OK True <- convEq' ctxt x y = do sc 1; return []+        | OK True <- convEq' ctxt holes x y = do sc 1; return []         | otherwise = do UI s f <- get-                         let r = recoverable x y-                         let err = CantUnify r-                                     topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s+                         let r = recoverable (normalise ctxt env x) +                                             (normalise ctxt env y)+                         let err = cantUnify from r+                                     topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s                          if (not r) then lift $ tfail err-                           else do put (UI s ((x, y, env, err) : f))+                           else do put (UI s ((x, y, env, err, from, Unify) : f))                                    return [] -- lift $ tfail err      unApp fn bnames appx@(App fx ax) appy@(App fy ay)-         | (injective fx && injective fy)-        || (injective fx && rigid appx && metavarApp appy)-        || (injective fy && rigid appy && metavarApp appx)-        || (injective fx && metavarApp fy && ax == ay)-        || (injective fy && metavarApp fx && ax == ay)+         | (injectiveApp fx && injectiveApp fy)+        || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)+        || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)+        || (injectiveApp fx && metavarApp fy && ax == ay)+        || (injectiveApp fy && metavarApp fx && ax == ay)          = do let (headx, _) = unApply fx               let (heady, _) = unApply fy               -- fail quickly if the heads are disjoint@@ -341,23 +415,7 @@                     hf <- un' False bnames fx' fy'                     sc 1                     combine bnames hf ha)-       | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $-            do let (headx, argsx) = unApply appx-               let (heady, argsy) = unApply appy-               -- traceWhen (headx == heady) (show (appx, appy)) $-               uplus (-                 if (length argsx == length argsy &&-                    ((headx == heady && inenv headx) || (argsx == argsy) ||-                     (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))-                       then---                      (notFn headx && notFn heady))) then-                   do uf <- un' True bnames headx heady-                      failed <- errors-                      if (not failed) then unArgs uf argsx argsy-                        else return []-                   else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $-                        unifyTmpFail appx appy)-                    (unifyTmpFail appx appy) -- whole application fails+       | otherwise = unifyTmpFail appx appy       where hnormalise [] _ _ t = t             hnormalise ns ctxt env t = normalise ctxt env t             checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _)@@ -378,6 +436,8 @@                      vs <- combine bnames as as'                      unArgs vs xs ys +            numArgs tm = let (f, args) = unApply tm in length args+             metavarApp tm = let (f, args) = unApply tm in                                 (metavar f &&                                  all (\x -> metavarApp x) args@@ -390,28 +450,6 @@                                  all (\x -> pat x || metavar x) (f : args)                                    && nub args == args -            sameArgStruct appx appy-                = let (_, ax) = unApply appx-                      (_, ay) = unApply appy in-                      length ax == length ay &&-                        and (zipWith sameStruct ax ay)--            sameStruct fapp@(App f x) gapp@(App g y)-                = let (f',a') = unApply fapp-                      (g',b') = unApply gapp in-                      (f' == g' && length a' == length b' &&-                          (injective f' || injective g'))-                        || (sameStruct f g && sameStruct x y)-            sameStruct (P _ x _) (P _ y _) = True-            sameStruct (V i) (V j) = i == j-            sameStruct (Constant x) (Constant y) = True-            sameStruct (P _ _ _) (Constant y) = True-            sameStruct (Constant x) (P _ _ _) = True-            sameStruct (Bind n t sc) (P _ _ _) = True-            sameStruct (P _ _ _) (Bind n t sc) = True-            sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc'-            sameStruct _ _ = False-             rigid (P (DCon _ _) _ _) = True             rigid (P (TCon _ _) _ _) = True             rigid t@(P Ref _ _)      = inenv t || globmetavar t@@ -427,8 +465,7 @@                                 _ -> False              metavar t = case t of-                             P _ x _ -> ((x `elem` holes || holeIn env x) &&-                                        not (x `elem` dont))+                             P _ x _ -> (x `elem` holes || holeIn env x)                                           || globmetavar t                              _ -> False             pat t = case t of@@ -441,20 +478,21 @@             notFn t = injective t || metavar t || inenv t  +    unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]     unifyTmpFail x y                   = do UI s f <- get-                       let r = recoverable x y-                       let err = CantUnify r-                                   topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s-                       put (UI s ((topx, topy, env, err) : f))+                       let r = recoverable (normalise ctxt env x) (normalise ctxt env y)+                       let err = cantUnify from r+                                   topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+                       put (UI s ((topx, topy, env, err, from, Unify) : f))                        return []      -- shortcut failure, if we *know* nothing can fix it     unifyFail x y = do UI s f <- get-                       let r = recoverable x y-                       let err = CantUnify r-                                   topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s-                       put (UI s ((topx, topy, env, err) : f))+                       let r = recoverable (normalise ctxt env x) (normalise ctxt env y)+                       let err = cantUnify from r+                                   topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s+                       put (UI s ((topx, topy, env, err, from, Unify) : f))                        lift $ tfail err  @@ -473,11 +511,12 @@     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-                       let r = recoverable (binderTy x) (binderTy y)-                       let err = CantUnify r topx topy-                                  (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s)-                                  (errEnv env) s-                       put (UI s ((binderTy x, binderTy y, env, err) : f))+                       let r = recoverable (normalise ctxt env (binderTy x)) +                                           (normalise ctxt env (binderTy y))+                       let err = cantUnify from r topx topy+                                   (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)+                                   (errEnv env) s+                       put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))                        return [] -- lift $ tfail err      checkCycle ns p@(x, P _ _ _) = return [p]@@ -486,13 +525,23 @@         | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))      checkScope ns (x, tm) =-          case boundVs (envPos x 0 env) tm of-               [] -> return [(x, tm)]-               (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))-                                     (inst ns tm) (errEnv env))+--           case boundVs (envPos x 0 env) tm of+--                [] -> return [(x, tm)]+--                (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))+--                                      (inst ns tm) (errEnv env))+        let v = highV (-1) tm in+            if v >= length ns+               then lift $ tfail (Msg "SCOPE ERROR")+               else return [(x, bind v ns tm)]       where inst [] tm = tm-            inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)+            inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm) +    bind i ns tm +      | i < 0 = tm+      | otherwise = let ((x,y),ty) = ns!!i in+                        App (Bind y (Lam ty) (bind (i-1) ns tm))+                            (P Bound x ty)+     combineArgs bnames args = ca [] args where        ca acc [] = return acc        ca acc (x : xs) = do x' <- combine bnames acc x@@ -509,7 +558,7 @@                           combine bnames as (ns' ++ bs)  boundVs :: Int -> Term -> [Int]-boundVs i (V j) | j <= i = []+boundVs i (V j) | j < i = []                 | otherwise = [j] boundVs i (Bind n b sc) = boundVs (i + 1) sc boundVs i (App f x) = let fs = boundVs i f@@ -517,6 +566,13 @@                           nub (fs ++ xs) boundVs i _ = [] +highV :: Int -> Term -> Int+highV i (V j) | j > i = j+                | otherwise = i+highV i (Bind n b sc) = maximum [i, highV i (binderTy b), (highV i sc - 1)]+highV i (App f x) = max (highV i f) (highV i x)+highV i _ = i+ envPos x i [] = 0 envPos x i ((y, _) : ys) | x == y = i                          | otherwise = envPos x (i + 1) ys@@ -526,7 +582,12 @@ -- more work may help. -- FIXME: Depending on how overloading gets used, this may cause problems. Better -- rethink overloading properly...+-- ASSUMPTION: inputs are in normal form +recoverable t@(App _ _) _+    | (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 = True     | otherwise = False@@ -542,7 +603,7 @@ 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---     recoverable (App f a) p@(P _ _ _) = recoverable f p+recoverable (App f a) p@(P _ _ _) = recoverable f p recoverable (App f a) (App f' a')     = recoverable f f' -- && recoverable a a' recoverable f (Bind _ (Pi _) sc)
src/Idris/Coverage.hs view
@@ -9,6 +9,7 @@ import Idris.AbsSyntax import Idris.Delaborate import Idris.Error+import Idris.Output (iputStrLn)  import Data.List import Data.Either@@ -17,10 +18,14 @@  import Control.Monad.State.Strict +-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the+-- pattern clauses which have been provided explicitly from new clause+-- generation.)+ mkPatTm :: PTerm -> Idris Term mkPatTm t = do i <- getIState                let timp = addImpl' True [] [] i t-               evalStateT (toTT timp) 0+               evalStateT (toTT (mapPT deNS timp)) 0   where     toTT (PRef _ n) = do i <- lift getIState                          case lookupDef n (tt_ctxt i) of@@ -29,10 +34,16 @@     toTT (PApp _ t args) = do t' <- toTT t                               args' <- mapM (toTT . getTm) args                               return $ mkApp t' args'+    -- For alternatives, pick the first and drop the namespaces. It doesn't+    -- really matter which is taken since matching will ignore the namespace.+    toTT (PAlternative _ (a : as)) = toTT a     toTT _ = do v <- get                 put (v + 1)                 return (P Bound (sMN v "imp") Erased) +    deNS (PRef f (NS n _)) = PRef f n+    deNS t = t+ -- Given a list of LHSs, generate a extra clauses which cover the remaining -- cases. The ones which haven't been provided are marked 'absurd' so that the -- checker will make sure they can't happen.@@ -40,30 +51,35 @@ -- This will only work after the given clauses have been typechecked and the -- names are fully explicit! -genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PTerm]+genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm] genClauses fc n xs given    = do i <- getIState-        let lhss = map (getLHS i) xs+        let lhs_tms = map (\x -> delab' i x True True) xs+        -- if a placeholder was given, don't bother generating cases for it+        let lhs_tms' = zipWith mergePlaceholders lhs_tms given+        let lhss = map pUnApply lhs_tms'+         let argss = transpose lhss         let all_args = map (genAll i) argss         logLvl 5 $ "COVERAGE of " ++ show n+        logLvl 5 $ show lhss         logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)         logLvl 10 $ show argss ++ "\n" ++ show all_args-        logLvl 10 $ "Original: \n" +++        logLvl 1 $ "Original: \n" ++              showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)         -- add an infinite supply of explicit arguments to update the possible-        -- cases for (the return type may be variadic, or function type, sp+        -- cases for (the return type may be variadic, or function type, so         -- there may be more case splitting that the idris_implicits record         -- suggests)         let parg = case lookupCtxt n (idris_implicits i) of-                        (p : _) -> p ++ repeat (PExp 0 [] Placeholder "")+                        (p : _) -> p ++ repeat (PExp 0 [] Placeholder)                         _ -> repeat (pexp Placeholder)         let tryclauses = mkClauses parg all_args         logLvl 2 $ show (length tryclauses) ++ " initially to check"-        logLvl 5 $ showSep "\n" (map (showTm i) tryclauses)+        logLvl 1 $ showSep "\n" (map (showTm i) tryclauses)         let new = filter (noMatch i) (nub tryclauses)         logLvl 1 $ show (length new) ++ " clauses to check for impossibility"-        logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)+        logLvl 3 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new) --           ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)         return new --         return (map (\t -> PClause n t [] PImpossible []) new)@@ -71,14 +87,24 @@             | (f, args) <- unApply term = map (\t -> delab' i t True True) args             | otherwise = [] -        lhsApp (PClause _ _ l _ _ _) = l-        lhsApp (PWith _ _ l _ _ _) = l+        pUnApply (PApp _ _ args) = map getTm args+        pUnApply _ = [] +        -- Return whether the given clause matches none of the input clauses+        -- (xs)         noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of-                                          Right _ -> False-                                          Left miss -> True) xs+                                       Right ms -> False+                                       Left miss -> True) xs  +        mergePlaceholders :: PTerm -> PTerm -> PTerm+        mergePlaceholders x Placeholder = Placeholder+        mergePlaceholders (PApp fc f args) (PApp fc' f' args')+            = PApp fc' f' (zipWith mergePArg args args')+           where mergePArg x y = let xtm = mergePlaceholders (getTm x) (getTm y) in+                                     x { getTm = xtm}+        mergePlaceholders x _ = x+         mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]         mkClauses parg args             | all (== [Placeholder]) args = []@@ -101,6 +127,7 @@  -- quick check for constructor equality quickEq :: PTerm -> PTerm -> Bool+quickEq (PConstant n) (PConstant n') = n == n' quickEq (PRef _ n) (PRef _ n') = n == n' quickEq (PApp _ t as) (PApp _ t' as')     | length as == length as'@@ -169,7 +196,7 @@                 ([pimp (sUN "A") Placeholder True,                   pimp (sUN "B") Placeholder True] ++                  [pexp l, pexp r]) o-    otherPats o@(PDPair fc t _ v)+    otherPats o@(PDPair fc p t _ v)         = ops fc (sUN "Ex_intro")                 ([pimp (sUN "a") Placeholder True,                   pimp (sUN "P") Placeholder True] ++@@ -187,13 +214,13 @@                          _ -> [p]     ops fc n arg o = return Placeholder -    getExpTm (PImp _ True _ _ _ _) = Placeholder -- machine inferred, no point!+    getExpTm (PImp _ True _ _ _) = Placeholder -- machine inferred, no point!     getExpTm t = getTm t      -- put it back to its original form     resugar (PApp _ (PRef fc (UN ei)) [_,_,t,v])       | ei == txt "Ex_intro"-        = PDPair fc (getTm t) Placeholder (getTm v)+        = PDPair fc TypeOrTerm (getTm t) Placeholder (getTm v)     resugar (PApp _ (PRef fc n) [_,_,l,r])       | n == pairCon         = PPair fc IsTerm (getTm l) (getTm r)@@ -218,12 +245,30 @@  upd p' p = p { getTm = p' } +-- Check whether function and all descendants cover all cases (partial is+-- okay, as long as it's due to recursion)++checkAllCovering :: FC -> [Name] -> Name -> Name -> Idris ()+checkAllCovering fc done top n | not (n `elem` done)+   = do i <- get+        case lookupTotal n (tt_ctxt i) of+             [tot@(Partial NotCovering)] -> +                  tclift $ tfail (At fc (Msg (show top ++ " is " ++ show tot+                                     ++ " due to " ++ show n)))+             _ -> return ()+        case lookupCtxt n (idris_callgraph i) of+             [cg] -> mapM_ (checkAllCovering fc (n : done) top) +                           (map fst (calls cg))+             _ -> return ()+checkAllCovering _ _ _ _ = return ()+ -- Check if, in a given type n, the constructor cn : ty is strictly positive, -- and update the context accordingly  checkPositive :: Name -> (Name, Type) -> Idris ()-checkPositive n (cn, ty)-    = do let p = cp ty+checkPositive n (cn, ty')+    = do let ty = delazy ty'+         let p = cp ty          i <- getIState          let tot = if p then Total (args ty) else Partial NotPositive          let ctxt' = setTotal cn tot (tt_ctxt i)@@ -255,12 +300,10 @@       prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool      prodRec n done _ | n `elem` done = return True-     prodRec n done (_, _, tm) = prod n done False tm+     prodRec n done (_, _, tm) = prod n done False (delazy' True tm)       prod :: Name -> [Name] -> Bool -> Term -> Idris Bool      prod n done ok ap@(App _ _)-        | (P _ (UN l) _, [_, arg]) <- unApply ap,-          l == txt "lazy" = prod n done ok arg         | (P nt f _, args) <- unApply ap             = do recOK <- checkProdRec (n:done) f                  let ctxt = tt_ctxt i@@ -293,9 +336,12 @@                    _ -> False      cotype nt n ty = False -calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]-                -> Idris Totality-calcTotality path fc n pats+-- Calculate the totality of a function from its patterns.+-- Either follow the size change graph (if inductive) or check for+-- productivity (if coinductive)++calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality+calcTotality fc n pats     = do i <- getIState          let opts = case lookupCtxt n (idris_flags i) of                             [fs] -> fs@@ -330,20 +376,10 @@                         [CaseOp _ _ _ _ pats _] ->                             do t' <- if AssertTotal `elem` opts                                         then return $ Total []-                                        else calcTotality path fc n pats+                                        else calcTotality fc n pats                                setTotality n t'                                addIBC (IBCTotal n t')                                return t'-                            -- if it's not total, it can't reduce, to keep-                            -- typechecking decidable---                                case t' of---                                  p@(Partial _) ->---                                      do setAccessibility n Frozen---                                         addIBC (IBCAccess n Frozen)---                                         logLvl 5 $ "HIDDEN: "---                                               ++ show n ++ show p---                                  _ -> return ()---                                return t'                         _ -> return $ Total []                 x -> return x         case t' of@@ -412,31 +448,57 @@        [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"        x -> error $ "buildSCG: " ++ show (n, x) +delazy = delazy' False -- not lazy codata+delazy' all t@(App f a)+     | (P _ (UN l) _, [_, _, arg]) <- unApply t,+       l == txt "Force" = delazy' all arg+     | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,+       l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg+     | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,+       l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg+delazy' all (App f a) = App (delazy' all f) (delazy' all a)+delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)+delazy' all t = t++data Guardedness = Toplevel | Unguarded | Guarded+ buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry] buildSCG' ist pats args = nub $ concatMap scgPat pats where-  scgPat (lhs, rhs) = let (f, pargs) = unApply (dePat lhs) in-                          findCalls (dePat rhs) (patvars lhs) pargs+  scgPat (lhs, rhs) = let lhs' = delazy lhs+                          rhs' = delazy rhs+                          (f, pargs) = unApply (dePat lhs') in+                          findCalls Toplevel (dePat rhs') (patvars lhs') pargs -  findCalls ap@(App f a) pvs pargs-     | (P _ (UN l) _, [_, arg]) <- unApply ap,-       l == txt "lazy"-        = findCalls arg pvs pargs+  findCalls guarded ap@(App f a) pvs pargs      -- under a call to "assert_total", don't do any checking, just believe      -- that it is total.      | (P _ (UN at) _, [_, _]) <- unApply ap,        at == txt "assert_total" = []+     -- under a call to "Delay LazyCodata", don't do any checking of the+     -- immediate call, as long as the call is guarded. +     -- Then check its arguments+     | (P _ (UN del) _, [_,_,arg]) <- unApply ap,+       guarded <- Guarded,+       del == txt "Delay" +           = let (capp, args) = unApply arg in+                 concatMap (\x -> findCalls Toplevel x pvs pargs) args      | (P _ n _, args) <- unApply ap-        = mkChange n args pargs ++-              concatMap (\x -> findCalls x pvs pargs) args-  findCalls (App f a) pvs pargs-        = findCalls f pvs pargs ++ findCalls a pvs pargs-  findCalls (Bind n (Let t v) e) pvs pargs-        = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs-  findCalls (Bind n _ e) pvs pargs-        = findCalls e (n : pvs) pargs-  findCalls (P _ f _ ) pvs pargs+        = let nguarded = case guarded of+                              Unguarded -> Unguarded+                              _ -> if isConName n (tt_ctxt ist)+                                      then Guarded+                                      else Unguarded in+              mkChange n args pargs +++                 concatMap (\x -> findCalls nguarded x pvs pargs) args+  findCalls guarded (App f a) pvs pargs+        = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs+  findCalls guarded (Bind n (Let t v) e) pvs pargs+        = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs+  findCalls guarded (Bind n _ e) pvs pargs+        = findCalls guarded e (n : pvs) pargs+  findCalls guarded (P _ f _ ) pvs pargs       | not (f `elem` pvs) = [(f, [])]-  findCalls _ _ _ = []+  findCalls _ _ _ _ = []    expandToArity n args       = case lookupTy n (tt_ctxt ist) of@@ -480,7 +542,7 @@       toJust (n, t) = Just t        getType n = case lookupTy n (tt_ctxt ist) of-                       [ty] -> ty -- must exist+                       [ty] -> delazy ty -- must exist        isInductive (P _ nty _) (P _ nty' _) =           let co = case lookupCtxt nty (idris_datatypes ist) of@@ -489,102 +551,11 @@               nty == nty' && not co       isInductive _ _ = False ---       getTypeFam t | (P _ n _, _) <- unApply t-   dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)   dePat t = t    patvars (Bind x (PVar _) sc) = x : patvars sc   patvars _ = []--{--buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]-buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $-                           nub $ scg sc (zip args args)-                                 (zip args (zip args (repeat Same)))-   where-      scg :: SC -> [(Name, Name)] -> -- local var, originating top level var-             [(Name, (Name, SizeChange))] -> -- orig to new,  and relationship-             [SCGEntry]-      scg (Case x alts) vars szs-          = let x' = findTL x vars in-                concatMap (scgAlt x' vars szs) alts-        where-          findTL x vars-            | Just x' <- lookup x vars-               = if x' `elem`  args then x'-                    else findTL x' vars-            | otherwise = x--      scg (STerm tm) vars szs = scgTerm tm vars szs-      scg _ _ _ = []--      -- how the arguments relate - either Smaller or Unknown-      argRels :: Name -> [(Name, SizeChange)]-      argRels n = let ctxt = tt_ctxt ist-                      [ty] = lookupTy n ctxt -- must exist!-                      P _ nty _ = fst (unApply (getRetTy ty))-                      co = case lookupCtxt nty (idris_datatypes ist) of-                              [TI _ x _ _] -> x-                              _ -> False-                      args = map snd (getArgTys ty) in-                      map (getRel co nty) (map (fst . unApply . getRetTy) args)-        where-          getRel True _ _ = (n, Unknown) -- coinductive-          getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)-          getRel _ ty t = (n, Unknown)--      scgAlt x vars szs (ConCase n _ args sc)-           -- all args smaller than top variable of x in sc-           -- (as long as they are in the same type family, and it's-           -- not coinductive)-         | Just tvar <- lookup x vars-              = let arel = argRels n-                    szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel-                                                       ++ szs-                    vars' = nub (zip args (repeat tvar) ++ vars) in-                    scg sc vars' szs'-         | otherwise = scg sc vars szs-      scgAlt x vars szs (ConstCase _ sc) = scg sc vars szs-      scgAlt x vars szs (DefaultCase sc) = scg sc vars szs--      scgTerm f@(App _ _) vars szs-         | (P _ (UN "lazy") _, [_, arg]) <- unApply f-             = scgTerm arg vars szs-         | (P _ fn _, args) <- unApply f-            = let rest = concatMap (\x -> scgTerm x vars szs) args in-                  case lookup fn vars of-                       Just _ -> rest-                       Nothing -> nub $ (fn, map (mkChange szs) args) : rest-      scgTerm (App f a) vars szs-            = scgTerm f vars szs ++ scgTerm a vars szs-      scgTerm (Bind n (Let t v) e) vars szs-            = scgTerm v vars szs ++ scgTerm e vars szs-      scgTerm (Bind n _ e) vars szs-            = scgTerm e (nub ((n, n) : vars)) szs-      scgTerm (P _ fn _) vars szs-            = case lookup fn vars of-                   Just _ -> []-                   Nothing -> [(fn, [])]-      scgTerm _ _ _ = []--      mkChange :: [(Name, (Name, SizeChange))] -> Term-                   -> Maybe (Int, SizeChange)-      mkChange szs tm-         | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg-         | (P _ n ty, _) <- unApply tm -- get higher order args too-          = do sc <- lookup n szs-               case sc of-                  (_, Unknown) -> Nothing-                  (o, sc) -> do i <- getArgPos 0 o args-                                return (i, sc)-      mkChange _ _ = Nothing--      getArgPos :: Int -> Name -> [Name] -> Maybe Int-      getArgPos i n [] = Nothing-      getArgPos i n (x : xs) | n == x = Just i-                             | otherwise = getArgPos (i + 1) n xs--}  checkSizeChange :: Name -> Idris Totality checkSizeChange n = do
src/Idris/DSL.hs view
@@ -38,8 +38,8 @@                                         (map (pmap (expandDo dsl)) opts) expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r) expandDo dsl (PPair fc p l r) = PPair fc p (expandDo dsl l) (expandDo dsl r)-expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t)-                                           (expandDo dsl r)+expandDo dsl (PDPair fc p l t r) = PDPair fc p (expandDo dsl l) (expandDo dsl t)+                                               (expandDo dsl r) expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as) expandDo dsl (PHidden t) = PHidden (expandDo dsl t) expandDo dsl (PNoImplicits t) = PNoImplicits (expandDo dsl t)@@ -57,10 +57,10 @@     block b [a] = PElabError (Msg "Last statement in do block must be an expression")     block b (DoBind fc n tm : rest)         = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]-    block b (DoBindP fc p tm : rest)+    block b (DoBindP fc p tm alts : rest)         = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder                                    (PCase fc (PRef fc (sMN 0 "bpat"))-                                             [(p, block b rest)]))]+                                             ((p, block b rest) : alts)))]     block b (DoLet fc n ty tm : rest)         = PLet n ty tm (block b rest)     block b (DoLetP fc p tm : rest)@@ -94,7 +94,7 @@     v' i (PCase f t as)  = PCase f (v' i t) (fmap (pmap (v' i)) as)     v' i (PEq f l r)     = PEq f (v' i l) (v' i r)     v' i (PPair f p l r) = PPair f p (v' i l) (v' i r)-    v' i (PDPair f l t r) = PDPair f (v' i l) (v' i t) (v' i r)+    v' i (PDPair f p l t r) = PDPair f p (v' i l) (v' i t) (v' i r)     v' i (PAlternative a as) = PAlternative a $ map (v' i) as     v' i (PHidden t)     = PHidden (v' i t)     v' i (PIdiom f t)    = PIdiom f (v' i t)@@ -147,9 +147,9 @@     db' (PPair fc p l r) = do l' <- db' l                               r' <- db' r                               return (PPair fc p l' r')-    db' (PDPair fc l t r) = do l' <- db' l-                               r' <- db' r-                               return (PDPair fc l' t r')+    db' (PDPair fc p l t r) = do l' <- db' l+                                 r' <- db' r+                                 return (PDPair fc p l' t r')     db' t = return t      dbArg a = do t' <- db' (getTm a)
src/Idris/DeepSeq.hs view
@@ -6,6 +6,48 @@  import Control.DeepSeq +import qualified Cheapskate.Types as CT++-- Manual from imported libs+instance NFData CT.Doc where+        rnf (CT.Doc opts contents) = rnf opts `seq` rnf contents `seq` ()++instance NFData CT.Options where+        rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()++instance NFData CT.Block where+        rnf (CT.Para lines) = rnf lines `seq` ()+        rnf (CT.Header i lines) = rnf i `seq` rnf lines `seq` ()+        rnf (CT.Blockquote bs) = rnf bs `seq` ()+        rnf (CT.List b t xs) = rnf b `seq` rnf t `seq` rnf xs `seq` ()+        rnf (CT.CodeBlock attr txt) = rnf attr `seq` rnf txt `seq` ()+        rnf (CT.HtmlBlock txt) = rnf txt `seq` ()+        rnf CT.HRule = ()++instance NFData CT.Inline where+        rnf (CT.Str txt) = rnf txt `seq` ()+        rnf CT.Space = ()+        rnf CT.SoftBreak = ()+        rnf CT.LineBreak = ()+        rnf (CT.Emph xs) = rnf xs `seq` ()+        rnf (CT.Strong xs) = rnf xs `seq` ()+        rnf (CT.Code xs) = rnf xs `seq` ()+        rnf (CT.Link a b xs) = rnf a `seq` rnf b `seq` rnf xs `seq` ()+        rnf (CT.Image a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()+        rnf (CT.Entity a) = rnf a `seq` ()+        rnf (CT.RawHtml x) = rnf x `seq` ()++instance NFData CT.ListType where+        rnf (CT.Bullet c) = rnf c `seq` ()+        rnf (CT.Numbered nw i) = rnf nw `seq` rnf i `seq` ()++instance NFData CT.CodeAttr where+        rnf (CT.CodeAttr a b) = rnf a `seq` rnf b `seq` ()++instance NFData CT.NumWrapper where+        rnf CT.PeriodFollowing = ()+        rnf CT.ParenFollowing = ()+ -- All generated by 'derive'  instance NFData Forceability where@@ -57,14 +99,14 @@         rnf _ = ()  instance NFData Plicity where-        rnf (Imp x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (Exp x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (Constraint x1 x2 x3)+        rnf (Imp x1 x2 x3)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (TacImp x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (Exp x1 x2 x3)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (Constraint x1 x2)+          = rnf x1 `seq` rnf x2 `seq` ()+        rnf (TacImp x1 x2 x3)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()  instance NFData FnOpt where         rnf Inlinable = ()@@ -84,18 +126,20 @@  instance (NFData t) => NFData (PDecl' t) where         rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PTy x1 x2 x3 x4 x5 x6)+        rnf (PTy x1 x2 x3 x4 x5 x6 x7)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()+              rnf x2 `seq`+                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()         rnf (PPostulate x1 x2 x3 x4 x5 x6)           = rnf x1 `seq`               rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()         rnf (PClauses x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PCAF x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (PData x1 x2 x3 x4 x5)+        rnf (PData x1 x2 x3 x4 x5 x6)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+              rnf x2 `seq`+                rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()         rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()         rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8)@@ -116,12 +160,17 @@         rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PDirective x1) = ()-        rnf (PProvider x1 x2 x3 x4 x5)+        rnf (PProvider x1 x2 x3 x4 x5 x6)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()         rnf (PTransform x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () +instance NFData ProvideWhat where+        rnf ProvAny       = ()+        rnf ProvTerm      = ()+        rnf ProvPostulate = ()+ instance NFData PunInfo where         rnf x = x `seq` () @@ -165,8 +214,8 @@         rnf (PRewrite x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (PPair x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (PDPair x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()+        rnf (PDPair x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()         rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (PHidden x1) = rnf x1 `seq` ()         rnf PType = ()@@ -200,8 +249,8 @@         rnf (Exact x1) = rnf x1 `seq` ()         rnf Compute = ()         rnf Trivial = ()-        rnf (ProofSearch x1 x2 x3)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (ProofSearch x1 x2)+          = rnf x1 `seq` rnf x2 `seq` ()         rnf Solve = ()         rnf Attack = ()         rnf ProofState = ()@@ -219,22 +268,21 @@ instance (NFData t) => NFData (PDo' t) where         rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()         rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()-        rnf (DoBindP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (DoLet x1 x2 x3 x4)           = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()         rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()  instance (NFData t) => NFData (PArg' t) where-        rnf (PImp x1 x2 x3 x4 x5 x6)-          = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()-        rnf (PExp x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (PConstraint x1 x2 x3 x4)-          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()-        rnf (PTacImplicit x1 x2 x3 x4 x5 x6)+        rnf (PImp x1 x2 x3 x4 x5)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()+        rnf (PExp x1 x2 x3)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PConstraint x1 x2 x3)+          = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()+        rnf (PTacImplicit x1 x2 x3 x4 x5)           = rnf x1 `seq`-              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()+              rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()  instance NFData ClassInfo where         rnf (CI x1 x2 x3 x4 x5 x6)
src/Idris/Delaborate.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE PatternGuards #-}--module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where+module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pprintErr) where  -- Convert core TT back into high level syntax, primarily for display -- purposes.@@ -13,6 +12,7 @@ import Idris.ErrReverse  import Data.List (intersperse)+import qualified Data.Text as T  import Debug.Trace @@ -56,19 +56,24 @@                                   _ -> PRef un n     de env _ (Bind n (Lam ty) sc)           = PLam n (de env [] ty) (de ((n,n):env) [] sc)-    de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc)-          = PPi impl n (de env [] ty) (de ((n,n):env) is sc)-    de env (PConstraint _ _ _ _: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)           = 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 _ (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)           = 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)     de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc     de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc-    de env _ (Bind n _ sc) = de ((n,n):env) [] sc+    de env plic (Bind n bb sc) = de ((n,n):env) [] sc     de env _ (Constant i) = PConstant i     de env _ Erased = Placeholder     de env _ Impossible = Placeholder@@ -88,18 +93,21 @@          | n == sUN "lazy" = de env [] r     deFn env (P _ n _) [ty, Bind x (Lam _) r]          | n == sUN "Exists"-               = PDPair un (PRef un x) (de env [] ty)+               = PDPair un IsType (PRef un x) (de env [] ty)                            (de ((x,x):env) [] (instantiate (P Bound x ty) r))     deFn env (P _ n _) [_,_,l,r]          | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)          | n == eqTy    = PEq un (de env [] l) (de env [] r)-         | n == sUN "Ex_intro" = PDPair un (de env [] l) Placeholder+         | n == sUN "Ex_intro" = PDPair un IsTerm (de env [] l) Placeholder                                            (de env [] r)-    deFn env (P _ n _) args | not mvs-         = case lookup n (idris_metavars ist) of-                Just (Just _, mi, _) ->-                     mkMVApp n (drop mi (map (de env []) args))-                _ -> mkPApp n (map (de env []) args)+    deFn env f@(P _ n _) args +         | n `elem` map snd env +              = PApp un (de env [] f) (map pexp (map (de env []) args))+    deFn env (P _ n _) args +         | not mvs = case lookup n (idris_metavars ist) of+                        Just (Just _, mi, _) ->+                            mkMVApp n (drop mi (map (de env []) args))+                        _ -> mkPApp n (map (de env []) args)          | otherwise = mkPApp n (map (de env []) args)     deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args)) @@ -108,14 +116,14 @@     mkMVApp n args             = PApp un (PMetavar n) (map pexp args)     mkPApp n args-        | [imps] <- lookupCtxt n (idris_implicits ist)+        | Just imps <- lookupCtxtExact n (idris_implicits ist)             = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)         | otherwise = PApp un (PRef un n) (map pexp args) -    imp (PImp p m l n _ d) arg = PImp p m l n arg d-    imp (PExp p l _ d)   arg = PExp p l arg d-    imp (PConstraint p l _ d) arg = PConstraint p l arg d-    imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d+    imp (PImp p m l n _) arg = PImp p m l n arg+    imp (PExp p l _)   arg = PExp p l arg+    imp (PConstraint p l _) arg = PConstraint p l arg+    imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg  -- | How far to indent sub-errors errorIndent :: Int@@ -127,12 +135,10 @@ indented = nest errorIndent . (line <>)  pprintTerm :: IState -> PTerm -> Doc OutputAnnotation-pprintTerm ist = prettyImp (opt_showimp (idris_options ist))+pprintTerm ist = pprintTerm' ist [] -pshow :: IState -> Err -> String-pshow ist err = displayDecorated (consoleDecorate ist) .-                renderPretty 1.0 80 .-                fmap (fancifyAnnots ist) $ pprintErr ist err+pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation+pprintTerm' ist bnd tm = pprintPTerm (opt_showimp (idris_options ist)) bnd [] tm  pprintErr :: IState -> Err -> Doc OutputAnnotation pprintErr i err = pprintErr' i (fmap (errReverse i) err)@@ -144,25 +150,28 @@          text ("Please consider reporting at " ++ bugaddr)        ] pprintErr' i (CantUnify _ x y e sc s) =-  text "Can't unify" <> indented (pprintTerm i (delab i x)) <$>-  text "with" <> indented (pprintTerm i (delab i y)) <>+  text "Can't unify" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) sc) (delab i x)) <$>+  text "with" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) sc) (delab i y)) <>   case e of     Msg "" -> empty     _ -> line <> line <> text "Specifically:" <>          indented (pprintErr' i e) <>-         if (opt_errContext (idris_options i)) then text $ showSc i sc else empty-pprintErr' i (CantConvert x y env) = trace (show (x,y)) $ -  text "Can't convert" <> indented (pprintTerm i (delab i x)) <$>-  text "with" <> indented (pprintTerm i (delab i y)) <>-  if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty+         if (opt_errContext (idris_options i)) then showSc i sc else empty+pprintErr' i (CantConvert x y env) =+  text "Can't convert" <>+  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x)) <$>+  text "with" <>+  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i y)) <>+  if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (CantSolveGoal x env) =-  text "Can't solve goal " <> indented (pprintTerm i (delab i x)) <>-  if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty+  text "Can't solve goal " <>+  indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i x)) <>+  if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (UnifyScope n out tm env) =   text "Can't unify" <> indented (annName n) <+>-  text "with" <> indented (pprintTerm i (delab i tm)) <+>+  text "with" <> indented (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm)) <+>   text "as" <> indented (annName out) <> text "is not in scope" <>-  if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty+  if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (CantInferType t) = text "Can't infer type for" <+> text t pprintErr' i (NonFunctionType f ty) =   pprintTerm i (delab i f) <+>@@ -176,16 +185,17 @@ pprintErr' i (CantIntroduce ty) =   text "Can't use lambda here: type is" <+> pprintTerm i (delab i ty) pprintErr' i (InfiniteUnify x tm env) =-  text "Unifying" <+> annName' x (showbasic x) <+> text "and" <+> pprintTerm i (delab i tm) <+>+  text "Unifying" <+> annName' x (showbasic x) <+> text "and" <+>+  pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delab i tm) <+>   text "would lead to infinite value" <>-  if (opt_errContext (idris_options i)) then line <> text (showSc i env) else empty+  if (opt_errContext (idris_options i)) then line <> showSc i env else empty pprintErr' i (NotInjective p x y) =   text "Can't verify injectivity of" <+> pprintTerm i (delab i p) <+>   text " when unifying" <+> pprintTerm i (delab i x) <+> text "and" <+>   pprintTerm i (delab i y) pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c) pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>-                                    cat (punctuate (comma <> space) (map text as))+                                    align (cat (punctuate (comma <> space) (map text as))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t)@@ -202,16 +212,33 @@ pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>                                    annName' n (showqual i n) <> colon <$>                                    pprintErr' i e+pprintErr' i (ElaboratingArg f x _ e)+  | isUN x =+     text "When elaborating argument" <+>+     annotate (AnnBoundName x False) (text (showbasic x)) <+> --TODO check plicity+     text "to" <+> whatIsName <> annName f <> colon <>+     indented (pprintErr' i e)+  | otherwise =+     text "When elaborating an application of" <+> whatIsName <>+     annName f <> colon <> indented (pprintErr' i e)+  where whatIsName = let ctxt = tt_ctxt i+                     in if isTConName f ctxt+                           then text "type constructor" <> space+                           else if isConName f ctxt+                                   then text "constructor" <> space+                                   else if isFnName f ctxt+                                           then text "function" <> space+                                           else empty pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg) pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+>  pprintErr' i e pprintErr' i (ReflectionError parts orig) =-  let parts' = map (hsep . map showPart) parts in-  vsep parts' <>+  let parts' = map (fillSep . map showPart) parts in+  align (fillSep parts') <>   if (opt_origerr (idris_options i))     then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)     else empty   where showPart :: ErrorReportPart -> Doc OutputAnnotation-        showPart (TextPart str) = text str+        showPart (TextPart str) = fillSep . map text . words $ str         showPart (NamePart n)   = annName n         showPart (TermPart tm)  = pprintTerm i (delab i tm)         showPart (SubReport rs) = indented . hsep . map showPart $ rs@@ -220,16 +247,27 @@   indented (pprintErr' i err) <>   text ("This is probably a bug. Please consider reporting it at " ++ bugaddr) +isUN :: Name -> Bool+isUN (UN n) = not $ T.isPrefixOf (T.pack "__") n -- TODO figure out why MNs are getting rewritte to UNs for top-level pattern-matching functions+isUN (NS n _) = isUN n+isUN _ = False+ annName :: Name -> Doc OutputAnnotation-annName n = annName' n (show n)+annName n = annName' n (showbasic n)  annName' :: Name -> String -> Doc OutputAnnotation-annName' n str = annotate (AnnName n Nothing Nothing) (text str)+annName' n str = annotate (AnnName n Nothing Nothing Nothing) (text str) -showSc i [] = ""-showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))-  where showVar (x, y) = "\t" ++ showbasic x ++ " : " ++ show (delab i y)+showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation+showSc i [] = empty+showSc i xs = line <> line <> text "In context:" <>+            indented (vsep (reverse (showSc' [] xs)))+     where showSc' bnd [] = []+           showSc' bnd ((n, ty):ctxt) =+             let this = bindingOf n False <+> colon <+> pprintTerm' i bnd (delab i ty)+             in this : showSc' ((n,False):bnd) ctxt + showqual :: IState -> Name -> String showqual i n = showName (Just i) [] False False (dens n)   where@@ -238,6 +276,7 @@                               _ -> ns     dens n = n +showbasic :: Name -> String showbasic n@(UN _) = show n showbasic (MN _ s) = str s showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n
src/Idris/Docs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} module Idris.Docs where  import Idris.AbsSyntax@@ -5,64 +6,78 @@ import Idris.Delaborate import Idris.Core.TT import Idris.Core.Evaluate+import Idris.Docstrings +import Util.Pretty+ import Data.Maybe import Data.List+import qualified Data.Text as T  -- TODO: Only include names with public/abstract accessibility -data FunDoc = Doc Name String-                  [(Name, PArg)] -- args-                  PTerm -- function type-                  (Maybe Fixity)+data FunDoc = FD Name Docstring+                 [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs+                 PTerm -- function type+                 (Maybe Fixity)+  deriving Show -data Doc = FunDoc FunDoc-         | DataDoc FunDoc -- type constructor docs-                   [FunDoc] -- data constructor docs-         | ClassDoc Name String -- class docs-                    [FunDoc] -- method docs+data Docs = FunDoc FunDoc+          | DataDoc FunDoc -- type constructor docs+                    [FunDoc] -- data constructor docs+          | ClassDoc Name Docstring -- class docs+                     [FunDoc] -- method docs+  deriving Show -showDoc "" = ""-showDoc x = "  -- " ++ x+showDoc d | nullDocstring d = empty+          | otherwise       = text "  -- " <> renderDocstring d -instance Show FunDoc where-   show (Doc n doc args ty f)-      = show n ++ " : " ++ show ty ++ "\n" ++ showDoc doc ++ "\n" ++-        maybe "" (\f -> show f ++ "\n\n") f ++-        let argshow = mapMaybe showArg args in-            if not (null argshow)-               then "Arguments:\n\t" ++ showSep "\t" argshow-               else ""+pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation+pprintFD imp (FD n doc args ty f)+    = nest 4 (prettyName imp [] n <+> colon <+>+              pprintPTerm imp [] [ n | (n@(UN n'),_,_,_) <- args+                                     , not (T.isPrefixOf (T.pack "__") n') ] ty <$>+              renderDocstring doc <$>+              maybe empty (\f -> text (show f) <> line) f <>+              let argshow = showArgs args [] in+              if not (null argshow)+                then nest 4 $ text "Arguments:" <$> vsep argshow+                else empty) -    where showArg (n, arg@(PExp _ _ _ _))-             = Just $ showName n ++ show (getTm arg) ++-                      showDoc (pargdoc arg) ++ "\n"-          showArg (n, arg@(PConstraint _ _ _ _))-             = Just $ "Class constraint " ++-                      show (getTm arg) ++ showDoc (pargdoc arg)-                      ++ "\n"-          showArg (n, arg@(PImp _ _ _ _ _ doc))-           | not (null doc)-             = Just $ "(implicit) " ++-                      show n ++ " : " ++ show (getTm arg)-                      ++ showDoc (pargdoc arg) ++ "\n"-          showArg (n, _) = Nothing+    where showArgs ((n, ty, Exp {}, Just d):args) bnd+             = bindingOf n False <+> colon <+>+               pprintPTerm imp bnd [] ty <>+               showDoc d <> line+               :+               showArgs args ((n, False):bnd)+          showArgs ((n, ty, Constraint {}, Just d):args) bnd+             = text "Class constraint" <+>+               pprintPTerm imp bnd [] ty <> showDoc d <> line+               :+               showArgs args ((n, True):bnd)+          showArgs ((n, ty, Imp {}, Just d):args) bnd+             = text "(implicit)" <+>+               bindingOf n True <+> colon <+>+               pprintPTerm imp bnd [] ty <>+               showDoc d <> line+               :+               showArgs args ((n, True):bnd)+          showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)+          showArgs []                  _ = [] -          showName (MN _ _) = ""-          showName x = show x ++ " : " -instance Show Doc where -    show (FunDoc d) = show d-    show (DataDoc t args) = "Data type " ++ show t ++-       "\nConstructors:\n\n" ++-       showSep "\n" (map show args)-    show (ClassDoc n doc meths)-       = "Type class " ++ show n ++ -- parameters?-         "\nMethods:\n\n" ++-         showSep "\n" (map show meths)+pprintDocs imp (FunDoc d) = pprintFD imp d+pprintDocs imp (DataDoc t args)+           = text "Data type" <+> pprintFD imp t <$>+             nest 4 (text "Constructors:" <> line <>+                     vsep (map (pprintFD imp) args))+pprintDocs imp (ClassDoc n doc meths)+           = text "Type class" <+> prettyName imp [] n <$> -- parameters?+             nest 4 (text "Methods:" <$>+                     vsep (map (pprintFD imp) meths)) -getDocs :: Name -> Idris Doc+getDocs :: Name -> Idris Docs getDocs n    = do i <- getIState         case lookupCtxt n (idris_classes i) of@@ -72,42 +87,41 @@                        _ -> do fd <- docFun n                                return (FunDoc fd) -docData :: Name -> TypeInfo -> Idris Doc+docData :: Name -> TypeInfo -> Idris Docs docData n ti   = do tdoc <- docFun n        cdocs <- mapM docFun (con_names ti)        return (DataDoc tdoc cdocs) -docClass :: Name -> ClassInfo -> Idris Doc+docClass :: Name -> ClassInfo -> Idris Docs docClass n ci   = do i <- getIState        let docstr = case lookupCtxt n (idris_docstrings i) of-                         [str] -> str-                         _ -> ""+                         [str] -> fst str+                         _ -> emptyDocstring        mdocs <- mapM docFun (map fst (class_methods ci))        return (ClassDoc n docstr mdocs)  docFun :: Name -> Idris FunDoc docFun n   = do i <- getIState-       let docstr = case lookupCtxt n (idris_docstrings i) of-                         [str] -> str-                         _ -> ""-       let ty = case lookupTy n (tt_ctxt i) of-                     (t : _) -> t-       let argnames = map fst (getArgTys ty)-       let args = case lookupCtxt n (idris_implicits i) of-                       [args] -> zip argnames args-                       _ -> []+       let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of+                                  [d] -> d+                                  _ -> noDocs+       let ty = delabTy i n+       let args = getPArgNames ty argDocs        let infixes = idris_infixes i        let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes        let f = case fixdecls of                     []          -> Nothing                     (Fix x _:_) -> Just x -       return (Doc n docstr args (delab i ty) f)+       return (FD n docstr args ty f)        where funName :: Name -> String              funName (UN n)   = str n              funName (NS n _) = funName n -+getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)]+getPArgNames (PPi plicity name ty body) ds =+  (name, ty, plicity, lookup name ds) : getPArgNames body ds+getPArgNames _ _ = []
+ src/Idris/Docstrings.hs view
@@ -0,0 +1,119 @@+-- | Wrapper around Markdown library+module Idris.Docstrings (+    Docstring, parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs,+    overview, containsText+  ) where++import qualified Cheapskate as C+import qualified Cheapskate.Types as CT++import Util.Pretty++import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name)++import qualified Data.Text as T+import qualified Data.Foldable as F+import qualified Data.Sequence as S++-- | Representation of Idris's inline documentation+type Docstring = CT.Doc++-- | Construct a docstring from a Text that contains Markdown-formatted docs+parseDocstring :: T.Text -> CT.Doc+parseDocstring = C.markdown options+++options = CT.Options { CT.sanitize = True+                     , CT.allowRawHtml = False+                     , CT.preserveHardBreaks = True+                     , CT.debug = False+                     }++-- | Convert a docstring to be shown by the pretty-printer+renderDocstring ::  Docstring -> Doc OutputAnnotation+renderDocstring (CT.Doc _ blocks) = renderBlocks blocks++-- | Construct a docstring consisting of the first block-level element of the+-- argument docstring, for use in summaries.+overview :: Docstring -> Docstring+overview (CT.Doc opts blocks) = CT.Doc opts (S.take 1 blocks)++renderBlocks ::  CT.Blocks -> Doc OutputAnnotation+renderBlocks blocks  | S.length blocks > 1  = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $+                                              fmap renderBlock blocks+                     | S.length blocks == 1 = renderBlock (S.index blocks 0)+                     | otherwise            = empty++renderBlock :: CT.Block -> Doc OutputAnnotation+renderBlock (CT.Para inlines) = renderInlines inlines+renderBlock (CT.Header lvl inlines) = renderInlines inlines <+> parens (text (show lvl))+renderBlock (CT.Blockquote blocks) = indent 8 $ renderBlocks blocks+renderBlock (CT.List b ty blockss) = renderList b ty blockss+renderBlock (CT.CodeBlock attr src) = indent 8 $ text (T.unpack src)+renderBlock (CT.HtmlBlock txt) = text "<html block>" -- TODO+renderBlock CT.HRule = text "----------------------"++renderList :: Bool -> CT.ListType -> [CT.Blocks] -> Doc OutputAnnotation+renderList b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks) blockss+renderList b (CT.Numbered nw i) blockss =+  vsep $+  zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)+           [i..] (repeat punc) (map renderBlocks blockss)+  where punc = case nw of+                 CT.PeriodFollowing -> char '.'+                 CT.ParenFollowing  -> char '('++renderInlines :: CT.Inlines -> Doc OutputAnnotation+renderInlines = F.foldr (<>) empty . fmap renderInline++renderInline :: CT.Inline -> Doc OutputAnnotation+renderInline (CT.Str s) = text $ T.unpack s+renderInline CT.Space = space+renderInline CT.SoftBreak = softline+renderInline CT.LineBreak = line+renderInline (CT.Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines txt -- TODO+renderInline (CT.Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines txt -- TODO+renderInline (CT.Code txt) = text $ T.unpack txt+renderInline (CT.Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines body) <+>+                                        parens (text $ T.unpack url)+renderInline (CT.Image body url title) = text "<image>" -- TODO+renderInline (CT.Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO+renderInline (CT.RawHtml txt) = text "<html content>" --TODO++-- | The empty docstring+emptyDocstring :: Docstring+emptyDocstring = CT.Doc options S.empty++-- | Check whether a docstring is emtpy+nullDocstring :: Docstring -> Bool+nullDocstring (CT.Doc _ blocks) = S.null blocks++-- | Empty documentation for a definition+noDocs :: (Docstring, [(Name, Docstring)])+noDocs = (emptyDocstring, [])++-- | Does a string occur in the docstring?+containsText ::  T.Text -> Docstring -> Bool+containsText str (CT.Doc _ blocks) = F.any (blockContains (T.toLower str)) blocks+  -- blockContains and inlineContains should always be called with a lower-case search string+  where blockContains :: T.Text -> CT.Block -> Bool+        blockContains str (CT.Para inlines) = F.any (inlineContains str) inlines+        blockContains str (CT.Header lvl inlines) = F.any (inlineContains str) inlines+        blockContains str (CT.Blockquote blocks) = F.any (blockContains str) blocks+        blockContains str (CT.List b ty blockss) = F.any (F.any (blockContains str)) blockss+        blockContains str (CT.CodeBlock attr src) = T.isInfixOf str (T.toLower src)+        blockContains str (CT.HtmlBlock txt) = False -- TODO+        blockContains str CT.HRule = False++        inlineContains :: T.Text -> CT.Inline -> Bool+        inlineContains str (CT.Str s) = T.isInfixOf str (T.toLower s)+        inlineContains str CT.Space = False+        inlineContains str CT.SoftBreak = False+        inlineContains str CT.LineBreak = False+        inlineContains str (CT.Emph txt) = F.any (inlineContains str) txt+        inlineContains str (CT.Strong txt) = F.any (inlineContains str) txt+        inlineContains str (CT.Code txt) = T.isInfixOf str (T.toLower txt)+        inlineContains str (CT.Link body url title) = F.any (inlineContains str) body+        inlineContains str (CT.Image body url title) = False+        inlineContains str (CT.Entity a) = False+        inlineContains str (CT.RawHtml txt) = T.isInfixOf str (T.toLower txt)
src/Idris/ElabDecls.hs view
@@ -16,6 +16,7 @@ import Idris.Inliner import Idris.PartialEval import Idris.DeepSeq+import Idris.Output (iputStrLn, pshow, iWarn) import IRTS.Lang import Paths_idris @@ -26,6 +27,8 @@ import Idris.Core.Typecheck import Idris.Core.CaseTree +import Idris.Docstrings+ import Control.DeepSeq import Control.Monad import Control.Monad.State.Strict as State@@ -38,7 +41,7 @@ import Data.Char(isLetter, toLower) import Data.List.Split (splitOn) -import Util.Pretty(pretty)+import Util.Pretty(pretty, text)  recheckC fc env t     = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...)@@ -56,22 +59,23 @@ checkAddDef add toplvl fc ((n, (i, top, t)) : ns)                 = do ctxt <- getContext                     (t', _) <- recheckC fc [] t-                    when add $ addDeferred [(n, (i, top, t, toplvl))]+                    when add $ do addDeferred [(n, (i, top, t, toplvl))]+                                  addIBC (IBCDef n)                     ns' <- checkAddDef add toplvl fc ns                     return ((n, (i, top, t')) : ns') --                     mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t --                                                   return (n, (i, top, t'))) ns  -- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".-elabType :: ElabInfo -> SyntaxInfo -> String ->+elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->             FC -> FnOpts -> Name -> PTerm -> Idris Type elabType = elabType' False  elabType' :: Bool -> -- normalise it-             ElabInfo -> SyntaxInfo -> String ->+             ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->              FC -> FnOpts -> Name -> PTerm -> Idris Type-elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in-                                               n  = liftname info n_in in    -}+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          ctxt <- getContext          i <- getIState@@ -81,7 +85,7 @@          ty' <- implicit syn n ty'           let ty = addImpl i ty'-         logLvl 2 $ show n ++ " type " ++ showTmImpls ty+         logLvl 3 $ show n ++ " type " ++ showTmImpls ty          ((tyT, defer, is), log) <-                tclift $ elaborate ctxt n (TType (UVal 0)) []                         (errAt "type of " n (erun fc (build i info False [] n ty)))@@ -89,8 +93,7 @@          -- if the type is not complete, note that we'll need to infer          -- things later (for solving metavariables)          when (not (null ds)) $ addTyInferred n---          let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds---          addDeferred ds'+          mapM_ (elabCaseBlock info opts) is          ctxt <- getContext          logLvl 5 $ "Rechecking"@@ -106,8 +109,8 @@          -- Add normalised type to internals          rep <- useREPL          when rep $ do-           addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))-           addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))+           addInternalApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?+           addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))           let (t, _) = unApply (getRetTy nty')          let corec = case t of@@ -115,18 +118,20 @@                                         [TI _ True _ _] -> True                                         _ -> False                         _ -> False-         let opts' = if corec then (Coinductive : opts) else opts+         -- Productivity checking now via checking for guarded 'Delay' +         let opts' = opts -- if corec then (Coinductive : opts) else opts          let usety = if norm then nty' else nty          ds <- checkDef fc [(n, (-1, Nothing, usety))]          addIBC (IBCDef n)          let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds          addDeferred ds'          setFlags n opts'-         addDocStr n doc+         checkDocs fc argDocs ty+         addDocStr n doc argDocs          addIBC (IBCDoc n)          addIBC (IBCFlags n opts')-         when (Implicit `elem` opts) $ do addCoercion n-                                          addIBC (IBCCoercion n)+         when (Implicit `elem` opts') $ do addCoercion n+                                           addIBC (IBCCoercion n)          -- If the function is declared as an error handler and the language          -- extension is enabled, then add it to the list of error handlers.          errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState@@ -141,8 +146,6 @@                          addIBC (IBCErrorHandler n)                  else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"              else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."-         when corec $ do setAccessibility n Frozen-                         addIBC (IBCAccess n Frozen)          return usety   where     -- for making an internalapp, we only want the explicit ones, and don't@@ -167,13 +170,13 @@         , ns2 == map txt ["Maybe", "Prelude"]         , ns3 == map txt ["List", "Prelude"]         , ns4 == map txt ["Errors","Reflection","Language"] = True-    tyIsHandler _                                   = False+    tyIsHandler _                                           = False  -elabPostulate :: ElabInfo -> SyntaxInfo -> String ->+elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->                  FC -> FnOpts -> Name -> PTerm -> Idris () elabPostulate info syn doc fc opts n ty-    = do elabType info syn doc fc opts n ty+    = do elabType info syn doc [] fc opts n ty          -- make sure it's collapsible, so it is never needed at run time          -- start by getting the elaborated type          ctxt <- getContext@@ -194,8 +197,8 @@          -- remove it from the deferred definitions list          solveDeferred n -elabData :: ElabInfo -> SyntaxInfo -> String -> FC -> DataOpts -> PData -> Idris ()-elabData info syn doc fc opts (PLaterdecl n t_in)+elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()+elabData info syn doc argDocs fc opts (PLaterdecl n t_in)     = do let codata = Codata `elem` opts          iLOG (show (fc, doc))          checkUndefined fc n@@ -213,7 +216,7 @@          logLvl 2 $ "---> " ++ show cty          updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons -elabData info syn doc fc opts (PDatadecl n t_in dcons)+elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)     = do let codata = Codata `elem` opts          iLOG (show fc)          undef <- isUndefined fc n@@ -241,26 +244,29 @@          let as = map (const Nothing) (getArgTys cty)          let params = findParams  (map snd cons)          logLvl 2 $ "Parameters : " ++ show params-         putIState (i { idris_datatypes = +         putIState (i { idris_datatypes =                           addDef n (TI (map fst cons) codata opts params)                                              (idris_datatypes i) })          addIBC (IBCDef n)          addIBC (IBCData n)-         addDocStr n doc+         checkDocs fc argDocs t_in+         addDocStr n doc argDocs          addIBC (IBCDoc n)          let metainf = DataMI params          addIBC (IBCMetaInformation n metainf)-         collapseCons n cons+         -- TMP HACK! Make this a data option+         when (n /= sUN "Lazy'") $ collapseCons n cons          updateContext (addDatatype (Data n ttag cty cons))          updateContext (setMetaInformation n metainf)          mapM_ (checkPositive n) cons-         if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty-                                          else return ()+         if DefaultEliminator `elem` opts+           then evalStateT (elabEliminator params n t dcons info) Map.empty+           else return ()   where-        checkDefinedAs fc n t ctxt +        checkDefinedAs fc n t ctxt             = case lookupDef n ctxt of                    [] -> return ()-                   [TyDecl _ ty] -> +                   [TyDecl _ ty] ->                       case converts ctxt [] t ty of                            OK () -> return ()                            _ -> tclift $ tfail (At fc (AlreadyDefined n))@@ -318,7 +324,8 @@ type EliminatorState = StateT (Map.Map String Int) Idris  -- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite-elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] -> +elabEliminator :: [Int] -> Name -> PTerm ->+                  [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->                   ElabInfo -> EliminatorState () elabEliminator paramPos n ty cons info = do   elimLog $ "Elaborating eliminator"@@ -327,15 +334,15 @@   generalParams <- namePis False pms   motiveIdxs    <- namePis False idxs   let motive = mkMotive n paramPos generalParams motiveIdxs-  consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do-                              name <- freshName $ "elim_" ++ simpleName cnm-                              consTerm <- extractConsTerm c generalParams-                              return (name, expl, consTerm)) cons+  consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do+                               name <- freshName $ "elim_" ++ simpleName cnm+                               consTerm <- extractConsTerm c generalParams+                               return (name, expl, consTerm)) cons   scrutineeIdxs <- namePis False idxs   let motiveConstr = [(motiveName, expl, motive)]   let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))   let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))-  let eliminatorTyDecl = PTy (show n) defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy+  let eliminatorTyDecl = PTy (parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy   let clauseConsElimArgs = map getPiName consTerms   let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs   let clauseGeneralArgs  = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'@@ -484,7 +491,7 @@         splitArgPms _                 = ([],[])  -        implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]+        implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]         implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do           i <-  State.lift getIState           implargs' <- case lookupCtxt cnm (idris_implicits i) of@@ -499,8 +506,8 @@               in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs              _ -> return implargs -        extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm-        extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do+        extractConsTerm :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm+        extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do           let cons' = replaceParams paramPos generalParameters ty           let (args, resTy) = splitPi cons'           implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)@@ -535,8 +542,8 @@         convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)         convertImplPi _                             = Nothing -        generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause-        generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do+        generateEliminatorClauses :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause+        generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do           let cons' = replaceParams paramPos generalParameters ty           let (args, resTy) = splitPi cons'           i <- State.lift getIState@@ -557,7 +564,7 @@  elabPrims :: Idris () elabPrims = do mapM_ (elabDecl EAll toplevel)-                     (map (\(opt, decl) -> PData "" defaultSyntax (fileFC "builtin") opt decl)+                     (map (\(opt, decl) -> PData emptyDocstring [] defaultSyntax (fileFC "builtin") opt decl)                         (zip                          [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]                          [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))@@ -625,8 +632,8 @@   -- | Elaborate a type provider-elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()-elabProvider info syn fc n ty tm+elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> PTerm -> PTerm -> Idris ()+elabProvider info syn fc what n ty tm     = do i <- getIState          -- Ensure that the experimental extension is enabled          unless (TypeProviders `elem` idris_language_extensions i) $@@ -646,23 +653,33 @@            ifail $ "Expected provider type IO (Provider (" ++                    show ty' ++ "))" ++ ", got " ++ show et ++ " instead." -         -- Create the top-level type declaration-         elabType info syn "" fc [] n ty-          -- Execute the type provider and normalise the result          -- use 'run__provider' to convert to a primitive IO action           rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)                                           [Erased, e])          let rhs' = normalise ctxt [] rhs-         logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs+         logLvl 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs -         -- Extract the provided term from the type provider-         tm <- getProvided fc rhs'+         -- Extract the provided term or postulate from the type provider+         provided <- getProvided fc rhs' -         -- Finally add a top-level definition of the provided term-         elabClauses info fc [] n [PClause fc n (PRef fc n) [] (delab i tm) []]-         logLvl 1 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm+         case provided of+           Provide tm+             | what `elem` [ProvTerm, ProvAny] ->+               do -- Finally add a top-level definition of the provided term+                  elabType info syn emptyDocstring [] fc [] n ty+                  elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]+                  logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm+             | otherwise ->+               ierror . Msg $ "Attempted to provide a term where a postulate was expected."+           Postulate+             | what `elem` [ProvPostulate, ProvAny] ->+               do -- Add the postulate+                  elabPostulate info syn (parseDocstring $ T.pack "Provided postulate") fc [] n ty+                  logLvl 3 $ "Elaborated provided postulate " ++ show n+             | otherwise ->+               ierror . Msg $ "Attempted to provide a postulate where a term was expected."      where isTType :: TT Name -> Bool           isTType (TType _) = True@@ -676,7 +693,6 @@             , prov == txt "Provider" && provs == txt "Providers" = True           isProviderOf _ _ = False --- | Elaborate a type provider elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris () elabTransform info fc safe lhs_in rhs_in     = do ctxt <- getContext@@ -695,7 +711,7 @@          let rhs = addImplBound i (map fst newargs) rhs_in          ((rhs', defer), _) <-               tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty []-                       (do pbinds lhs_tm+                       (do pbinds i lhs_tm                            setNextName                            erun fc (build i info False [] (sUN "transform") rhs)                            erun fc $ psolve lhs_tm@@ -710,10 +726,10 @@          addIBC (IBCTrans (clhs_tm, crhs_tm))  -elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->-              PTerm -> String -> Name -> PTerm -> Idris ()+elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->+              PTerm -> Docstring -> Name -> PTerm -> Idris () elabRecord info syn doc fc tyn ty cdoc cn cty-    = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc, [])])+    = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])          cty' <- implicit syn cn cty          i <- getIState          cty <- case lookupTy cn (tt_ctxt i) of@@ -736,7 +752,7 @@   where --     syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in } -    isNonImp (PExp _ _ _ _, a) = Just a+    isNonImp (PExp _ _ _, a) = Just a     isNonImp _ = Nothing      tryElabDecl info (fn, ty, val)@@ -748,15 +764,15 @@                                       show fn ++ " (" ++ show ty ++ ")"                                   putIState i) -    getImplB k (PPi (Imp l s _ _) n Placeholder sc)+    getImplB k (PPi (Imp l s _) n Placeholder sc)         = getImplB k sc-    getImplB k (PPi (Imp l s d p) n ty sc)-        = getImplB (\x -> k (PPi (Imp l s d p) n ty x)) sc+    getImplB k (PPi (Imp l s p) n ty sc)+        = getImplB (\x -> k (PPi (Imp l s p) n ty x)) sc     getImplB k (PPi _ n ty sc)         = getImplB k sc     getImplB k _ = k -    renameBs (PImp _ _ _ _ _ _ : ps) (PPi p n ty s)+    renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s)         = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s))     renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s)     renameBs _ t = t@@ -783,7 +799,7 @@      mkProj recty substs cimp ((pn_in, pty), pos)         = do let pn = expandNS syn pn_in-             let pfnTy = PTy "" defaultSyntax fc [] pn+             let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn                             (PPi expl rec recty                                (substMatches substs pty))              let pls = repeat Placeholder@@ -804,7 +820,7 @@             let valname = sMN 0 "updateval"             let pt = k (PPi expl pn pty                            (PPi expl rec recty recty))-            let pfnTy = PTy "" defaultSyntax fc [] setname pt+            let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt             let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]             let lhsArgs = pls             let rhsArgs = take pos pls ++ (PRef fc valname) :@@ -820,8 +836,8 @@             return (pn, pfnTy, PClauses fc [] setname [pclause])  elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->-           (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)-elabCon info syn tn codata (doc, n, t_in, fc, forcenames)+           (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)+elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)     = do checkUndefined fc n          ctxt <- getContext          i <- getIState@@ -842,7 +858,8 @@          tyIs cty'          logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'          addIBC (IBCDef n)-         addDocStr n doc+         checkDocs fc argDocs t_in+         addDocStr n doc argDocs          addIBC (IBCDoc n)          let fs = map (getNamePos 0 t) forcenames          -- FIXME: 'forcenames' is an almighty hack! Need a better way of@@ -857,9 +874,19 @@     tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn)))      mkLazy (PPi pl n ty sc) -        = PPi (pl { pargopts = nub (Lazy : pargopts pl) }) n ty (mkLazy sc)+        = let ty' = if getTyName ty+                       then PApp fc (PRef fc (sUN "Lazy'")) +                            [pexp (PRef fc (sUN "LazyCodata")),+                             pexp ty]+                       else ty in+              PPi pl n ty' (mkLazy sc)     mkLazy t = t +    getTyName (PApp _ (PRef _ n) _) = n == nsroot tn+    getTyName (PRef _ n) = n == nsroot tn+    getTyName _ = False++     getNamePos :: Int -> PTerm -> Name -> Maybe Int     getNamePos i (PPi _ n _ sc) x | n == x = Just i                                   | otherwise = getNamePos (i + 1) sc x@@ -881,8 +908,10 @@                     tclift $ tfail $ At fc (NoTypeDecl n)               [ty] -> return ty            let atys = map snd (getArgTys fty)-           pats_in <- mapM (elabClause info opts)+           cs_elab <- mapM (elabClause info opts)                            (zip [0..] cs)+           let (pats_in, cs_full) = unzip cs_elab+            logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in             -- if the return type of 'ty' is collapsible, the optimised version should@@ -966,8 +995,8 @@                    simpleCase tcase False reflect CompileTime fc atys pdef            cov <- coverage            pmissing <--                   if cov-                      then do missing <- genClauses fc n (map getLHS pdef) cs+                   if cov && not (hasDefault cs)+                      then do missing <- genClauses fc n (map getLHS pdef) cs_full                               -- missing <- genMissing n scargs sc                               missing' <- filterM (checkPossible info fc True n) missing                               let clhs = map getLHS pdef@@ -995,6 +1024,7 @@            let tot = if pcover || AssertTotal `elem` opts                       then Unchecked -- finish checking later                       else Partial NotCovering -- already know it's not total+   --          case lookupCtxt (namespace info) n (idris_flags ist) of   --             [fs] -> if TotalFn `elem` fs   --                       then case tot of@@ -1050,7 +1080,10 @@                           return ()   --                         addIBC (IBCTotal n tot)                [] -> return ()-           return ()+           -- Check it's covering, if 'covering' option is used. Chase+           -- all called functions, and fail if any of them are also+           -- 'Partial NotCovering'+           when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n   where     noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of                                       Right _ -> False@@ -1070,6 +1103,10 @@     depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)     depat acc x = (acc, x) +    hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs+                  , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args+    hasDefault _ = False+     getLHS (_, l, _) = l      simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, @@ -1140,10 +1177,10 @@                            (map (\ (lhs, rhs) ->                               (showTmImpls lhs ++ " = " ++                                 showTmImpls rhs)) pats)-            elabType info defaultSyntax "" fc opts newnm specTy+            elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy             let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats             elabClauses info fc opts newnm def-            logLvl 1 $ "Specialised " ++ show newnm)+            logLvl 2 $ "Specialised " ++ show newnm)           -- if it doesn't work, just don't specialise. Could happen for lots           -- of valid reasons (e.g. local variables in scope which can't be           -- lifted out).@@ -1240,16 +1277,14 @@                   case recheck ctxt [] (forget lhs_tm) lhs_tm of                        OK _ -> return True                        err -> return False----                   b <- inferredDiff fc (delab' i lhs_tm True) lhs---                   return (not b) -- then return (Just lhs_tm) else return Nothing---                   trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)-            Error err -> return (impossibleError err)+            Error err -> if tcgen then return False+                                  else return (impossibleError err)     where impossibleError (CantUnify _ topx topy e _ _)                = not (sameFam topx topy || not (impossibleError e))           impossibleError (CantConvert _ _ _) = False           impossibleError (At _ e) = impossibleError e           impossibleError (Elaborating _ _ e) = impossibleError e+          impossibleError (ElaboratingArg _ _ _ e) = impossibleError e           impossibleError _ = True            sameFam topx topy @@ -1257,16 +1292,81 @@                      ((P _ x _, _), (P _ y _, _)) -> x == y                      _ -> False +getFixedInType i env (PExp _ _ _ : is) (Bind n (Pi t) sc)+    = 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 :: [Name] -> Type -> PTerm -> PTerm+propagateParams ps t tm@(PApp _ (PRef fc n) args)+     = PApp fc (PRef fc n) (addP t args)+   where addP (Bind n _ sc) (t : ts)+              | Placeholder <- getTm t,+                n `elem` ps,+                not (n `elem` allNamesIn tm)+                    = t { getTm = PRef fc n } : addP sc ts+         addP (Bind n _ sc) (t : ts) = t : addP sc ts+         addP _ ts = ts+propagateParams ps t (PRef fc n)+     = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)+propagateParams ps t x = x++-- Return the elaborated LHS/RHS, and the original LHS with implicits added elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->-              Idris (Either Term (Term, Term))+              Idris (Either Term (Term, Term), PTerm) elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])    = do let tcgen = Dictionary `elem` opts+        i <- get+        let lhs = addImpl i lhs_in         b <- checkPossible info fc tcgen fname lhs_in         case b of             True -> tclift $ tfail (At fc                                  (Msg $ show lhs_in ++ " is a valid case"))             False -> do ptm <- mkPatTm lhs_in-                        return (Left ptm)+                        return (Left ptm, lhs) elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)    = do let tcgen = Dictionary `elem` opts         ctxt <- getContext@@ -1283,24 +1383,27 @@                          [t] -> t                          _ -> []         let params = getParamsInType i [] fn_is fn_ty-        let lhs = stripUnmatchable i $-                    addImplPat i (propagateParams params (stripLinear i lhs_in))+        let lhs = mkLHSapp $ stripUnmatchable i $+                    propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))         logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)-        logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))+        logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in +++                  "\n" ++ show (fn_ty, fn_is)) -        (((lhs', dlhs, []), probs), _) <-+        (((lhs', dlhs, []), probs, inj), _) <-             tclift $ elaborate ctxt (sMN 0 "patLHS") infP []                      (do res <- errAt "left hand side of " fname                                   (erun fc (buildTC i info True opts fname (infTerm lhs)))                          probs <- get_probs-                         return (res, probs))+                         inj <- get_inj+                         return (res, probs, inj)) -        when inf $ addTyInfConstraints fc (map (\(x,y,_,_) -> (x,y)) probs)+        when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)          let lhs_tm = orderPats (getInferTerm lhs')         let lhs_ty = getInferType lhs'         logLvl 3 ("Elaborated: " ++ show lhs_tm)         logLvl 3 ("Elaborated type: " ++ show lhs_ty)+        logLvl 5 ("Injective: " ++ show fname ++ " " ++ show inj)          -- If we're inferring metavariables in the type, don't recheck,         -- because we're only doing this to try to work out those metavariables@@ -1313,8 +1416,8 @@          rep <- useREPL         when rep $ do-          addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)-          addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))+          addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?+          addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))          logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)         -- Elaborate where block@@ -1331,7 +1434,7 @@         -- Elaborate those with a type *before* RHS, those without *after*         let (wbefore, wafter) = sepBlocks wb -        logLvl 5 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter+        logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter         mapM_ (elabDecl' EAll info) wbefore         -- Now build the RHS, using the type of the LHS as the goal.         i <- getIState -- new implicits from where block@@ -1343,7 +1446,8 @@         logLvl 5 "STARTING CHECK"         ((rhs', defer, is, probs), _) <-            tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty []-                    (do pbinds lhs_tm+                    (do pbinds ist lhs_tm+                        mapM_ setinj (nub (params ++ inj))                         setNextName                          (_, _, is) <- errAt "right hand side of " fname                                          (erun fc (build i info False opts fname rhs))@@ -1357,14 +1461,16 @@                         probs <- get_probs                         return (tm, ds, is, probs)) -        when inf $ addTyInfConstraints fc (map (\(x,y,_,_) -> (x,y)) probs)+        when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)          logLvl 5 "DONE CHECK"         logLvl 2 $ "---> " ++ show rhs'-        when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer)+        when (not (null defer)) $ iLOG $ "DEFERRED " ++ +                    show (map (\ (n, (_,_,t)) -> (n, t)) defer)         def' <- checkDef fc defer         let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'         addDeferred def''+        mapM_ (\(n, _) -> addIBC (IBCDef n)) def''          when (not (null def')) $ do            mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'')@@ -1401,8 +1507,11 @@         when (rev || ErrorReverse `elem` opts) $ do            addIBC (IBCErrRev (crhs, clhs))            addErrRev (crhs, clhs) -        return $ Right (clhs, crhs)+        return $ (Right (clhs, crhs), lhs)   where+    mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []+    mkLHSapp t = t+     decorate (NS x ns)        = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum]) --        = NS (UN ('#':show x)) (ns ++ [show cnum, show fname])@@ -1412,7 +1521,7 @@ --        = NS (UN ('#':show x)) [show cnum, show fname]      sepBlocks bs = sepBlocks' [] bs where-      sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)+      sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)             = let (bf, af) = sepBlocks' (n : ns) bs in                   (d : bf, af)       sepBlocks' ns (d@(PClauses _ _ n _) : bs)@@ -1435,41 +1544,7 @@                                      --      _ -> MN i (show n)) . l                     } -    getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)-        = getParamsInType i env is (instantiate (P Bound n t) sc)-    getParamsInType i env (_ : is) (Bind n (Pi t) sc)-        = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)-    getParamsInType 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) ++-                             getParamsInType i env is f ++-                             getParamsInType i env is a-                [] -> nub $ getParamsInType i env is f ++-                            getParamsInType i env is a-        | otherwise = nub $ getParamsInType i env is f ++-                            getParamsInType i env is a-    getParamsInType i _ _ _ = [] -    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 :: [Name] -> PTerm -> PTerm-    propagateParams ps (PApp _ (PRef fc n) args)-         = PApp fc (PRef fc n) (map addP args)-       where addP imp@(PImp _ _ _ _ Placeholder _)-                  | pname imp `elem` ps = imp { getTm = PRef fc (pname imp) }-             addP t = t-    propagateParams ps (PRef fc n)-         = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)-    propagateParams ps x = x-     -- if a hole is just an argument/result of a case block, treat it as     -- the unit type. Hack to help elaborate case in do blocks.     elabCaseHole aux h = do@@ -1496,8 +1571,16 @@         -- Build the LHS as an "Infer", and pull out its type and         -- pattern bindings         i <- getIState-        let lhs = addImplPat i (stripLinear i lhs_in)-        logLvl 5 ("LHS: " ++ showTmImpls lhs)+        -- get the parameters first, to pass through to any where block+        let fn_ty = case lookupTy fname (tt_ctxt i) of+                         [t] -> t+                         _ -> error "Can't happen (elabClause function type)"+        let fn_is = case lookupCtxt fname (idris_implicits i) of+                         [t] -> t+                         _ -> []+        let params = getParamsInType i [] fn_is fn_ty+        let lhs = propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))+        logLvl 2 ("LHS: " ++ show lhs)         ((lhs', dlhs, []), _) <-             tclift $ elaborate ctxt (sMN 0 "patLHS") infP []               (errAt "left hand side of with in " fname@@ -1515,7 +1598,7 @@         ((wval', defer, is), _) <-             tclift $ elaborate ctxt (sMN 0 "withRHS")                         (bindTyArgs PVTy bargs infP) []-                        (do pbinds lhs_tm+                        (do pbinds i lhs_tm                             setNextName                             -- TODO: may want where here - see winfo abpve                             (_', d, is) <- errAt "with value in " fname@@ -1579,7 +1662,7 @@         i <- getIState         ((rhs', defer, is), _) <-            tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty []-                    (do pbinds lhs_tm+                    (do pbinds i lhs_tm                         setNextName                         (_, d, is) <- erun fc (build i info False opts fname rhs)                         psolve lhs_tm@@ -1591,7 +1674,7 @@         mapM_ (elabCaseBlock info opts) is         logLvl 5 ("Checked RHS " ++ show rhs')         (crhs, crhsty) <- recheckC fc [] rhs'-        return $ Right (clhs, crhs)+        return $ (Right (clhs, crhs), lhs)   where     getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t     getImps _ = []@@ -1655,11 +1738,11 @@  data MArgTy = IA | EA | CA deriving Show -elabClass :: ElabInfo -> SyntaxInfo -> String ->+elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->              FC -> [PTerm] ->              Name -> [(Name, PTerm)] -> [PDecl] -> Idris () elabClass info syn doc fc constraints tn ps ds-    = do let cn = sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)+    = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)          let tty = pibind ps PType          let constraint = PApp fc (PRef fc tn)                                   (map (pexp . PRef fc) (map fst ps))@@ -1682,10 +1765,10 @@          let cty = impbind ps $ conbind constraints                       $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)                                constraint-         let cons = [("", cn, cty, fc, [])]+         let cons = [(emptyDocstring, [], cn, cty, fc, [])]          let ddecl = PDatadecl tn tty cons          logLvl 5 $ "Class data " ++ show (showDImp True ddecl)-         elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl+         elabData info (syn { no_imp = no_imp syn ++ mnames }) doc [] fc [] ddecl          -- for each constraint, build a top level function to chase it          logLvl 5 $ "Building functions"          let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps@@ -1723,8 +1806,8 @@     conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)     conbind [] x = x -    getMName (PTy _ _ _ _ n _) = nsroot n-    tdecl allmeths (PTy doc syn _ o n t)+    getMName (PTy _ _ _ _ _ n _) = nsroot n+    tdecl allmeths (PTy doc _ syn _ o n t)            = do t' <- implicit' syn allmeths n t                 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'                 return ( (n, (toExp (map fst ps) Exp t')),@@ -1737,7 +1820,7 @@         case lookup n mtys of             Just (syn, o, ty) -> do let ty' = insertConstraint c ty                                     let ds = map (decorateid defaultdec)-                                                 [PTy "" syn fc [] n ty',+                                                 [PTy emptyDocstring [] syn fc [] n ty',                                                   PClauses fc (o ++ opts) n cs]                                     iLOG (show ds)                                     return (n, ((defaultdec n, ds!!1), ds))@@ -1747,7 +1830,7 @@     defaultdec (UN n) = sUN ("default#" ++ str n)     defaultdec (NS n ns) = NS (defaultdec n) ns -    tydecl (PTy _ _ _ _ _ _) = True+    tydecl (PTy _ _ _ _ _ _ _) = True     tydecl _ = False     instdecl (PInstance _ _ _ _ _ _ _ _) = True     instdecl _ = False@@ -1775,7 +1858,7 @@              addInstance False conn' cfn              addIBC (IBCInstance False conn' cfn) --              iputStrLn ("Added " ++ show (conn, cfn, ty))-             return [PTy "" syn fc [] cfn ty,+             return [PTy emptyDocstring [] syn fc [] cfn ty,                      PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]      -- Generate a top level function which looks up a method in a given@@ -1791,12 +1874,12 @@              iLOG (showTmImpls ty)              iLOG (show (m, ty', capp, margs))              iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)-             return [PTy doc syn fc o m ty',+             return [PTy doc [] syn fc o m ty',                      PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]] -    getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA : getMArgs sc-    getMArgs (PPi (Exp _ _ _ _) n ty sc) = EA  : getMArgs sc-    getMArgs (PPi (Constraint _ _ _) n ty sc) = CA : getMArgs sc+    getMArgs (PPi (Imp _ _ _) n ty sc) = IA : getMArgs sc+    getMArgs (PPi (Exp _ _ _) n ty sc) = EA  : getMArgs sc+    getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc     getMArgs _ = []      getMeth (m:ms) (a:as) x | x == a = PRef fc m@@ -1812,14 +1895,14 @@     rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns     rhsArgs [] _ = [] -    insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)+    insertConstraint c (PPi p@(Imp _ _ _) n ty sc)                           = PPi p n ty (insertConstraint c sc)     insertConstraint c sc = PPi constraint (sMN 0 "class") c sc      -- make arguments explicit and don't bind class parameters-    toExp ns e (PPi (Imp l s _ p) n ty sc)+    toExp ns e (PPi (Imp l s p) n ty sc)         | n `elem` ns = toExp ns e sc-        | otherwise = PPi (e l s "" p) n ty (toExp ns e sc)+        | otherwise = PPi (e l s p) n ty (toExp ns e sc)     toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)     toExp ns e sc = sc @@ -1839,7 +1922,7 @@     let constraint = PApp fc (PRef fc n) (map pexp ps)     let iname = mkiname n ps expn     when (what /= EDefns) $ do-         nty <- elabType' True info syn "" fc [] iname t+         nty <- elabType' True info syn emptyDocstring [] fc [] iname t          -- if the instance type matches any of the instances we have already,          -- and it's not a named instance, then it's overlapping, so report an error          case expn of@@ -1855,7 +1938,7 @@          -- get the implicit parameters that need passing through to the          -- where block          wparams <- mapM (\p -> case p of-                                  PApp _ _ args -> getWParams args+                                  PApp _ _ args -> getWParams (map getTm args)                                   _ -> return []) ps          let pnames = map pname (concat (nub wparams))          let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)@@ -1881,18 +1964,30 @@          logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp True . mkTyDecl) mtys)          logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++                                       show (concat (nub wparams))-         let lhs = PRef fc iname++         -- Bring variables in instance head into scope+         ist <- getIState+         let headVars = mapMaybe (\p -> case p of+                                           PRef _ n -> +                                              case lookupTy n (tt_ctxt ist) of+                                                  [] -> Just n+                                                  _ -> Nothing+                                           _ -> Nothing) ps+--          let lhs = PRef fc iname+         let lhs = PApp fc (PRef fc iname)+                           (map (\n -> pimp n (PRef fc n) True) headVars)          let rhs = PApp fc (PRef fc (instanceName ci))                            (map (pexp . mkMethApp) mtys)++         logLvl 5 $ "Instance LHS " ++ show lhs+         logLvl 5 $ "Instance RHS " ++ show rhs+          let idecls = [PClauses fc [Dictionary] iname                                  [PClause fc iname lhs [] rhs wb]]          iLOG (show idecls)          mapM_ (elabDecl EAll info) idecls          addIBC (IBCInstance intInst n iname)---          -- for each constraint, build a top level function to chase it---          logLvl 5 $ "Building functions"---          fns <- mapM (cfun (instanceName ci) constraint syn idecls) cs---          mapM_ (elabDecl EAll info) (concat fns)+   where     intInst = case ps of                 [PConstant (AType (ATInt ITNative))] -> True@@ -1947,17 +2042,17 @@      mkMethApp (n, _, _, ty)           = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))-    lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'+    lamBind i (PPi (Constraint _ _) _ _ sc) sc'           = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')     lamBind i (PPi _ n ty sc) sc'           = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')     lamBind i _ sc = sc-    methArgs i (PPi (Imp _ _ _ _) n ty sc)-        = PImp 0 True [] n (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc-    methArgs i (PPi (Exp _ _ _ _) n ty sc)-        = PExp 0 [] (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc-    methArgs i (PPi (Constraint _ _ _) n ty sc)-        = PConstraint 0 [] (PResolveTC fc) "" : methArgs (i+1) sc+    methArgs i (PPi (Imp _ _ _) n ty sc)+        = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc+    methArgs i (PPi (Exp _ _ _) n ty sc)+        = PExp 0 [] (PRef fc (sMN i "meth")) : methArgs (i+1) sc+    methArgs i (PPi (Constraint _ _) n ty sc)+        = PConstraint 0 [] (PResolveTC fc) : methArgs (i+1) sc     methArgs i _ = []      papp fc f [] = f@@ -1965,7 +2060,7 @@      getWParams [] = return []     getWParams (p : ps)-      | PRef _ n <- getTm p+      | PRef _ n <- p         = do ps' <- getWParams ps              ctxt <- getContext              case lookupP n ctxt of@@ -1976,12 +2071,12 @@     decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns     decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns -    mkTyDecl (n, op, t, _) = PTy "" syn fc op n t+    mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t      conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)     conbind [] x = x -    coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)+    coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc)     coninsert cs sc = conbind cs sc      insertDefaults :: IState -> Name ->@@ -2000,7 +2095,7 @@      warnMissing decls ns iname meth         | null $ filter (clauseFor meth iname ns) decls-            = iWarn fc $ "method " ++ show meth ++ " not defined"+            = iWarn fc . text $ "method " ++ show meth ++ " not defined"         | otherwise = return ()      checkInClass ns meth@@ -2039,7 +2134,7 @@                      PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]] -} -decorateid decorate (PTy doc s f o n t) = PTy doc s f o (decorate n) t+decorateid decorate (PTy doc argdocs s f o n t) = PTy doc argdocs s f o (decorate n) t decorateid decorate (PClauses f o n cs)    = PClauses f o (decorate n) (map dc cs)     where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds@@ -2050,9 +2145,20 @@           dappname t = t  -pbinds (Bind n (PVar t) sc) = do attack; patbind n-                                 pbinds sc-pbinds tm = return ()+-- if 't' is a type class application, assume its arguments are injective+pbinds :: IState -> Term -> ElabD ()+pbinds i (Bind n (PVar t) sc) +    = do attack; patbind n+         case unApply t of+              (P _ c _, args) -> case lookupCtxt c (idris_classes i) of+                                   [] -> return ()+                                   _ -> -- type class, set as injective+                                        mapM_ setinjArg args+              _ -> return ()+         pbinds i sc+  where setinjArg (P _ n _) = setinj n+        setinjArg _ = return ()+pbinds i tm = return ()  pbty (Bind n (PVar t) sc) tm = Bind n (PVTy t) (pbty sc tm) pbty _ tm = tm@@ -2082,22 +2188,22 @@      = return () -- nothing to elaborate elabDecl' _ info (PSyntax _ p)      = return () -- nothing to elaborate-elabDecl' what info (PTy doc s f o n ty)+elabDecl' what info (PTy doc argdocs s f o n ty)   | what /= EDefns     = do iLOG $ "Elaborating type decl " ++ show n ++ show o-         elabType info s doc f o n ty+         elabType info s doc argdocs f o n ty          return () elabDecl' what info (PPostulate doc s f o n ty)   | what /= EDefns     = do iLOG $ "Elaborating postulate " ++ show n ++ show o          elabPostulate info s doc f o n ty-elabDecl' what info (PData doc s f co d)+elabDecl' what info (PData doc argDocs s f co d)   | what /= ETypes     = do iLOG $ "Elaborating " ++ show (d_name d)-         elabData info s doc f co d+         elabData info s doc argDocs f co d   | otherwise     = do iLOG $ "Elaborating [type of] " ++ show (d_name d)-         elabData info s doc f co (PLaterdecl (d_name d) (d_tcon d))+         elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_tcon d)) elabDecl' what info d@(PClauses f o n ps)   | what /= ETypes     = do iLOG $ "Elaborating clause " ++ show n@@ -2154,17 +2260,17 @@          elabRecord info s doc f tyn ty cdoc cn cty   | otherwise     = do iLOG $ "Elaborating [type of] " ++ show tyn-         elabData info s doc f [] (PLaterdecl tyn ty)+         elabData info s doc [] f [] (PLaterdecl tyn ty) elabDecl' _ info (PDSL n dsl)     = do i <- getIState          putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })          addIBC (IBCDSL n) elabDecl' what info (PDirective i)   | what /= EDefns = i-elabDecl' what info (PProvider syn fc n tp tm)+elabDecl' what info (PProvider syn fc provWhat n tp tm)   | what /= EDefns     = do iLOG $ "Elaborating type provider " ++ show n-         elabProvider info syn fc n tp tm+         elabProvider info syn fc provWhat n tp tm elabDecl' what info (PTransform fc safety old new)     = elabTransform info fc safety old new elabDecl' _ _ _ = return () -- skipped this time@@ -2209,3 +2315,14 @@             Right vs -> return False             Left (x, y) -> return True +-- | Check a PTerm against documentation and ensure that every documented+-- argument actually exists.  This must be run _after_ implicits have been+-- found, or it will give spurious errors.+checkDocs :: FC -> [(Name, Docstring)] -> PTerm -> Idris ()+checkDocs fc args tm = cd (Map.fromList args) tm+  where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc+        cd as _ | Map.null as = return ()+                | otherwise   = ierror . At fc . Msg $+                                "There is documentation for argument(s) "+                                ++ (concat . intersperse ", " . map show . Map.keys) as+                                ++ " but they were not found."
src/Idris/ElabTerm.hs view
@@ -7,19 +7,21 @@ import Idris.Delaborate import Idris.Error import Idris.ProofSearch+import Idris.Output (pshow)  import Idris.Core.Elaborate hiding (Tactic(..)) import Idris.Core.TT import Idris.Core.Evaluate import Idris.Core.Unify import Idris.Core.Typecheck (check)+import Idris.ErrReverse (errReverse)  import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.State.Strict import Data.List import qualified Data.Map as M-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Set as S import qualified Data.Text as T @@ -71,12 +73,17 @@                                 resolveTC 7 g fn ist) ivs          tm <- get_term          ctxt <- get_context-         when (not pattern) $ do matchProblems; unifyProblems          probs <- get_probs+         u <- getUnifyLog++         when (not pattern) $ +           traceWhen u ("Remaining problems:\n" ++ show probs) $ +             do matchProblems True; unifyProblems+         probs <- get_probs          case probs of             [] -> return ()-            ((_,_,_,e):es) -> if inf then return ()-                                     else lift (Error e)+            ((_,_,_,e,_,_):es) -> if inf then return ()+                                         else lift (Error e)          is <- getAux          tt <- get_term          let (tm, ds) = runState (collectDeferred (Just fn) tt) []@@ -103,8 +110,8 @@          tm <- get_term          case probs of             [] -> return ()-            ((_,_,_,e):es) -> if inf then return ()-                                     else lift (Error e)+            ((_,_,_,e,_,_):es) -> if inf then return ()+                                         else lift (Error e)          is <- getAux          tt <- get_term          let (tm, ds) = runState (collectDeferred (Just fn) tt) []@@ -125,6 +132,8 @@          end_unify          when pattern -- convert remaining holes to pattern vars               (do update_term orderPats+                  matchProblems False -- only the ones we matched earlier+                  unifyProblems                   mkPat)   where     tcgen = Dictionary `elem` opts@@ -149,23 +158,44 @@                   [] -> return ()      elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()-    elabE ina t = {- do g <- goal-                 tm <- get_term-                 trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm)-                    $ -}-                  do t' <- insertCoerce ina t+    elabE ina t = +               --do g <- goal+                  --trace ("Elaborating " ++ show t ++ " : " ++ show g) $+                  do ct <- insertCoerce ina t+                     t' <- insertLazy ct                      g <- goal                      tm <- get_term                      ps <- get_probs                      hs <- get_holes---                      trace ("Elaborating " ++ show t' ++ " in " ++ show g--- --                             ++ "\n" ++ show tm---                             ++ "\nholes " ++ show hs---                             ++ "\nproblems " ++ show ps---                             ++ "\n-----------\n") $---                      trace ("ELAB " ++ show t') $ -                     elab' ina t'+                     --trace ("Elaborating " ++ show t' ++ " in " ++ show g+                     --         ++ "\n" ++ show tm+                     --         ++ "\nholes " ++ show hs+                     --         ++ "\nproblems " ++ show ps+                     --         ++ "\n-----------\n") $+                     --trace ("ELAB " ++ show t') $ +                     let fc = fileFC "Force"+                     env <- get_env+                     handleError (forceErr env)+                         (elab' ina t')+                         (elab' ina (PApp fc (PRef fc (sUN "Force"))+                                       [pimp (sUN "t") Placeholder True,+                                        pimp (sUN "a") Placeholder True, +                                        pexp ct])) True +    forceErr env (CantUnify _ t t' _ _ _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),+            ht == txt "Lazy'" = True+    forceErr env (CantUnify _ t t' _ _ _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),+            ht == txt "Lazy'" = True+    forceErr env (InfiniteUnify _ t _)+       | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),+            ht == txt "Lazy'" = True+    forceErr env (Elaborating _ _ t) = forceErr env t+    forceErr env (ElaboratingArg _ _ _ t) = forceErr env t+    forceErr env (At _ t) = forceErr env t+    forceErr env t = False+     local f = do e <- get_env                  return (f `elem` map fst e) @@ -216,7 +246,7 @@                                             [pimp (sMN 0 "A") Placeholder True,                                              pimp (sMN 0 "B") Placeholder True,                                              pexp l, pexp r])-    elab' ina (PDPair fc l@(PRef _ n) t r)+    elab' ina (PDPair fc p l@(PRef _ n) t r)             = case t of                 Placeholder ->                    do hnf_compute@@ -232,16 +262,17 @@                                          [pimp (sMN 0 "a") t False,                                           pimp (sMN 0 "P") Placeholder True,                                           pexp l, pexp r])-    elab' ina (PDPair fc l t r) = elab' ina (PApp fc (PRef fc existsCon)-                                            [pimp (sMN 0 "a") t False,-                                             pimp (sMN 0 "P") Placeholder True,-                                             pexp l, pexp r])+    elab' ina (PDPair fc p l t r) = elab' ina (PApp fc (PRef fc existsCon)+                                              [pimp (sMN 0 "a") t False,+                                               pimp (sMN 0 "P") Placeholder True,+                                               pexp l, pexp r])     elab' ina (PAlternative True as)         = do hnf_compute              ty <- goal              ctxt <- get_context              let (tc, _) = unApply ty              let as' = pruneByType tc ctxt as+--              trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $              tryAll (zip (map (elab' ina) as') (map showHd as'))         where showHd (PApp _ (PRef _ n) _) = show n               showHd (PRef _ n) = show n@@ -433,11 +464,17 @@ --                    trace ("args is " ++ show args) $ return ()                     ns <- apply (Var f) (map isph args) --                    trace ("ns is " ++ show ns) $ return ()+                    -- mark any type class arguments as injective+                    mapM_ checkIfInjective (map snd ns)+                    unifyProblems -- try again with the new information,+                                  -- to help with disambiguation                     -- Sort so that the implicit tactics and alternatives go last                     let (ns', eargs) = unzip $                              sortBy cmpArg (zip ns args)                     elabArgs ist (ina || not isinf, guarded, inty)-                           [] fc False f ns' (map (\x -> (lazyarg x, getTm x)) eargs)+                           [] fc False f ns' +                             (f == sUN "Force")+                             (map (\x -> (lazyarg x, getTm x)) eargs)                     solve                     ivs' <- get_instances                     -- Attempt to resolve any type classes which have 'complete' types,@@ -453,16 +490,52 @@                                                   (movelast n)                                          else movelast n)                               (ivs' \\ ivs)-      where tcArg (n, PConstraint _ _ Placeholder _) = True-            tcArg _ = False-            -            -- normal < tactic < default tactic+      where -- normal < alternatives < lambdas < rewrites < tactic < default tactic+            -- reason for lambdas after alternatives is that having +            -- the alternative resolved can help with typechecking the lambda+            -- or the rewrite. Rewrites/tactics need as much information+            -- as possible about the type.+            -- FIXME: Better would be to allow alternative resolution to be+            -- retried after more information is in.             cmpArg (_, x) (_, y)-                   = compare (priority x + alt x) (priority y + alt y)+                   = compare (conDepth 0 (getTm x) + priority x + alt x) +                             (conDepth 0 (getTm y) + priority y + alt y)                 where alt t = case getTm t of                                    PAlternative False _ -> 5+                                   PAlternative True _ -> 1+                                   PLam _ _ _ -> 2+                                   PRewrite _ _ _ _ -> 3                                    _ -> 0 +            -- Score a point for every level where there is a non-constructor+            -- function (so higher score --> done later)+            -- Only relevant when on lhs+            conDepth d t | not pattern = 0+            conDepth d (PRef _ f) | isConName f (tt_ctxt ist) = 0+                                  | otherwise = max (100 - d) 1+            conDepth d (PApp _ f as) +               = conDepth d f + sum (map (conDepth (d+1)) (map getTm as))+            conDepth d (PPatvar _ _) = 0+            conDepth d (PAlternative _ as) = maximum (map (conDepth d) as)+            conDepth d Placeholder = 0+            conDepth d t = max (100 - d) 1++            checkIfInjective n = do+                env <- get_env+                case lookup n env of+                     Nothing -> return ()+                     Just b ->+                       case unApply (binderTy b) of+                            (P _ c _, args) -> +                                case lookupCtxt c (idris_classes ist) of+                                   [] -> return ()+                                   _ -> -- type class, set as injective+                                        mapM_ setinjArg args+                            _ -> return ()+                     +            setinjArg (P _ n _) = setinj n+            setinjArg _ = return ()+             tacTm (PTactics _) = True             tacTm (PProof _) = True             tacTm _ = False@@ -484,9 +557,9 @@               mkN n = case namespace info of                         Just xs@(_:_) -> sNS n xs                         _ -> n-    elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts+    elab' ina (PProof ts) = do compute; mapM_ (runTac True ist fn) ts     elab' ina (PTactics ts)-        | not pattern = do mapM_ (runTac False ist) ts+        | not pattern = do mapM_ (runTac False ist fn) ts         | otherwise = elab' ina Placeholder     elab' ina (PElabError e) = fail (pshow ist e)     elab' ina (PRewrite fc r sc newg)@@ -558,7 +631,7 @@     elab' ina (PUnifyLog t) = do unifyLog True                                  elab' ina t                                  unifyLog False-    elab' ina x = fail $ "Unelaboratable syntactic form " ++ show x+    elab' ina x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x      isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))     isScr (PRef _ n) (n', b) = (n', (n == n', b))@@ -608,6 +681,25 @@     getFC d (PAlternative _ (x:_)) = getFC d x     getFC d x = d +    insertLazy :: PTerm -> ElabD PTerm+    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Delay" = return t+    insertLazy t@(PApp _ (PRef _ (UN l)) _) | l == txt "Force" = return t+    insertLazy (PCoerced t) = return t+    insertLazy t =+        do ty <- goal+           env <- get_env+           let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)+           let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]+           case tyh of+                P _ (UN l) _ | l == txt "Lazy'"+                    -> return (PAlternative False tries)+                _ -> return t+      where+        mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)+        mkDelay t = let fc = fileFC "Delay" in+                        addImpl ist (PApp fc (PRef fc (sUN "Delay")) +                                          [pexp t])+     insertCoerce ina t =         do ty <- goal            -- Check for possible coercions to get to the goal@@ -633,67 +725,45 @@              -> Bool              -> Name -- ^ Name of the function being applied              -> [(Name, Name)] -- ^ (Argument Name, Hole Name)+             -> Bool -- ^ under a 'force'              -> [(Bool, PTerm)] -- ^ (Laziness, argument)              -> ElabD ()-    elabArgs ist ina failed fc retry f [] _---         | retry = let (ns, ts) = unzip (reverse failed) in---                       elabArgs ina [] False ns ts-        | otherwise = return ()-    elabArgs ist ina failed fc r f (n:ns) ((_, Placeholder) : args)-        = elabArgs ist ina failed fc r f ns args-    elabArgs ist ina failed fc r f ((argName, holeName):ns) ((lazy, t) : args)+    elabArgs ist ina failed fc retry f [] force _ = return ()+    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 ((lazy, t) : args)         | lazy && not pattern           = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy"))                                            [pimp (sUN "a") Placeholder True,                                             pexp t])         | otherwise = elabArg argName holeName t       where elabArg argName holeName t =-              reflectFunctionErrors ist f argName $-              do hs <- get_holes-                 tm <- get_term-                 failed' <- -- trace (show (n, t, hs, tm)) $-                            -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $-                            case holeName `elem` hs of-                              True -> do focus holeName; elabE ina t; return failed-                              False -> return failed-                 elabArgs ist ina failed fc r f ns args---- | Perform error reflection for function applicaitons with specific error handlers-reflectFunctionErrors :: IState -> Name -> Name -> ElabD a -> ElabD a-reflectFunctionErrors ist f arg action =-  do elabState <- get-     (result, newState) <- case runStateT action elabState of-                             OK (res, newState) -> return (res, newState)-                             Error e@(ReflectionError _ _) -> (lift . tfail) e-                             Error e@(ReflectionFailed _ _) -> (lift . tfail) e-                             Error e -> handle e >>= lift . tfail-     put newState-     return result-  where handle :: Err -> ElabD Err-        handle e = do let funhandlers = (maybe M.empty id . lookupCtxtExact f . idris_function_errorhandlers) ist-                          handlers = (maybe [] S.toList . M.lookup arg) funhandlers-                          reports  = map (\n -> RApp (Var n) (reflectErr e)) handlers+              do now_elaborating fc f argName+                 wrapErr f argName $ do+                   hs <- get_holes+                   tm <- get_term+                   -- No coercing under an explicit Force (or it can Force/Delay+                   -- recursively!)+                   let elab = if force then elab' else elabE+                   failed' <- -- trace (show (n, t, hs, tm)) $+                              -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $+                              case holeName `elem` hs of+                                True -> do focus holeName; elab ina t; return failed+                                False -> return failed+                   done_elaborating_arg f argName+                   elabArgs ist ina failed fc r f ns force args+            wrapErr f argName action =+              do elabState <- get+                 while <- elaborating_app+                 let while' = map (\(x, y, z)-> (y, z)) while+                 (result, newState) <- case runStateT action elabState of+                                         OK (res, newState) -> return (res, newState)+                                         Error e -> do done_elaborating_arg f argName+                                                       lift (tfail (elaboratingArgErr while' e))+                 put newState+                 return result  -                      -- Typecheck error handlers - if this fails, then something else was wrong earlier!-                      handlers <- case mapM (check (tt_ctxt ist) []) reports of-                                      Error e -> lift . tfail $-                                                 ReflectionFailed "Type error while constructing reflected error" e-                                      OK hs   -> return hs--                      -- Normalize error handler terms to produce the new messages-                      let ctxt    = tt_ctxt ist-                          results = map (normalise ctxt []) (map fst handlers)--                      -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent-                      let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)-                      errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of-                                      Left err -> lift (tfail err)-                                      Right ok -> return ok-                      return $ case errorparts of-                                   []    -> e-                                   parts -> ReflectionError errorparts e- -- For every alternative, look at the function at the head. Automatically resolve -- any nested alternatives where that function is also at the head @@ -710,6 +780,7 @@               case fs of                  [a] -> a                  _ -> PAlternative a as'+     choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)     choose f t = t @@ -763,9 +834,11 @@   resolveTC :: Int -> Term -> Name -> IState -> ElabD ()-resolveTC 0 topg fn ist = fail $ "Can't resolve type class"-resolveTC 1 topg fn ist = try' (trivial' ist) (resolveTC 0 topg fn ist) True-resolveTC depth topg fn ist+resolveTC = resTC' [] ++resTC' tcs 0 topg fn ist = fail $ "Can't resolve type class"+resTC' tcs 1 topg fn ist = try' (trivial' ist) (resolveTC 0 topg fn ist) True+resTC' tcs depth topg fn ist       = do hnf_compute            g <- goal            ptm <- get_term@@ -837,15 +910,17 @@                 mapM_ (\ (_,n) -> do focus n                                      t' <- goal                                      let (tc', ttype) = unApply t'-                                     let depth' = if t == t' then depth - 1 else depth-                                     resolveTC depth' topg fn ist)+                                     let got = fst (unApply t)+                                     let depth' = if tc' `elem` tcs+                                                     then depth - 1 else depth +                                     resTC' (got : tcs)  depth' topg fn ist)                       (filter (\ (x, y) -> not x) (zip (map fst imps) args))                 -- if there's any arguments left, we've failed to resolve                 hs <- get_holes                 ulog <- getUnifyLog                 solve                 traceWhen ulog ("Got " ++ show n) $ return ()-       where isImp (PImp p _ _ _ _ _) = (True, p)+       where isImp (PImp p _ _ _ _) = (True, p)              isImp arg = (False, priority arg)  collectDeferred :: Maybe Name ->@@ -869,11 +944,13 @@ -- Running tactics directly -- if a tactic adds unification problems, return an error -runTac :: Bool -> IState -> PTactic -> ElabD ()-runTac autoSolve ist tac+runTac :: Bool -> IState -> Name -> PTactic -> ElabD ()+runTac autoSolve ist fn tac      = do env <- get_env          g <- goal-         no_errors (runT (fmap (addImplBound ist (map fst env)) tac))+         if autoSolve +            then runT (fmap (addImplBound ist (map fst env)) tac)+            else no_errors (runT (fmap (addImplBound ist (map fst env)) tac))                    (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))   where     runT (Intro []) = do g <- goal@@ -918,7 +995,7 @@                                      show fn')) fnimps              tryAll tacs              when autoSolve solveAll-       where isImp (PImp _ _ _ _ _ _) = True+       where isImp (PImp _ _ _ _ _) = True              isImp _ = False              envArgs n = do e <- get_env                             case lookup n e of@@ -982,8 +1059,8 @@     runT Compute = compute     runT Trivial = do trivial' ist; when autoSolve solveAll     runT TCInstance = runT (Exact (PResolveTC emptyFC))-    runT (ProofSearch top n hints)-         = do proofSearch' ist top n hints; when autoSolve solveAll+    runT (ProofSearch top hints)+         = do proofSearch' ist top fn hints; when autoSolve solveAll     runT (Focus n) = focus n     runT Solve = solve     runT (Try l r) = do try' (runT l) (runT r) True@@ -1015,9 +1092,9 @@                                runReflected tactic         where tacticTy = Var (reflm "Tactic")               listTy = Var (sNS (sUN "List") ["List", "Prelude"])-              scriptTy = (RBind (sUN "__pi_arg")+              scriptTy = (RBind (sMN 0 "__pi_arg")                                 (Pi (RApp listTy envTupleType))-                                    (RBind (sUN "__pi_arg1")+                                    (RBind (sMN 1 "__pi_arg")                                            (Pi (Var $ reflm "TT")) tacticTy))     runT (ByReflection tm) -- run the reflection function 'tm' on the                            -- goal, then apply the resulting reflected Tactic@@ -1062,7 +1139,7 @@                           ctxt <- get_context                           env <- get_env                           let value' = hnf ctxt env value-                          runTac autoSolve ist (Exact $ PQuote (reflect value'))+                          runTac autoSolve ist fn (Exact $ PQuote (reflect value'))     runT (Fill v) = do attack -- let x = fill x in ...                        tyn <- getNameFrom (sMN 0 "letty")                        claim tyn RType@@ -1077,7 +1154,7 @@                        env <- get_env                        let value' = normalise ctxt env value                        rawValue <- reifyRaw value'-                       runTac autoSolve ist (Exact $ PQuote rawValue)+                       runTac autoSolve ist fn (Exact $ PQuote rawValue)     runT (GoalType n tac) = do g <- goal                                case unApply g of                                     (P _ n' _, _) ->@@ -1090,7 +1167,7 @@     runT x = fail $ "Not implemented " ++ show x      runReflected t = do t' <- reify ist t-                        runTac autoSolve ist t'+                        runTac autoSolve ist fn t'  -- | Prefix a name with the "Language.Reflection" namespace reflm :: String -> Name@@ -1122,6 +1199,8 @@              | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t') reifyApp ist t [t']              | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')+reifyApp ist t [t']+             | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t') reifyApp _ t [t']            | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t') reifyApp ist t [t']@@ -1520,25 +1599,21 @@ reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n] reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e] reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]-reflectErr (At fc err) = raw_apply (Var $ reflErrName "At") [reflectFC fc, reflectErr err]-           where reflectFC (FC source line col) = raw_apply (Var $ reflErrName "FileLoc")-                                                            [ RConstant (Str source)-                                                            , RConstant (I line)-                                                            , RConstant (I col)-                                                            ]-reflectErr (Elaborating str n e) =-  raw_apply (Var $ reflErrName "Elaborating")-            [ RConstant (Str str)-            , reflectName n-            , reflectErr e-            ] reflectErr (ProviderError str) =   raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)] reflectErr (LoadingFailed str err) =   raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)] reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x] +elaboratingArgErr :: [(Name, Name)] -> Err -> Err+elaboratingArgErr [] err = err+elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)+  where rewrite (ElaboratingArg _ _ _ _) = Nothing+        rewrite (ProofSearchFail e) = fmap ProofSearchFail (rewrite e)+        rewrite (At fc e) = fmap (At fc) (rewrite e)+        rewrite err = Just (ElaboratingArg f x during err) + withErrorReflection :: Idris a -> Idris a withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)     where handle :: Err -> Idris Err@@ -1546,30 +1621,57 @@                                                return e -- Don't do meta-reflection of errors           handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"                                                return e+          -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them+          handle e@(At fc err) = do logLvl 3 "Reflecting body of At"+                                    err' <- handle err+                                    return (At fc err')+          handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"+                                                 err' <- handle err+                                                 return (Elaborating what n err')+          handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"+                                                      hs <- getFnHandlers f a+                                                      err' <- if null hs+                                                                 then handle err+                                                                 else applyHandlers err hs+                                                      return (ElaboratingArg f a prev err')+          -- TODO: argument-specific error handlers go here for ElaboratingArg           handle e = do ist <- getIState                         logLvl 2 "Starting error reflection"                         let handlers = idris_errorhandlers ist-                        logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))-                        let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers+                        applyHandlers e handlers+          getFnHandlers :: Name -> Name -> Idris [Name]+          getFnHandlers f arg = do ist <- getIState+                                   let funHandlers = maybe M.empty id .+                                                     lookupCtxtExact f .+                                                     idris_function_errorhandlers $ ist+                                   return . maybe [] S.toList . M.lookup arg $ funHandlers -                        -- Typecheck error handlers - if this fails, then something else was wrong earlier!-                        handlers <- case mapM (check (tt_ctxt ist) []) reports of-                                      Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e-                                      OK hs   -> return hs -                        -- Normalize error handler terms to produce the new messages-                        ctxt <- getContext-                        let results = map (normalise ctxt []) (map fst handlers)-                        logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))+          applyHandlers e handlers =+                      do ist <- getIState+                         let err = fmap (errReverse ist) e+                         logLvl 3 $ "Using reflection handlers " +++                                    concat (intersperse ", " (map show handlers))+                         let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers -                        -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent-                        let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)-                        errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of-                                        Left err -> ierror err-                                        Right ok -> return ok-                        return $ case errorparts of-                                   []    -> e-                                   parts -> ReflectionError errorparts e+                         -- Typecheck error handlers - if this fails, then something else was wrong earlier!+                         handlers <- case mapM (check (tt_ctxt ist) []) reports of+                                       Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e+                                       OK hs   -> return hs++                         -- Normalize error handler terms to produce the new messages+                         ctxt <- getContext+                         let results = map (normalise ctxt []) (map fst handlers)+                         logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))++                         -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent+                         let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)+                         errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of+                                         Left err -> ierror err+                                         Right ok -> return ok+                         return $ case errorparts of+                                    []    -> e+                                    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)
src/Idris/ErrReverse.hs view
@@ -13,7 +13,7 @@ -- errors will be more readable  errReverse :: IState -> Term -> Term-errReverse ist t = rewrite 5 (elideLambdas t)+errReverse ist t = rewrite 5 t -- (elideLambdas t)   where      rewrite 0 t = t@@ -65,7 +65,7 @@      elideLambdas (App f a) = App (elideLambdas f) (elideLambdas a)     elideLambdas (Bind n (Lam t) sc) -       | size sc > 100 = P Ref (sUN "...") Erased+       | size sc > 200 = P Ref (sUN "...") Erased     elideLambdas (Bind n b sc)        = Bind n (fmap elideLambdas b) (elideLambdas sc)     elideLambdas t = t
src/Idris/Error.hs view
@@ -5,6 +5,7 @@ import Prelude hiding (catch) import Idris.AbsSyntax import Idris.Delaborate+import Idris.Output  import Idris.Core.TT import Idris.Core.Typecheck@@ -23,7 +24,7 @@              when (not tit) $                 do ist <- getIState                    (tclift $ ucheck (idris_constraints ist)) `idrisCatch`-                              (\e -> do setErrLine (getErrLine e)+                              (\e -> do setErrSpan (getErrSpan e)                                         iputStrLn (pshow ist e))  showErr :: Err -> Idris String@@ -43,9 +44,9 @@ setAndReport e = do ist <- getIState                     let h = idris_outh ist                     case e of-                      At fc@(FC f l c) e -> do setErrLine l-                                               ihWarn h fc $ pshow ist e-                      _ -> do setErrLine (getErrLine e)+                      At fc e -> do setErrSpan fc+                                    ihWarn h fc $ pprintErr ist e+                      _ -> do setErrSpan (getErrSpan e)                               ihputStrLn h $ pshow ist e  ifail :: String -> Idris a@@ -56,7 +57,7 @@  tclift :: TC a -> Idris a tclift (OK v) = return v-tclift (Error err@(At (FC f l c) e)) = do setErrLine l ; throwError err+tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err tclift (Error err) = throwError err  tctry :: TC a -> TC a -> Idris a@@ -65,11 +66,6 @@            OK v -> return v            Error err -> tclift tc2 -getErrLine :: Err -> Int-getErrLine (At (FC _ l _) _) = l-getErrLine _ = 0--getErrColumn :: Err -> Int-getErrColumn (At (FC _ _ c) _) = c-getErrColumn _ = 0-+getErrSpan :: Err -> FC+getErrSpan (At fc _) = fc+getErrSpan _ = emptyFC
src/Idris/Help.hs view
@@ -29,6 +29,7 @@     ([":t"], ExprArg, "Check the type of an expression"),     ([":miss", ":missing"], NameArg, "Show missing clauses"),     ([":doc"], NameArg, "Show internal documentation"),+    ([":apropos"], NoArg, "Search names, types, and documentation"),     ([":i", ":info"], NameArg, "Display information about a type class"),     ([":total"], NameArg, "Check the totality of a name"),     ([":r",":reload"], NoArg, "Reload current file"),
src/Idris/IBC.hs view
@@ -9,7 +9,11 @@ import Idris.Imports import Idris.Error import Idris.Delaborate+import Idris.Docstrings+import Idris.Output +import qualified Cheapskate.Types as CT+ import Data.Binary import Data.Vector.Binary import Data.List@@ -24,10 +28,8 @@ import Codec.Compression.Zlib (compress) import Util.Zlib (decompressEither) - ibcVersion :: Word8-ibcVersion = 59-+ibcVersion = 65  data IBCFile = IBCFile { ver :: Word8,                          sourcefile :: FilePath,@@ -53,7 +55,7 @@                          ibc_flags :: [(Name, [FnOpt])],                          ibc_cg :: [(Name, CGInfo)],                          ibc_defs :: [(Name, Def)],-                         ibc_docstrings :: [(Name, String)],+                         ibc_docstrings :: [(Name, (Docstring, [(Name, Docstring)]))],                          ibc_transforms :: [(Term, Term)],                          ibc_errRev :: [(Term, Term)],                          ibc_coercions :: [Name],@@ -61,7 +63,9 @@                          ibc_namehints :: [(Name, Name)],                          ibc_metainformation :: [(Name, MetaInformation)],                          ibc_errorhandlers :: [Name],-                         ibc_function_errorhandlers :: [(Name, Name, Name)] -- fn, arg, handler+                         ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler+                         ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],+                         ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))]                        }    deriving Show {-!@@ -69,13 +73,15 @@ !-}  initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []-+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []  loadIBC :: FilePath -> Idris ()-loadIBC fp = do iLOG $ "Loading ibc " ++ fp-                ibcf <- runIO $ (bdecode fp :: IO IBCFile)-                process ibcf fp+loadIBC fp = do imps <- getImported+                when (not (fp `elem` imps)) $+                  do iLOG $ "Loading ibc " ++ fp+                     ibcf <- runIO $ (bdecode fp :: IO IBCFile)+                     process ibcf fp+                     addImported fp  bencode :: Binary a => FilePath -> a -> IO () bencode f d = B.writeFile f (compress (encode d))@@ -91,9 +97,9 @@ writeIBC src f     = do iLOG $ "Writing ibc " ++ show f          i <- getIState-         case (Data.List.map fst (idris_metavars i)) \\ primDefs of-                (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"-                [] -> return ()+--          case (Data.List.map fst (idris_metavars i)) \\ primDefs of+--                 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"+--                 [] -> return ()          resetNameIdx          ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })          idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)@@ -143,10 +149,14 @@ ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f } ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f } ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }-ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of-                        [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))-                                  return f' { ibc_defs = (n,v) : ibc_defs f'     }-                        _ -> ifail "IBC write failed"+ibc i (IBCDef n) f +   = do f' <- case lookupDef n (tt_ctxt i) of+                   [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))+                             return f' { ibc_defs = (n,v) : ibc_defs f'     }+                   _ -> ifail "IBC write failed"+        case lookupCtxt n (idris_patdefs i) of+                   [v] -> return f' { ibc_patdefs = (n,v) : ibc_patdefs f' }+                   _ -> return f' -- Not a pattern definition   where      updateDef :: Def -> StateT (IBCFile, Int) Idris Def     updateDef (CaseOp c t args o s cd)@@ -222,6 +232,10 @@ ibc i (IBCErrorHandler n) f = return f { ibc_errorhandlers = n : ibc_errorhandlers f } ibc i (IBCFunctionErrorHandler fn a n) f =   return f { ibc_function_errorhandlers = (fn, a, n) : ibc_function_errorhandlers f }+ibc i (IBCMetavar n) f = +     case lookup n (idris_metavars i) of+          Nothing -> return f+          Just t -> return f { ibc_metavars = (n, t) : ibc_metavars f }  process :: IBCFile -> FilePath -> Idris () process i fn@@ -250,6 +264,7 @@                pDyLibs (ibc_dynamic_libs i)                pHdrs (ibc_hdrs i)                pDefs (symbols i) (ibc_defs i)+               pPatdefs (ibc_patdefs i)                pAccess (ibc_access i)                pTotal (ibc_total i)                pCG (ibc_cg i)@@ -262,6 +277,7 @@                pMetaInformation (ibc_metainformation i)                pErrorHandlers (ibc_errorhandlers i)                pFunctionErrorHandlers (ibc_function_errorhandlers i)+               pMetavars (ibc_metavars i)  timestampOlder :: FilePath -> FilePath -> IO () timestampOlder src ibc = do srct <- getModificationTime src@@ -374,11 +390,21 @@ pHdrs :: [(Codegen, String)] -> Idris () pHdrs hs = mapM_ (uncurry addHdr) hs +pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()+pPatdefs ds +   = mapM_ (\ (n, d) -> +                do i <- getIState+                   putIState (i { idris_patdefs = addDef n d (idris_patdefs i) }))+           ds+ pDefs :: [Name] -> [(Name, Def)] -> Idris () pDefs syms ds     = mapM_ (\ (n, d) ->-               do i <- getIState-                  let d' = updateDef d+               do let d' = updateDef d+                  case d' of+                       TyDecl _ _ -> return () +                       _ -> solveDeferred n +                  i <- getIState                   logLvl 5 $ "Added " ++ show (n, d')                   putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds   where@@ -389,7 +415,7 @@     updateOrig (Left t) = Left (update t)     updateOrig (Right (l, r)) = Right (update l, update r) -    updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r)) +    updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))         = CaseDefs (ts, fmap update t)                    (cs, fmap update c)                    (is, fmap update i)@@ -401,8 +427,8 @@     update (Proj t i) = Proj (update t) i     update t = t -pDocs :: [(Name, String)] -> Idris ()-pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds+pDocs :: [(Name, (Docstring, [(Name, Docstring)]))] -> Idris ()+pDocs ds = mapM_ (\ (n, a) -> addDocStr n (fst a) (snd a)) ds  pAccess :: [(Name, Accessibility)] -> Idris () pAccess ds = mapM_ (\ (n, a) ->@@ -451,6 +477,92 @@ pFunctionErrorHandlers [] = return () pFunctionErrorHandlers ((fn, arg, handler):ns) = do addFunctionErrorHandlers fn arg [handler]                                                     pFunctionErrorHandlers ns++pMetavars :: [(Name, (Maybe Name, Int, Bool))] -> Idris ()+pMetavars ns = do i <- getIState+                  putIState $ i { idris_metavars = Data.List.reverse ns +                                                     ++ idris_metavars i }++----- For Cheapskate++instance Binary CT.Doc where+  put (CT.Doc opts lines) = do put opts ; put lines+  get = do opts <- get+           lines <- get+           return (CT.Doc opts lines)++instance Binary CT.Options where+  put (CT.Options x1 x2 x3 x4) = do put x1 ; put x2 ; put x3 ; put x4+  get = do x1 <- get+           x2 <- get+           x3 <- get+           x4 <- get+           return (CT.Options x1 x2 x3 x4)++instance Binary CT.Block where+  put (CT.Para lines) = do putWord8 0 ; put lines+  put (CT.Header i lines) = do putWord8 1 ; put i ; put lines+  put (CT.Blockquote bs) = do putWord8 2 ; put bs+  put (CT.List b t xs) = do putWord8 3 ; put b ; put t ; put xs+  put (CT.CodeBlock attr txt) = do putWord8 4 ; put attr ; put txt+  put (CT.HtmlBlock txt) = do putWord8 5 ; put txt+  put CT.HRule = putWord8 6+  get = do i <- getWord8+           case i of+             0 -> fmap CT.Para get+             1 -> liftM2 CT.Header get get+             2 -> fmap CT.Blockquote get+             3 -> liftM3 CT.List get get get+             4 -> liftM2 CT.CodeBlock get get+             5 -> liftM CT.HtmlBlock get+             6 -> return CT.HRule++instance Binary CT.Inline where+  put (CT.Str txt) = do putWord8 0 ; put txt+  put CT.Space = putWord8 1+  put CT.SoftBreak = putWord8 2+  put CT.LineBreak = putWord8 3+  put (CT.Emph xs) = putWord8 4 >> put xs+  put (CT.Strong xs) = putWord8 5 >> put xs+  put (CT.Code xs) = putWord8 6 >> put xs+  put (CT.Link a b c) = putWord8 7 >> put a >> put b >> put c+  put (CT.Image a b c) = putWord8 8 >> put a >> put b >> put c+  put (CT.Entity a) = putWord8 9 >> put a+  put (CT.RawHtml x) = putWord8 10 >> put x+  get = do i <- getWord8+           case i of+             0 -> liftM CT.Str get+             1 -> return CT.Space+             2 -> return CT.SoftBreak+             3 -> return CT.LineBreak+             4 -> liftM CT.Emph get+             5 -> liftM CT.Strong get+             6 -> liftM CT.Code get+             7 -> liftM3 CT.Link get get get+             8 -> liftM3 CT.Image get get get+             9 -> liftM CT.Entity get+             10 -> liftM CT.RawHtml get++instance Binary CT.ListType where+  put (CT.Bullet c) = putWord8 0 >> put c+  put (CT.Numbered nw i) = putWord8 1 >> put nw >> put i+  get = do i <- getWord8+           case i of+             0 -> liftM CT.Bullet get+             1 -> liftM2 CT.Numbered get get++instance Binary CT.CodeAttr where+  put (CT.CodeAttr a b) = put a >> put b+  get = liftM2 CT.CodeAttr get get++instance Binary CT.NumWrapper where+  put (CT.PeriodFollowing) = putWord8 0+  put (CT.ParenFollowing) = putWord8 1+  get = do i <- getWord8+           case i of+             0 -> return CT.PeriodFollowing+             1 -> return CT.ParenFollowing+ ----- Generated by 'derive'  instance Binary SizeChange where@@ -484,13 +596,15 @@                return (CGInfo x1 x2 [] x4 x5)  instance Binary FC where-        put (FC x1 x2 x3)+        put (FC x1 (x2, x3) (x4, x5))           = do put x1                put (x2 * 65536 + x3)+               put (x4 * 65536 + x5)         get           = do x1 <- get                x2x3 <- get-               return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))+               x4x5 <- get+               return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))   instance Binary Name where@@ -549,6 +663,7 @@                                  put x1                 CaseN x1 -> do putWord8 4; put x1                 ElimN x1 -> do putWord8 5; put x1+                InstanceCtorN x1 -> do putWord8 6; put x1         get           = do i <- getWord8                case i of@@ -568,6 +683,8 @@                            return (CaseN x1)                    5 -> do x1 <- get                            return (ElimN x1)+                   6 -> do x1 <- get+                           return (InstanceCtorN x1)                    _ -> error "Corrupted binary data for SpecialName"  @@ -607,6 +724,7 @@                 B32V x1 -> putWord8 23 >> put x1                 B64V x1 -> putWord8 24 >> put x1                 BufferType -> putWord8 25+                ManagedPtrType -> putWord8 26         get           = do i <- getWord8                case i of@@ -648,6 +766,7 @@                    23 -> fmap B32V get                    24 -> fmap B64V get                    25 -> return BufferType+                   26 -> return ManagedPtrType                     _ -> error "Corrupted binary data for Const" @@ -1037,7 +1156,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)+        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)          = {-# SCC "putIBCFile" #-}             do put x1                put x2@@ -1072,6 +1191,8 @@                put x31                put x32                put x33+               put x34+               put x35          get           = do x1 <- get@@ -1108,7 +1229,9 @@                     x31 <- get                     x32 <- get                     x33 <- 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 <- get+                    x35 <- 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)                   else return (initIBC { ver = x1 })  instance Binary DataOpt where@@ -1137,6 +1260,7 @@                 Reflection -> putWord8 8                 ErrorHandler -> putWord8 9                 ErrorReverse -> putWord8 10+                CoveringFn -> putWord8 11         get           = do i <- getWord8                case i of@@ -1152,6 +1276,7 @@                    8 -> return Reflection                    9 -> return ErrorHandler                    10 -> return ErrorReverse+                   11 -> return CoveringFn                    _ -> error "Corrupted binary data for FnOpt"  instance Binary Fixity where@@ -1217,51 +1342,43 @@ instance Binary Plicity where         put x           = case x of-                Imp x1 x2 x3 x4 ->+                Imp x1 x2 x3 ->                              do putWord8 0                                 put x1                                 put x2                                 put x3-                                put x4-                Exp x1 x2 x3 x4 ->+                Exp x1 x2 x3 ->                              do putWord8 1                                 put x1                                 put x2                                 put x3-                                put x4-                Constraint x1 x2 x3 ->+                Constraint x1 x2 ->                                     do putWord8 2                                        put x1                                        put x2-                                       put x3-                TacImp x1 x2 x3 x4 ->+                TacImp x1 x2 x3 ->                                    do putWord8 3                                       put x1                                       put x2                                       put x3-                                      put x4         get           = do i <- getWord8                case i of                    0 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get-                           return (Imp x1 x2 x3 x4)+                           return (Imp x1 x2 x3)                    1 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get-                           return (Exp x1 x2 x3 x4)+                           return (Exp x1 x2 x3)                    2 -> do x1 <- get                            x2 <- get-                           x3 <- get-                           return (Constraint x1 x2 x3)+                           return (Constraint x1 x2)                    3 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get-                           return (TacImp x1 x2 x3 x4)+                           return (TacImp x1 x2 x3)                    _ -> error "Corrupted binary data for Plicity"  @@ -1272,7 +1389,7 @@                                     put x1                                     put x2                                     put x3-                PTy x1 x2 x3 x4 x5 x6+                PTy x1 x2 x3 x4 x5 x6 x7                                    -> do putWord8 1                                          put x1                                          put x2@@ -1280,18 +1397,20 @@                                          put x4                                          put x5                                          put x6+                                         put x7                 PClauses x1 x2 x3 x4 -> do putWord8 2                                            put x1                                            put x2                                            put x3                                            put x4-                PData x1 x2 x3 x4 x5 ->+                PData x1 x2 x3 x4 x5 x6 ->                                      do putWord8 3                                         put x1                                         put x2                                         put x3                                         put x4                                         put x5+                                        put x6                 PParams x1 x2 x3 -> do putWord8 4                                        put x1                                        put x2@@ -1358,7 +1477,8 @@                            x4 <- get                            x5 <- get                            x6 <- get-                           return (PTy x1 x2 x3 x4 x5 x6)+                           x7 <- get+                           return (PTy x1 x2 x3 x4 x5 x6 x7)                    2 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1369,7 +1489,8 @@                            x3 <- get                            x4 <- get                            x5 <- get-                           return (PData x1 x2 x3 x4 x5)+                           x6 <- get+                           return (PData x1 x2 x3 x4 x5 x6)                    4 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1611,11 +1732,12 @@                                         put x2                                         put x3                                         put x4-                PDPair x1 x2 x3 x4 -> do putWord8 19-                                         put x1-                                         put x2-                                         put x3-                                         put x4+                PDPair x1 x2 x3 x4 x5 -> do putWord8 19+                                            put x1+                                            put x2+                                            put x3+                                            put x4+                                            put x5                 PAlternative x1 x2 -> do putWord8 20                                          put x1                                          put x2@@ -1728,7 +1850,8 @@                             x2 <- get                             x3 <- get                             x4 <- get-                            return (PDPair x1 x2 x3 x4)+                            x5 <- get+                            return (PDPair x1 x2 x3 x4 x5)                    20 -> do x1 <- get                             x2 <- get                             return (PAlternative x1 x2)@@ -1863,10 +1986,11 @@                                       put x1                                       put x2                                       put x3-                DoBindP x1 x2 x3 -> do putWord8 2-                                       put x1-                                       put x2-                                       put x3+                DoBindP x1 x2 x3 x4 -> do putWord8 2+                                          put x1+                                          put x2+                                          put x3+                                          put x4                 DoLet x1 x2 x3 x4 -> do putWord8 3                                         put x1                                         put x2@@ -1889,7 +2013,8 @@                    2 -> do x1 <- get                            x2 <- get                            x3 <- get-                           return (DoBindP x1 x2 x3)+                           x4 <- get+                           return (DoBindP x1 x2 x3 x4)                    3 -> do x1 <- get                            x2 <- get                            x3 <- get@@ -1905,34 +2030,30 @@ instance (Binary t) => Binary (PArg' t) where         put x           = case x of-                PImp x1 x2 x3 x4 x5 x6 ->+                PImp x1 x2 x3 x4 x5 ->                                     do putWord8 0                                        put x1                                        put x2                                        put x3                                        put x4                                        put x5-                                       put x6-                PExp x1 x2 x3 x4 ->+                PExp x1 x2 x3 ->                                  do putWord8 1                                     put x1                                     put x2                                     put x3-                                    put x4-                PConstraint x1 x2 x3 x4 ->+                PConstraint x1 x2 x3 ->                                         do putWord8 2                                            put x1                                            put x2                                            put x3-                                           put x4-                PTacImplicit x1 x2 x3 x4 x5 x6 ->+                PTacImplicit x1 x2 x3 x4 x5 ->                                                do putWord8 3                                                   put x1                                                   put x2                                                   put x3                                                   put x4                                                   put x5-                                                  put x6         get           = do i <- getWord8                case i of@@ -1941,25 +2062,21 @@                            x3 <- get                            x4 <- get                            x5 <- get-                           x6 <- get-                           return (PImp x1 x2 x3 x4 x5 x6)+                           return (PImp x1 x2 x3 x4 x5)                    1 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get-                           return (PExp x1 x2 x3 x4)+                           return (PExp x1 x2 x3)                    2 -> do x1 <- get                            x2 <- get                            x3 <- get-                           x4 <- get-                           return (PConstraint x1 x2 x3 x4)+                           return (PConstraint x1 x2 x3)                    3 -> do x1 <- get                            x2 <- get                            x3 <- get                            x4 <- get                            x5 <- get-                           x6 <- get-                           return (PTacImplicit x1 x2 x3 x4 x5 x6)+                           return (PTacImplicit x1 x2 x3 x4 x5)                    _ -> error "Corrupted binary data for PArg'"
src/Idris/IdeSlave.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-} -module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable) where+module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..)) where  import Text.Printf import Numeric@@ -69,22 +69,41 @@ instance (SExpable a, SExpable b, SExpable c, SExpable d) => SExpable (a, b, c, d) where   toSExp (l, m, n, o) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o] +instance (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) =>+         SExpable (a, b, c, d, e) where+   toSExp (l, m, n, o, p) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o, toSExp p]+ instance SExpable NameOutput where-  toSExp TypeOutput = SymbolAtom "type"-  toSExp FunOutput  = SymbolAtom "function"-  toSExp DataOutput = SymbolAtom "data"+  toSExp TypeOutput    = SymbolAtom "type"+  toSExp FunOutput     = SymbolAtom "function"+  toSExp DataOutput    = SymbolAtom "data"+  toSExp MetavarOutput = SymbolAtom "metavar" +maybeProps :: SExpable a => [(String, Maybe a)] -> [(SExp, SExp)]+maybeProps [] = []+maybeProps ((n, Just p):ps) = (SymbolAtom n, toSExp p) : maybeProps ps+maybeProps ((n, Nothing):ps) = maybeProps ps+ instance SExpable OutputAnnotation where-  toSExp (AnnName n Nothing   _) = toSExp [(SymbolAtom "name", StringAtom (show n)),-                                           (SymbolAtom "implicit", BoolAtom False)]-  toSExp (AnnName n (Just ty) _) = toSExp [(SymbolAtom "name", StringAtom (show n)),-                                           (SymbolAtom "decor", toSExp ty),-                                           (SymbolAtom "implicit", BoolAtom False)]+  toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),+                                        (SymbolAtom "implicit", BoolAtom False)] +++                                       maybeProps [("decor", ty)] +++                                       maybeProps [("doc-overview", d), ("type", t)]   toSExp (AnnBoundName n imp)    = toSExp [(SymbolAtom "name", StringAtom (show n)),                                            (SymbolAtom "decor", SymbolAtom "bound"),                                            (SymbolAtom "implicit", BoolAtom imp)]   toSExp AnnConstData            = toSExp [(SymbolAtom "decor", SymbolAtom "data")]   toSExp AnnConstType            = toSExp [(SymbolAtom "decor", SymbolAtom "type")]+  toSExp AnnKeyword              = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]+  toSExp (AnnFC (FC f (sl, sc) (el, ec)))      = toSExp [(SymbolAtom "source-loc",+                                                    ((SymbolAtom "filename", StringAtom f),+                                                     (SymbolAtom "start",  IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),+                                                     (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec))))]+  toSExp (AnnTextFmt fmt) = toSExp [(SymbolAtom "text-formatting", SymbolAtom format)]+      where format = case fmt of+                       BoldText      -> "bold"+                       ItalicText    -> "italic"+                       UnderlineText -> "underline"  escape :: String -> String escape = concatMap escapeChar@@ -116,6 +135,8 @@ parseSExp :: String -> Result SExp parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0) +data Opt = ShowImpl | ErrContext deriving Show+ data IdeSlaveCommand = REPLCompletions String                      | Interpret String                      | TypeOf String@@ -126,6 +147,10 @@                      | MakeWithBlock Int String                      | ProofSearch Int String [String]                      | LoadFile String+                     | DocsFor String+                     | Apropos String+                     | GetOpts+                     | SetOpt Opt Bool   deriving Show  sexpToCommand :: SExp -> Maybe IdeSlaveCommand@@ -143,6 +168,12 @@   where getHints = mapM (\h -> case h of                                  StringAtom s -> Just s                                  _            -> Nothing)+sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name])                       = Just (DocsFor name)+sexpToCommand (SexpList [SymbolAtom "apropos", StringAtom search])                      = Just (Apropos search)+sexpToCommand (SymbolAtom "get-options")                                                = Just GetOpts+sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])+  | Just opt <- lookup s opts                                                           = Just (SetOpt opt b)+    where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more sexpToCommand _                                                                         = Nothing  parseMessage :: String -> Either Err (SExp, Integer)
+ src/Idris/Output.hs view
@@ -0,0 +1,173 @@+module Idris.Output where++import Idris.Core.TT+import Idris.Core.Evaluate (isDConName, isTConName, isFnName)++import Idris.AbsSyntax+import Idris.Delaborate+import Idris.Docstrings+import Idris.IdeSlave++import Util.Pretty+import Util.ScreenSize (getScreenWidth)++import System.IO (stdout, Handle, hPutStrLn)++pshow :: IState -> Err -> String+pshow ist err = displayDecorated (consoleDecorate ist) .+                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) $+                                    text (show fc) <> colon <//> 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++iRender :: Doc a -> Idris (SimpleDoc a)+iRender d = do w <- getWidth+               ist <- getIState+               let ideSlave = case idris_outputmode ist of+                                IdeSlave _ -> True+                                _          -> False+               case w of+                 InfinitelyWide -> return $ renderPretty 1.0 1000000000 d+                 ColsWide n -> return $+                               if n < 1+                                 then renderPretty 1.0 1000000000 d+                                 else renderPretty 0.8 n d+                 AutomaticWidth | ideSlave  -> return $ renderPretty 1.0 1000000000 d+                                | otherwise -> do width <- runIO getScreenWidth+                                                  return $ renderPretty 0.8 width d++ihPrintResult :: Handle -> String -> Idris ()+ihPrintResult h s = do i <- getIState+                       case idris_outputmode i of+                         RawOutput -> case s of+                                        "" -> return ()+                                        s  -> runIO $ hPutStrLn h s+                         IdeSlave n ->+                             let good = SexpList [SymbolAtom "ok", toSExp s] in+                             runIO $ hPutStrLn h $ convSExp "return" good n++-- | Write a pretty-printed term to the console with semantic coloring+consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris ()+consoleDisplayAnnotated h output = do ist <- getIState+                                      rendered <- iRender $ output+                                      runIO . hPutStrLn h .+                                        displayDecorated (consoleDecorate ist) $+                                        rendered+++-- | Write pretty-printed output to IDESlave with semantic annotations+ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()+ideSlaveReturnAnnotated n h out = do ist <- getIState+                                     (str, spans) <- fmap displaySpans .+                                                     iRender .+                                                     fmap (fancifyAnnots ist) $+                                                     out+                                     let good = [SymbolAtom "ok", toSExp str, toSExp spans]+                                     runIO . hPutStrLn h $ convSExp "return" good n++ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()+ihPrintTermWithType h tm ty = do ist <- getIState+                                 let output = tm <+> colon <+> ty+                                 case idris_outputmode ist of+                                   RawOutput -> consoleDisplayAnnotated h output+                                   IdeSlave n -> ideSlaveReturnAnnotated n h output++-- | 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 imp <- impShow+                                       ist <- getIState+                                       let output = vsep (map (uncurry (ppOverload imp)) overloads)+                                       case idris_outputmode ist of+                                         RawOutput -> consoleDisplayAnnotated h output+                                         IdeSlave n -> ideSlaveReturnAnnotated n h output+  where fullName n = prettyName True bnd n+        ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd [] tm)++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++fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation+fancifyAnnots ist annot@(AnnName n _ _ _) =+  do let ctxt = tt_ctxt ist+         docs = docOverview ist n+         ty   = Just (getTy ist n)+     case () of+       _ | isDConName    n ctxt -> AnnName n (Just DataOutput) docs ty+       _ | isFnName      n ctxt -> AnnName n (Just FunOutput) docs ty+       _ | isTConName    n ctxt -> AnnName n (Just TypeOutput) docs ty+       _ | isMetavarName n ist  -> AnnName n (Just MetavarOutput) docs ty+       _ | otherwise            -> annot+  where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs+        docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)+                               let o   = overview (fst docs)+                                   -- TODO make width configurable+                                   out = displayS . renderPretty 1.0 50 $ renderDocstring o+                               return (out "")+        getTy :: IState -> Name -> String -- fails if name not already extant!+        getTy ist n = let theTy = pprintPTerm (opt_showimp (idris_options ist)) [] [] $+                                  delabTy ist n+                      in (displayS . renderPretty 1.0 50 $ theTy) ""+fancifyAnnots _ annot = annot++-- | 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 -> do+                           (str, spans) <- fmap displaySpans .+                                           iRender .+                                           fmap (fancifyAnnots ist) $+                                           e+                           let good = [SymbolAtom "error", toSExp str, toSExp spans]+                           runIO . hPutStrLn h $ convSExp "return" good n++ihPrintError :: Handle -> String -> Idris ()+ihPrintError h s = do i <- getIState+                      case idris_outputmode i of+                        RawOutput -> case s of+                                          "" -> return ()+                                          s  -> runIO $ hPutStrLn h s+                        IdeSlave n ->+                          let good = SexpList [SymbolAtom "error", toSExp s] in+                          runIO . hPutStrLn h $ convSExp "return" good n++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 = 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+                                   _ -> return ()++-- this needs some typing magic and more structured output towards emacs+iputGoal :: SimpleDoc OutputAnnotation -> Idris ()+iputGoal g = do i <- getIState+                case idris_outputmode i of+                  RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)+                  IdeSlave n -> runIO . putStrLn $+                                convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n
src/Idris/ParseData.hs view
@@ -20,6 +20,8 @@ import Idris.Core.TT import Idris.Core.Evaluate +import Idris.Docstrings+ import Control.Applicative import Control.Monad import Control.Monad.State.Strict@@ -33,13 +35,15 @@ import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 +import Debug.Trace+ {- |Parses a record type declaration Record ::=     DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock; -} record :: SyntaxInfo -> IdrisParser PDecl record syn = do (doc, acc) <- try (do-                      doc <- option "" (docComment '|')+                      doc <- option noDocs docComment                       acc <- optional accessibility                       reserved "record"                       return (doc, acc))@@ -49,13 +53,13 @@                 ty <- typeExpr (allowImp syn)                 let tyn = expandNS syn tyn_in                 reserved "where"-                (cdoc, cn, cty, _, _) <- indentedBlockS (constructor syn)+                (cdoc, argDocs, cn, cty, _, _) <- indentedBlockS (constructor syn)                 accData acc tyn [cn]                 let rsyn = syn { syn_namespace = show (nsroot tyn) :                                                     syn_namespace syn }                 let fns = getRecNames rsyn cty                 mapM_ (\n -> addAcc n acc) fns-                return $ PRecord doc rsyn fc tyn ty cdoc cn cty+                return $ PRecord (fst doc) rsyn fc tyn ty cdoc cn cty              <?> "record type declaration"   where     getRecNames :: SyntaxInfo -> PTerm -> [Name]@@ -100,29 +104,29 @@   ; -} data_ :: SyntaxInfo -> IdrisParser PDecl-data_ syn = do (doc, acc, dataOpts) <- try (do-                    doc <- option "" (docComment '|')+data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do+                    (doc, argDocs) <- option noDocs docComment                     pushIndent                     acc <- optional accessibility                     elim <- dataOpts []                     co <- dataI                     let dataOpts = combineDataOpts(elim ++ co)-                    return (doc, acc, dataOpts))+                    return (doc, argDocs, acc, dataOpts))                fc <- getFC                tyn_in <- fnName                (do try (lchar ':')                    popIndent                    ty <- typeExpr (allowImp syn)                    let tyn = expandNS syn tyn_in-                   option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do+                   option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do                      reserved "where"                      cons <- indentedBlock (constructor syn)-                     accData acc tyn (map (\ (_, n, _, _, _) -> n) cons)-                     return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do+                     accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons)+                     return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons))) <|> (do                     args <- many name                     let ty = bindArgs (map (const PType) args) PType                     let tyn = expandNS syn tyn_in-                    option (PData doc syn fc dataOpts (PLaterdecl tyn ty)) (do+                    option (PData doc argDocs syn fc dataOpts (PLaterdecl tyn ty)) (do                       try (lchar '=') <|> do reserved "where"                                              let kw = (if DefaultEliminator `elem` dataOpts then "" else "%noelim ") ++ (if Codata `elem` dataOpts then "co" else "") ++ "data "                                              let n  = show tyn_in ++ " "@@ -134,14 +138,14 @@                                              let fix2 = s ++ ": " ++ ns ++ " -> Type where\n  ..."                                              let fix3 = s ++ ": " ++ ss ++ " -> Type where\n  ..."                                              fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]-                      cons <- sepBy1 (simpleConstructor syn) (lchar '|')+                      cons <- sepBy1 (simpleConstructor syn) (reservedOp "|")                       terminator                       let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)-                      cons' <- mapM (\ (doc, x, cargs, cfc, fs) ->+                      cons' <- mapM (\ (doc, argDocs, x, cargs, cfc, fs) ->                                    do let cty = bindArgs cargs conty-                                      return (doc, x, cty, cfc, fs)) cons-                      accData acc tyn (map (\ (_, n, _, _, _) -> n) cons')-                      return $ PData doc syn fc dataOpts (PDatadecl tyn ty cons')))+                                      return (doc, argDocs, x, cty, cfc, fs)) cons+                      accData acc tyn (map (\ (_, _, n, _, _, _) -> n) cons')+                      return $ PData doc argDocs syn fc dataOpts (PDatadecl tyn ty cons')))            <?> "data type declaration"   where     mkPApp :: FC -> PTerm -> [PTerm] -> PTerm@@ -150,17 +154,17 @@     bindArgs :: [PTerm] -> PTerm -> PTerm     bindArgs xs t = foldr (PPi expl (sMN 0 "_t")) t xs     combineDataOpts :: DataOpts -> DataOpts-    combineDataOpts opts = if Codata `elem` opts -                              then delete DefaultEliminator opts +    combineDataOpts opts = if Codata `elem` opts+                              then delete DefaultEliminator opts                               else opts   {- | Parses a type constructor declaration   Constructor ::= DocComment? FnName TypeSig; -}-constructor :: SyntaxInfo -> IdrisParser (String, Name, PTerm, FC, [Name])+constructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) constructor syn-    = do doc <- option "" (docComment '|')+    = do (doc, argDocs) <- option noDocs docComment          cn_in <- fnName; fc <- getFC          let cn = expandNS syn cn_in          lchar ':'@@ -169,21 +173,21 @@          fs <- option [] (do lchar '%'; reserved "erase"                              sepBy1 name (lchar ','))          ty <- typeExpr (allowImp syn)-         return (doc, cn, ty, fc, fs)+         return (doc, argDocs, cn, ty, fc, fs)       <?> "constructor"  {- | Parses a constructor for simple discriminative union data types   SimpleConstructor ::= FnName SimpleExpr* DocComment? -}-simpleConstructor :: SyntaxInfo -> IdrisParser (String, Name, [PTerm], FC, [Name])+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, [PTerm], FC, [Name]) simpleConstructor syn-     = do cn_in <- fnName+     = do doc <- option noDocs (try docComment)+          cn_in <- fnName           let cn = expandNS syn cn_in           fc <- getFC           args <- many (do notEndApp                            simpleExpr syn)-          doc <- option "" (docComment '^')-          return (doc, cn, args, fc, [])+          return (fst doc, [], cn, args, fc, [])        <?> "constructor"  {- | Parses a dsl block declaration
src/Idris/ParseExpr.hs view
@@ -78,8 +78,8 @@  doexpr' :: SyntaxInfo -> IdrisParser PTerm doexpr' syn =     try (externalExpr syn)-            <|> internalExpr syn-            <?> "expression"+              <|> internalExpr syn+              <?> "expression"  {- | Parses a user-defined expression -} externalExpr :: SyntaxInfo -> IdrisParser PTerm@@ -158,7 +158,7 @@     update ns (PAppBind fc t args) = PAppBind fc (update ns t) (map (fmap (update ns)) args)     update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)     update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)-    update ns (PDPair fc l t r) = PDPair fc (update ns l) (update ns t) (update ns r)+    update ns (PDPair fc p l t r) = PDPair fc p (update ns l) (update ns t) (update ns r)     update ns (PAlternative a as) = PAlternative a (map (update ns) as)     update ns (PHidden t) = PHidden (update ns t)     update ns (PDoBlock ds) = PDoBlock $ upd ns ds@@ -167,7 +167,9 @@             upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds             upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)                                                 : upd (dropn n ns) ds-            upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t)+            upd ns (DoBindP fc i t ts : ds) +                    = DoBindP fc (update ns i) (update ns t) +                                 (map (\(l,r) -> (update ns l, update ns r)) ts)                                                 : upd ns ds             upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)                                                 : upd ns ds@@ -204,7 +206,7 @@      <|> quoteGoal syn      <|> let_ syn      <|> rewriteTerm syn-     <|> try(pi syn)+     <|> try (pi syn)      <|> doBlock syn      <|> caseExpr syn      <|> simpleExpr syn@@ -245,7 +247,7 @@ -} proofExpr :: SyntaxInfo -> IdrisParser PTerm proofExpr syn = do reserved "proof"-                   ts <- indentedBlock (tactic syn)+                   ts <- indentedBlock1 (tactic syn)                    return $ PProof ts                 <?> "proof block" @@ -258,7 +260,7 @@ -} tacticsExpr :: SyntaxInfo -> IdrisParser PTerm tacticsExpr syn = do reserved "tactics"-                     ts <- indentedBlock (tactic syn)+                     ts <- indentedBlock1 (tactic syn)                      return $ PTactics ts                   <?> "tactics block" @@ -349,7 +351,7 @@                     fc <- getFC                     r <- expr syn                     lchar ')'-                    return (PDPair fc (PRef fc ln) lty r))+                    return (PDPair fc TypeOrTerm (PRef fc ln) lty r))         <|> try (do fc <- getFC; o <- operator; e <- expr syn; lchar ')'                     -- No prefix operators! (bit of a hack here...)                     if (o == "-" || o == "!") @@ -369,7 +371,7 @@                                                            pexp (PRef fc0 (sMN 1000 "ARG"))]))         <|> do l <- expr syn                bracketedExpr syn l-            + bracketedExpr :: SyntaxInfo -> PTerm -> IdrisParser PTerm bracketedExpr syn e =              do lchar ')'; return e@@ -384,7 +386,7 @@                          return fc                 r <- expr syn                 lchar ')'-                return (PDPair fc e Placeholder r)+                return (PDPair fc TypeOrTerm e Placeholder r)         <?> "end of bracketed expression"   where mergePairs :: [(PTerm, FC)] -> PTerm         mergePairs [(t, fc)]    = t@@ -736,16 +738,22 @@ @  -} let_ :: SyntaxInfo -> IdrisParser PTerm-let_ syn = try (do reserved "let"; n <- name;+let_ syn = try (do reserved "let"; fc <- getFC; n <- name;                    ty <- option Placeholder (do lchar ':'; expr' syn)                    lchar '='                    v <- expr syn+                   ts <- option [] (do lchar '|'+                                       sepBy1 (do_alt syn) (lchar '|'))                    reserved "in";  sc <- expr syn-                   return (PLet n ty v sc))+                   case ts of+                        [] -> return (PLet n ty v sc)+                        alts -> return (PCase fc v ((PRef fc n, sc) : ts)))            <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )                    symbol "="; v <- expr syn+                   ts <- option [] (do lchar '|'+                                       sepBy1 (do_alt syn) (lchar '|'))                    reserved "in"; sc <- expr syn-                   return (PCase fc v [(pat, sc)]))+                   return (PCase fc v ((pat, sc) : ts)))            <?> "let binding"  {- | Parses a quote goal@@ -780,15 +788,15 @@  pi :: SyntaxInfo -> IdrisParser PTerm pi syn =-     do opts <- if implicitAllowed syn -- laziness is top level only-                then option [] (do lchar '|'; return [Lazy])-                else return []+     do opts <- -- if implicitAllowed syn -- laziness is top level only+                -- then option [] (do lchar '|'; return [Lazy])+                -- else return []+                return []         st <- static-        (do try(lchar '('); xt <- typeDeclList syn; lchar ')'-            doc <- option "" (docComment '^')+        (do try (lchar '('); xt <- typeDeclList syn; lchar ')'             symbol "->"             sc <- expr syn-            return (bindList (PPi (Exp opts st doc False)) xt sc)) <|> (do+            return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do                lchar '{'                (do reserved "auto"                    when (Lazy `elem` opts || (st == Static)) $ fail "auto type constraints can not be lazy or static"@@ -797,7 +805,7 @@                    symbol "->"                    sc <- expr syn                    return (bindList (PPi-                     (TacImp [] Dynamic (PTactics [Trivial]) "")) xt sc)) +                     (TacImp [] Dynamic (PTactics [Trivial]))) xt sc))                   <|> (do                        reserved "default"                        when (Lazy `elem` opts || (st == Static)) $ fail "default tactic constraints can not be lazy or static"@@ -806,13 +814,13 @@                        lchar '}'                        symbol "->"                        sc <- expr syn-                       return (bindList (PPi (TacImp [] Dynamic script "")) xt sc)) +                       return (bindList (PPi (TacImp [] Dynamic script)) xt sc))                   <|> (if implicitAllowed syn then do                             xt <- typeDeclList syn                             lchar '}'                             symbol "->"                             sc <- expr syn-                            return (bindList (PPi (Imp opts st "" False)) xt sc)+                            return (bindList (PPi (Imp opts st False)) xt sc)                        else do fail "no implicit arguments allowed here"))   <?> "dependent type signature" @@ -967,17 +975,28 @@                symbol "<-"                fc <- getFC                e <- expr syn;-               return (DoBind fc i e))+               option (DoBind fc i e)+                      (do lchar '|'+                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          return (DoBindP fc (PRef fc i) e ts)))    <|> try (do i <- expr' syn                symbol "<-"                fc <- getFC                e <- expr syn;-               return (DoBindP fc i e))+               option (DoBindP fc i e [])+                      (do lchar '|'+                          ts <- sepBy1 (do_alt syn) (lchar '|')+                          return (DoBindP fc i e ts)))    <|> do e <- expr syn           fc <- getFC           return (DoExp fc e)    <?> "do block expression" +do_alt syn = do l <- expr' syn+                symbol "=>"+                r <- expr' syn+                return (l, r)+ {- | Parses an expression in idiom brackets @ Idiom ::= '[|' Expr '|]';@@ -1002,6 +1021,7 @@   | 'Float'   | 'String'   | 'Ptr'+  | 'ManagedPtr'   | 'prim__UnsafeBuffer'   | 'Bits8'   | 'Bits16'@@ -1026,6 +1046,7 @@         <|> do reserved "Float";        return (AType ATFloat)         <|> do reserved "String";       return StrType         <|> do reserved "Ptr";          return PtrType+        <|> do reserved "ManagedPtr";   return ManagedPtrType         <|> do reserved "prim__UnsafeBuffer"; return BufferType         <|> do reserved "Bits8";  return (AType (ATInt (ITFixed IT8)))         <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))@@ -1110,19 +1131,19 @@ tactic syn = do reserved "intro"; ns <- sepBy (indentPropHolds gtProp *> name) (lchar ',')                 return $ Intro ns           <|> do reserved "intros"; return Intros-          <|> try (do reserved "refine"; n <- (indentPropHolds gtProp *> name)+          <|> try (do reserved "refine"; n <- (indentPropHolds gtProp *> fnName)                       imps <- some imp                       return $ Refine n imps)-          <|> do reserved "refine"; n <- (indentPropHolds gtProp *> name)+          <|> do reserved "refine"; n <- (indentPropHolds gtProp *> fnName)                  i <- get                  return $ Refine n []-          <|> do reserved "mrefine"; n <- (indentPropHolds gtProp *> name)+          <|> do reserved "mrefine"; n <- (indentPropHolds gtProp *> fnName)                  i <- get                  return $ MatchRefine n           <|> do reserved "rewrite"; t <- (indentPropHolds gtProp *> expr syn);                  i <- get                  return $ Rewrite (desugar syn i t)-          <|> do reserved "induction"; nm <- (indentPropHolds gtProp *> name);+          <|> do reserved "induction"; nm <- (indentPropHolds gtProp *> fnName);                  return $ Induction nm           <|> do reserved "equiv"; t <- (indentPropHolds gtProp *> expr syn);                  i <- get@@ -1164,6 +1185,7 @@                  return $ TSeq t (mergeSeq ts)           <|> do reserved "compute"; return Compute           <|> do reserved "trivial"; return Trivial+          <|> do reserved "search"; return (ProofSearch Nothing [])           <|> do reserved "instance"; return TCInstance           <|> do reserved "solve"; return Solve           <|> do reserved "attack"; return Attack@@ -1172,7 +1194,17 @@           <|> do reserved "undo"; return Undo           <|> do reserved "qed"; return Qed           <|> do reserved "abandon"; return Abandon-          <|> do lchar ':'; reserved "q"; return Abandon+          <|> do lchar ':';+                 (    (do reserved "q"; return Abandon)+                  <|> (do (reserved "e" <|> reserved "eval");+                          t <- (indentPropHolds gtProp *> expr syn);+                          i <- get+                          return $ TEval (desugar syn i t))+                  <|> (do (reserved "t" <|> reserved "type");+                          t <- (indentPropHolds gtProp *> expr syn);+                          i <- get+                          return $ TCheck (desugar syn i t))+                  <?> "prover command")           <?> "tactic"   where     imp :: IdrisParser Bool
src/Idris/ParseHelpers.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, OverlappingInstances, StandaloneDeriving #-} module Idris.ParseHelpers where  import Prelude hiding (pi)@@ -15,7 +15,12 @@  import Idris.Core.TT import Idris.Core.Evaluate+import Idris.Delaborate (pprintErr)+import Idris.Docstrings+import Idris.Output (ihWarn) +import qualified Util.Pretty as Pretty (text)+ import Control.Applicative import Control.Monad import Control.Monad.State.Strict@@ -32,22 +37,55 @@  import System.FilePath +import Debug.Trace+ -- | Idris parser with state used during parsing type IdrisParser = StateT IState IdrisInnerParser  newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }-  deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, Parsing, DeltaParsing, MarkParsing Delta, Monoid)+  deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, DeltaParsing, MarkParsing Delta, Monoid, TokenParsing) -instance TokenParsing IdrisInnerParser where-  someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()+deriving instance Parsing IdrisInnerParser +instance TokenParsing IdrisParser where+  someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()+  token p = do s <- get+               (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC+               r <- p+               (FC fn _ (el, ec)) <- getFC+               whiteSpace+               put (s { lastTokenSpan = Just (FC fn (sl, sc) (el, ec)) })+               return r -- | Generalized monadic parsing constraint type type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)  -- | Helper to run Idris inner parser based stateT parsers runparser :: StateT st IdrisInnerParser res -> st -> String -> String -> Result res-runparser p i inputname = parseString (runInnerParser (evalStateT p i)) (Directed (UTF8.fromString inputname) 0 0 0 0)+runparser p i inputname =+  parseString (runInnerParser (evalStateT p i))+              (Directed (UTF8.fromString inputname) 0 0 0 0) +noDocCommentHere :: String -> IdrisParser ()+noDocCommentHere msg =+  optional (do fc <- getFC+               docComment+               ist <- get+               put ist { parserWarnings = (fc, Msg msg) : parserWarnings ist}) *>+  pure ()++clearParserWarnings :: Idris ()+clearParserWarnings = do ist <- getIState+                         putIState ist { parserWarnings = [] }++reportParserWarnings :: Idris ()+reportParserWarnings = do ist <- getIState+                          mapM_ (uncurry $ ihWarn (idris_outh ist))+                                (map (\ (fc, err) -> (fc, pprintErr ist err)) .+                                 reverse .+                                 nub $+                                 parserWarnings ist)+                          clearParserWarnings+ {- * Space, comments and literals (token/lexing like parsers) -}  -- | Consumes any simple whitespace (any character which satisfies Char.isSpace)@@ -62,12 +100,6 @@ eol :: MonadicParsing m => m () eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line" --- | Checks if a character is a documentation comment marker-isDocCommentMarker :: Char -> Bool-isDocCommentMarker '|' = True-isDocCommentMarker '^' = True-isDocCommentMarker   _  = False- {- | Consumes a single-line comment  @@@ -78,7 +110,9 @@  -} singleLineComment :: MonadicParsing m => m () singleLineComment =     try (string "--" *> eol *> pure ())-                    <|> string "--" *> satisfy (not . isDocCommentMarker) *> many (satisfy (not . isEol)) *> eol *> pure ()+                    <|> try (string "--" *> many simpleWhiteSpace *>+                             many (satisfy (not . isEol)) *>+                             eol *> pure ())                     <?> ""  {- | Consumes a multi-line comment@@ -100,13 +134,12 @@ -} multiLineComment :: MonadicParsing m => m () multiLineComment =     try (string "{-" *> (string "-}") *> pure ())-                   <|> string "{-" *> satisfy (not . isDocCommentMarker) *> inCommentChars+                   <|> string "{-" *> inCommentChars                    <?> ""   where inCommentChars :: MonadicParsing m => m ()         inCommentChars =     string "-}" *> pure ()                          <|> try (multiLineComment) *> inCommentChars-                         <|> try (docComment '|') *> inCommentChars-                         <|> try (docComment '^') *> inCommentChars+                         <|> string "|||" *> many (satisfy (not . isEol)) *> eol *> inCommentChars                          <|> skipSome (noneOf startEnd) *> inCommentChars                          <|> oneOf startEnd *> inCommentChars                          <?> "end of comment"@@ -116,19 +149,39 @@ {-| Parses a documentation comment (similar to haddoc) given a marker character  @-  DocComment_t ::=   '--' DocCommentMarker_t ~EOL_t* EOL_t-                  | '{ -' DocCommentMarket_t ~'- }'* '- }'+  DocComment_t ::=   '|||' ~EOL_t* EOL_t                  ; @  -}-docComment :: MonadicParsing m => Char -> m String-docComment marker | isDocCommentMarker marker = do dc <- docComment' marker; return (T.unpack $ T.strip $ T.pack dc)-                       | otherwise            = fail "internal error: tried to parse a documentation comment with invalid marker"-  where docComment' :: MonadicParsing m => Char -> m String-        docComment' marker  =     string "--" *> char marker *> many (satisfy (not . isEol)) <* eol-                              <|> string "{-" *> char marker *> (manyTill anyChar (try (string "-}")) <?> "end of comment")-                              <?> ""+docComment :: IdrisParser (Docstring, [(Name, Docstring)])+docComment = do dc <- pushIndent *> docCommentLine+                rest <- many (indented docCommentLine)+                args <- many (indented argDocCommentLine)+                popIndent+                return (parseDocstring $ T.pack (concat . intersperse "\n" $ dc:rest),+                        map (\(n, d) -> (n, parseDocstring (T.pack d))) args) +  where docCommentLine :: MonadicParsing m => m String+        docCommentLine = try (do string "|||"+                                 many (satisfy (==' '))+                                 contents <- option "" (do first <- satisfy (\c -> not (isEol c || c == '@'))+                                                           res <- many (satisfy (not . isEol))+                                                           return $ first:res)+                                 eol ; someSpace+                                 return contents)-- ++ concat rest))+                        <?> ""+        argDocCommentLine = do string "|||"+                               many (satisfy isSpace)+                               char '@'+                               many (satisfy isSpace)+                               n <- name+                               many (satisfy isSpace)+                               docs <- many (satisfy (not . isEol))+                               eol ; someSpace+                               return (n, docs)+++ -- | Parses some white space whiteSpace :: MonadicParsing m => m () whiteSpace = Tok.whiteSpace@@ -286,7 +339,7 @@ getFC = do s <- position            let (dir, file) = splitFileName (fileName s)            let f = if dir == addTrailingPathSeparator "." then file else fileName s-           return $ FC f (lineNum s) (columnNum s)+           return $ FC f (lineNum s, columnNum s) (lineNum s, columnNum s) -- TODO: Change to actual spanning  {-* Syntax helpers-} -- | Bind constraints to term
src/Idris/ParseOps.hs view
@@ -37,10 +37,15 @@         [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]        ++ toTable (reverse fixes) ++       [[backtick],-       [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],+       [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],        [binary "="  PEq AssocLeft],        [binary "->" (\fc x y -> PPi expl (sUN "__pi_arg") x y) AssocRight]]+  where+    flatten :: PTerm -> PTerm -- flatten application+    flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))+    flatten t = t + -- | Calculates table for fixtiy declarations toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm toTable fs = map (map toBin)@@ -59,7 +64,6 @@                           indentPropHolds gtProp                           reservedOp name                           indentPropHolds gtProp-                          doc <- option "" (docComment '^')                           return (f fc))  -- | Prefix operator@@ -82,12 +86,16 @@  optional namespace  @-  OperatorFront ::= (Identifier_t '.')? '(' Operator_t ')';+  OperatorFront ::=+    '(' '=' ')'+    | (Identifier_t '.')? '(' Operator_t ')'+    ; @  -} operatorFront :: IdrisParser Name-operatorFront = maybeWithNS (lchar '(' *> operator <* lchar ')') False []+operatorFront = try ((lchar '(' *> reservedOp "="  <* lchar ')') >> (return eqTy))+            <|> maybeWithNS (lchar '(' *> operator <* lchar ')') False []  {- | Parses a function (either normal name or operator)
src/Idris/Parser.hs view
@@ -29,15 +29,19 @@ import Idris.IBC import Idris.Unlit import Idris.Providers+import Idris.Output  import Idris.ParseHelpers import Idris.ParseOps import Idris.ParseExpr import Idris.ParseData +import Idris.Docstrings+ import Paths_idris  import Util.DynamicLinker+import qualified Util.Pretty as P  import Idris.Core.TT import Idris.Core.Evaluate@@ -86,7 +90,8 @@ @ -} moduleHeader :: IdrisParser [String]-moduleHeader =     try (do reserved "module"+moduleHeader =     try (do noDocCommentHere "Modules cannot have documentation comments"+                           reserved "module"                            i <- identifier                            option ';' (lchar ';')                            return (moduleName i))@@ -311,9 +316,10 @@ fnDecl' :: SyntaxInfo -> IdrisParser PDecl fnDecl' syn = checkFixity $               do (doc, fc, opts', n, acc) <- try (do-                        doc <- option "" (docComment '|')                         pushIndent                         ist <- get+                        doc <- option noDocs docComment+                        ist <- get                         let initOpts = if default_total ist                                           then [TotalFn]                                           else []@@ -328,7 +334,7 @@                  ty <- typeExpr (allowImp syn)                  terminator                  addAcc n acc-                 return (PTy doc syn fc opts' n ty)+                 return (PTy (fst doc) (snd doc) syn fc opts' n ty)             <|> postulate syn             <|> caf syn             <|> pattern syn@@ -341,7 +347,7 @@                                             unless fOk . fail $                                               "Missing fixity declaration for " ++ show n                                             return decl-          getName (PTy _ _ _ _ n _) = Just n+          getName (PTy _ _ _ _ _ n _) = Just n           getName _ = Nothing           fixityOK (NS n _) = fixityOK n           fixityOK (UN n)  | all (flip elem opChars) (str n) =@@ -379,6 +385,7 @@ fnOpts opts         = do reserved "total"; fnOpts (TotalFn : opts)       <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))+      <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))       <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;                   fnOpts (CExport c : opts)       <|> do try (lchar '%' *> reserved "assert_total");@@ -410,7 +417,7 @@ @ -} postulate :: SyntaxInfo -> IdrisParser PDecl-postulate syn = do doc <- try $ do doc <- option "" (docComment '|')+postulate syn = do doc <- try $ do doc <- option noDocs docComment                                    pushIndent                                    reserved "postulate"                                    return doc@@ -428,7 +435,7 @@                    fc <- getFC                    terminator                    addAcc n acc-                   return (PPostulate doc syn fc opts' n ty)+                   return (PPostulate (fst doc) syn fc opts' n ty)                  <?> "postulate"  {- | Parses a using declaration@@ -558,7 +565,7 @@ -} class_ :: SyntaxInfo -> IdrisParser [PDecl] class_ syn = do (doc, acc) <- try (do-                  doc <- option "" (docComment '|')+                  doc <- option noDocs docComment                   acc <- optional accessibility                   return (doc, acc))                 reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- fnName@@ -566,7 +573,7 @@                 cs <- many carg                 ds <- option [] (classBlock syn)                 accData acc n (concatMap declared ds)-                return [PClass doc syn fc cons n cs ds]+                return [PClass (fst doc) syn fc cons n cs ds]              <?> "type-class declaration"   where     carg :: IdrisParser (Name, PTerm)@@ -1000,8 +1007,8 @@                                            mapM_ (addNameHint ty') ns                                            mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]              <|> do try (lchar '%' *> reserved "error_handlers")-                    fn <- iName []-                    arg <- iName []+                    fn <- fnName+                    arg <- fnName                     ns <- sepBy1 name (lchar ',')                     return [PDirective (do fn' <- disambiguate fn                                            ns' <- mapM disambiguate ns@@ -1036,18 +1043,25 @@ {- | Parses a type provider  @-Provider ::= '%' 'provide' '(' FnName TypeSig ')' 'with' Expr;+Provider ::= '%' 'provide' Provider_What? '(' FnName TypeSig ')' 'with' Expr;+ProviderWhat ::= 'proof' | 'term' | 'type' | 'postulate' @  -} provider :: SyntaxInfo -> IdrisParser [PDecl] provider syn = do try (lchar '%' *> reserved "provide");+                  what <- provideWhat                   lchar '('; n <- fnName; lchar ':'; t <- typeExpr syn; lchar ')'                   fc <- getFC                   reserved "with"                   e <- expr syn-                  return  [PProvider syn fc n t e]+                  return  [PProvider syn fc what n t e]                <?> "type provider"-+  where provideWhat :: IdrisParser ProvideWhat+        provideWhat = option ProvAny+                        (      ((reserved "proof" <|> reserved "term" <|> reserved "type") *>+                                pure ProvTerm)+                           <|> (reserved "postulate" *> pure ProvPostulate)+                   <?> "provider variety") {- | Parses a transform  @@@ -1083,8 +1097,7 @@     = do i <- getIState          case parseString (runInnerParser (evalStateT imports i)) (Directed (UTF8.fromString fname) 0 0 0 0) input of               Failure err    -> fail (show err)-              Success (x, i) -> do -- Discard state updates (there should be-                                   -- none anyway)+              Success (x, i) -> do putIState i                                    return x   where imports :: IdrisParser (([String], [(String, Maybe String, FC)], Maybe Delta), IState)         imports = do whiteSpace@@ -1104,7 +1117,8 @@              case span (/= ':') s of                (failname, ':':rest) -> case span isDigit rest of                  (line, ':':rest') -> case span isDigit rest' of-                   (col, ':':msg) -> (FC failname (read line) (read col), msg)+                   (col, ':':msg) -> let pos = (read line, read col) in+                                         (FC failname pos pos, msg)  -- | A program is a list of declarations, possibly with associated -- documentation strings.@@ -1119,10 +1133,11 @@                                   i <- getIState                                   case idris_outputmode i of                                     RawOutput -> ihputStrLn (idris_outh i) (show doc)-                                    IdeSlave n -> ihWarn (idris_outh i) fc msg-                                  putIState (i { errLine = Just (fc_line fc) }) -- Just errl })+                                    IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)+                                  putIState (i { errSpan = Just fc })                                   return []             Success (x, i)  -> do putIState i+                                  reportParserWarnings                                   return $ collect x   where mainProg :: IdrisParser ([PDecl], IState)         mainProg = case mrk of@@ -1137,7 +1152,7 @@ loadModule :: Handle -> FilePath -> Idris String loadModule outh f    = idrisCatch (loadModule' outh f)-                (\e -> do setErrLine (getErrLine e)+                (\e -> do setErrSpan (getErrSpan e)                           ist <- getIState                           msg <- showErr e                           ihputStrLn outh msg@@ -1185,9 +1200,9 @@ loadSource' :: Handle -> Bool -> FilePath -> Idris () loadSource' h lidr r    = idrisCatch (loadSource h lidr r)-                (\e -> do setErrLine (getErrLine e)-                          msg <- showErr e-                          ihputStrLn h msg)+                (\e -> do setErrSpan (getErrSpan e)+                          ist <- getIState+                          ihRenderError h (pprintErr ist e))  {- | Load Idris source code-} loadSource :: Handle -> Bool -> FilePath -> Idris ()@@ -1198,6 +1213,15 @@                   file_in <- runIO $ readFile f                   file <- if lidr then tclift $ unlit f file_in else return file_in                   (mname, imports, pos) <- parseImports f file+                  ids <- allImportDirs+                  ibcsd <- valIBCSubDir i+                  mapM_ (\f -> do fp <- runIO $ findImport ids ibcsd f+                                  case fp of+                                      LIDR fn -> ifail $ "No ibc for " ++ f+                                      IDR fn -> ifail $ "No ibc for " ++ f+                                      IBC fn src -> loadIBC fn) +                        [fn | (fn, _, _) <- imports]+                  reportParserWarnings                    -- process and check module aliases                   let modAliases = M.fromList@@ -1215,56 +1239,60 @@                   mapM_ (addIBC . IBCImport) [realName | (realName, alias, fc) <- imports]                   let syntax = defaultSyntax{ syn_namespace = reverse mname }                   ds' <- parseProg syntax f file pos-                  unless (null ds') $ do-                    let ds = namespaces mname ds'-                    logLvl 3 (show $ showDecls True ds)-                    i <- getIState-                    logLvl 10 (show (toAlist (idris_implicits i)))-                    logLvl 3 (show (idris_infixes i))-                    -- Now add all the declarations to the context-                    v <- verbose-                    when v $ ihputStrLn h $ "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-                    elabDecls toplevel (map toMutual ds)-                    i <- getIState-                    -- simplify every definition do give the totality checker-                    -- a better chance-                    mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n-                                    updateContext (simplifyCasedef n))-                             (map snd (idris_totcheck i))-                    -- build size change graph from simplified definitions-                    iLOG "Totality checking"-                    i <- getIState-                    mapM_ buildSCG (idris_totcheck i)-                    mapM_ checkDeclTotality (idris_totcheck i) -                    -- Redo totality check for deferred names-                    let deftots = idris_defertotcheck i-                    iLOG $ "Totality checking " ++ show deftots-                    mapM_ (\x -> do tot <- getTotality x-                                    case tot of-                                         Total _ -> setTotality x Unchecked-                                         _ -> return ()) (map snd deftots)-                    mapM_ buildSCG deftots-                    mapM_ checkDeclTotality deftots+                  -- Parsing done, now process declarations -                    iLOG ("Finished " ++ f)-                    ibcsd <- valIBCSubDir i-                    iLOG "Universe checking"-                    iucheck-                    let ibc = ibcPathNoFallback ibcsd f-                    i <- getIState-                    addHides (hide_list i)-                    ok <- noErrors-                    when ok $-                      idrisCatch (do writeIBC f ibc; clearIBC)-                                 (\c -> return ()) -- failure is harmless-                    i <- getIState-                    putIState (i { default_total = def_total,-                                   hide_list = [] })-                    return ()+                  let ds = namespaces mname ds'+                  logLvl 3 (show $ showDecls True ds)+                  i <- getIState+                  logLvl 10 (show (toAlist (idris_implicits i)))+                  logLvl 3 (show (idris_infixes i))+                  -- Now add all the declarations to the context+                  v <- verbose+                  when v $ ihputStrLn h $ "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+                  elabDecls toplevel (map toMutual ds)+                  i <- getIState+                  -- simplify every definition do give the totality checker+                  -- a better chance+                  mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+                                  updateContext (simplifyCasedef n))+                           (map snd (idris_totcheck i))+                  -- build size change graph from simplified definitions+                  iLOG "Totality checking"+                  i <- getIState+                  mapM_ buildSCG (idris_totcheck i)+                  mapM_ checkDeclTotality (idris_totcheck i)++                  -- Redo totality check for deferred names+                  let deftots = idris_defertotcheck i+                  iLOG $ "Totality checking " ++ show deftots+                  mapM_ (\x -> do tot <- getTotality x+                                  case tot of+                                       Total _ -> setTotality x Unchecked+                                       _ -> return ()) (map snd deftots)+                  mapM_ buildSCG deftots+                  mapM_ checkDeclTotality deftots++                  iLOG ("Finished " ++ f)+                  ibcsd <- valIBCSubDir i+                  iLOG "Universe checking"+                  iucheck+                  let ibc = ibcPathNoFallback ibcsd f+                  i <- getIState+                  addHides (hide_list i)++                  -- Finally, write an ibc if checking was successful++                  ok <- noErrors+                  when ok $+                    idrisCatch (do writeIBC f ibc; clearIBC)+                               (\c -> return ()) -- failure is harmless+                  i <- getIState+                  putIState (i { default_total = def_total,+                                 hide_list = [] })                   return ()   where     namespaces :: [String] -> [PDecl] -> [PDecl]
src/Idris/PartialEval.hs view
@@ -103,7 +103,7 @@   deImp (PApp fc t as) = PApp fc t (map deImpArg as)   deImp t = t -  deImpArg a@(PImp _ _ _ _ _ _) = a { getTm = Placeholder }+  deImpArg a@(PImp _ _ _ _ _) = a { getTm = Placeholder }   deImpArg a = a  data PEArgType = ImplicitS | ImplicitD@@ -124,7 +124,7 @@          | imparg imp = (ImplicitD, tm)          | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased)) -    imparg (PExp _ _ _ _) = False+    imparg (PExp _ _ _) = False     imparg _ = True      buildApp env [] [] _ _ = []
src/Idris/Primitives.hs view
@@ -172,7 +172,9 @@     (0, LStdIn) partial,    Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)     (0, LNullPtr) total,-+   -- Managed pointer registration+   Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)+    (2, LRegisterPtr) total,    -- Buffers    Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_cantreduce)     (1, LAllocate) total,
src/Idris/ProofSearch.hs view
@@ -100,7 +100,8 @@                             [args] -> map isImp (snd args)                             _ -> fail "Ambiguous name"             ps <- get_probs-            args <- map snd <$> apply (Var n) imps+            args <- map snd <$> try' (apply (Var n) imps)+                                     (match_apply (Var n) imps) True             ps' <- get_probs             when (length ps < length ps') $ fail "Can't apply constructor"             mapM_ (\ (_, h) -> do focus h@@ -108,6 +109,6 @@                   (filter (\ (x, y) -> not x) (zip (map fst imps) args))             solve -    isImp (PImp p _ _ _ _ _) = (True, p)+    isImp (PImp p _ _ _ _) = (True, p)     isImp arg = (False, priority arg)
src/Idris/Prover.hs view
@@ -10,17 +10,19 @@ import Idris.Delaborate import Idris.ElabDecls import Idris.ElabTerm-import Idris.Parser+import Idris.Parser hiding (params) import Idris.Error import Idris.DataOpts import Idris.Completion import Idris.IdeSlave+import Idris.Output  import Text.Trifecta.Result(Result(..))  import System.Console.Haskeline import System.Console.Haskeline.History import Control.Monad.State.Strict+import Control.DeepSeq  import Util.Pretty import Debug.Trace@@ -58,7 +60,7 @@ prove ctxt lit n ty     = do let ps = initElaborator n ctxt ty          ideslavePutSExp "start-proof-mode" n-         (tm, prf) <- ploop True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing+         (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing          iLOG $ "Adding " ++ show tm          iputStrLn $ showProof lit n prf          i <- getIState@@ -88,10 +90,10 @@                      Error a -> ierror a  dumpState :: IState -> ProofState -> Idris ()-dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =   do rendered <- iRender $ prettyName False [] nm <> colon <+> text "No more goals."      iputGoal rendered-dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = do+dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _ _) = do   let OK ty  = goalAtFocus ps   let OK env = envAtFocus ps   let state = prettyOtherGoals hs <> line <>@@ -103,7 +105,7 @@   where     showImplicits = opt_showimp (idris_options ist) -    tPretty bnd t = pprintPTerm showImplicits bnd $ delab ist t+    tPretty bnd t = pprintPTerm showImplicits bnd [] $ delab ist t      assumptionNames :: Env -> [Name]     assumptionNames = map fst@@ -160,9 +162,10 @@        Just (Interpret cmd) -> return (Just cmd)        Nothing -> return Nothing -ploop :: Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])-ploop d prompt prf e h+ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])+ploop fn d prompt prf e h     = do i <- getIState+         let autoSolve = opt_autoSolve (idris_options i)          when d $ dumpState i (proof e)          (x, h') <-            case idris_outputmode i of@@ -200,8 +203,66 @@                                 when (not (null hs)) $ ifail "Incomplete proof"                                 iPrintResult "Proof completed!"                                 return (False, e, True, prf)+              Success (TCheck (PRef _ n)) ->+                do ctxt <- getContext+                   ist <- getIState+                   imp <- impShow+                   idrisCatch (do+                       let h      = idris_outh ist+                           OK env = envAtFocus (proof e)+                           ctxt'  = envCtxt env ctxt+                           bnd    = map (\x -> (fst x, False)) env+                           ist'   = ist { tt_ctxt = ctxt' }+                       putIState ist'+                       -- Unlike the REPL, metavars have no special treatment, to+                       -- make it easier to see how to prove with them.+                       case lookupNames n ctxt' of+                         [] -> ihPrintError h $ "No such variable " ++ show n+                         ts -> ihPrintFunTypes h bnd n (map (\n -> (n, delabTy ist' n)) ts)+                       putIState ist+                       return (False, e, False, prf))+                     (\err -> do putIState ist ; ierror err)+              Success (TCheck t) ->+                do ist <- getIState+                   ctxt <- getContext+                   idrisCatch (do+                       let OK env = envAtFocus (proof e)+                           ctxt'  = envCtxt env ctxt+                       putIState ist { tt_ctxt = ctxt' }+                       (tm, ty) <- elabVal toplevel False t+                       let imp = opt_showimp (idris_options ist)+                           ty' = normaliseC ctxt [] ty+                           h   = idris_outh ist+                       case tm of+                          TType _ ->+                            ihPrintTermWithType h (prettyImp imp PType) type1Doc+                          _ -> let bnd = map (\x -> (fst x, False)) env in+                               ihPrintTermWithType h (pprintPTerm imp bnd [] (delab ist tm))+                                                     (pprintPTerm imp bnd [] (delab ist ty))+                       putIState ist+                       return (False, e, False, prf))+                     (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)+              Success (TEval t)  -> withErrorReflection $+                                    do ctxt <- getContext+                                       ist <- getIState+                                       idrisCatch (do+                                           let OK env = envAtFocus (proof e)+                                               ctxt'  = envCtxt env ctxt+                                               ist'   = ist { tt_ctxt = ctxt' }+                                               bnd    = map (\x -> (fst x, False)) env+                                           putIState ist'+                                           (tm, ty) <- elabVal toplevel False t+                                           let tm'    = force (normaliseAll ctxt' env tm)+                                               ty'    = force (normaliseAll ctxt' env ty)+                                               imp    = opt_showimp (idris_options ist')+                                               tmDoc  = pprintPTerm imp bnd [] (delab ist' tm')+                                               tyDoc  = pprintPTerm imp bnd [] (delab ist' ty')+                                           ihPrintTermWithType (idris_outh ist') tmDoc tyDoc+                                           putIState ist+                                           return (False, e, False, prf))+                                         (\err -> do putIState ist ; ierror err)               Success tac -> do (_, e) <- elabStep e saveState-                                (_, st) <- elabStep e (runTac True i tac)+                                (_, st) <- elabStep e (runTac autoSolve i fn tac) --                               trace (show (problems (proof st))) $                                 iPrintResult ""                                 return (True, st, False, prf ++ [step]))@@ -210,5 +271,5 @@          ideslavePutSExp "write-proof-state" (prf', length prf')          if done then do (tm, _) <- elabStep st get_term                          return (tm, prf')-                 else ploop d prompt prf' st h'-+                 else ploop fn d prompt prf' st h'+  where envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env
src/Idris/Providers.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE PatternGuards #-}-module Idris.Providers (providerTy, getProvided) where+{-# LANGUAGE PatternGuards, DeriveFunctor #-}+module Idris.Providers (providerTy, getProvided, Provided(..)) where  import Idris.Core.TT import Idris.Core.Evaluate@@ -11,14 +11,19 @@  -- | Wrap a type provider in the type of type providers providerTy :: FC -> PTerm -> PTerm-providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] tm ""]+providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] tm]  ioret = sUN "prim_io_return" ermod = sNS (sUN "Error") ["Providers"] prmod = sNS (sUN "Provide") ["Providers"]+posmod = sNS (sUN "Postulate") ["Providers"] +data Provided a = Provide a+                | Postulate+  deriving (Show, Eq, Functor)+ -- | Handle an error, if the type provider returned an error. Otherwise return the provided term.-getProvided :: FC -> TT Name -> Idris (TT Name)+getProvided :: FC -> TT Name -> Idris (Provided (TT Name)) getProvided fc tm | (P _ pioret _, [tp, result]) <- unApply tm                   , (P _ nm _, [_, err]) <- unApply result                   , pioret == ioret && nm == ermod@@ -28,7 +33,11 @@                   | (P _ pioret _, [tp, result]) <- unApply tm                   , (P _ nm _, [_, res]) <- unApply result                   , pioret == ioret && nm == prmod-                      = return res+                      = return . Provide $ res+                  | (P _ pioret _, [tp, result]) <- unApply tm+                  , (P _ nm _, [_]) <- unApply result+                  , pioret == ioret && nm == posmod+                      = return Postulate                   | otherwise = ifail $ "Internal type provider error: result was not " ++                                         "IO (Provider a), or perhaps missing normalisation."
src/Idris/REPL.hs view
@@ -4,12 +4,14 @@ module Idris.REPL where  import Idris.AbsSyntax+import Idris.Apropos (apropos) import Idris.REPLParser import Idris.ElabDecls import Idris.ElabTerm import Idris.Error import Idris.ErrReverse import Idris.Delaborate+import Idris.Docstrings (Docstring, overview, renderDocstring) import Idris.Prover import Idris.Parser import Idris.Primitives@@ -21,10 +23,11 @@ import qualified Idris.IdeSlave as IdeSlave import Idris.Chaser import Idris.Imports-import Idris.Colours+import Idris.Colours hiding (colourise) import Idris.Inliner import Idris.CaseSplit import Idris.DeepSeq+import Idris.Output  import Paths_idris import Version_idris (gitHash)@@ -41,6 +44,9 @@ import IRTS.Compiler import IRTS.CodegenCommon +import Data.List.Split (splitOn)+import qualified Data.Text as T+ import Text.Trifecta.Result(Result(..))  -- import RTS.SC@@ -140,19 +146,11 @@                   _ -> ""          loop fn ist sock-            = do (h,host,_) <- accept sock-                 -- just use the local part of the hostname-                 -- for the "localhost.localdomain" case-                 if ((takeWhile (/= '.') host) == "localhost" ||-                     host == "127.0.0.1")-                   then do-                     cmd <- hGetLine h-                     (ist', fn) <- processNetCmd orig ist h fn cmd-                     hClose h-                     loop fn ist' sock-                   else do-                     putStrLn $ "Closing connection attempt from non-localhost " ++ host-                     hClose h+            = do (h,_,_) <- accept sock+                 cmd <- hGetLine h+                 (ist', fn) <- processNetCmd orig ist h fn cmd+                 hClose h+                 loop fn ist' sock  processNetCmd :: IState -> IState -> Handle -> FilePath -> String ->                  IO (IState, FilePath)@@ -227,11 +225,11 @@                             Success (Prove n') -> do iPrintResult ""                                                      idrisCatch                                                        (process stdout fn (Prove n'))-                                                       (\e -> getIState >>= iPrintError . flip pshow e)+                                                       (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)                                                      isetPrompt (mkPrompt mods)                             Success cmd -> idrisCatch                                              (ideslaveProcess fn cmd)-                                             (\e -> getIState >>= iPrintError . flip pshow e)+                                             (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)                      Just (IdeSlave.REPLCompletions str) ->                        do (unused, compls) <- replCompletion (reverse str, "")                           let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]@@ -244,12 +242,19 @@                           isetPrompt (mkPrompt [filename])                           -- Report either success or failure                           i <- getIState-                          case (errLine i) of+                          case (errSpan i) of                             Nothing -> iPrintResult $ "loaded " ++ filename                             Just x -> iPrintError $ "didn't load " ++ filename                           ideslave orig [filename]                      Just (IdeSlave.TypeOf name) ->-                       process stdout "(ideslave)" (Check (PRef (FC "(ideslave)" 0 0) (sUN name)))+                       case splitName name of+                         Left err -> iPrintError err+                         Right n -> process stdout "(ideslave)"+                                      (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))+                     Just (IdeSlave.DocsFor name) ->+                       case splitName name of+                         Left err -> iPrintError err+                         Right n -> process stdout "(ideslave)" (DocStr n)                      Just (IdeSlave.CaseSplit line name) ->                        process stdout fn (CaseSplitAt False line (sUN name))                      Just (IdeSlave.AddClause line name) ->@@ -262,10 +267,34 @@                        process stdout fn (MakeWith False line (sUN name))                      Just (IdeSlave.ProofSearch line name hints) ->                        process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))+                     Just (IdeSlave.Apropos a) ->+                       process stdout fn (Apropos a)+                     Just (IdeSlave.GetOpts) ->+                       do ist <- getIState+                          let opts = idris_options ist+                          let impshow = opt_showimp opts+                          let errCtxt = opt_errContext opts+                          let options = (IdeSlave.SymbolAtom "ok",+                                         [(IdeSlave.SymbolAtom "show-implicits", impshow),+                                          (IdeSlave.SymbolAtom "error-context", errCtxt)])+                          runIO . putStrLn $ IdeSlave.convSExp "return" options id+                     Just (IdeSlave.SetOpt IdeSlave.ShowImpl b) ->+                       do setImpShow b+                          let msg = (IdeSlave.SymbolAtom "ok", b)+                          runIO . putStrLn $ IdeSlave.convSExp "return" msg id+                     Just (IdeSlave.SetOpt IdeSlave.ErrContext b) ->+                       do setErrContext b+                          let msg = (IdeSlave.SymbolAtom "ok", b)+                          runIO . putStrLn $ IdeSlave.convSExp "return" msg id                      Nothing -> do iPrintError "did not understand")                (\e -> do iPrintError $ show e))          (\e -> do iPrintError $ show e)        ideslave orig mods+  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  ideslaveProcess :: FilePath -> Command -> Idris () ideslaveProcess fn Help = process stdout fn Help@@ -291,8 +320,6 @@ --ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode! ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t) ---that most likely does not work, since we need to wrap---input/output of the executed binary... ideslaveProcess fn Execute = do process stdout fn Execute                                 iPrintResult "" ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f)@@ -328,6 +355,8 @@ ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs) ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)                                             iPrintResult ""+ideslaveProcess fn (Apropos a) = do process stdout fn (Apropos a)+                                    iPrintResult "" ideslaveProcess fn _ = iPrintError "command not recognized or not supported"  @@ -406,8 +435,8 @@     = do i <- getIState          env <- runIO $ getEnvironment          let editor = getEditor env-         let line = case errLine i of-                        Just l -> " +" ++ show l ++ " "+         let line = case errSpan i of+                        Just l -> " +" ++ show (fst (fc_start l)) ++ " "                         Nothing -> " "          let cmd = editor ++ line ++ fixName f          runIO $ system cmd@@ -482,7 +511,7 @@             case lookup t (idris_metavars ist) of                 Just (_, i, _) -> ihRenderResult h . fmap (fancifyAnnots ist) $                                   showMetavarInfo imp ist n i-                Nothing -> ihPrintFunTypes h n (map (\n -> (n, delabTy ist n)) ts)+                Nothing -> ihPrintFunTypes h [] n (map (\n -> (n, delabTy ist n)) ts)           [] -> ihPrintError h $ "No such variable " ++ show n   where     showMetavarInfo imp ist n i@@ -502,10 +531,10 @@     putTy imp ist _ bnd sc = putGoal imp ist ((n,False):bnd) sc     putGoal imp ist bnd g                = text "--------------------------------------" <$>-                 annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>+                 annotate (AnnName n Nothing Nothing Nothing) (text $ show n) <+> colon <+>                  align (tPretty bnd ist g) -    tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd t+    tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t   process h fn (Check t)@@ -521,14 +550,14 @@                                       (prettyImp imp (delab ist ty))  process h fn (DocStr n)-                      = do i <- getIState-                           case lookupCtxtName n (idris_docstrings i) of-                                [] -> iPrintError $ "No documentation for " ++ show n-                                ns -> do mapM_ showDoc ns-                                         iPrintResult ""-    where showDoc (n, d)-             = do doc <- getDocs n-                  iputStrLn $ show doc+   = do i <- getIState+        let imp = opt_showimp (idris_options i)+        case lookupCtxtName n (idris_docstrings i) of+          [] -> iPrintError $ "No documentation for " ++ show n+          ns -> do toShow <- mapM (showDoc imp) ns+                   ihRenderResult h (vsep toShow)+    where showDoc imp (n, d) = do doc <- getDocs n+                                  return $ pprintDocs imp doc process h fn Universes                      = do i <- getIState                           let cs = idris_constraints i@@ -704,7 +733,7 @@               runIO $ copyFile fb fn            else ihPrintResult h with   where getIndent s = length (takeWhile isSpace s)-    + process h fn (DoProofSearch updatefile l n hints)     = do src <- runIO $ readFile fn          let (before, tyline : later) = splitAt (l-1) (lines src)@@ -718,8 +747,8 @@                                   Just (t, e, False) -> (t, e, False)                                   _ -> (Nothing, 0, True)          let fc = fileFC fn-         let body t = PProof [Try (TSeq Intros (ProofSearch t n hints))-                                  (ProofSearch t n hints)]+         let body t = PProof [Try (TSeq Intros (ProofSearch t hints))+                                  (ProofSearch t hints)]          let def = PClause fc mn (PRef fc mn) [] (body top) []          newmv <- idrisCatch              (do elabDecl' EAll toplevel (PClauses fc [] mn [def])@@ -861,17 +890,19 @@                                 c <- colourise                                 iPrintResult (showTm ist (delab ist tm')) process h fn Execute-                   = do (m, _) <- elabVal toplevel False+                   = do ist <- getIState+                        (m, _) <- elabVal toplevel False                                         (PApp fc                                            (PRef fc (sUN "run__IO"))                                            [pexp $ PRef fc (sNS (sUN "main") ["Main"])])---                                      (PRef (FC "main" 0) (NS (UN "main") ["main"]))                         (tmpn, tmph) <- runIO tempfile                         runIO $ hClose tmph                         t <- codegen                         compile t tmpn m-                        runIO $ system tmpn-                        return ()+                        case idris_outputmode ist of+                          RawOutput -> do runIO $ system tmpn+                                          return ()+                          IdeSlave n -> do runIO . hPutStrLn h $ IdeSlave.convSExp "run-program" tmpn n   where fc = fileFC "main" process h fn (Compile codegen f)       = do (m, _) <- elabVal toplevel False@@ -926,6 +957,8 @@ 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 _) = iPrintError "Not a valid option" process h fn (UnsetOpt _) = iPrintError "Not a valid option"@@ -944,6 +977,21 @@            iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers process h fn (SetConsoleWidth w) = setWidth w +process h fn (Apropos a) =+  do ist <- getIState+     let impl = opt_showimp (idris_options ist)+     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 (renderApropos impl) aproposInfo)+  where renderApropos impl (name, ty, docs) =+          prettyName True [] name <+> colon <+> align (prettyImp impl ty) <$>+          fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)+        isUN (UN _) = True+        isUN (NS n _) = isUN n+        isUN _ = False  classInfo :: ClassInfo -> Idris () classInfo ci = do iputStrLn "Methods:\n"@@ -1099,47 +1147,77 @@            let ninputs = zip [1..] inputs            ifiles <- mapWhileOK (\(num, input) ->                 do putIState ist-                   v <- verbose-    --                           when v $ iputStrLn $ "(" ++ show num ++ "/" ++-    --                                                show (length inputs) ++-    --                                                ") " ++ input                    modTree <- buildTree                                    (map snd (take (num-1) ninputs))                                    input                    let ifiles = getModuleFiles modTree                    iLOG ("MODULE TREE : " ++ show modTree)                    iLOG ("RELOAD: " ++ show ifiles)-                   when (not (all ibc ifiles) || loadCode) $ tryLoad ifiles+                   when (not (all ibc ifiles) || loadCode) $ +                        tryLoad False (filter (not . ibc) ifiles)                    -- return the files that need rechecking-                   return (if (all ibc ifiles) then ifiles else []))+                   return ifiles)                        ninputs            inew <- getIState-           -- to check everything worked consistently (in particular, will catch-           -- if the ibc version is out of date) if we weren't loading per-           -- module-           case errLine inew of+           let tidata = idris_tyinfodata inew+           let lineapps = idris_lineapps inew+           let patdefs = idris_patdefs inew+           -- If it worked, load the whole thing from all the ibcs together+           case errSpan inew of               Nothing ->-                do putIState ist-                   when (not loadCode) $ tryLoad $ nub (concat ifiles)+                do putIState (ist { idris_tyinfodata = tidata })+                   ibcfiles <- mapM findNewIBC (nub (concat ifiles))+                   tryLoad True (mapMaybe id ibcfiles)               _ -> return ()-           putIState inew)+           ist <- getIState+           putIState (ist { idris_tyinfodata = tidata,+                            idris_lineapps = lineapps,+                            idris_patdefs = patdefs }))         (\e -> do i <- getIState                   case e of-                    At f _ -> do setErrLine (fc_line f)-                                 iputStrLn (show e)+                    At f _ -> do setErrSpan f+                                 ihRenderError stdout $ pprintErr i e                     ProgramLineComment -> return () -- fail elsewhere-                    _ -> do setErrLine 3 -- FIXME! Propagate it+                    _ -> do setErrSpan emptyFC -- FIXME! Propagate it                             iputStrLn (pshow i e))    where -- load all files, stop if any fail-         tryLoad :: [IFileType] -> Idris ()-         tryLoad [] = return ()-         tryLoad (f : fs) = do loadFromIFile h f-                               ok <- noErrors-                               when ok $ tryLoad fs+         tryLoad :: Bool -> [IFileType] -> Idris ()+         tryLoad keepstate [] = return ()+         tryLoad keepstate (f : fs) +                 = do ist <- getIState+                      loadFromIFile h f+                      inew <- getIState+                      -- FIXME: Save these in IBC to avoid this hack! Need to+                      -- preserve it all from source inputs+                      let tidata = idris_tyinfodata inew+                      let lineapps = idris_lineapps inew+                      let patdefs = idris_patdefs inew+                      ok <- noErrors+                      when ok $ do when (not keepstate) $ putIState ist+                                   ist <- getIState+                                   putIState (ist { idris_tyinfodata = tidata,+                                                    idris_lineapps = lineapps,+                                                    idris_patdefs = patdefs })+                                   tryLoad keepstate fs           ibc (IBC _ _) = True          ibc _ = False +         findNewIBC :: IFileType -> Idris (Maybe IFileType)+         findNewIBC i@(IBC _ _) = return (Just i)+         findNewIBC s@(IDR f) = do ist <- get+                                   ibcsd <- valIBCSubDir ist+                                   let ibc = ibcPathNoFallback ibcsd f+                                   ok <- runIO $ doesFileExist ibc+                                   if ok then return (Just (IBC ibc s))+                                         else return Nothing+         findNewIBC s@(LIDR f) = do ist <- get+                                    ibcsd <- valIBCSubDir ist+                                    let ibc = ibcPathNoFallback ibcsd f+                                    ok <- runIO $ doesFileExist ibc+                                    if ok then return (Just (IBC ibc s))+                                          else return Nothing+          -- Like mapM, but give up when there's an error          mapWhileOK f [] = return []          mapWhileOK f (x : xs) = do x' <- f x@@ -1184,6 +1262,7 @@        when (DefaultTotal `elem` opts) $ do i <- getIState                                             putIState (i { default_total = True })        setColourise $ not quiet && last (True : opt getColour opts)+       when (not runrepl) $ setWidth InfinitelyWide        mapM_ addLangExt (opt getLanguageExt opts)        setREPL runrepl        setQuiet (quiet || isJust script)
src/Idris/REPLParser.hs view
@@ -98,6 +98,7 @@               <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t))               <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)               <|> try (do cmd ["consolewidth"]; w <- pConsoleWidth ; return (SetConsoleWidth w))+              <|> try (do cmd ["apropos"]; str <- many anyChar ; return (Apropos str))               <|> do P.whiteSpace; do eof; return NOP                              <|> do t <- P.fullExpr defaultSyntax; return (Eval t) @@ -107,6 +108,7 @@ pOption = do discard (P.symbol "errorcontext"); return ErrContext       <|> do discard (P.symbol "showimplicits"); return ShowImpl       <|> do discard (P.symbol "originalerrors"); return ShowOrigErr+      <|> do discard (P.symbol "autosolve"); return AutoSolve  pConsoleWidth :: P.IdrisParser ConsoleWidth pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth
src/Idris/Unlit.hs view
@@ -24,8 +24,8 @@ check f l [] = return ()  chkAdj :: FilePath -> Int -> LineType -> LineType -> TC ()-chkAdj f l Prog Comm = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column?-chkAdj f l Comm Prog = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column?+chkAdj f l Prog Comm = tfail $ At (FC f (l, 0) (l, 0)) ProgramLineComment --TODO: Span correctly+chkAdj f l Comm Prog = tfail $ At (FC f (l, 0) (l, 0)) ProgramLineComment --TODO: Span correctly chkAdj f l _    _    = return ()
src/Pkg/Package.hs view
@@ -17,6 +17,7 @@ import Idris.Core.TT import Idris.REPL import Idris.AbsSyntax+import Idris.Output  import IRTS.System @@ -52,17 +53,17 @@                     Nothing -> exitWith (ExitFailure 1)                     Just ist -> do                        -- Quit with error code if there was a problem-                       case errLine ist of+                       case errSpan ist of                             Just _ -> exitWith (ExitFailure 1)                             _ -> return ()                        -- Also give up if there are metavariables to solve                        case (map fst (idris_metavars ist) \\ primDefs) of-                            [] -> when install $ installPkg pkgdesc-                            ms -> do if install -                                        then putStrLn "Can't install: there are undefined metavariables:"-                                        else putStrLn "There are undefined metavariables:"-                                     putStrLn $ "\t" ++ show ms -                                     exitWith (ExitFailure 1)+                            _ -> when install $ installPkg pkgdesc+--                             ms -> do if install +--                                         then putStrLn "Can't install: there are undefined metavariables:"+--                                         else putStrLn "There are undefined metavariables:"+--                                      putStrLn $ "\t" ++ show ms +--                                      exitWith (ExitFailure 1)  -- | Type check packages only --@@ -85,7 +86,7 @@             when quit $ case res of                           Nothing -> exitWith (ExitFailure 1)                           Just res' -> do-                            case errLine res' of+                            case errSpan res' of                               Just _ -> exitWith (ExitFailure 1)                               _ -> return ()
src/Util/DynamicLinker.hs view
@@ -14,8 +14,8 @@ import qualified Control.Exception as Exception (catch, IOException) import System.Win32.DLL import System.Win32.Types-type DL = HMODULE import System.FilePath.Windows ((</>))+type DL = HMODULE #endif  hostDynamicLibExt :: String
src/Util/LLVMStubs.hs view
@@ -20,12 +20,5 @@ getHostCPUName = return ""  -codegenLLVM :: [(TT.Name, SDecl)] ->-               String -> -- target triple-               String -> -- target CPU-               Word -> -- Optimization degree-               FilePath -> -- output file name-               OutputType ->-               IO ()--codegenLLVM _ _ _ _ _ _ = fail "This Idris was compiled without the LLVM backend."+codegenLLVM :: CodeGenerator+codegenLLVM _ = fail "This Idris was compiled without the LLVM backend."
test/Makefile view
@@ -8,13 +8,13 @@ 	@perl ./runtest.pl $(patsubst %.test,%,$@)  test_java:-	perl ./runtest.pl without buffer001 --codegen Java+	perl ./runtest.pl without sugar004 buffer001 --codegen Java  test_js:-	@perl ./runtest.pl without reg029 reg031 io001 dsl002 io003 effects001 effects002 basic007 buffer001 --codegen node+	@perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 bounded001 folding002 --codegen node  test_llvm:-	@perl ./runtest.pl without io003 buffer001 --codegen llvm+	@perl ./runtest.pl without sugar004 io003 buffer001 --codegen llvm  update: 	/usr/bin/env perl ./runtest.pl all -u
test/basic002/test006.idr view
@@ -36,4 +36,3 @@     trivial; }; -
test/basic006/expected view
@@ -1,13 +1,14 @@ When elaborating right hand side of foo:-test020a.idr:14:18:Can't unify-        Vect n a-with-        List a--Specifically:+test020a.idr:14:18:When elaborating an application of function Prelude.List.reverse:         Can't unify                 Vect n a         with                 List a+        +        Specifically:+                Can't unify+                        Vect n a+                with+                        List a [3, 2, 1] "Number 42"
test/basic009/expected view
@@ -1,4 +1,5 @@ MAIN-PASS Faulty.idr:6:7:When elaborating type of Faulty.fault:-Can't disambiguate name: A.num, B.C.num+When elaborating an application of type constructor =:+        Can't disambiguate name: A.num, B.C.num Multiple.idr:3:1:import alias not unique: "X"
test/dsl001/test001.idr view
@@ -26,7 +26,7 @@       Var : HasType i G t -> Expr G t       Val : (x : Int) -> Expr G TyInt       Lam : Expr (a :: G) t -> Expr G (TyFun a t)-      App : Expr G (TyFun a t) -> Expr G a -> Expr G t+      App : Lazy (Expr G (TyFun a t)) -> Expr G a -> Expr G t       Op  : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->             Expr G c       If  : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a@@ -38,6 +38,7 @@       index_first = stop       index_next = pop +  total   interp : Env G -> [static] (e : Expr G t) -> interpTy t   interp env (Var i)     = lookup i env   interp env (Val x)     = x@@ -62,13 +63,13 @@   eDouble : Expr G (TyFun TyInt TyInt)   eDouble = expr (\x => App (App eAdd x) (Var stop)) -  app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t-  app = \f, a => App f a+--   app : Lazy (Expr G (TyFun a t)) -> Expr G a -> Expr G t+--   app = \f, a => App (Force f) a    eFac : Expr G (TyFun TyInt TyInt)   eFac = expr (\x => If (Op (==) x (Val 0))                  (Val 1)-                 (Op (*) (app eFac (Op (-) x (Val 1))) x))+                 (Op (*) (App eFac (Op (-) x (Val 1))) x))    -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2
test/dsl002/Resimp.idr view
@@ -105,7 +105,7 @@  {-- Control structures --} -       Lift   : |(action:IO a) -> Res gam gam (R a)+       Lift   : IO a -> Res gam gam (R a)        Check  : (p:HasType gam i (Choice (interpTy a) (interpTy b))) ->                 (failure:Res (update gam p a) (update gam p c) t) ->                 (success:Res (update gam p b) (update gam p c) t) ->
test/effects001/test021.idr view
@@ -5,11 +5,11 @@ import Effect.StdIO import Control.IOExcept -data FName = Count | NotCount+data Count : Type where  FileIO : Type -> Type -> Type FileIO st t-   = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t+   = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff IO t  readFile : FileIO (OpenFile Read) (List String) readFile = readAcc [] where@@ -22,14 +22,12 @@                         else return (reverse acc)  testFile : FileIO () ()-testFile = do open "testFile" Read-              if_valid then do putStrLn (show !readFile)-                               close-                               putStrLn (show !(Count :- get))-                 else putStrLn ("Error!")+testFile = do True <- open "testFile" Read  | False => putStrLn "Error!"+              putStrLn (show !readFile)+              close+              putStrLn (show !(Count :- get))  main : IO ()-main = do ioe_run (run [(), (), Count := 0] testFile)-                  (\err => print err) (\ok => return ())+main = run testFile
test/effects001/test021a.idr view
@@ -17,7 +17,7 @@ -- Evaluator t --    = Eff m [EXCEPTION String, RND, STATE Env] t -eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer+eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff IO Integer eval (Var x) = do vs <- get                   case lookup x vs of                         Nothing => raise ("No such variable " ++ x)@@ -32,7 +32,7 @@ testExpr = Add (Add (Var "foo") (Val 42)) (Random 100)  runEval : List (String, Integer) -> Expr -> IO Integer-runEval args expr = run [(), (), 123456, args] (eval expr)+runEval args expr = runInit [(), (), 123456, args] (eval expr)  main : IO () main = do let x = 42
test/effects002/test025.idr view
@@ -5,8 +5,8 @@ import Control.IOExcept  MemoryIO : Type -> Type -> Type -> Type-MemoryIO td ts r = Eff (IOExcept String) [ Dst ::: RAW_MEMORY td-                                         , Src ::: RAW_MEMORY ts ] r+MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td+                     , Src ::: RAW_MEMORY ts ] } Eff (IOExcept String) r  inpVect : Vect 5 Bits8 inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]@@ -28,7 +28,7 @@                 return (map (prim__zextB8_Int) res)  main : IO ()-main = do ioe_run (run [Dst := (), Src := ()] testMemory)-                  (\err => print err) (\ok => print ok)+main = ioe_run (runInit [Dst := (), Src := ()] testMemory)+               (\err => print err) (\ok => print ok)
test/error003/ErrorReflection.idr view
@@ -59,17 +59,6 @@                                         ty1 <- reifyTy tm1'                                         ty2 <- reifyTy tm2'                                         return [TextPart $ "DSL type error: " ++ (show ty1) ++ " doesn't match " ++(show ty2)]-dslerr (At (FileLoc f l c) err) = do err' <- dslerr err-                                     return [ TextPart "In file"-                                            , TextPart f-                                            , TextPart "line", TextPart (cast l)-                                            , TextPart "column", TextPart (cast c)-                                            , SubReport err']-dslerr (Elaborating s n err) = do err' <- dslerr err-                                  return ([ TextPart $ "When elaborating " ++ s-                                          , NamePart n-                                          , TextPart ":"-                                          , SubReport err']) dslerr _ = Nothing
test/error003/expected view
@@ -1,3 +1,2 @@-In file ErrorReflection.idr line 78 column 5 -        When elaborating right hand side of  Main.bad : -                DSL type error: (t'(504) => t'(504)) doesn't match ()+ErrorReflection.idr:67:5:When elaborating right hand side of bad:+DSL type error: (t(503) => t'(504)) doesn't match ()
test/error004/FunErrTest.idr view
@@ -13,11 +13,11 @@      -> a cadr (x :: (y :: _)) {cons1=refl} {cons2=refl} = y cadr (x :: [])       {cons1=refl} {cons2=refl} impossible+cadr []              {cons1=refl} {cons2=refl} impossible  extractList : TT -> Maybe TT extractList (App (App reflCon (App isCons lst)) _) = Just lst extractList _ = Nothing-  total has2elts : Err -> Maybe (List ErrorReportPart)
test/error004/expected view
@@ -1,4 +1,6 @@ FunErrTest.idr:35:10:When elaborating right hand side of badCadr1:-Could not prove that [] has at least two elements.+When elaborating argument cons1 to function FunErrTest.cadr:+        Could not prove that [] has at least two elements. FunErrTest.idr:38:10:When elaborating right hand side of badCadr2:-Could not prove that tail [(fromInteger 1)] refl has at least two elements.+When elaborating argument cons2 to function FunErrTest.cadr:+        Could not prove that tail [(fromInteger 1)] refl has at least two elements.
+ test/ffi005/Postulate.idr view
@@ -0,0 +1,14 @@+module Main++import Providers++%language TypeProviders++bad : IO (Provider _|_)+bad = pure Postulate++%provide (oops : _|_) with bad++main : IO ()+main = putStrLn "oops"+
+ test/ffi005/Postulate2.idr view
@@ -0,0 +1,13 @@+module Main++import Providers++%language TypeProviders++bad : IO (Provider _|_)+bad = pure Postulate++%provide postulate (oops : _|_) with bad++main : IO ()+main = putStrLn "oops"
+ test/ffi005/Postulate3.idr view
@@ -0,0 +1,13 @@+module Main++import Providers++%language TypeProviders++bad : IO (Provider _|_)+bad = pure Postulate++%provide term (oops : _|_) with bad++main : IO ()+main = putStrLn "oops"
+ test/ffi005/expected view
@@ -0,0 +1,3 @@+oops+oops+Attempted to provide a postulate where a term was expected.
+ test/ffi005/run view
@@ -0,0 +1,12 @@+#!/usr/bin/env bash++idris $@ Postulate.idr -o postulate+./postulate+rm -f postulate *.ibc++idris $@ Postulate2.idr -o postulate+./postulate+rm -f postulate *.ibc++idris $@ Postulate3.idr -o postulate+rm -f postulate *.ibc
+ test/interactive002/expected view
@@ -0,0 +1,11 @@+Type checking ./interactive002.idr+Nat+Nat+Nat+Nat+Vect (n + m) a+Nat+Nat+S n+String+()
+ test/interactive002/input view
@@ -0,0 +1,11 @@+:ps 2 foo_arg1+:ps 2 foo_arg2+:ps 2 foo_arg3+:ps 2 foo_ret+:ps 6 bar_out+:ps 9 plus_in1+:ps 9 plus_out+:ps 13 what+:ps 16 ifoo_arg1+:ps 16 ifoo_out+
+ test/interactive002/interactive002.idr view
@@ -0,0 +1,20 @@++foo : ?foo_arg1 -> ?foo_arg2 -> ?foo_arg3 -> ?foo_ret+foo (S a) b c = plus (a + b + c) 42+foo Z b c = plus b c++bar : Vect n a -> Vect m a -> ?bar_out+bar xs ys = xs ++ ys++myplus : ?plus_in1 -> ?plus_in2 -> ?plus_out+myplus Z y = y+myplus (S k) y = S (myplus k y)++vfun : a -> Vect n a -> Vect n a -> Vect ?what a+vfun v xs ys = v :: ys++ifoo : ?ifoo_arg1 -> IO ?ifoo_out+ifoo x = do putStrLn x+            putStrLn "World"++
+ test/interactive002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --quiet interactive002.idr < input+rm -f *.ibc
+ test/interactive003/expected view
@@ -0,0 +1,5 @@+Type checking ./interactive003.idr+ys+x :: (app xs ys)+[]+f x y :: (vzipWith f xs ys)
+ test/interactive003/input view
@@ -0,0 +1,4 @@+:ps 2 app_rhs_1+:ps 3 app_rhs_2+:ps 6 vzipWith_rhs_3+:ps 7 vzipWith_rhs_1
+ test/interactive003/interactive003.idr view
@@ -0,0 +1,8 @@+app : Vect n a -> Vect m a -> Vect (n + m) a+app [] ys = ?app_rhs_1+app (x :: xs) ys = ?app_rhs_2+    +vzipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c+vzipWith f [] [] = ?vzipWith_rhs_3+vzipWith f (x :: xs) (y :: ys) = ?vzipWith_rhs_1+
+ test/interactive003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --quiet interactive003.idr < input+rm -f *.ibc
test/io001/test004.idr view
@@ -1,6 +1,6 @@ module Main -mwhile : |(test : IO Bool) -> |(body : IO ()) -> IO ()+mwhile : (test : IO Bool) -> (body : IO ()) -> IO () mwhile t b = do v <- t                 case v of                      True => do b
test/io003/test018.idr view
@@ -7,8 +7,7 @@ recvMsg = getMsg  pong : IO ()-pong = do -- putStrLn "Waiting for ping"-          (sender, x) <- recvMsg+pong = do (sender, x) <- recvMsg           putStrLn x           putStrLn "Received"           sendToThread sender "Hello to you too!"
test/proof002/Reflect.idr view
@@ -40,9 +40,10 @@   expr_r (Var i) = (_ ** (RApp RNil i, refl))   expr_r (App ex ey) = let (xl ** (xr, xprf)) = expr_r ex in                        let (yl ** (yr, yprf)) = expr_r ey in-                           appRExpr _ _ xr yr xprf yprf+                               appRExpr _ _ xr yr xprf yprf     where-      appRExpr : (xs', ys' : List a) ->+      appRExpr : (xs', ys' : List a) -> +                 {G : List (List a)} -> {xs, ys : List a} ->                  RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->                  (ws' ** (RExpr G ws', xs' ++ ys' = ws'))       appRExpr x' y' rxs (RApp e i) xprf yprf@@ -173,7 +174,7 @@   rewrite sym xprf;   rewrite sym yprf;   rewrite prf;-  rewrite sym (appendAssociative xs xs2 ys1);+  rewrite sym (appendAssociative xs1 xs2 ys1);   trivial; }
test/proof002/expected view
@@ -1,11 +1,12 @@-test030a.idr:12:14:When elaborating right hand side of testReflect1:-Can't unify-        IsJust (Just x)-with-        IsJust (prove (getProof x))--Specifically:+Reflect.idr:207:38:When elaborating right hand side of testReflect1:+When elaborating an application of function Reflect.getJust:         Can't unify-                Just x+                IsJust (Just x)         with-                Nothing+                IsJust (prove (getProof x))+        +        Specifically:+                Can't unify+                        Just x+                with+                        Nothing
test/reg007/expected view
@@ -1,5 +1,5 @@ reg007.lidr:8:1:A.n is already defined-reg007.lidr:12:9:When elaborating right hand side of hurrah:+reg007.lidr:12:11:When elaborating right hand side of hurrah: Can't unify         n = lala with
test/reg018/expected view
@@ -1,4 +1,4 @@-reg018a.idr:16:1:conat.minusCoNat is not productive+reg018a.idr:16:1:conat.minusCoNat is possibly not total due to recursive path 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 not productive+reg018c.idr:19:1:CodataTest.inf is possibly not total due to: {CodataTest.inf19} reg018d.idr:5:1:Main.pull is not total as there are missing cases
test/reg018/reg018c.idr view
@@ -10,7 +10,7 @@  take : (n: Nat) -> InfStream a -> Vect n a take Z _ = []-take (S n) (x :: xs) = x :: take n xs+take (S n) (x :: xs) = x :: CodataTest.take n xs  hdtl : InfStream a -> (a, InfStream a) hdtl (x :: xs) = (x, xs)
test/reg025/reg025.idr view
@@ -27,10 +27,10 @@ find : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect n a)        -> Either (All (\x => Not (P x)) xs) (y : a ** (P y, (i : Fin n ** y = index i xs))) find _ Nil = Left Nil-find d (x::xs) with (d x)+find {P} d (x::xs) with (d x)   | Yes prf = Right (x ** (prf, (fZ ** refl)))   | No prf =-    case find d xs of+    case find {P} d xs of       Right (y ** (prf', (i ** prf''))) =>         Right (y ** (prf', (fS i ** replace {P=(\x => y = x)} (indexStep {x=x}) prf'')))       Left prf' => Left (prf::prf')
test/reg026/reg026.idr view
@@ -9,6 +9,6 @@ data Action = Left | Ahead | Right  admissible : X t -> Action -> Bool-admissible x Ahead = column x == 0 || column x == 4-admissible x Left  = column x <= 2-admissible x Right = column x >= 2+admissible {t} x Ahead = column {t} x == 0 || column {t} x == 4+admissible {t} x Left  = column {t} x <= 2+admissible {t} x Right = column {t} x >= 2
test/reg027/reg027.idr view
@@ -16,7 +16,7 @@   pure v = \x => v   (<$>) f a = \x => f x (a x) -instance Monad (\x => Int -> x) where +instance Monad IntFn where    f >>= k = \x => k (f x) x  dbl : IntFn Int
+ test/reg034/expected view
@@ -0,0 +1,24 @@+reg034.idr:6:5:When elaborating left hand side of bar:+When elaborating an application of main.bar:+        Can't unify+                [95mx[0m [94m=[0m [95mx[0m+        with+                [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m [95mys[0m+        +        Specifically:+                Can't unify+                        [92mlength[0m [95mys[0m+                with+                        [92mlength[0m [95mxs[0m+reg034.idr:9:5:When elaborating left hand side of foo:+When elaborating an application of main.foo:+        Can't unify+                [95mx[0m [94m=[0m [95mx[0m+        with+                [95mf[0m [95mx[0m [94m=[0m [95mf[0m [95my[0m+        +        Specifically:+                Can't unify+                        [95mf[0m [95my[0m+                with+                        [95mf[0m [95mx[0m
+ test/reg034/reg034.idr view
@@ -0,0 +1,10 @@+module main+import Prelude.List++bar : (xs : List ()) -> (ys : List ()) -> +      Prelude.List.length xs = Prelude.List.length ys -> xs = ys+bar xs xs refl = refl++foo : (f : Nat -> Nat) -> (x : Nat) -> (y : Nat) -> f x = f y -> x = y+foo f x x refl = refl+
+ test/reg034/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check reg034.idr+rm -f reg034 *.ibc
+ test/reg035/expected view
@@ -0,0 +1,4 @@+reg035b.idr:7:6:Can't convert+        [94mAdditive[0m -> [94mNat[0m+with+        [94mFin[0m [91m0[0m
+ test/reg035/reg035.idr view
@@ -0,0 +1,15 @@+elimId : (a : Type) ->+         (a1 : a) ->+         (a2 : a) ->+         (m : (x : a) -> (y : a) -> x = y -> Type) ->+         (f : (x : a) -> m x x refl) ->+         (id : a1 = a2) ->+         m a1 a2 id+elimId _ x _ _ f refl = f x++tran : (a : Type) -> (b : a) -> (c : a) -> (d : a) ->  +       (e : b = c) ->  (f : c = d) ->  b = d+tran = \ a : Type , b : a , c : a , d : a , e : b = c =>+    (elimId a b c (\ f : a , g : a , h : f = g => +                         (i : a) ->  (j : g = i) ->  f = i)+                 (\ f : a , g : a , h : f = g =>  h) e d)
+ test/reg035/reg035a.lidr view
@@ -0,0 +1,66 @@+> module Set++> %default total++> postulate soAndIntro : (p : alpha -> Bool) ->+>                        (q : beta -> Bool) -> +>                        (a : alpha) ->+>                        (b : beta) ->+>                        so (p a) ->+>                        so (q b) ->+>                        so (p a && q b)++> hasNoDuplicates : (Eq alpha) => List alpha -> Bool+> hasNoDuplicates as = as == nub as++> %assert_total+> setEq : (Eq alpha) => List alpha -> List alpha -> Bool+> setEq Nil Nil = True+> setEq Nil (y :: ys) = False+> setEq (x :: xs) Nil = False+> setEq {alpha} (x :: xs) (y :: ys) =+>   (x == y && setEq xs ys) +>   ||+>   (elem x ys && elem y xs && +>    setEq (filter (/= y) xs) (filter (/= x) ys)+>   )++> data Set : Type -> Type where+>   setify : (as : List a) -> Set a++> instance (Eq a) => Eq (Set a) where+>   (==) (setify as) (setify bs) = setEq as bs++> postulate reflexive_Set_eqeq : (Eq a) => +>                                (as : Set a) -> +>                                so (as == as)++> unwrap : Set a -> List a+> unwrap (setify as) = as++> union : Set (Set a) -> Set a+> union (setify ss) = setify (concat (map unwrap ss)) ++> listify : (Eq a) => Set a -> List a+> listify = nub . unwrap++> arePairwiseDisjoint : (Eq a) => Set (Set a) -> Bool+> arePairwiseDisjoint (setify ss) = +>   hasNoDuplicates (concat (map listify ss))++> isPartition : (Eq a) => Set (Set a) -> Set a -> Bool+> isPartition ass as = arePairwiseDisjoint ass && union ass == as++> partitionLemma0 : (Eq alpha) => +>                   (ass : Set (Set alpha)) -> +>                   so (arePairwiseDisjoint ass) ->+>                   so (ass `isPartition` union ass)+> partitionLemma0 ass asspd = (soAndIntro (\ xss => arePairwiseDisjoint xss)+>                                        (\ xs => union ass == xs)+>                                        ass+>                                        (union ass)+>                                        asspd +>                                        uasseqas) where+>   uasseqas : so (union ass == union ass)+>   uasseqas = reflexive_Set_eqeq (union ass)+
+ test/reg035/reg035b.idr view
@@ -0,0 +1,11 @@+import Data.Vect++total+finZEmpty : Fin Z -> a++fins : (n : Nat) -> (xs : Vect n (Fin n) ** ((x : Fin n) -> Elem x xs))+fins Z     = ([] ** (finZEmpty {a=_}))++-- f : (a : Nat) -> a = S a -> _|_+-- f a = believe_me+
+ test/reg035/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris --check reg035.idr+idris --check reg035a.lidr+idris --check reg035b.idr+rm -f *.ibc
+ test/reg036/expected view
+ test/reg036/reg036.idr view
@@ -0,0 +1,12 @@+import Data.HVect+    +using (m : Nat, ts : Vect m Type)+      +  data HV : Vect n Type -> Type where+    MkHV : HVect ts -> HV ts++  showHV : Shows m ts => HV ts -> String+  showHV (MkHV v) = show v++  instance Shows m ts => Show (HV ts) where+    show = showHV
+ test/reg036/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check reg036.idr+rm -f reg036 *.ibc
+ test/reg037/expected view
+ test/reg037/reg037.idr view
@@ -0,0 +1,9 @@++--- Parser regression for (=) as a function name (fnName)++class Foo (t : (A : Type) -> (B : Type) -> A -> B -> Type) where+  foo : (A : Type) -> (B : Type) -> (x : A) -> (y : B) -> t A B x y -> t A B x y++instance Foo (=) where+  foo A B x y prf = prf+
+ test/reg037/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check reg037.idr+rm -f reg037 *.ibc
+ test/reg038/expected view
+ test/reg038/reg038.idr view
@@ -0,0 +1,17 @@+class C t (f : t -> t) (r : t -> t -> Type) where+    g : (a : t) -> r (f a) (f a) -> r (f a) (f a)++data Foo : {t : Type} -> t -> t -> Type where+  MkFoo : {t : Type} -> {x : t} -> {y : t} -> Foo x y++instance C t f (Foo {t = t}) where+  g x = id++data Bar : {t1 : Type} -> {t2 : Type} -> t1 -> t2 -> Type where+  MkBar : {x : t1} -> Bar x x++instance C s f (Bar {t1 = s} {t2 = s}) where+    g x = id++instance C s f ((=) {A = s} {B = s}) where+    g x = id
+ test/reg038/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check reg038.idr+rm -f *.ibc
+ test/totality004/expected view
@@ -0,0 +1,2 @@+[1, 2, 2, 4, 3, 6, 4, 8, 5, 10]+totality004a.idr:13:1:Main.process is possibly not total due to recursive path Main.process --> Main.process --> Main.process
+ test/totality004/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ totality004.idr -o totality004+./totality004+idris $@ --check totality004a.idr +rm -f totality004 *.ibc
+ test/totality004/totality004.idr view
@@ -0,0 +1,25 @@+module Main++%default total++data SP : Type -> Type -> Type where+  get : (a -> SP a b) -> SP a b+  put : b -> Inf (SP a b) -> SP a b++copy : SP a a+copy = get (\x => put x copy)++process : SP a b -> Stream a -> Stream b+process (get f) (x :: xs) = process (f x) xs+process (put b sp) xs = b :: process sp xs++doubleInt : SP Nat Int+doubleInt = get (\x => put (the Int (cast x)) +                        (put (the Int (cast x) * 2) doubleInt))++countStream : Nat -> Stream Nat+countStream x = x :: countStream (x + 1)++main : IO ()+main = print (take 10 (process doubleInt (countStream 1)))+
+ test/totality004/totality004a.idr view
@@ -0,0 +1,25 @@+module Main++%default total++data SP : Type -> Type -> Type where+  get : (a -> SP a b) -> SP a b+  put : b -> Inf (SP a b) -> SP a b++copy : SP a a+copy = get (\x => put x copy)++process : SP a b -> Stream a -> Stream b+process (get f) (x :: xs) = process (f x) xs+process (put b sp) xs = process sp xs++doubleInt : SP Nat Int+doubleInt = get (\x => put (the Int (cast x)) +                        (put (the Int (cast x) * 2) doubleInt))++countStream : Nat -> Stream Nat+countStream x = x :: countStream (x + 1)++main : IO ()+main = print (take 10 (process doubleInt (countStream 1)))+
+ test/totality005/expected view
@@ -0,0 +1,2 @@+totality005.idr:6:1:Main.fib is possibly not total due to recursive path Main.fib+[0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377]
+ test/totality005/run view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+idris $@ totality005.idr --total --check+idris $@ totality005.idr -o totality005+./totality005+rm -f totality005 *.ibc
+ test/totality005/totality005.idr view
@@ -0,0 +1,9 @@++zipWithS : (f : a -> b -> c) -> Stream a -> Stream b -> Stream c+zipWithS f (x :: xs) (y :: ys) = f x y :: zipWithS f xs ys++fib : Stream Nat+fib = 0 :: zipWithS (+) fib (1 :: fib)++main : IO ()+main = print (take 15 fib)
+ test/tutorial001/expected view
+ test/tutorial001/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris --check tutorial001.idr+rm -f *.ibc
+ test/tutorial001/tutorial001.idr view
@@ -0,0 +1,9 @@+foo : Int -> Int+foo x = case isLT of+            Yes => x*2+            No => x*4+   where+      data MyLT = Yes | No+      isLT : MyLT+      isLT = if x < 20 then Yes else No+
+ test/tutorial002/expected view
+ test/tutorial002/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ tutorial002.idr --check+rm -f *.ibc
+ test/tutorial002/tutorial002.idr view
@@ -0,0 +1,61 @@+module Main++data Binary : Nat -> Type where+    bEnd : Binary Z+    bO : Binary n -> Binary (n + n)+    bI : Binary n -> Binary (S (n + n))++instance Show (Binary n) where+    show (bO x) = show x ++ "0"+    show (bI x) = show x ++ "1"+    show bEnd = ""++data Parity : Nat -> Type where+   even : Parity (n + n)+   odd  : Parity (S (n + n))++parity : (n:Nat) -> Parity n+parity Z     = even {n=Z}+parity (S Z) = odd {n=Z}+parity (S (S k)) with (parity k)+    parity (S (S (j + j)))     | even ?= even {n=S j}+    parity (S (S (S (j + j)))) | odd  ?= odd {n=S j}++natToBin : (n:Nat) -> Binary n+natToBin Z = bEnd+natToBin (S k) with (parity k)+   natToBin (S (j + j))     | even  = bI (natToBin j)+   natToBin (S (S (j + j))) | odd  ?= bO (natToBin (S j))++intToNat : Int -> Nat+intToNat 0 = Z+intToNat x = if (x>0) then (S (intToNat (x-1))) else Z++main : IO ()+main = do putStr "Enter a number: "+          x <- getLine+          print (natToBin (fromInteger (cast x)))++---------- Proofs ----------++Main.natToBin_lemma_1 = proof+  intros+  rewrite plusSuccRightSucc j j+  rewrite sym (plusSuccRightSucc j j)+  trivial+++parity_lemma_1 = proof+    intros+    rewrite sym (plusSuccRightSucc j j)+    trivial+++parity_lemma_2 = proof {+    intro;+    intro;+    rewrite sym (plusSuccRightSucc j j);+    trivial;+}++
+ test/tutorial003/expected view
+ test/tutorial003/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ tutorial003.idr --check +rm -f *.ibc
+ test/tutorial003/tutorial003.idr view
@@ -0,0 +1,38 @@+module idiom++data Expr = Var String+          | Val Int+          | Add Expr Expr++data Eval : Type -> Type where+   MkEval : (List (String, Int) -> Maybe a) -> Eval a++fetch : String -> Eval Int+fetch x = MkEval (\e => fetchVal e) where+    fetchVal : List (String, Int) -> Maybe Int+    fetchVal [] = Nothing+    fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)++instance Functor Eval where+    map f (MkEval g) = MkEval (\e => map f (g e))++instance Applicative Eval where+    pure x = MkEval (\e => Just x)++    (<$>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where+       app : Maybe (a -> b) -> Maybe a -> Maybe b+       app (Just fx) (Just gx) = Just (fx gx)+       app _         _         = Nothing++eval : Expr -> Eval Int+eval (Var x)   = fetch x+eval (Val x)   = [| x |]+eval (Add x y) = [| eval x + eval y |]++runEval : List (String, Int) -> Expr -> Maybe Int+runEval env e = case eval e of+    MkEval envFn => envFn env++m_add' : Maybe Int -> Maybe Int -> Maybe Int+m_add' x y = [| x + y |]+
+ test/tutorial004/expected view
+ test/tutorial004/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ tutorial004.idr --check+rm -f *.ibc
+ test/tutorial004/tutorial004.idr view
@@ -0,0 +1,57 @@++fiveIsFive : 5 = 5+fiveIsFive = refl++twoPlusTwo : 2 + 2 = 4+twoPlusTwo = refl++total disjoint : (n : Nat) -> Z = S n -> _|_+disjoint n p = replace {P = disjointTy} p ()+  where+    disjointTy : Nat -> Type+    disjointTy Z = ()+    disjointTy (S k) = _|_++total acyclic : (n : Nat) -> n = S n -> _|_+acyclic Z p = disjoint _ p+acyclic (S k) p = acyclic k (succInjective _ _ p)++empty1 : _|_+empty1 = hd [] where+    hd : List a -> a+    hd (x :: xs) = x++empty2 : _|_+empty2 = empty2++plusReduces : (n:Nat) -> plus Z n = n+plusReduces n = refl++plusReducesZ : (n:Nat) -> n = plus n Z+plusReducesZ Z = refl+plusReducesZ (S k) = cong (plusReducesZ k)++plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)+plusReducesS Z m = refl+plusReducesS (S k) m = cong (plusReducesS k m)++plusReducesZ' : (n:Nat) -> n = plus n Z+plusReducesZ' Z     = ?plusredZ_Z+plusReducesZ' (S k) = let ih = plusReducesZ' k in+                      ?plusredZ_S+++---------- Proofs ----------++plusredZ_S = proof {+    intro;+    intro;+    rewrite ih;+    trivial;+}++plusredZ_Z = proof {+    compute;+    trivial;+}+
+ test/tutorial005/expected view
+ test/tutorial005/run view
@@ -0,0 +1,3 @@+#!/usr/bin/env bash+idris $@ tutorial005.idr --check+rm -f *.ibc
+ test/tutorial005/tutorial005.idr view
@@ -0,0 +1,14 @@+module wheres++even : Nat -> Bool+even Z = True+even (S k) = odd k where+  odd Z = False+  odd (S k) = even k++test : List Nat+test = [c (S 1), c Z, d (S Z)]+  where c x = 42 + x+        d y = c (y + 1 + z y)+              where z w = y + w+
+ test/tutorial006/expected view
@@ -0,0 +1,23 @@+tutorial006a.idr:3:23:When elaborating right hand side of vapp:+When elaborating argument [95mxs[0m to constructor [91mPrelude.Vect.::[0m:+        Can't unify+                [94mVect[0m ([95mn[0m [92m+[0m [95mm[0m) [95ma[0m+        with+                [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m+        +        Specifically:+                Can't unify+                        [92mplus[0m [95mn[0m [95mm[0m+                with+                        [92mplus[0m [95mn[0m [95mm[0m+tutorial006b.idr:10:10:When elaborating right hand side of Main.parity:+Can't unify+        [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m))+with+        [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m)))++Specifically:+        Can't unify+                [92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)+        with+                [91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))
+ test/tutorial006/run view
@@ -0,0 +1,4 @@+#!/usr/bin/env bash+idris $@ tutorial006a.idr --check+idris $@ tutorial006b.idr --check+rm -f *.ibc
+ test/tutorial006/tutorial006a.idr view
@@ -0,0 +1,5 @@+vapp : Vect n a -> Vect m a -> Vect (n + m) a+vapp Nil       ys = ys+vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN++
+ test/tutorial006/tutorial006b.idr view
@@ -0,0 +1,12 @@++data Parity : Nat -> Type where+   even : Parity (n + n)+   odd  : Parity (S (n + n))++parity : (n:Nat) -> Parity n+parity Z     = even {n=Z}+parity (S Z) = odd {n=Z}+parity (S (S k)) with (parity k)+  parity (S (S (j + j)))     | even = even {n=S j}+  parity (S (S (S (j + j)))) | odd  = odd {n=S j}+