diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -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 diff --git a/jsrts/Runtime-common.js b/jsrts/Runtime-common.js --- a/jsrts/Runtime-common.js +++ b/jsrts/Runtime-common.js @@ -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; diff --git a/jsrts/jsbn/jsbn.js b/jsrts/jsbn/jsbn.js --- a/jsrts/jsbn/jsbn.js +++ b/jsrts/jsbn/jsbn.js @@ -1233,3 +1233,6 @@ return new BigInteger(val); } })(); + +var __IDRRT__ZERO = __IDRRT__bigInt("0"); +var __IDRRT__ONE = __IDRRT__bigInt("1"); diff --git a/libs/Makefile b/libs/Makefile --- a/libs/Makefile +++ b/libs/Makefile @@ -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 diff --git a/libs/base/Control/Isomorphism.idr b/libs/base/Control/Isomorphism.idr --- a/libs/base/Control/Isomorphism.idr +++ b/libs/base/Control/Isomorphism.idr @@ -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 }= diff --git a/libs/base/Control/Monad/State.idr b/libs/base/Control/Monad/State.idr --- a/libs/base/Control/Monad/State.idr +++ b/libs/base/Control/Monad/State.idr @@ -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 diff --git a/libs/base/Data/Buffer.idr b/libs/base/Data/Buffer.idr --- a/libs/base/Data/Buffer.idr +++ b/libs/base/Data/Buffer.idr @@ -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 diff --git a/libs/base/Data/Fun.idr b/libs/base/Data/Fun.idr --- a/libs/base/Data/Fun.idr +++ b/libs/base/Data/Fun.idr @@ -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 + diff --git a/libs/base/Data/HVect.idr b/libs/base/Data/HVect.idr --- a/libs/base/Data/HVect.idr +++ b/libs/base/Data/HVect.idr @@ -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 diff --git a/libs/base/Data/Sign.idr b/libs/base/Data/Sign.idr --- a/libs/base/Data/Sign.idr +++ b/libs/base/Data/Sign.idr @@ -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 diff --git a/libs/base/Data/SortedMap.idr b/libs/base/Data/SortedMap.idr --- a/libs/base/Data/SortedMap.idr +++ b/libs/base/Data/SortedMap.idr @@ -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 diff --git a/libs/base/Data/Vect.idr b/libs/base/Data/Vect.idr --- a/libs/base/Data/Vect.idr +++ b/libs/base/Data/Vect.idr @@ -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))) diff --git a/libs/base/Data/ZZ.idr b/libs/base/Data/ZZ.idr --- a/libs/base/Data/ZZ.idr +++ b/libs/base/Data/ZZ.idr @@ -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 diff --git a/libs/base/Debug/Trace.idr b/libs/base/Debug/Trace.idr --- a/libs/base/Debug/Trace.idr +++ b/libs/base/Debug/Trace.idr @@ -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) diff --git a/libs/base/Decidable/Order.idr b/libs/base/Decidable/Order.idr --- a/libs/base/Decidable/Order.idr +++ b/libs/base/Decidable/Order.idr @@ -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)) + diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr --- a/libs/base/Language/Reflection.idr +++ b/libs/base/Language/Reflection.idr @@ -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 diff --git a/libs/base/Language/Reflection/Errors.idr b/libs/base/Language/Reflection/Errors.idr --- a/libs/base/Language/Reflection/Errors.idr +++ b/libs/base/Language/Reflection/Errors.idr @@ -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 diff --git a/libs/base/Language/Reflection/Utils.idr b/libs/base/Language/Reflection/Utils.idr --- a/libs/base/Language/Reflection/Utils.idr +++ b/libs/base/Language/Reflection/Utils.idr @@ -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 ++ ")" diff --git a/libs/base/Providers.idr b/libs/base/Providers.idr --- a/libs/base/Providers.idr +++ b/libs/base/Providers.idr @@ -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 diff --git a/libs/base/System.idr b/libs/base/System.idr --- a/libs/base/System.idr +++ b/libs/base/System.idr @@ -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 diff --git a/libs/base/System/Concurrency/Process.idr b/libs/base/System/Concurrency/Process.idr --- a/libs/base/System/Concurrency/Process.idr +++ b/libs/base/System/Concurrency/Process.idr @@ -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) diff --git a/libs/base/Uninhabited.idr b/libs/base/Uninhabited.idr deleted file mode 100644 --- a/libs/base/Uninhabited.idr +++ /dev/null @@ -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) diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -10,8 +10,6 @@ Decidable.Decidable, Decidable.Order, - Uninhabited, - Providers, Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, diff --git a/libs/effects/Effect/Default.idr b/libs/effects/Effect/Default.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/Default.idr @@ -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 + diff --git a/libs/effects/Effect/Exception.idr b/libs/effects/Effect/Exception.idr --- a/libs/effects/Effect/Exception.idr +++ b/libs/effects/Effect/Exception.idr @@ -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 - diff --git a/libs/effects/Effect/File.idr b/libs/effects/Effect/File.idr --- a/libs/effects/Effect/File.idr +++ b/libs/effects/Effect/File.idr @@ -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 ] diff --git a/libs/effects/Effect/Memory.idr b/libs/effects/Effect/Memory.idr --- a/libs/effects/Effect/Memory.idr +++ b/libs/effects/Effect/Memory.idr @@ -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 diff --git a/libs/effects/Effect/Monad.idr b/libs/effects/Effect/Monad.idr --- a/libs/effects/Effect/Monad.idr +++ b/libs/effects/Effect/Monad.idr @@ -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.(>>=) diff --git a/libs/effects/Effect/Random.idr b/libs/effects/Effect/Random.idr --- a/libs/effects/Effect/Random.idr +++ b/libs/effects/Effect/Random.idr @@ -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 diff --git a/libs/effects/Effect/Select.idr b/libs/effects/Effect/Select.idr --- a/libs/effects/Effect/Select.idr +++ b/libs/effects/Effect/Select.idr @@ -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 diff --git a/libs/effects/Effect/State.idr b/libs/effects/Effect/State.idr --- a/libs/effects/Effect/State.idr +++ b/libs/effects/Effect/State.idr @@ -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 diff --git a/libs/effects/Effect/StdIO.idr b/libs/effects/Effect/StdIO.idr --- a/libs/effects/Effect/StdIO.idr +++ b/libs/effects/Effect/StdIO.idr @@ -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 diff --git a/libs/effects/Effect/System.idr b/libs/effects/Effect/System.idr new file mode 100644 --- /dev/null +++ b/libs/effects/Effect/System.idr @@ -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 + diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr --- a/libs/effects/Effects.idr +++ b/libs/effects/Effects.idr @@ -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 ] diff --git a/libs/effects/effects.ipkg b/libs/effects/effects.ipkg --- a/libs/effects/effects.ipkg +++ b/libs/effects/effects.ipkg @@ -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 diff --git a/libs/javascript/JavaScript/JSON.idr b/libs/javascript/JavaScript/JSON.idr --- a/libs/javascript/JavaScript/JSON.idr +++ b/libs/javascript/JavaScript/JSON.idr @@ -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)) diff --git a/libs/neweffects/Effect/Default.idr b/libs/neweffects/Effect/Default.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Default.idr +++ /dev/null @@ -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 - diff --git a/libs/neweffects/Effect/Exception.idr b/libs/neweffects/Effect/Exception.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Exception.idr +++ /dev/null @@ -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? - diff --git a/libs/neweffects/Effect/File.idr b/libs/neweffects/Effect/File.idr deleted file mode 100644 --- a/libs/neweffects/Effect/File.idr +++ /dev/null @@ -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 - - - - diff --git a/libs/neweffects/Effect/Memory.idr b/libs/neweffects/Effect/Memory.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Memory.idr +++ /dev/null @@ -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 () - diff --git a/libs/neweffects/Effect/Monad.idr b/libs/neweffects/Effect/Monad.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Monad.idr +++ /dev/null @@ -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.(>>=) - - diff --git a/libs/neweffects/Effect/Random.idr b/libs/neweffects/Effect/Random.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Random.idr +++ /dev/null @@ -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 - diff --git a/libs/neweffects/Effect/Select.idr b/libs/neweffects/Effect/Select.idr deleted file mode 100644 --- a/libs/neweffects/Effect/Select.idr +++ /dev/null @@ -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 - diff --git a/libs/neweffects/Effect/State.idr b/libs/neweffects/Effect/State.idr deleted file mode 100644 --- a/libs/neweffects/Effect/State.idr +++ /dev/null @@ -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 - diff --git a/libs/neweffects/Effect/StdIO.idr b/libs/neweffects/Effect/StdIO.idr deleted file mode 100644 --- a/libs/neweffects/Effect/StdIO.idr +++ /dev/null @@ -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 - diff --git a/libs/neweffects/Effects.idr b/libs/neweffects/Effects.idr deleted file mode 100644 --- a/libs/neweffects/Effects.idr +++ /dev/null @@ -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 () - diff --git a/libs/neweffects/Makefile b/libs/neweffects/Makefile deleted file mode 100644 --- a/libs/neweffects/Makefile +++ /dev/null @@ -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 diff --git a/libs/neweffects/neweffects.ipkg b/libs/neweffects/neweffects.ipkg deleted file mode 100644 --- a/libs/neweffects/neweffects.ipkg +++ /dev/null @@ -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 - diff --git a/libs/oldeffects/Effect/Exception.idr b/libs/oldeffects/Effect/Exception.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/Exception.idr @@ -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? + diff --git a/libs/oldeffects/Effect/File.idr b/libs/oldeffects/Effect/File.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/File.idr @@ -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 + + + + diff --git a/libs/oldeffects/Effect/Memory.idr b/libs/oldeffects/Effect/Memory.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/Memory.idr @@ -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 () + diff --git a/libs/oldeffects/Effect/Monad.idr b/libs/oldeffects/Effect/Monad.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/Monad.idr @@ -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 + + diff --git a/libs/oldeffects/Effect/Random.idr b/libs/oldeffects/Effect/Random.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/Random.idr @@ -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 + diff --git a/libs/oldeffects/Effect/Select.idr b/libs/oldeffects/Effect/Select.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/Select.idr @@ -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 + diff --git a/libs/oldeffects/Effect/State.idr b/libs/oldeffects/Effect/State.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/State.idr @@ -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 + diff --git a/libs/oldeffects/Effect/StdIO.idr b/libs/oldeffects/Effect/StdIO.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effect/StdIO.idr @@ -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 + + diff --git a/libs/oldeffects/Effects.idr b/libs/oldeffects/Effects.idr new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Effects.idr @@ -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 () diff --git a/libs/oldeffects/Makefile b/libs/oldeffects/Makefile new file mode 100644 --- /dev/null +++ b/libs/oldeffects/Makefile @@ -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 diff --git a/libs/oldeffects/oldeffects.ipkg b/libs/oldeffects/oldeffects.ipkg new file mode 100644 --- /dev/null +++ b/libs/oldeffects/oldeffects.ipkg @@ -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 + diff --git a/libs/prelude/Builtins.idr b/libs/prelude/Builtins.idr --- a/libs/prelude/Builtins.idr +++ b/libs/prelude/Builtins.idr @@ -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 diff --git a/libs/prelude/Decidable/Equality.idr b/libs/prelude/Decidable/Equality.idr --- a/libs/prelude/Decidable/Equality.idr +++ b/libs/prelude/Decidable/Equality.idr @@ -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 -> _|_ diff --git a/libs/prelude/IO.idr b/libs/prelude/IO.idr --- a/libs/prelude/IO.idr +++ b/libs/prelude/IO.idr @@ -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 diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -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 diff --git a/libs/prelude/Prelude/Applicative.idr b/libs/prelude/Prelude/Applicative.idr --- a/libs/prelude/Prelude/Applicative.idr +++ b/libs/prelude/Prelude/Applicative.idr @@ -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 diff --git a/libs/prelude/Prelude/Basics.idr b/libs/prelude/Prelude/Basics.idr --- a/libs/prelude/Prelude/Basics.idr +++ b/libs/prelude/Prelude/Basics.idr @@ -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 diff --git a/libs/prelude/Prelude/Bits.idr b/libs/prelude/Prelude/Bits.idr --- a/libs/prelude/Prelude/Bits.idr +++ b/libs/prelude/Prelude/Bits.idr @@ -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 diff --git a/libs/prelude/Prelude/Bool.idr b/libs/prelude/Prelude/Bool.idr --- a/libs/prelude/Prelude/Bool.idr +++ b/libs/prelude/Prelude/Bool.idr @@ -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 diff --git a/libs/prelude/Prelude/Chars.idr b/libs/prelude/Prelude/Chars.idr --- a/libs/prelude/Prelude/Chars.idr +++ b/libs/prelude/Prelude/Chars.idr @@ -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 ] + diff --git a/libs/prelude/Prelude/Classes.idr b/libs/prelude/Prelude/Classes.idr --- a/libs/prelude/Prelude/Classes.idr +++ b/libs/prelude/Prelude/Classes.idr @@ -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 diff --git a/libs/prelude/Prelude/Either.idr b/libs/prelude/Prelude/Either.idr --- a/libs/prelude/Prelude/Either.idr +++ b/libs/prelude/Prelude/Either.idr @@ -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 diff --git a/libs/prelude/Prelude/Fin.idr b/libs/prelude/Prelude/Fin.idr --- a/libs/prelude/Prelude/Fin.idr +++ b/libs/prelude/Prelude/Fin.idr @@ -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 diff --git a/libs/prelude/Prelude/Functor.idr b/libs/prelude/Prelude/Functor.idr --- a/libs/prelude/Prelude/Functor.idr +++ b/libs/prelude/Prelude/Functor.idr @@ -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 diff --git a/libs/prelude/Prelude/List.idr b/libs/prelude/Prelude/List.idr --- a/libs/prelude/Prelude/List.idr +++ b/libs/prelude/Prelude/List.idr @@ -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; diff --git a/libs/prelude/Prelude/Maybe.idr b/libs/prelude/Prelude/Maybe.idr --- a/libs/prelude/Prelude/Maybe.idr +++ b/libs/prelude/Prelude/Maybe.idr @@ -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 -- : "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." diff --git a/libs/prelude/Prelude/Monad.idr b/libs/prelude/Prelude/Monad.idr --- a/libs/prelude/Prelude/Monad.idr +++ b/libs/prelude/Prelude/Monad.idr @@ -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 diff --git a/libs/prelude/Prelude/Nat.idr b/libs/prelude/Prelude/Nat.idr --- a/libs/prelude/Prelude/Nat.idr +++ b/libs/prelude/Prelude/Nat.idr @@ -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 diff --git a/libs/prelude/Prelude/Stream.idr b/libs/prelude/Prelude/Stream.idr --- a/libs/prelude/Prelude/Stream.idr +++ b/libs/prelude/Prelude/Stream.idr @@ -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) diff --git a/libs/prelude/Prelude/Strings.idr b/libs/prelude/Prelude/Strings.idr --- a/libs/prelude/Prelude/Strings.idr +++ b/libs/prelude/Prelude/Strings.idr @@ -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 diff --git a/libs/prelude/Prelude/Uninhabited.idr b/libs/prelude/Prelude/Uninhabited.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Prelude/Uninhabited.idr @@ -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) diff --git a/libs/prelude/Prelude/Vect.idr b/libs/prelude/Prelude/Vect.idr --- a/libs/prelude/Prelude/Vect.idr +++ b/libs/prelude/Prelude/Vect.idr @@ -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; } diff --git a/libs/prelude/prelude.ipkg b/libs/prelude/prelude.ipkg --- a/libs/prelude/prelude.ipkg +++ b/libs/prelude/prelude.ipkg @@ -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 diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -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" ++ diff --git a/rts/Makefile b/rts/Makefile --- a/rts/Makefile +++ b/rts/Makefile @@ -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 diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -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; diff --git a/rts/idris_net.c b/rts/idris_net.c --- a/rts/idris_net.c +++ b/rts/idris_net.c @@ -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; diff --git a/rts/idris_net.h b/rts/idris_net.h --- a/rts/idris_net.h +++ b/rts/idris_net.h @@ -9,6 +9,7 @@ #include #include #include +#include typedef struct idrnet_recv_result { int result; diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -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); diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -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); diff --git a/rts/idris_stdfgn.c b/rts/idris_stdfgn.c --- a/rts/idris_stdfgn.c +++ b/rts/idris_stdfgn.c @@ -1,5 +1,10 @@ #include "idris_stdfgn.h" #include "idris_rts.h" +#include "idris_gc.h" +#include +#include +#include +#include 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); } diff --git a/rts/idris_stdfgn.h b/rts/idris_stdfgn.h --- a/rts/idris_stdfgn.h +++ b/rts/idris_stdfgn.h @@ -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 diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -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) diff --git a/src/IRTS/CodegenCommon.hs b/src/IRTS/CodegenCommon.hs --- a/src/IRTS/CodegenCommon.hs +++ b/src/IRTS/CodegenCommon.hs @@ -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 () diff --git a/src/IRTS/CodegenJava.hs b/src/IRTS/CodegenJava.hs --- a/src/IRTS/CodegenJava.hs +++ b/src/IRTS/CodegenJava.hs @@ -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) diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -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 diff --git a/src/IRTS/CodegenLLVM.hs b/src/IRTS/CodegenLLVM.hs --- a/src/IRTS/CodegenLLVM.hs +++ b/src/IRTS/CodegenLLVM.hs @@ -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' diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -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 diff --git a/src/IRTS/Defunctionalise.hs b/src/IRTS/Defunctionalise.hs --- a/src/IRTS/Defunctionalise.hs +++ b/src/IRTS/Defunctionalise.hs @@ -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 diff --git a/src/IRTS/Lang.hs b/src/IRTS/Lang.hs --- a/src/IRTS/Lang.hs +++ b/src/IRTS/Lang.hs @@ -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) diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -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) diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -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 diff --git a/src/Idris/Apropos.hs b/src/Idris/Apropos.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Apropos.hs @@ -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 diff --git a/src/Idris/CaseSplit.hs b/src/Idris/CaseSplit.hs --- a/src/Idris/CaseSplit.hs +++ b/src/Idris/CaseSplit.hs @@ -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 _ _ = "" diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -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 diff --git a/src/Idris/Colours.hs b/src/Idris/Colours.hs --- a/src/Idris/Colours.hs +++ b/src/Idris/Colours.hs @@ -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 diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -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! diff --git a/src/Idris/Core/CaseTree.hs b/src/Idris/Core/CaseTree.hs --- a/src/Idris/Core/CaseTree.hs +++ b/src/Idris/Core/CaseTree.hs @@ -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) diff --git a/src/Idris/Core/DeepSeq.hs b/src/Idris/Core/DeepSeq.hs --- a/src/Idris/Core/DeepSeq.hs +++ b/src/Idris/Core/DeepSeq.hs @@ -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` () diff --git a/src/Idris/Core/Elaborate.hs b/src/Idris/Core/Elaborate.hs --- a/src/Idris/Core/Elaborate.hs +++ b/src/Idris/Core/Elaborate.hs @@ -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 diff --git a/src/Idris/Core/Evaluate.hs b/src/Idris/Core/Evaluate.hs --- a/src/Idris/Core/Evaluate.hs +++ b/src/Idris/Core/Evaluate.hs @@ -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 diff --git a/src/Idris/Core/Execute.hs b/src/Idris/Core/Execute.hs --- a/src/Idris/Core/Execute.hs +++ b/src/Idris/Core/Execute.hs @@ -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 diff --git a/src/Idris/Core/ProofState.hs b/src/Idris/Core/ProofState.hs --- a/src/Idris/Core/ProofState.hs +++ b/src/Idris/Core/ProofState.hs @@ -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') diff --git a/src/Idris/Core/TT.hs b/src/Idris/Core/TT.hs --- a/src/Idris/Core/TT.hs +++ b/src/Idris/Core/TT.hs @@ -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 diff --git a/src/Idris/Core/Typecheck.hs b/src/Idris/Core/Typecheck.hs --- a/src/Idris/Core/Typecheck.hs +++ b/src/Idris/Core/Typecheck.hs @@ -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)) diff --git a/src/Idris/Core/Unify.hs b/src/Idris/Core/Unify.hs --- a/src/Idris/Core/Unify.hs +++ b/src/Idris/Core/Unify.hs @@ -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) diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -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 diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -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) diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -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) diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -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 diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -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 _ _ = [] diff --git a/src/Idris/Docstrings.hs b/src/Idris/Docstrings.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Docstrings.hs @@ -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 "" -- 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 "" -- TODO +renderInline (CT.Entity a) = text $ "" -- TODO +renderInline (CT.RawHtml txt) = text "" --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) diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -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." diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -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) diff --git a/src/Idris/ErrReverse.hs b/src/Idris/ErrReverse.hs --- a/src/Idris/ErrReverse.hs +++ b/src/Idris/ErrReverse.hs @@ -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 diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -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 diff --git a/src/Idris/Help.hs b/src/Idris/Help.hs --- a/src/Idris/Help.hs +++ b/src/Idris/Help.hs @@ -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"), diff --git a/src/Idris/IBC.hs b/src/Idris/IBC.hs --- a/src/Idris/IBC.hs +++ b/src/Idris/IBC.hs @@ -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'" diff --git a/src/Idris/IdeSlave.hs b/src/Idris/IdeSlave.hs --- a/src/Idris/IdeSlave.hs +++ b/src/Idris/IdeSlave.hs @@ -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) diff --git a/src/Idris/Output.hs b/src/Idris/Output.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Output.hs @@ -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 diff --git a/src/Idris/ParseData.hs b/src/Idris/ParseData.hs --- a/src/Idris/ParseData.hs +++ b/src/Idris/ParseData.hs @@ -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 diff --git a/src/Idris/ParseExpr.hs b/src/Idris/ParseExpr.hs --- a/src/Idris/ParseExpr.hs +++ b/src/Idris/ParseExpr.hs @@ -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 diff --git a/src/Idris/ParseHelpers.hs b/src/Idris/ParseHelpers.hs --- a/src/Idris/ParseHelpers.hs +++ b/src/Idris/ParseHelpers.hs @@ -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 diff --git a/src/Idris/ParseOps.hs b/src/Idris/ParseOps.hs --- a/src/Idris/ParseOps.hs +++ b/src/Idris/ParseOps.hs @@ -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) diff --git a/src/Idris/Parser.hs b/src/Idris/Parser.hs --- a/src/Idris/Parser.hs +++ b/src/Idris/Parser.hs @@ -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] diff --git a/src/Idris/PartialEval.hs b/src/Idris/PartialEval.hs --- a/src/Idris/PartialEval.hs +++ b/src/Idris/PartialEval.hs @@ -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 [] [] _ _ = [] diff --git a/src/Idris/Primitives.hs b/src/Idris/Primitives.hs --- a/src/Idris/Primitives.hs +++ b/src/Idris/Primitives.hs @@ -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, diff --git a/src/Idris/ProofSearch.hs b/src/Idris/ProofSearch.hs --- a/src/Idris/ProofSearch.hs +++ b/src/Idris/ProofSearch.hs @@ -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) diff --git a/src/Idris/Prover.hs b/src/Idris/Prover.hs --- a/src/Idris/Prover.hs +++ b/src/Idris/Prover.hs @@ -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 diff --git a/src/Idris/Providers.hs b/src/Idris/Providers.hs --- a/src/Idris/Providers.hs +++ b/src/Idris/Providers.hs @@ -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." diff --git a/src/Idris/REPL.hs b/src/Idris/REPL.hs --- a/src/Idris/REPL.hs +++ b/src/Idris/REPL.hs @@ -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) diff --git a/src/Idris/REPLParser.hs b/src/Idris/REPLParser.hs --- a/src/Idris/REPLParser.hs +++ b/src/Idris/REPLParser.hs @@ -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 diff --git a/src/Idris/Unlit.hs b/src/Idris/Unlit.hs --- a/src/Idris/Unlit.hs +++ b/src/Idris/Unlit.hs @@ -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 () diff --git a/src/Pkg/Package.hs b/src/Pkg/Package.hs --- a/src/Pkg/Package.hs +++ b/src/Pkg/Package.hs @@ -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 () diff --git a/src/Util/DynamicLinker.hs b/src/Util/DynamicLinker.hs --- a/src/Util/DynamicLinker.hs +++ b/src/Util/DynamicLinker.hs @@ -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 diff --git a/src/Util/LLVMStubs.hs b/src/Util/LLVMStubs.hs --- a/src/Util/LLVMStubs.hs +++ b/src/Util/LLVMStubs.hs @@ -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." diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -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 diff --git a/test/basic002/test006.idr b/test/basic002/test006.idr --- a/test/basic002/test006.idr +++ b/test/basic002/test006.idr @@ -36,4 +36,3 @@ trivial; }; - diff --git a/test/basic006/expected b/test/basic006/expected --- a/test/basic006/expected +++ b/test/basic006/expected @@ -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" diff --git a/test/basic009/expected b/test/basic009/expected --- a/test/basic009/expected +++ b/test/basic009/expected @@ -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" diff --git a/test/dsl001/test001.idr b/test/dsl001/test001.idr --- a/test/dsl001/test001.idr +++ b/test/dsl001/test001.idr @@ -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 diff --git a/test/dsl002/Resimp.idr b/test/dsl002/Resimp.idr --- a/test/dsl002/Resimp.idr +++ b/test/dsl002/Resimp.idr @@ -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) -> diff --git a/test/effects001/test021.idr b/test/effects001/test021.idr --- a/test/effects001/test021.idr +++ b/test/effects001/test021.idr @@ -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 diff --git a/test/effects001/test021a.idr b/test/effects001/test021a.idr --- a/test/effects001/test021a.idr +++ b/test/effects001/test021a.idr @@ -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 diff --git a/test/effects002/test025.idr b/test/effects002/test025.idr --- a/test/effects002/test025.idr +++ b/test/effects002/test025.idr @@ -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) diff --git a/test/error003/ErrorReflection.idr b/test/error003/ErrorReflection.idr --- a/test/error003/ErrorReflection.idr +++ b/test/error003/ErrorReflection.idr @@ -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 diff --git a/test/error003/expected b/test/error003/expected --- a/test/error003/expected +++ b/test/error003/expected @@ -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 () diff --git a/test/error004/FunErrTest.idr b/test/error004/FunErrTest.idr --- a/test/error004/FunErrTest.idr +++ b/test/error004/FunErrTest.idr @@ -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) diff --git a/test/error004/expected b/test/error004/expected --- a/test/error004/expected +++ b/test/error004/expected @@ -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. diff --git a/test/ffi005/Postulate.idr b/test/ffi005/Postulate.idr new file mode 100644 --- /dev/null +++ b/test/ffi005/Postulate.idr @@ -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" + diff --git a/test/ffi005/Postulate2.idr b/test/ffi005/Postulate2.idr new file mode 100644 --- /dev/null +++ b/test/ffi005/Postulate2.idr @@ -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" diff --git a/test/ffi005/Postulate3.idr b/test/ffi005/Postulate3.idr new file mode 100644 --- /dev/null +++ b/test/ffi005/Postulate3.idr @@ -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" diff --git a/test/ffi005/expected b/test/ffi005/expected new file mode 100644 --- /dev/null +++ b/test/ffi005/expected @@ -0,0 +1,3 @@ +oops +oops +Attempted to provide a postulate where a term was expected. diff --git a/test/ffi005/run b/test/ffi005/run new file mode 100644 --- /dev/null +++ b/test/ffi005/run @@ -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 diff --git a/test/interactive002/expected b/test/interactive002/expected new file mode 100644 --- /dev/null +++ b/test/interactive002/expected @@ -0,0 +1,11 @@ +Type checking ./interactive002.idr +Nat +Nat +Nat +Nat +Vect (n + m) a +Nat +Nat +S n +String +() diff --git a/test/interactive002/input b/test/interactive002/input new file mode 100644 --- /dev/null +++ b/test/interactive002/input @@ -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 + diff --git a/test/interactive002/interactive002.idr b/test/interactive002/interactive002.idr new file mode 100644 --- /dev/null +++ b/test/interactive002/interactive002.idr @@ -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" + + diff --git a/test/interactive002/run b/test/interactive002/run new file mode 100644 --- /dev/null +++ b/test/interactive002/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --quiet interactive002.idr < input +rm -f *.ibc diff --git a/test/interactive003/expected b/test/interactive003/expected new file mode 100644 --- /dev/null +++ b/test/interactive003/expected @@ -0,0 +1,5 @@ +Type checking ./interactive003.idr +ys +x :: (app xs ys) +[] +f x y :: (vzipWith f xs ys) diff --git a/test/interactive003/input b/test/interactive003/input new file mode 100644 --- /dev/null +++ b/test/interactive003/input @@ -0,0 +1,4 @@ +:ps 2 app_rhs_1 +:ps 3 app_rhs_2 +:ps 6 vzipWith_rhs_3 +:ps 7 vzipWith_rhs_1 diff --git a/test/interactive003/interactive003.idr b/test/interactive003/interactive003.idr new file mode 100644 --- /dev/null +++ b/test/interactive003/interactive003.idr @@ -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 + diff --git a/test/interactive003/run b/test/interactive003/run new file mode 100644 --- /dev/null +++ b/test/interactive003/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --quiet interactive003.idr < input +rm -f *.ibc diff --git a/test/io001/test004.idr b/test/io001/test004.idr --- a/test/io001/test004.idr +++ b/test/io001/test004.idr @@ -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 diff --git a/test/io003/test018.idr b/test/io003/test018.idr --- a/test/io003/test018.idr +++ b/test/io003/test018.idr @@ -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!" diff --git a/test/proof002/Reflect.idr b/test/proof002/Reflect.idr --- a/test/proof002/Reflect.idr +++ b/test/proof002/Reflect.idr @@ -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; } diff --git a/test/proof002/expected b/test/proof002/expected --- a/test/proof002/expected +++ b/test/proof002/expected @@ -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 diff --git a/test/reg007/expected b/test/reg007/expected --- a/test/reg007/expected +++ b/test/reg007/expected @@ -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 diff --git a/test/reg018/expected b/test/reg018/expected --- a/test/reg018/expected +++ b/test/reg018/expected @@ -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 diff --git a/test/reg018/reg018c.idr b/test/reg018/reg018c.idr --- a/test/reg018/reg018c.idr +++ b/test/reg018/reg018c.idr @@ -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) diff --git a/test/reg025/reg025.idr b/test/reg025/reg025.idr --- a/test/reg025/reg025.idr +++ b/test/reg025/reg025.idr @@ -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') diff --git a/test/reg026/reg026.idr b/test/reg026/reg026.idr --- a/test/reg026/reg026.idr +++ b/test/reg026/reg026.idr @@ -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 diff --git a/test/reg027/reg027.idr b/test/reg027/reg027.idr --- a/test/reg027/reg027.idr +++ b/test/reg027/reg027.idr @@ -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 diff --git a/test/reg034/expected b/test/reg034/expected new file mode 100644 --- /dev/null +++ b/test/reg034/expected @@ -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 + x = x + with + length xs = length ys + + Specifically: + Can't unify + length ys + with + length xs +reg034.idr:9:5:When elaborating left hand side of foo: +When elaborating an application of main.foo: + Can't unify + x = x + with + f x = f y + + Specifically: + Can't unify + f y + with + f x diff --git a/test/reg034/reg034.idr b/test/reg034/reg034.idr new file mode 100644 --- /dev/null +++ b/test/reg034/reg034.idr @@ -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 + diff --git a/test/reg034/run b/test/reg034/run new file mode 100644 --- /dev/null +++ b/test/reg034/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check reg034.idr +rm -f reg034 *.ibc diff --git a/test/reg035/expected b/test/reg035/expected new file mode 100644 --- /dev/null +++ b/test/reg035/expected @@ -0,0 +1,4 @@ +reg035b.idr:7:6:Can't convert + Additive -> Nat +with + Fin 0 diff --git a/test/reg035/reg035.idr b/test/reg035/reg035.idr new file mode 100644 --- /dev/null +++ b/test/reg035/reg035.idr @@ -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) diff --git a/test/reg035/reg035a.lidr b/test/reg035/reg035a.lidr new file mode 100644 --- /dev/null +++ b/test/reg035/reg035a.lidr @@ -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) + diff --git a/test/reg035/reg035b.idr b/test/reg035/reg035b.idr new file mode 100644 --- /dev/null +++ b/test/reg035/reg035b.idr @@ -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 + diff --git a/test/reg035/run b/test/reg035/run new file mode 100644 --- /dev/null +++ b/test/reg035/run @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +idris --check reg035.idr +idris --check reg035a.lidr +idris --check reg035b.idr +rm -f *.ibc diff --git a/test/reg036/expected b/test/reg036/expected new file mode 100644 --- /dev/null +++ b/test/reg036/expected diff --git a/test/reg036/reg036.idr b/test/reg036/reg036.idr new file mode 100644 --- /dev/null +++ b/test/reg036/reg036.idr @@ -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 diff --git a/test/reg036/run b/test/reg036/run new file mode 100644 --- /dev/null +++ b/test/reg036/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check reg036.idr +rm -f reg036 *.ibc diff --git a/test/reg037/expected b/test/reg037/expected new file mode 100644 --- /dev/null +++ b/test/reg037/expected diff --git a/test/reg037/reg037.idr b/test/reg037/reg037.idr new file mode 100644 --- /dev/null +++ b/test/reg037/reg037.idr @@ -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 + diff --git a/test/reg037/run b/test/reg037/run new file mode 100644 --- /dev/null +++ b/test/reg037/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check reg037.idr +rm -f reg037 *.ibc diff --git a/test/reg038/expected b/test/reg038/expected new file mode 100644 --- /dev/null +++ b/test/reg038/expected diff --git a/test/reg038/reg038.idr b/test/reg038/reg038.idr new file mode 100644 --- /dev/null +++ b/test/reg038/reg038.idr @@ -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 diff --git a/test/reg038/run b/test/reg038/run new file mode 100644 --- /dev/null +++ b/test/reg038/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check reg038.idr +rm -f *.ibc diff --git a/test/totality004/expected b/test/totality004/expected new file mode 100644 --- /dev/null +++ b/test/totality004/expected @@ -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 diff --git a/test/totality004/run b/test/totality004/run new file mode 100644 --- /dev/null +++ b/test/totality004/run @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +idris $@ totality004.idr -o totality004 +./totality004 +idris $@ --check totality004a.idr +rm -f totality004 *.ibc diff --git a/test/totality004/totality004.idr b/test/totality004/totality004.idr new file mode 100644 --- /dev/null +++ b/test/totality004/totality004.idr @@ -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))) + diff --git a/test/totality004/totality004a.idr b/test/totality004/totality004a.idr new file mode 100644 --- /dev/null +++ b/test/totality004/totality004a.idr @@ -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))) + diff --git a/test/totality005/expected b/test/totality005/expected new file mode 100644 --- /dev/null +++ b/test/totality005/expected @@ -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] diff --git a/test/totality005/run b/test/totality005/run new file mode 100644 --- /dev/null +++ b/test/totality005/run @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +idris $@ totality005.idr --total --check +idris $@ totality005.idr -o totality005 +./totality005 +rm -f totality005 *.ibc diff --git a/test/totality005/totality005.idr b/test/totality005/totality005.idr new file mode 100644 --- /dev/null +++ b/test/totality005/totality005.idr @@ -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) diff --git a/test/tutorial001/expected b/test/tutorial001/expected new file mode 100644 --- /dev/null +++ b/test/tutorial001/expected diff --git a/test/tutorial001/run b/test/tutorial001/run new file mode 100644 --- /dev/null +++ b/test/tutorial001/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris --check tutorial001.idr +rm -f *.ibc diff --git a/test/tutorial001/tutorial001.idr b/test/tutorial001/tutorial001.idr new file mode 100644 --- /dev/null +++ b/test/tutorial001/tutorial001.idr @@ -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 + diff --git a/test/tutorial002/expected b/test/tutorial002/expected new file mode 100644 --- /dev/null +++ b/test/tutorial002/expected diff --git a/test/tutorial002/run b/test/tutorial002/run new file mode 100644 --- /dev/null +++ b/test/tutorial002/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ tutorial002.idr --check +rm -f *.ibc diff --git a/test/tutorial002/tutorial002.idr b/test/tutorial002/tutorial002.idr new file mode 100644 --- /dev/null +++ b/test/tutorial002/tutorial002.idr @@ -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; +} + + diff --git a/test/tutorial003/expected b/test/tutorial003/expected new file mode 100644 --- /dev/null +++ b/test/tutorial003/expected diff --git a/test/tutorial003/run b/test/tutorial003/run new file mode 100644 --- /dev/null +++ b/test/tutorial003/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ tutorial003.idr --check +rm -f *.ibc diff --git a/test/tutorial003/tutorial003.idr b/test/tutorial003/tutorial003.idr new file mode 100644 --- /dev/null +++ b/test/tutorial003/tutorial003.idr @@ -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 |] + diff --git a/test/tutorial004/expected b/test/tutorial004/expected new file mode 100644 --- /dev/null +++ b/test/tutorial004/expected diff --git a/test/tutorial004/run b/test/tutorial004/run new file mode 100644 --- /dev/null +++ b/test/tutorial004/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ tutorial004.idr --check +rm -f *.ibc diff --git a/test/tutorial004/tutorial004.idr b/test/tutorial004/tutorial004.idr new file mode 100644 --- /dev/null +++ b/test/tutorial004/tutorial004.idr @@ -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; +} + diff --git a/test/tutorial005/expected b/test/tutorial005/expected new file mode 100644 --- /dev/null +++ b/test/tutorial005/expected diff --git a/test/tutorial005/run b/test/tutorial005/run new file mode 100644 --- /dev/null +++ b/test/tutorial005/run @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +idris $@ tutorial005.idr --check +rm -f *.ibc diff --git a/test/tutorial005/tutorial005.idr b/test/tutorial005/tutorial005.idr new file mode 100644 --- /dev/null +++ b/test/tutorial005/tutorial005.idr @@ -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 + diff --git a/test/tutorial006/expected b/test/tutorial006/expected new file mode 100644 --- /dev/null +++ b/test/tutorial006/expected @@ -0,0 +1,23 @@ +tutorial006a.idr:3:23:When elaborating right hand side of vapp: +When elaborating argument xs to constructor Prelude.Vect.::: + Can't unify + Vect (n + m) a + with + Vect (plus n m) a + + Specifically: + Can't unify + plus n m + with + plus n m +tutorial006b.idr:10:10:When elaborating right hand side of Main.parity: +Can't unify + Parity (plus (S j) (S j)) +with + Parity (S (S (plus j j))) + +Specifically: + Can't unify + plus (S j) (S j) + with + S (S (plus j j)) diff --git a/test/tutorial006/run b/test/tutorial006/run new file mode 100644 --- /dev/null +++ b/test/tutorial006/run @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +idris $@ tutorial006a.idr --check +idris $@ tutorial006b.idr --check +rm -f *.ibc diff --git a/test/tutorial006/tutorial006a.idr b/test/tutorial006/tutorial006a.idr new file mode 100644 --- /dev/null +++ b/test/tutorial006/tutorial006a.idr @@ -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 + + diff --git a/test/tutorial006/tutorial006b.idr b/test/tutorial006/tutorial006b.idr new file mode 100644 --- /dev/null +++ b/test/tutorial006/tutorial006b.idr @@ -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} +