diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -3,6 +3,10 @@ include config.mk -include custom.mk +ifdef CI +CABALFLAGS += -f CI +endif + install: $(CABAL) install $(CABALFLAGS) diff --git a/codegen/idris-c/Main.hs b/codegen/idris-c/Main.hs new file mode 100644 --- /dev/null +++ b/codegen/idris-c/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import Idris.Core.TT +import Idris.AbsSyntax +import Idris.ElabDecls +import Idris.REPL + +import IRTS.Compiler +import IRTS.CodegenC + +import System.Environment +import System.Exit + +import Paths_idris + +data Opts = Opts { inputs :: [FilePath], + output :: FilePath } + +showUsage = do putStrLn "Usage: idris-c [-o ]" + exitWith ExitSuccess + +getOpts :: IO Opts +getOpts = do xs <- getArgs + return $ process (Opts [] "a.out") xs + where + process opts ("-o":o:xs) = process (opts { output = o }) xs + process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs + process opts [] = opts + +c_main :: Opts -> Idris () +c_main opts = do elabPrims + loadInputs (inputs opts) Nothing + mainProg <- elabMain + ir <- compile (Via "c") (output opts) mainProg + runIO $ codegenC ir + +main :: IO () +main = do opts <- getOpts + if (null (inputs opts)) + then showUsage + else runMain (c_main opts) + + + diff --git a/config.mk b/config.mk --- a/config.mk +++ b/config.mk @@ -2,7 +2,7 @@ CABAL :=cabal # IDRIS_ENABLE_STATS should not be set in final release # Any flags defined here which alter the RTS API must also be added to src/IRTS/CodegenC.hs -CFLAGS :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS $(CFLAGS) +CFLAGS :=-O2 -Wall -DHAS_PTHREAD -DIDRIS_ENABLE_STATS -msse2 $(CFLAGS) #CABALFLAGS := ## Disable building of Effects diff --git a/idris.cabal b/idris.cabal --- a/idris.cabal +++ b/idris.cabal @@ -1,5 +1,5 @@ Name: idris -Version: 0.9.15.1 +Version: 0.9.16 License: BSD3 License-file: LICENSE Author: Edwin Brady @@ -91,6 +91,8 @@ libs/prelude/prelude.ipkg libs/prelude/Prelude/*.idr libs/prelude/Decidable/*.idr + libs/prelude/Language/*.idr + libs/prelude/Language/Reflection/*.idr libs/prelude/Makefile libs/prelude/*.idr @@ -103,7 +105,6 @@ libs/base/Data/Vect/*.idr libs/base/Debug/*.idr libs/base/Decidable/*.idr - libs/base/Language/*.idr libs/base/Language/Reflection/*.idr libs/base/Makefile libs/base/Network/*.idr @@ -273,6 +274,18 @@ test/reg053/run test/reg053/*.idr test/reg053/expected + test/reg054/run + test/reg054/*.idr + test/reg054/expected + test/reg055/run + test/reg055/*.idr + test/reg055/expected + test/reg056/run + test/reg056/*.idr + test/reg056/expected + test/reg057/run + test/reg057/*.idr + test/reg057/expected test/basic001/run test/basic001/*.idr @@ -308,11 +321,19 @@ test/basic011/run test/basic011/*.idr test/basic011/expected + test/basic012/run + test/basic012/*.idr + test/basic012/expected test/buffer001-disabled/*.idr test/buffer001-disabled/run test/buffer001-disabled/expected + test/delab001/*.idr + test/delab001/run + test/delab001/expected + test/delab001/input + test/dsl001/run test/dsl001/*.idr test/dsl001/expected @@ -331,6 +352,10 @@ test/effects002/run test/effects002/*.idr test/effects002/expected + test/effects003/run + test/effects003/*.idr + test/effects003/expected + test/effects003/input test/error001/run test/error001/*.idr @@ -344,6 +369,9 @@ test/error004/run test/error004/*.idr test/error004/expected + test/error005/run + test/error005/*.idr + test/error005/expected test/ffi001/run test/ffi001/*.idr @@ -397,7 +425,12 @@ test/idrisdoc008/expected test/idrisdoc008/*.idr test/idrisdoc008/*.ipkg + test/idrisdoc009/run + test/idrisdoc009/expected + test/idrisdoc009/input + test/idrisdoc009/*.idr + test/interactive001/run test/interactive001/input test/interactive001/*.idr @@ -483,6 +516,10 @@ test/records003/*.idr test/records003/expected + test/sourceLocation001/run + test/sourceLocation001/*.idr + test/sourceLocation001/expected + test/sugar001/run test/sugar001/*.idr test/sugar001/expected @@ -492,7 +529,14 @@ test/sugar003/run test/sugar003/*.idr test/sugar003/expected + test/sugar004/run + test/sugar004/*.idr + test/sugar004/expected + test/sugar005/run + test/sugar005/*.idr + test/sugar005/expected + test/totality001/run test/totality001/*.idr test/totality001/expected @@ -579,6 +623,11 @@ Default: False manual: True +Flag CI + Description: Built everything using "-Werror", meant for CI-builds only + Default: False + manual: True + Library hs-source-dirs: src Exposed-modules: @@ -591,13 +640,13 @@ , Idris.Core.Execute , Idris.Core.ProofState , Idris.Core.ProofTerm - , Idris.Core.TC , Idris.Core.TT , Idris.Core.Typecheck , Idris.Core.Unify , Idris.Elab.Utils , Idris.Elab.Type + , Idris.Elab.AsPat , Idris.Elab.Clause , Idris.Elab.Data , Idris.Elab.Record @@ -696,13 +745,13 @@ , bytestring < 0.11 , cheapskate < 0.2 , containers >= 0.5 && < 0.6 - , deepseq < 1.4 + , deepseq < 1.5 , directory >= 1.2 && < 1.3 , filepath < 1.4 , fingertree >= 0.1 && < 0.2 , haskeline >= 0.7 && < 0.8 - , lens >= 4.1.1 && < 4.5 - , mtl < 2.3 + , lens >= 4.1.1 && < 4.8 + , mtl >= 2.2.1 && < 2.3 , network < 2.7 , optparse-applicative >= 0.11 && < 0.12 , parsers >= 0.9 && < 0.13 @@ -713,6 +762,7 @@ , time >= 1.4 && < 1.6 , transformers < 0.5 , trifecta >= 1.1 && < 1.6 + , uniplate >=1.6 && < 1.7 , unordered-containers < 0.3 , utf8-string < 0.4 , vector < 0.11 @@ -757,6 +807,8 @@ if flag(freestanding) other-modules: Target_idris cpp-options: -DFREESTANDING + if flag(CI) + ghc-options: -Werror Executable idris Main-is: Main.hs @@ -765,25 +817,26 @@ Build-depends: idris , base , filepath + , directory , haskeline >= 0.7 , transformers ghc-prof-options: -auto-all -caf-all ghc-options: -threaded -rtsopts -funbox-strict-fields --- Executable idris-c --- Main-is: Main.hs --- hs-source-dirs: codegen/idris-c --- --- Build-depends: idris --- , base --- , filepath --- , haskeline >= 0.7 --- , transformers --- --- ghc-prof-options: -auto-all -caf-all --- ghc-options: -threaded -rtsopts -funbox-strict-fields +Executable idris-c + Main-is: Main.hs + hs-source-dirs: codegen/idris-c + Build-depends: idris + , base + , filepath + , haskeline >= 0.7 + , transformers + + ghc-prof-options: -auto-all -caf-all + ghc-options: -threaded -rtsopts -funbox-strict-fields + Executable idris-javascript Main-is: Main.hs hs-source-dirs: codegen/idris-javascript @@ -795,7 +848,7 @@ , transformers ghc-prof-options: -auto-all -caf-all - ghc-options: -threaded -rtsopts -funbox-strict-fields + ghc-options: -threaded -rtsopts -funbox-strict-fields -O2 Executable idris-node Main-is: Main.hs @@ -808,4 +861,4 @@ , transformers ghc-prof-options: -auto-all -caf-all - ghc-options: -threaded -rtsopts -funbox-strict-fields + ghc-options: -threaded -rtsopts -funbox-strict-fields -O2 diff --git a/libs/base/Control/Arrow.idr b/libs/base/Control/Arrow.idr --- a/libs/base/Control/Arrow.idr +++ b/libs/base/Control/Arrow.idr @@ -5,15 +5,28 @@ %access public +infixr 5 <++> infixr 3 *** infixr 3 &&& +infixr 2 +++ +infixr 2 \|/ class Category arr => Arrow (arr : Type -> Type -> Type) where arrow : (a -> b) -> arr a b first : arr a b -> arr (a, c) (b, c) + second : arr a b -> arr (c, a) (c, b) + second f = arrow swap >>> first f >>> arrow swap where + swap : (x,y) -> (y,x) + swap (x,y) = (y,x) + (***) : arr a b -> arr a' b' -> arr (a, a') (b, b') + f *** g = first f >>> second g + (&&&) : arr a b -> arr a b' -> arr a (b, b') + f &&& g = arrow dup >>> f *** g where + dup : x -> (x,x) + dup x = (x,x) instance Arrow Morphism where arrow f = Mor f @@ -37,3 +50,56 @@ (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a y <- g a return (x, y) + +class Arrow arr => ArrowZero (arr : Type -> Type -> Type) where + zeroArrow : arr a b + +class ArrowZero arr => ArrowPlus (arr : Type -> Type -> Type) where + (<++>) : arr a b -> arr a b -> arr a b + +class Arrow arr => ArrowChoice (arr : Type -> Type -> Type) where + left : arr a b -> arr (Either a c) (Either b c) + + right : arr a b -> arr (Either c a) (Either c b) + right f = arrow swap >>> left f >>> arrow swap where + swap : Either a b -> Either b a + swap (Left x) = Right x + swap (Right x) = Left x + + (+++) : arr a b -> arr c d -> arr (Either a c) (Either b d) + f +++ g = left f >>> right g + + (\|/) : arr a b -> arr c b -> arr (Either a c) b + f \|/ g = f +++ g >>> arrow fromEither + +instance Monad m => ArrowChoice (Kleislimorphism m) where + left f = f +++ (arrow id) + right f = (arrow id) +++ f + f +++ g = (f >>> (arrow Left)) \|/ (g >>> (arrow Right)) + (Kleisli f) \|/ (Kleisli g) = Kleisli (either f g) + +class Arrow arr => ArrowApply (arr : Type -> Type -> Type) where + app : arr (arr a b, a) b + +instance Monad m => ArrowApply (Kleislimorphism m) where + app = Kleisli $ \(Kleisli f, x) => f x + +data ArrowMonad : (Type -> Type -> Type) -> Type -> Type where + MkArrowMonad : (runArrowMonad : arr (the Type ()) a) -> ArrowMonad arr a + +runArrowMonad : ArrowMonad arr a -> arr (the Type ()) a +runArrowMonad (MkArrowMonad a) = a + +instance Arrow a => Functor (ArrowMonad a) where + map f (MkArrowMonad m) = MkArrowMonad $ m >>> arrow f + +instance Arrow a => Applicative (ArrowMonad a) where + pure x = MkArrowMonad $ arrow $ \_ => x + (MkArrowMonad f) <$> (MkArrowMonad x) = MkArrowMonad $ f &&& x >>> arrow (uncurry id) + +instance ArrowApply a => Monad (ArrowMonad a) where + (MkArrowMonad m) >>= f = + MkArrowMonad $ m >>> (arrow $ \x => (runArrowMonad (f x), ())) >>> app + +class Arrow arr => ArrowLoop (arr : Type -> Type -> Type) where + loop : arr (Pair a c) (Pair b c) -> arr a b 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,6 +1,7 @@ module Control.Isomorphism import Syntax.PreorderReasoning +import Data.Fin %default total diff --git a/libs/base/Control/Monad/Reader.idr b/libs/base/Control/Monad/Reader.idr --- a/libs/base/Control/Monad/Reader.idr +++ b/libs/base/Control/Monad/Reader.idr @@ -2,6 +2,7 @@ import Builtins import Control.Monad.Identity +import Control.Monad.Trans %access public @@ -40,6 +41,9 @@ instance Monad m => MonadReader r (ReaderT r m) where ask = RD return local f (RD m) = RD $ m . f + +instance MonadTrans (ReaderT r) where + lift x = RD (const x) ||| Evaluate a function in the context of a Reader monad asks : MonadReader r m => (r -> a) -> m a 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 @@ -1,6 +1,7 @@ module Control.Monad.State import Control.Monad.Identity +import Control.Monad.Trans %access public @@ -36,6 +37,10 @@ instance Monad m => MonadState s (StateT s m) where get = ST (\x => return (x, x)) put x = ST (\y => return ((), x)) + +instance MonadTrans (StateT s) where + lift x = ST (\st => do r <- x + return (r, st)) ||| Apply a function to modify the context of this computation modify : MonadState s m => (s -> s) -> m () diff --git a/libs/base/Control/Monad/Trans.idr b/libs/base/Control/Monad/Trans.idr new file mode 100644 --- /dev/null +++ b/libs/base/Control/Monad/Trans.idr @@ -0,0 +1,4 @@ +module Control.Monad.Trans + +class MonadTrans (t : (Type -> Type) -> Type -> Type) where + lift : Monad m => m a -> t m a diff --git a/libs/base/Control/Monad/Writer.idr b/libs/base/Control/Monad/Writer.idr --- a/libs/base/Control/Monad/Writer.idr +++ b/libs/base/Control/Monad/Writer.idr @@ -2,6 +2,7 @@ import Builtins import Control.Monad.Identity +import Control.Monad.Trans %access public @@ -43,6 +44,10 @@ return ((a, w), w) pass (WR m) = WR $ do ((a, f), w) <- m return (a, f w) + +instance Monoid w => MonadTrans (WriterT w) where + lift x = WR $ do r <- x + return (r, neutral) ||| Run an action in the Writer monad and transform the written output listens : MonadWriter w m => (w -> b) -> m a -> m (a, b) diff --git a/libs/base/Data/Bits.idr b/libs/base/Data/Bits.idr --- a/libs/base/Data/Bits.idr +++ b/libs/base/Data/Bits.idr @@ -1,5 +1,7 @@ module Data.Bits +import Data.Fin + %default total divCeil : Nat -> Nat -> Nat diff --git a/libs/base/Data/BoundedList.idr b/libs/base/Data/BoundedList.idr --- a/libs/base/Data/BoundedList.idr +++ b/libs/base/Data/BoundedList.idr @@ -1,5 +1,7 @@ module Data.BoundedList +import Data.Fin + %access public %default total 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 @@ -1,5 +1,7 @@ module Data.Buffer +import Data.Fin + %default total -- !!! TODO: Open issues: diff --git a/libs/base/Data/Fin.idr b/libs/base/Data/Fin.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Fin.idr @@ -0,0 +1,187 @@ +module Data.Fin + +%default total + +||| Numbers strictly less than some bound. The name comes from "finite sets". +||| +||| It's probably not a good idea to use `Fin` for arithmetic, and they will be +||| exceedingly inefficient at run time. +||| @ 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' + (==) _ _ = False + +||| There are no elements of `Fin Z` +FinZAbsurd : Fin Z -> Void +FinZAbsurd FZ impossible + +FinZElim : Fin Z -> a +FinZElim x = void (FinZAbsurd x) + +||| Convert a Fin to a Nat +finToNat : Fin n -> Nat +finToNat FZ = Z +finToNat (FS k) = S (finToNat k) + +||| `finToNat` is injective +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 + +||| Convert a Fin to an Integer +finToInteger : Fin n -> Integer +finToInteger FZ = 0 +finToInteger (FS k) = 1 + finToInteger k + +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) + strengthen (FS k) | Left x = Left (FS x) + 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 + +total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f' +FSinjective Refl = Refl + +instance Ord (Fin n) where + compare FZ FZ = EQ + compare FZ (FS _) = LT + compare (FS _) FZ = GT + compare (FS x) (FS y) = compare x y + +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) +natToFin Z (S j) = Just FZ +natToFin (S k) (S j) with (natToFin k j) + | Just k' = Just (FS k') + | Nothing = Nothing +natToFin _ _ = Nothing + +integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) +integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction! +integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing + +||| Allow overloading of Integer literals for Fin. +||| @ x the Integer that the user typed +||| @ prf an automatically-constructed proof that `x` is in bounds +fromInteger : (x : Integer) -> + {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 + +%language ErrorReflection + +total +finFromIntegerErrors : Err -> Maybe (List ErrorReportPart) +finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~n ~m)) err xs y) + = Just [ TextPart "When using", TermPart n + , TextPart "as a literal for a" + , TermPart `(Fin ~m) + , SubReport [ TextPart "Could not show that" + , TermPart n + , TextPart "is less than" + , TermPart m + ] + ] +finFromIntegerErrors _ = Nothing + +%error_handlers Data.Fin.fromInteger prf finFromIntegerErrors + +instance Enum (Fin (S n)) where + pred FZ = FZ + pred (FS n) = weaken n + succ n = case strengthen (FS n) of + Left _ => last + Right k => k + toNat n = cast n + fromNat {n=n} m = case natToFin m (S n) of + Just k => k + Nothing => last + +-------------------------------------------------------------------------------- +-- DecEq +-------------------------------------------------------------------------------- + +total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void +FZNotFS Refl impossible + +instance DecEq (Fin n) where + decEq FZ FZ = Yes Refl + decEq FZ (FS f) = No FZNotFS + decEq (FS f) FZ = No $ negEqSym FZNotFS + decEq (FS f) (FS f') with (decEq f f') + | Yes p = Yes $ cong p + | No p = No $ \h => p $ FSinjective {f = f} {f' = f'} h 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,5 +1,7 @@ module Data.Fun +import Data.Vect + %default total ||| Build an n-ary function type from a Vect of Types and a result type 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 @@ -1,5 +1,6 @@ module Data.HVect +import Data.Fin import Data.Vect %access public diff --git a/libs/base/Data/Hash.idr b/libs/base/Data/Hash.idr --- a/libs/base/Data/Hash.idr +++ b/libs/base/Data/Hash.idr @@ -1,5 +1,7 @@ module Data.Hash +import Data.Vect + %access public %default total diff --git a/libs/base/Data/Matrix.idr b/libs/base/Data/Matrix.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/Matrix.idr @@ -0,0 +1,256 @@ +module Data.Matrix + +import Data.Complex +import Data.ZZ +import Data.Fin +import Data.Vect + +%default total + +infixr 2 <.> -- vector inner product +infixr 2 >< -- vector outer product +infixr 2 <<>> -- matrix commutator +infixr 2 >><< -- matrix anticommutator +infixl 3 <\> -- row times a matrix +infixr 4 -- matrix times a column +infixr 5 <> -- matrix multiplication +infixr 7 \&\ -- vector tensor product +infixr 7 <&> -- matrix tensor product + +----------------------------------------------------------------------- +-- Vectors as members of algebraic classes +----------------------------------------------------------------------- + +instance Semigroup a => Semigroup (Vect n a) where + (<+>) v w = zipWith (<+>) v w + +instance Monoid a => Monoid (Vect n a) where + neutral {n} = replicate n neutral + +instance Group a => Group (Vect n a) where + inverse = map inverse + +instance AbelianGroup a => AbelianGroup (Vect n a) where {} + +instance Ring a => Ring (Vect n a) where + (<*>) v w = zipWith (<*>) v w + +instance RingWithUnity a => RingWithUnity (Vect n a) where + unity {n} = replicate n unity + +instance Field a => Field (Vect n a) where + inverseM = map inverseM + +instance RingWithUnity a => Module a (Vect n a) where + (<#>) r v = map (r <*>) v + +instance RingWithUnity a => Module a (Vect n (Vect l a)) where + (<#>) r m = map (r <#>) m +-- should be Module a b => Module a (Vect n b), but results in 'overlapping instance' + +----------------------------------------------------------------------- +-- (Ring) Vector functions +----------------------------------------------------------------------- + +||| Inner product of ring vectors +(<.>) : Ring a => Vect n a -> Vect n a -> a +(<.>) w v = foldr (<+>) neutral (zipWith (<*>) w v) + +||| Tensor multiply (⊗) ring vectors +(\&\) : Ring a => Vect n a -> Vect m a -> Vect (n * m) a +(\&\) {n} {m} v w = zipWith (<*>) (oextend m v) (orep n w) where + orep : (n : Nat) -> Vect m a -> Vect (n * m) a + orep n v = concat $ replicate n v + oextend : (n : Nat) -> Vect k a -> Vect (k * n) a + oextend n w = concat $ map (replicate n) w + +||| Standard basis vector with one nonzero entry, ring data type and vector-length unfixed +basis : RingWithUnity a => {d : Nat} -> (Fin d) -> Vect d a +basis i = replaceAt i unity $ neutral + +----------------------------------------------------------------------- +-- Matrix functions +----------------------------------------------------------------------- + +||| Matrix with n rows and m columns +Matrix : Nat -> Nat -> Type -> Type +Matrix n m a = Vect n (Vect m a) + +||| Gets the specified column of a matrix. For rows use the vector function 'index' +getCol : Fin m -> Matrix n m a -> Vect n a +getCol fm q = map (index fm) q + +||| Deletes the specified column of a matrix. For rows use the vector function 'deleteAt' +deleteCol : Fin (S m) -> Matrix n (S m) a -> Matrix n m a +deleteCol f m = map (deleteAt f) m + +||| Matrix element at specified row and column indices +indices : Fin n -> Fin m -> Matrix n m a -> a +indices f1 f2 m = index f2 (index f1 m) + +||| Matrix times a column vector +() : Ring a => Matrix n m a -> Vect m a -> Vect n a +() m v = map (v <.>) m + +||| Matrix times a row vector +(<\>) : Ring a => Vect n a -> Matrix n m a -> Vect m a +(<\>) r m = map (r <.>) $ transpose m + +||| Matrix multiplication +(<>) : Ring a => Matrix n k a -> + Matrix k m a -> + Matrix n m a +(<>) m1 m2 = map (<\> m2) m1 + +||| Tensor multiply (⊗) for ring matrices +(<&>) : Ring a => Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) (w1 * w2) a +(<&>) m1 m2 = zipWith (\&\) (stepOne m1 m2) (stepTwo m1 m2) where + stepOne : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w1 a + stepOne {h2} m1 m2 = concat $ map (replicate h2) m1 + stepTwo : Matrix h1 w1 a -> Matrix h2 w2 a -> Matrix (h1 * h2) w2 a + stepTwo {h1} m1 m2 = concat $ (Vect.replicate h1) m2 + +||| Cast a vector from a standard Vect to a proper n x 1 matrix +col : Vect n a -> Matrix n 1 a +col v = map (\x => [x]) v + +||| Cast a row from a standard Vect to a proper 1 x n matrix +row : Vect n a -> Matrix 1 n a +row r = [r] + +||| Outer product between ring vectors +(><) : Ring a => Vect n a -> Vect m a -> Matrix n m a +(><) x y = (col x) <> (row y) + +||| All finite numbers up to the given bound +allN : (n : Nat) -> Vect n (Fin n) +allN Z = Nil +allN (S n) = FZ :: (map FS $ allN n) + +||| Identity matrix +Id : RingWithUnity a => {d : Nat} -> Matrix d d a +Id {d} = map (\n => basis n) $ allN d + +||| Matrix commutator +(<<>>) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a +(<<>>) m1 m2 = (m1 <> m2) <-> (m2 <> m1) + +||| Matrix anti-commutator +(>><<) : Ring a => Matrix n n a -> Matrix n n a -> Matrix n n a +(>><<) m1 m2 = (m1 <> m2) <+> (m2 <> m1) + +----------------------------------------------------------------------- +-- Matrix Algebra Properties +----------------------------------------------------------------------- + +-- TODO: Prove properties of matrix algebra for 'Verified' algebraic classes + +----------------------------------------------------------------------- +-- Numberic data types as rings +----------------------------------------------------------------------- + +instance Semigroup Integer where + (<+>) = (+) + +instance Monoid Integer where + neutral = 0 + +instance Group Integer where + inverse = (* -1) + +instance AbelianGroup Integer + +instance Ring Integer where + (<*>) = (*) + +instance RingWithUnity Integer where + unity = 1 + + +instance Semigroup Int where + (<+>) = (+) + +instance Monoid Int where + neutral = 0 + +instance Group Int where + inverse = (* -1) + +instance AbelianGroup Int + +instance Ring Int where + (<*>) = (*) + +instance RingWithUnity Int where + unity = 1 + + +instance Semigroup Float where + (<+>) = (+) + +instance Monoid Float where + neutral = 0 + +instance Group Float where + inverse = (* -1) + +instance AbelianGroup Float + +instance Ring Float where + (<*>) = (*) + +instance RingWithUnity Float where + unity = 1 + +instance Field Float where + inverseM f = 1 / f + + +instance Semigroup Nat where + (<+>) = (+) + +instance Monoid Nat where + neutral = 0 + +instance VerifiedSemigroup Nat where + semigroupOpIsAssociative = plusAssociative + +instance VerifiedMonoid Nat where + monoidNeutralIsNeutralL = plusZeroRightNeutral + monoidNeutralIsNeutralR = plusZeroLeftNeutral + + +instance Semigroup ZZ where + (<+>) = (+) + +instance Monoid ZZ where + neutral = 0 + +instance Group ZZ where + inverse = (* -1) + +instance AbelianGroup ZZ + +instance Ring ZZ where + (<*>) = (*) + +instance RingWithUnity ZZ where + unity = 1 + + +instance Semigroup a => Semigroup (Complex a) where + (<+>) (a :+ b) (c :+ d) = (a <+> c) :+ (b <+> d) + +instance Monoid a => Monoid (Complex a) where + neutral = (neutral :+ neutral) + +instance Group a => Group (Complex a) where + inverse (r :+ i) = (inverse r :+ inverse i) + +instance Ring a => AbelianGroup (Complex a) where {} + +instance Ring a => Ring (Complex a) where + (<*>) (a :+ b) (c :+ d) = (a <*> c <-> b <*> d) :+ (a <*> d <+> b <*> c) + +instance RingWithUnity a => RingWithUnity (Complex a) where + unity = (unity :+ neutral) diff --git a/libs/base/Data/So.idr b/libs/base/Data/So.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/So.idr @@ -0,0 +1,25 @@ +module Data.So + +%default total + +||| Ensure that some run-time Boolean test has been performed. +||| +||| This lifts a Boolean predicate to the type level. See the function `choose` +||| if you need to perform a Boolean test and convince the type checker of this +||| fact. +||| +||| If you find yourself using `So` for something other than primitive types, +||| it may be appropriate to define a type of evidence for the property that you +||| care about instead. +data So : Bool -> Type where + Oh : So True + +instance Uninhabited (So False) where + uninhabited Oh impossible + +||| 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 + + 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 @@ -1,6 +1,7 @@ module Data.Vect import Language.Reflection +import public Data.VectType %access public %default total diff --git a/libs/base/Data/Vect/Quantifiers.idr b/libs/base/Data/Vect/Quantifiers.idr --- a/libs/base/Data/Vect/Quantifiers.idr +++ b/libs/base/Data/Vect/Quantifiers.idr @@ -1,5 +1,7 @@ module Data.Vect.Quantifiers +import Data.Vect + ||| A proof that some element of a vector satisfies some property ||| ||| @ P the property to be satsified diff --git a/libs/base/Data/VectType.idr b/libs/base/Data/VectType.idr new file mode 100644 --- /dev/null +++ b/libs/base/Data/VectType.idr @@ -0,0 +1,598 @@ +module Data.VectType + +import Data.Fin + +%access public +%default total + +namespace Vect { + +infixr 7 :: + +%elim data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a + +-- Hints for interactive editing +%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 + + +||| Insert an element at a particular index +insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a +insertAt FZ y xs = y :: xs +insertAt (FS k) y (x::xs) = x :: insertAt k y xs +insertAt (FS k) y [] = absurd k + +||| 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 (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) -> Vect (n + m) a -> Vect n a +take Z xs = [] +take (S k) (x :: xs) = x :: take k xs + +||| Remove the first m elements of a Vect +||| @ m the number of elements to remove +drop : (n : Nat) -> Vect (n + m) a -> Vect m a +drop Z xs = xs +drop (S k) (x :: xs) = drop k xs + +||| Take the longest prefix of a Vect such that all elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +takeWhile p [] = (_ ** []) +takeWhile p (x::xs) = + let (len ** ys) = takeWhile p xs + in if p x then + (S len ** x :: ys) + else + (_ ** []) + +||| Remove the longest prefix of a Vect such that all removed elements satisfy some +||| Boolean predicate. +||| +||| @ p the predicate +dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) +dropWhile p [] = (_ ** []) +dropWhile p (x::xs) = + if p x then + dropWhile p xs + else + (_ ** x::xs) + +-------------------------------------------------------------------------------- +-- Transformations +-------------------------------------------------------------------------------- + +||| Reverse the order of the elements of a vector +reverse : Vect n a -> Vect n a +reverse xs = go [] xs + where go : Vect n a -> Vect m a -> Vect (n+m) a + go {n} acc [] = rewrite plusZeroRightNeutral n in acc + go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m + in go (x::acc) 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' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n + in 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 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 + +||| 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 + +-------------------------------------------------------------------------------- +-- 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 three equal-length vectors into a vector with some function +zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d +zipWith3 f [] [] [] = [] +zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs + +||| Combine two equal-length vectors pairwise +zip : Vect n a -> Vect n b -> Vect n (a, b) +zip = zipWith (\x,y => (x,y)) + +||| Combine three equal-length vectors elementwise into a vector of tuples +zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c) +zip3 = zipWith3 (\x,y,z => (x,y,z)) + +||| 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) + +||| Convert a vector of three-tuples to a triplet of vectors +unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c) +unzip3 [] = ([], [], []) +unzip3 ((l,c,r)::xs) with (unzip3 xs) + | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) + +-------------------------------------------------------------------------------- +-- Equality +-------------------------------------------------------------------------------- + +instance (Eq a) => Eq (Vect n a) where + (==) [] [] = True + (==) (x::xs) (y::ys) = + if x == y then + xs == ys + else + False + + +-------------------------------------------------------------------------------- +-- Order +-------------------------------------------------------------------------------- + +instance Ord a => Ord (Vect n a) where + compare [] [] = EQ + compare (x::xs) (y::ys) = + if x /= y then + compare x y + else + compare xs ys + + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + +instance Functor (Vect n) where + map f [] = [] + map f (x::xs) = f x :: map f xs + + +||| Map a partial function across a vector, returning those elements for which +||| the function had a value. +||| +||| The first projection of the resulting pair (ie the length) will always be +||| at most the length of the input vector. This is not, however, guaranteed +||| by the type. +||| +||| @ f the partial function (expressed by returning `Maybe`) +||| @ xs the vector to check for results +mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b) +mapMaybe f [] = (_ ** []) +mapMaybe f (x::xs) = + let (len ** ys) = mapMaybe f xs + in case f x of + Just y => (S len ** y :: ys) + Nothing => ( len ** ys) + + +-------------------------------------------------------------------------------- +-- 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 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 + +||| Foldr without seeding the accumulator +foldr1 : (t -> t -> t) -> Vect (S n) t -> t +foldr1 f (x::xs) = foldr f x xs + +||| Foldl without seeding the accumulator +foldl1 : (t -> t -> t) -> Vect (S n) t -> t +foldl1 f (x::xs) = foldl f x xs +-------------------------------------------------------------------------------- +-- Scans +-------------------------------------------------------------------------------- + +scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b +scanl f q [] = [q] +scanl f q (x::xs) = q :: scanl f (f q x) xs + +-------------------------------------------------------------------------------- +-- Membership tests +-------------------------------------------------------------------------------- + +||| 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 + +||| 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 (==) + +||| 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 (==) + +||| 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 (==) + +-------------------------------------------------------------------------------- +-- Searching with a predicate +-------------------------------------------------------------------------------- + +||| 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 + findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat + findIndex' cnt p [] = Nothing + findIndex' cnt p (x::xs) with (p x) + | 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 + total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) + findIndices' cnt p [] = (_ ** []) + findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs) + | (_ ** tail) = + if p x then + (_ ** cnt::tail) + else + (_ ** tail) + +elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat +elemIndexBy p e = findIndex $ p e + +elemIndex : Eq a => a -> Vect m a -> Maybe Nat +elemIndex = elemIndexBy (==) + +total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) +elemIndicesBy p e = findIndices $ p e + +total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) +elemIndices = elemIndicesBy (==) + +-------------------------------------------------------------------------------- +-- 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) + | (_ ** tail) = + if p x then + (_ ** x::tail) + 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 + nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) + nubBy' acc p [] = (_ ** []) + nubBy' acc p (x::xs) with (elemBy p x acc) + | True = nubBy' acc p xs + | 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 (==) + +deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a) +deleteBy _ _ [] = (_ ** []) +deleteBy eq x (y::ys) = + let (len ** zs) = deleteBy eq x ys + in if x `eq` y then (_ ** ys) else (S len ** y ::zs) + +delete : (Eq a) => a -> Vect n a -> (p ** Vect p a) +delete = deleteBy (==) + +-------------------------------------------------------------------------------- +-- 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) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) +splitAt n xs = (take n xs, drop n xs) + +partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a)) +partition p [] = ((_ ** []), (_ ** [])) +partition p (x::xs) = + let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in + if p x then + ((S leftLen ** x::lefts), (rightLen ** rights)) + else + ((leftLen ** lefts), (S rightLen ** x::rights)) + +-------------------------------------------------------------------------------- +-- Predicates +-------------------------------------------------------------------------------- + +isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool +isPrefixOfBy p [] right = True +isPrefixOfBy p left [] = False +isPrefixOfBy p (x::xs) (y::ys) with (p x y) + | True = isPrefixOfBy p xs ys + | False = False + +isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool +isPrefixOf = isPrefixOfBy (==) + +isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool +isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) + +isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool +isSuffixOf = isSuffixOfBy (==) + +-------------------------------------------------------------------------------- +-- Conversions +-------------------------------------------------------------------------------- + +total maybeToVect : Maybe a -> (p ** Vect p a) +maybeToVect Nothing = (_ ** []) +maybeToVect (Just j) = (_ ** [j]) + +total vectToMaybe : Vect n a -> Maybe a +vectToMaybe [] = Nothing +vectToMaybe (x::xs) = Just x + +-------------------------------------------------------------------------------- +-- Misc +-------------------------------------------------------------------------------- + +catMaybes : Vect n (Maybe a) -> (p ** Vect p a) +catMaybes [] = (_ ** []) +catMaybes (Nothing::xs) = catMaybes xs +catMaybes ((Just j)::xs) with (catMaybes xs) + | (_ ** tail) = (_ ** j::tail) + +diag : Vect n (Vect n a) -> Vect n a +diag [] = [] +diag ((x::xs)::xss) = x :: diag (map tail xss) + +range : Vect n (Fin n) +range {n=Z} = [] +range {n=S _} = FZ :: map FS range + +||| Transpose a Vect of Vects, turning rows into columns and vice versa. +||| +||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`. +transpose : Vect m (Vect n a) -> Vect n (Vect m a) +transpose [] = replicate _ [] +transpose (x :: xs) = zipWith (::) x (transpose xs) + +-------------------------------------------------------------------------------- +-- Applicative/Monad/Traversable +-------------------------------------------------------------------------------- + +instance Applicative (Vect k) where + pure = replicate _ + + fs <$> vs = zipWith apply fs vs + +instance Monad (Vect n) where + m >>= f = diag (map f m) + +instance Traversable (Vect n) where + traverse f [] = pure Vect.Nil + traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] + +-------------------------------------------------------------------------------- +-- Show +-------------------------------------------------------------------------------- + +instance Show a => Show (Vect n a) where + show = show . toList + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys) +vectConsCong x xs xs Refl = Refl + +vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs +vectNilRightNeutral [] = Refl +vectNilRightNeutral (x :: xs) = + vectConsCong _ _ _ (vectNilRightNeutral xs) + +vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z +vectAppendAssociative [] y z = Refl +vectAppendAssociative (x :: xs) ys zs = + vectConsCong _ _ _ (vectAppendAssociative xs ys zs) + +} + +-------------------------------------------------------------------------------- +-- DecEq +-------------------------------------------------------------------------------- + +total +vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y +vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl + +total +vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys +vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl + +instance DecEq a => DecEq (Vect n a) where + decEq [] [] = Yes Refl + decEq (x :: xs) (y :: ys) with (decEq x y) + decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) + decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl + decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2) + decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1) + +{- The following definition is elaborated in a wrong case-tree. Examination pending. +instance DecEq a => DecEq (Vect n a) where + decEq [] [] = Yes Refl + decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) + decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl + decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) + decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) +-} + +-- For the primitives, we have to cheat because we don't have access to their +-- internal implementations. + diff --git a/libs/base/Debug/Error.idr b/libs/base/Debug/Error.idr new file mode 100644 --- /dev/null +++ b/libs/base/Debug/Error.idr @@ -0,0 +1,20 @@ +module Debug.Error + +import Language.Reflection +import System + +||| Terminate the program after printing a user-specified error message. +||| +||| @ loc The source location to display for the error +||| @ message The error to print +partial +error : {default tactics {sourceLocation} loc : SourceLocation} -> + (message : String) -> + a +error {loc = FileLoc filename (line, col) _} message = + believe_me . unsafePerformIO $ + do let place = filename ++ " line " ++ show line ++ " column " ++ show col + let message' = place ++ ": " ++ message + putStrLn message' + exit 1 + diff --git a/libs/base/Decidable/Decidable.idr b/libs/base/Decidable/Decidable.idr --- a/libs/base/Decidable/Decidable.idr +++ b/libs/base/Decidable/Decidable.idr @@ -1,6 +1,7 @@ module Decidable.Decidable import Data.Rel +import Data.Fun %access public @@ -17,6 +18,6 @@ --decision : Decidable ts p => (ts : Vect k Type) -> (p : Rel ts) -> liftRel ts p Dec --decision ts p = decide {ts} {p} -using (P : Type, p : P) - data Given : Dec P -> Type where - always : Given (Yes p) +using (a : Type, x : a) + data Given : Dec a -> Type where + Always : Given (Yes x) 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 @@ -2,6 +2,9 @@ import Decidable.Decidable import Decidable.Equality +import Data.Fin +import Data.Fun +import Data.Rel %access public diff --git a/libs/base/Language/Reflection.idr b/libs/base/Language/Reflection.idr deleted file mode 100644 --- a/libs/base/Language/Reflection.idr +++ /dev/null @@ -1,479 +0,0 @@ -module Language.Reflection - -%access public - -data TTName = - ||| A user-provided name - UN String | - ||| A name in some namespace. - ||| - ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo` - NS TTName (List String) | - ||| Machine-chosen names - MN Int String | - ||| Name of something which is never used in scope - NErased -%name TTName n, n' - -implicit -userSuppliedName : String -> TTName -userSuppliedName = UN - -data TTUExp = - ||| Universe variable - UVar Int | - ||| Explicit universe level - UVal Int -%name TTUExp uexp - -data NativeTy = IT8 | IT16 | IT32 | IT64 - -data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar - | ITVec NativeTy Int - -data ArithTy = ATInt Language.Reflection.IntTy | ATFloat - -||| Primitive constants -data Const = I Int | BI Integer | Fl Float | Ch Char | Str String - | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64 - | B8V Bits8x16 | B16V Bits16x8 - | B32V Bits32x4 | B64V Bits64x2 - | AType ArithTy | StrType - | PtrType | ManagedPtrType | BufferType | VoidType | Forgot - -%name Const c, c' - -abstract class ReflConst (a : Type) where - toConst : a -> Const - -instance ReflConst Int where - toConst x = I x - -instance ReflConst Integer where - toConst = BI - -instance ReflConst Float where - toConst = Fl - -instance ReflConst Char where - toConst = Ch - -instance ReflConst String where - toConst = Str - -instance ReflConst Bits8 where - toConst = B8 - -instance ReflConst Bits16 where - toConst = B16 - -instance ReflConst Bits32 where - toConst = B32 - -instance ReflConst Bits64 where - toConst = B64 - -implicit -reflectConstant: (ReflConst a) => a -> Const -reflectConstant = toConst - - -||| Types of named references -data NameType = - ||| A reference which is just bound, e.g. by intro - Bound | - ||| A reference to a de Bruijn-indexed variable - Ref | - ||| Data constructor with tag and number - DCon Int Int | - ||| Type constructor with tag and number - TCon Int Int - -%name NameType nt, nt' - -||| Types annotations for bound variables in different -||| binding contexts -data Binder a = Lam a - | Pi a a - | Let a a - | NLet a a - | Hole a - | GHole a - | Guess a a - | PVar a - | PVTy a -%name Binder b, b' - -instance Functor Binder where - map f (Lam x) = Lam (f x) - map f (Pi x k) = Pi (f x) (f k) - map f (Let x y) = Let (f x) (f y) - map f (NLet x y) = NLet (f x) (f y) - map f (Hole x) = Hole (f x) - map f (GHole x) = GHole (f x) - map f (Guess x y) = Guess (f x) (f y) - map f (PVar x) = PVar (f x) - map f (PVTy x) = PVTy (f x) - -instance Foldable Binder where - foldr f z (Lam x) = f x z - foldr f z (Pi x k) = f x (f k z) - foldr f z (Let x y) = f x (f y z) - foldr f z (NLet x y) = f x (f y z) - foldr f z (Hole x) = f x z - foldr f z (GHole x) = f x z - foldr f z (Guess x y) = f x (f y z) - foldr f z (PVar x) = f x z - foldr f z (PVTy x) = f x z - -instance Traversable Binder where - traverse f (Lam x) = [| Lam (f x) |] - traverse f (Pi x k) = [| Pi (f x) (f k) |] - traverse f (Let x y) = [| Let (f x) (f y) |] - traverse f (NLet x y) = [| NLet (f x) (f y) |] - traverse f (Hole x) = [| Hole (f x) |] - traverse f (GHole x) = [| GHole (f x) |] - traverse f (Guess x y) = [| Guess (f x) (f y) |] - traverse f (PVar x) = [| PVar (f x) |] - traverse f (PVTy x) = [| PVTy (f x) |] - - -||| Reflection of the well typed core language -data TT = - ||| A reference to some name (P for Parameter) - P NameType TTName TT | - ||| de Bruijn variables - V Int | - ||| Bind a variable - Bind TTName (Binder TT) TT | - ||| Apply one term to another - App TT TT | - ||| Embed a constant - TConst Const | - ||| Argument projection; runtime only - Proj TT Int | - ||| Erased terms - Erased | - ||| Impossible terms - Impossible | - ||| The type of types along (with universe constraints) - TType TTUExp -%name TT tm, tm' - -||| Raw terms without types -data Raw = - ||| Variables, global or local - Var TTName | - ||| Bind a variable - RBind TTName (Binder Raw) Raw | - ||| Application - RApp Raw Raw | - ||| The type of types - RType | - RForce Raw | - ||| Embed a constant - RConstant Const -%name Raw tm, tm' - -||| Error reports are a list of report parts -data ErrorReportPart = - ||| A human-readable string - TextPart String | - ||| An Idris name (to be semantically coloured) - NamePart TTName | - ||| An Idris term, to be pretty printed - TermPart TT | - ||| An indented sub-report, to provide more details - SubReport (List ErrorReportPart) -%name ErrorReportPart part, p - -||| A representation of Idris's tactics that can be returned from custom -||| tactic implementations. Generate these using `applyTactic`. -data Tactic = - ||| Try the first tactic and resort to the second one on failure - Try Tactic Tactic | - ||| Only run if the goal has the right type - GoalType String Tactic | - ||| Resolve function name, find matching arguments in the - ||| context and compute the proof target - Refine TTName | - ||| Apply both tactics in sequence - Seq Tactic Tactic | - ||| Intelligently construct the proof target from the context - Trivial | - ||| Build a proof by applying contructors up to a maximum depth - Search Int | - ||| Resolve a type class - Instance | - ||| Infer the proof target from the context - Solve | - ||| introduce all variables into the context - Intros | - ||| Introduce a named variable into the context, use the - ||| first one if the given name is not found - Intro TTName | - ||| Invoke the reflected rep. of another tactic - ApplyTactic TT | - ||| Turn a value into its reflected representation - Reflect TT | - ||| Use a `%reflection` function - ByReflection TT | - ||| Turn a raw value back into a term - Fill Raw | - ||| Use the given value to conclude the proof - Exact TT | - ||| Focus on a particular hole - Focus TTName | - ||| Rewrite with an equality - Rewrite TT | - ||| Perform induction on a particular expression - Induction TT | - ||| Perform case analysis on a particular expression - Case TT | - ||| Name a reflected term - LetTac TTName TT | - ||| Name a reflected term and type it - LetTacTy TTName TT TT | - ||| Normalise the goal - Compute | - ||| Do nothing - Skip | - ||| Fail with an error message - Fail (List ErrorReportPart) -%name Tactic tac, tac' - - -||| Things with a canonical representation in the TT datatype. -||| -||| This type class is intended to be used during proof automation and the -||| construction of custom tactics. -||| -||| @ a the type to be quoted -class Quotable a where - ||| A representation of the type `a`. - ||| - ||| This is to enable quoting polymorphic datatypes - quotedTy : TT - - ||| Quote a particular element of `a`. - ||| - ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))``` - quote : a -> TT - -instance Quotable Nat where - quotedTy = `(Nat) - - quote Z = `(Z) - quote (S k) = `(S ~(quote k)) - -instance Quotable Int where - quotedTy = `(Int) - quote x = TConst (I x) - -instance Quotable Float where - quotedTy = `(Float) - quote x = TConst (Fl x) - -instance Quotable Char where - quotedTy = `(Char) - quote x = TConst (Ch x) - -instance Quotable Bits8 where - quotedTy = `(Bits8) - quote x = TConst (B8 x) - -instance Quotable Bits16 where - quotedTy = `(Bits16) - quote x = TConst (B16 x) - -instance Quotable Bits32 where - quotedTy = `(Bits32) - quote x = TConst (B32 x) - -instance Quotable Bits64 where - quotedTy = `(Bits64) - quote x = TConst (B64 x) - -instance Quotable Integer where - quotedTy = `(Integer) - quote x = TConst (BI x) - -instance Quotable Bits8x16 where - quotedTy = `(Bits8x16) - quote x = TConst (B8V x) - -instance Quotable Bits16x8 where - quotedTy = `(Bits16x8) - quote x = TConst (B16V x) - -instance Quotable Bits32x4 where - quotedTy = `(Bits32x4) - quote x = TConst (B32V x) - -instance Quotable Bits64x2 where - quotedTy = `(Bits64x2) - quote x = TConst (B64V x) - -instance Quotable String where - quotedTy = `(String) - quote x = TConst (Str x) - -instance Quotable NameType where - quotedTy = `(NameType) - quote Bound = `(Bound) - quote Ref = `(Ref) - quote (DCon x y) = `(DCon ~(quote x) ~(quote y)) - quote (TCon x y) = `(TCon ~(quote x) ~(quote y)) - -instance Quotable a => Quotable (List a) where - quotedTy = `(List ~(quotedTy {a=a})) - quote [] = `(List.Nil {a=~quotedTy}) - quote (x :: xs) = `(List.(::) {a=~quotedTy} ~(quote x) ~(quote xs)) - -instance Quotable TTName where - quotedTy = `(TTName) - quote (UN x) = `(UN ~(quote x)) - quote (NS n xs) = `(NS ~(quote n) ~(quote xs)) - quote (MN x y) = `(MN ~(quote x) ~(quote y)) - quote NErased = `(NErased) - -instance Quotable NativeTy where - quotedTy = `(NativeTy) - quote IT8 = `(Reflection.IT8) - quote IT16 = `(Reflection.IT16) - quote IT32 = `(Reflection.IT32) - quote IT64 = `(Reflection.IT64) - -instance Quotable Reflection.IntTy where - quotedTy = `(Reflection.IntTy) - quote (ITFixed x) = `(ITFixed ~(quote x)) - quote ITNative = `(Reflection.ITNative) - quote ITBig = `(ITBig) - quote ITChar = `(Reflection.ITChar) - quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y)) - -instance Quotable ArithTy where - quotedTy = `(ArithTy) - quote (ATInt x) = `(ATInt ~(quote x)) - quote ATFloat = `(ATFloat) - -instance Quotable Const where - quotedTy = `(Const) - quote (I x) = `(I ~(quote x)) - quote (BI x) = `(BI ~(quote x)) - quote (Fl x) = `(Fl ~(quote x)) - quote (Ch x) = `(Ch ~(quote x)) - quote (Str x) = `(Str ~(quote x)) - quote (B8 x) = `(B8 ~(quote x)) - quote (B16 x) = `(B16 ~(quote x)) - quote (B32 x) = `(B32 ~(quote x)) - quote (B64 x) = `(B64 ~(quote x)) - quote (B8V xs) = `(B8V ~(quote xs)) - quote (B16V xs) = `(B16V ~(quote xs)) - quote (B32V xs) = `(B32V ~(quote xs)) - quote (B64V xs) = `(B64V ~(quote xs)) - quote (AType x) = `(AType ~(quote x)) - quote StrType = `(StrType) - quote PtrType = `(PtrType) - quote ManagedPtrType = `(ManagedPtrType) - quote BufferType = `(BufferType) - quote VoidType = `(VoidType) - quote Forgot = `(Forgot) - - -instance Quotable TTUExp where - quotedTy = `(TTUExp) - quote (UVar x) = `(UVar ~(quote x)) - quote (UVal x) = `(UVal ~(quote x)) - -mutual - instance Quotable TT where - quotedTy = `(TT) - quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm)) - quote (V x) = `(V ~(quote x)) - quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm)) - quote (App f x) = `(App ~(quote f) ~(quote x)) - quote (TConst c) = `(TConst ~(quote c)) - quote (Proj tm x) = `(Proj ~(quote tm) ~(quote x)) - quote Erased = `(Erased) - quote Impossible = `(Impossible) - quote (TType uexp) = `(TType ~(quote uexp)) - - instance Quotable (Binder TT) where - quotedTy = `(Binder TT) - quote (Lam x) = `(Lam {a=TT} ~(assert_total (quote x))) - quote (Pi x k) = `(Pi {a=TT} ~(assert_total (quote x)) - ~(assert_total (quote k))) - quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x)) - ~(assert_total (quote y))) - quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x)) - ~(assert_total (quote y))) - quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x))) - quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x))) - quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x)) - ~(assert_total (quote y))) - quote (PVar x) = `(PVar {a=TT} ~(assert_total (quote x))) - quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x))) - - -instance Quotable ErrorReportPart where - quotedTy = `(ErrorReportPart) - quote (TextPart x) = `(TextPart ~(quote x)) - quote (NamePart n) = `(NamePart ~(quote n)) - quote (TermPart tm) = `(TermPart ~(quote tm)) - quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs)) - -mutual - quoteRaw : Raw -> TT - quoteRaw (Var n) = `(Var ~(quote n)) - quoteRaw (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinder b) ~(quoteRaw tm)) - quoteRaw (RApp tm tm') = `(RApp ~(quoteRaw tm) ~(quoteRaw tm')) - quoteRaw RType = `(RType) - quoteRaw (RForce tm) = `(RForce ~(quoteRaw tm)) - quoteRaw (RConstant c) = `(RConstant ~(quote c)) - - quoteRawBinder : Binder Raw -> TT - quoteRawBinder (Lam x) = `(Lam {a=Raw} ~(quoteRaw x)) - quoteRawBinder (Pi x k) = `(Pi {a=Raw} ~(quoteRaw x) ~(quoteRaw k)) - quoteRawBinder (Let x y) = `(Let {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) - quoteRawBinder (NLet x y) = `(NLet {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) - quoteRawBinder (Hole x) = `(Hole {a=Raw} ~(quoteRaw x)) - quoteRawBinder (GHole x) = `(GHole {a=Raw} ~(quoteRaw x)) - quoteRawBinder (Guess x y) = `(Guess {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) - quoteRawBinder (PVar x) = `(PVar {a=Raw} ~(quoteRaw x)) - quoteRawBinder (PVTy x) = `(PVTy {a=Raw} ~(quoteRaw x)) - -instance Quotable Raw where - quotedTy = `(Raw) - quote = quoteRaw - -instance Quotable (Binder Raw) where - quotedTy = `(Binder Raw) - quote = quoteRawBinder - -instance Quotable Tactic where - quotedTy = `(Tactic) - quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac')) - quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac)) - quote (Refine n) = `(Refine ~(quote n)) - quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac')) - quote Trivial = `(Trivial) - quote (Search x) = `(Search ~(quote x)) - quote Instance = `(Instance) - quote Solve = `(Solve) - quote Intros = `(Intros) - quote (Intro n) = `(Intro ~(quote n)) - quote (ApplyTactic tm) = `(ApplyTactic ~(quote tm)) - quote (Reflect tm) = `(Reflect ~(quote tm)) - quote (ByReflection tm) = `(ByReflection ~(quote tm)) - quote (Fill tm) = `(Fill ~(quote tm)) - quote (Exact tm) = `(Exact ~(quote tm)) - quote (Focus n) = `(Focus ~(quote n)) - quote (Rewrite tm) = `(Rewrite ~(quote tm)) - quote (Induction tm) = `(Induction ~(quote tm)) - quote (Case tm) = `(Case ~(quote tm)) - quote (LetTac n tm) = `(LetTac ~(quote n) ~(quote tm)) - quote (LetTacTy n tm tm') = `(LetTacTy ~(quote n) ~(quote tm) ~(quote tm')) - quote Compute = `(Compute) - quote Skip = `(Skip) - quote (Fail xs) = `(Fail ~(quote xs)) diff --git a/libs/base/Language/Reflection/Errors.idr b/libs/base/Language/Reflection/Errors.idr deleted file mode 100644 --- a/libs/base/Language/Reflection/Errors.idr +++ /dev/null @@ -1,45 +0,0 @@ -module Language.Reflection.Errors - -import Language.Reflection - -data SourceLocation : Type where - FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation - -%name SourceLocation loc - -data Err = Msg String - | InternalMsg String - | CantUnify Bool TT TT Err (List (TTName, TT)) Int - -- Int is 'score' - how much we did unify - -- Bool indicates recoverability, True indicates more info may make - -- unification succeed - | InfiniteUnify TTName TT (List (TTName, TT)) - | CantConvert TT TT (List (TTName, TT)) - | CantSolveGoal TT (List (TTName, TT)) - | UnifyScope TTName TTName TT (List (TTName, TT)) - | CantInferType String - | NonFunctionType TT TT - | NotEquality TT TT - | TooManyArguments TTName - | CantIntroduce TT - | NoSuchVariable TTName - | NoTypeDecl TTName - | NotInjective TT TT TT - | CantResolve TT - | CantResolveAlts (List String) - | IncompleteTerm TT - | UniverseError - | ProgramLineComment - | Inaccessible TTName - | NonCollapsiblePostulate TTName - | AlreadyDefined TTName - | ProofSearchFail Err - | NoRewriting TT - | ProviderError String - | LoadingFailed String Err - -%name Err err, e - --- Error reports become functions in List (String, TT) -> Err -> ErrorReport -ErrorHandler : Type -ErrorHandler = Err -> Maybe (List ErrorReportPart) 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 @@ -3,17 +3,17 @@ import Language.Reflection import Language.Reflection.Errors -%default total - -------------------------------------------------------- -- Tactic construction conveniences -------------------------------------------------------- +total seq : List Tactic -> Tactic seq [] = GoalType "This is an impossible case" Trivial seq [t] = t seq (t::ts) = t `Seq` seq ts +total try : List Tactic -> Tactic try [] = GoalType "This is an impossible case" Trivial try [t] = t @@ -23,6 +23,7 @@ -------------------------------------------------------- -- For use in tactic scripts -------------------------------------------------------- +total mkPair : a -> b -> (a, b) mkPair a b = (a, b) @@ -30,22 +31,25 @@ -------------------------------------------------------- -- Tools for constructing proof terms directly -------------------------------------------------------- - +total getUName : TTName -> Maybe String getUName (UN n) = Just n getUName (NS n ns) = getUName n getUName _ = Nothing +total unApply : TT -> (TT, List TT) unApply t = unA t [] where unA : TT -> List TT -> (TT, List TT) unA (App fn arg) args = unA fn (arg::args) unA tm args = (tm, args) +total mkApp : TT -> List TT -> TT mkApp tm [] = tm mkApp tm (a::as) = mkApp (App tm a) as +total binderTy : (Eq t) => Binder t -> t binderTy (Lam t) = t binderTy (Pi t _) = t @@ -261,6 +265,8 @@ show (TooManyArguments n) = "TooManyArguments " ++ show n show (CantIntroduce tm) = "CantIntroduce " ++ show tm show (NoSuchVariable n) = "NoSuchVariable " ++ show n + show (WithFnType tm) = "WithFnType " ++ show tm + show (CantMatch tm) = "CantMatch " ++ show tm show (NoTypeDecl n) = "NoTypeDecl " ++ show n show (NotInjective tm tm' x) = "NotInjective " ++ show tm ++ " " ++ show tm' show (CantResolve tm) = "CantResolve " ++ show tm diff --git a/libs/base/Network/Socket.idr b/libs/base/Network/Socket.idr --- a/libs/base/Network/Socket.idr +++ b/libs/base/Network/Socket.idr @@ -56,13 +56,13 @@ show NotASocket = "Not a socket" show Stream = "Stream" show Datagram = "Datagram" - show Raw = "Raw" + show RawSocket = "Raw" instance ToCode SocketType where toCode NotASocket = 0 toCode Stream = 1 toCode Datagram = 2 - toCode Raw = 3 + toCode RawSocket = 3 data RecvStructPtr = RSPtr Ptr diff --git a/libs/base/System.idr b/libs/base/System.idr --- a/libs/base/System.idr +++ b/libs/base/System.idr @@ -1,7 +1,5 @@ module System -import Prelude - %include C "unistd.h" %default partial %access public diff --git a/libs/base/base.ipkg b/libs/base/base.ipkg --- a/libs/base/base.ipkg +++ b/libs/base/base.ipkg @@ -4,7 +4,7 @@ modules = System, Network.Cgi, Network.Socket, - Debug.Trace, + Debug.Error, Debug.Trace, System.Info, System.Concurrency.Raw, System.Concurrency.Process, @@ -13,7 +13,7 @@ Providers, - Language.Reflection, Language.Reflection.Utils, Language.Reflection.Errors, + Language.Reflection.Utils, Syntax.PreorderReasoning, @@ -21,16 +21,18 @@ Data.Bits, Data.Mod2, Data.ZZ, Data.Sign, Data.SortedMap, Data.SortedSet, Data.BoundedList, - Data.Vect, Data.HVect, Data.Vect.Quantifiers, + Data.Fin, Data.Vect, Data.VectType, + Data.HVect, Data.Vect.Quantifiers, Data.Floats, Data.Complex, Data.Heap, Data.Fun, Data.Rel, Data.Buffer, Data.Erased, - Data.List, Data.Hash, + Data.List, Data.Hash, Data.Matrix, + Data.So, Control.Isomorphism, Control.Isomorphism.Primitives, Control.Monad.Identity, Control.Monad.RWS, + Control.Monad.Trans, Control.Monad.State, Control.Monad.Writer, Control.Monad.Reader, Control.Category, Control.Arrow, Control.Catchable, Control.IOExcept - diff --git a/libs/effects/Effect/Default.idr b/libs/effects/Effect/Default.idr --- a/libs/effects/Effect/Default.idr +++ b/libs/effects/Effect/Default.idr @@ -1,5 +1,7 @@ module Default +import Data.Vect + class Default a where default : a 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 @@ -87,6 +87,20 @@ handle (FH h) EOF k = do e <- feof h k e (FH h) +instance Handler FileIO (IOExcept a) where + handle () (Open fname m) k = do h <- ioe_lift $ openFile fname m + valid <- ioe_lift $ validFile h + if valid then k True (FH h) + else k False () + handle (FH h) Close k = do ioe_lift $ closeFile h + k () () + handle (FH h) ReadLine k = do str <- ioe_lift $ fread h + k str (FH h) + handle (FH h) (WriteString str) k = do ioe_lift $ fwrite h str + k () (FH h) + handle (FH h) EOF k = do e <- ioe_lift $ feof h + k e (FH h) + -- -------------------------------------------------------------- [ The Effect ] FILE_IO : Type -> EFFECT FILE_IO t = MkEff t FileIO 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 @@ -2,6 +2,8 @@ import Effects import Control.IOExcept +import Data.Vect +import public Data.So %access public @@ -64,11 +66,11 @@ private do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8) -do_peek _ _ Z = return (Prelude.Vect.Nil) +do_peek _ _ Z = return (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) + Monad.return (Vect.(::) b bs) private do_poke : Ptr -> Nat -> Vect size Bits8 -> IO () 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 @@ -1,6 +1,8 @@ module Effect.Random import Effects +import Data.Vect +import Data.Fin data Random : Effect where getRandom : { Integer } Random Integer @@ -19,7 +21,7 @@ ||| Generates a random Integer in a given range rndInt : Integer -> Integer -> { [RND] } Eff Integer rndInt lower upper = do v <- call $ getRandom - return (v `prim__sremBigInt` (upper - lower) + lower) + return ((v `prim__sremBigInt` (upper - lower)) + lower) ||| Generate a random number in Fin (S `k`) ||| diff --git a/libs/effects/Effects.idr b/libs/effects/Effects.idr --- a/libs/effects/Effects.idr +++ b/libs/effects/Effects.idr @@ -1,8 +1,8 @@ module Effects import Language.Reflection -import Control.Catchable -import Effect.Default +import public Effect.Default +import Data.Vect --- Effectful computations are described as algebraic data types that --- explain how an effect is interpreted in some underlying context. diff --git a/libs/prelude/Builtins.idr b/libs/prelude/Builtins.idr --- a/libs/prelude/Builtins.idr +++ b/libs/prelude/Builtins.idr @@ -9,25 +9,26 @@ ||| The trivial constructor for `()`. MkUnit -||| The non-dependent pair type, also known as conjunction. -||| @A the type of the left elements in the pair -||| @B the type of the left elements in the pair -data Pair : (A : Type) -> (B : Type) -> Type where - ||| A pair of elements - ||| @a the left element of the pair - ||| @b the right element of the pair - MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B +namespace Builtins + ||| The non-dependent pair type, also known as conjunction. + ||| @A the type of the left elements in the pair + ||| @B the type of the left elements in the pair + %elim data Pair : (A : Type) -> (B : Type) -> Type where + ||| A pair of elements + ||| @a the left element of the pair + ||| @b the right element of the pair + MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B -||| Dependent pairs -||| -||| Dependent pairs represent existential quantification - they consist of a -||| witness for the existential claim and a proof that the property holds for -||| it. Another way to see dependent pairs is as just data - for instance, the -||| length of a vector paired with that vector. -||| -||| @ a the type of the witness @ P the type of the proof -data Sigma : (a : Type) -> (P : a -> Type) -> Type where - MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P + ||| Dependent pairs + ||| + ||| Dependent pairs represent existential quantification - they consist of a + ||| witness for the existential claim and a proof that the property holds for + ||| it. Another way to see dependent pairs is as just data - for instance, the + ||| length of a vector paired with that vector. + ||| + ||| @ a the type of the witness @ P the type of the proof + data Sigma : (a : Type) -> (P : a -> Type) -> Type where + MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P ||| The empty type, also known as the trivially false proposition. ||| @@ -115,14 +116,14 @@ -- is better in any case? par (Delay x) = x -||| Assert to the totality checker than y is always structurally smaller than +||| Assert to the totality checker that 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 : a) -> (y : b) -> b assert_smaller x y = y -||| Assert to the totality checker than the given expression will always +||| Assert to the totality checker that the given expression will always ||| terminate. assert_total : a -> a assert_total x = 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 @@ -2,10 +2,11 @@ import Builtins import Prelude.Basics +import Prelude.Bool +import Prelude.Classes import Prelude.Either import Prelude.List -import Prelude.Vect -import Prelude.Fin +import Prelude.Nat import Prelude.Maybe -------------------------------------------------------------------------------- @@ -49,13 +50,13 @@ -- Nat -------------------------------------------------------------------------------- -total OnotS : Z = S n -> Void -OnotS Refl impossible +total ZnotS : Z = S n -> Void +ZnotS Refl impossible instance DecEq Nat where decEq Z Z = Yes Refl - decEq Z (S _) = No OnotS - decEq (S _) Z = No (negEqSym OnotS) + decEq Z (S _) = No ZnotS + decEq (S _) Z = No (negEqSym ZnotS) decEq (S n) (S m) with (decEq n m) | Yes p = Yes $ cong p | No p = No $ \h : (S n = S m) => p $ succInjective n m h @@ -93,21 +94,6 @@ decEq (Right x') (Left y') = No $ negEqSym leftNotRight -------------------------------------------------------------------------------- --- Fin --------------------------------------------------------------------------------- - -total FZNotFS : {f : Fin n} -> FZ {k = n} = FS f -> Void -FZNotFS Refl impossible - -instance DecEq (Fin n) where - decEq FZ FZ = Yes Refl - decEq FZ (FS f) = No FZNotFS - decEq (FS f) FZ = No $ negEqSym FZNotFS - decEq (FS f) (FS f') with (decEq f f') - | Yes p = Yes $ cong p - | No p = No $ \h => p $ FSinjective {f = f} {f' = f'} h - --------------------------------------------------------------------------------- -- Tuple -------------------------------------------------------------------------------- @@ -161,36 +147,6 @@ decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq) decEq (x :: xs) (y :: ys) | (No p) | (No p') = No (\eq => lemma_x_neq_xs_neq p p' eq) - --------------------------------------------------------------------------------- --- Vect --------------------------------------------------------------------------------- - -total -vectInjective1 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> x = y -vectInjective1 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl - -total -vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys -vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} Refl = Refl - -instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes Refl - decEq (x :: xs) (y :: ys) with (decEq x y) - decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys) - decEq (x :: xs) (x :: xs) | Yes Refl | Yes Refl = Yes Refl - decEq (x :: xs) (x :: ys) | Yes Refl | No neq = No (neq . vectInjective2) - decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1) - -{- The following definition is elaborated in a wrong case-tree. Examination pending. - -instance DecEq a => DecEq (Vect n a) where - decEq [] [] = Yes Refl - decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys) - decEq (x :: xs) (x :: xs) | (Yes Refl, Yes Refl) = Yes Refl - decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p)) - decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p)) --} -- For the primitives, we have to cheat because we don't have access to their -- internal implementations. diff --git a/libs/prelude/IO.idr b/libs/prelude/IO.idr --- a/libs/prelude/IO.idr +++ b/libs/prelude/IO.idr @@ -1,5 +1,6 @@ %unqualified +import Builtins import Prelude.List %access public diff --git a/libs/prelude/Language/Reflection.idr b/libs/prelude/Language/Reflection.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Language/Reflection.idr @@ -0,0 +1,496 @@ +module Language.Reflection + +import Builtins +import Prelude.Applicative +import Prelude.Basics +import Prelude.Foldable +import Prelude.Functor +import Prelude.List +import Prelude.Nat +import Prelude.Traversable + +%access public + +data TTName = + ||| A user-provided name + UN String | + ||| A name in some namespace. + ||| + ||| The namespace is in reverse order, so `(NS (UN "foo") ["B", "A"])` represents the name `A.B.foo` + NS TTName (List String) | + ||| Machine-chosen names + MN Int String | + ||| Name of something which is never used in scope + NErased +%name TTName n, n' + +implicit +userSuppliedName : String -> TTName +userSuppliedName = UN + +data TTUExp = + ||| Universe variable + UVar Int | + ||| Explicit universe level + UVal Int +%name TTUExp uexp + +data NativeTy = IT8 | IT16 | IT32 | IT64 + +data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar + | ITVec NativeTy Int + +data ArithTy = ATInt Language.Reflection.IntTy | ATFloat + +||| Primitive constants +data Const = I Int | BI Integer | Fl Float | Ch Char | Str String + | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64 + | B8V Bits8x16 | B16V Bits16x8 + | B32V Bits32x4 | B64V Bits64x2 + | AType ArithTy | StrType + | PtrType | ManagedPtrType | BufferType | VoidType | Forgot + +%name Const c, c' + +abstract class ReflConst (a : Type) where + toConst : a -> Const + +instance ReflConst Int where + toConst x = I x + +instance ReflConst Integer where + toConst = BI + +instance ReflConst Float where + toConst = Fl + +instance ReflConst Char where + toConst = Ch + +instance ReflConst String where + toConst = Str + +instance ReflConst Bits8 where + toConst = B8 + +instance ReflConst Bits16 where + toConst = B16 + +instance ReflConst Bits32 where + toConst = B32 + +instance ReflConst Bits64 where + toConst = B64 + +implicit +reflectConstant: (ReflConst a) => a -> Const +reflectConstant = toConst + + +||| Types of named references +data NameType = + ||| A reference which is just bound, e.g. by intro + Bound | + ||| A reference to a de Bruijn-indexed variable + Ref | + ||| Data constructor with tag and number + DCon Int Int | + ||| Type constructor with tag and number + TCon Int Int + +%name NameType nt, nt' + +||| Types annotations for bound variables in different +||| binding contexts +data Binder a = Lam a + | Pi a a + | Let a a + | NLet a a + | Hole a + | GHole a + | Guess a a + | PVar a + | PVTy a +%name Binder b, b' + +instance Functor Binder where + map f (Lam x) = Lam (f x) + map f (Pi x k) = Pi (f x) (f k) + map f (Let x y) = Let (f x) (f y) + map f (NLet x y) = NLet (f x) (f y) + map f (Hole x) = Hole (f x) + map f (GHole x) = GHole (f x) + map f (Guess x y) = Guess (f x) (f y) + map f (PVar x) = PVar (f x) + map f (PVTy x) = PVTy (f x) + +instance Foldable Binder where + foldr f z (Lam x) = f x z + foldr f z (Pi x k) = f x (f k z) + foldr f z (Let x y) = f x (f y z) + foldr f z (NLet x y) = f x (f y z) + foldr f z (Hole x) = f x z + foldr f z (GHole x) = f x z + foldr f z (Guess x y) = f x (f y z) + foldr f z (PVar x) = f x z + foldr f z (PVTy x) = f x z + +instance Traversable Binder where + traverse f (Lam x) = [| Lam (f x) |] + traverse f (Pi x k) = [| Pi (f x) (f k) |] + traverse f (Let x y) = [| Let (f x) (f y) |] + traverse f (NLet x y) = [| NLet (f x) (f y) |] + traverse f (Hole x) = [| Hole (f x) |] + traverse f (GHole x) = [| GHole (f x) |] + traverse f (Guess x y) = [| Guess (f x) (f y) |] + traverse f (PVar x) = [| PVar (f x) |] + traverse f (PVTy x) = [| PVTy (f x) |] + + +||| Reflection of the well typed core language +data TT = + ||| A reference to some name (P for Parameter) + P NameType TTName TT | + ||| de Bruijn variables + V Int | + ||| Bind a variable + Bind TTName (Binder TT) TT | + ||| Apply one term to another + App TT TT | + ||| Embed a constant + TConst Const | + ||| Argument projection; runtime only + Proj TT Int | + ||| Erased terms + Erased | + ||| Impossible terms + Impossible | + ||| The type of types along (with universe constraints) + TType TTUExp +%name TT tm, tm' + +||| Raw terms without types +data Raw = + ||| Variables, global or local + Var TTName | + ||| Bind a variable + RBind TTName (Binder Raw) Raw | + ||| Application + RApp Raw Raw | + ||| The type of types + RType | + RForce Raw | + ||| Embed a constant + RConstant Const +%name Raw tm, tm' + +data SourceLocation : Type where + FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation + +%name SourceLocation loc + +||| Error reports are a list of report parts +data ErrorReportPart = + ||| A human-readable string + TextPart String | + ||| An Idris name (to be semantically coloured) + NamePart TTName | + ||| An Idris term, to be pretty printed + TermPart TT | + ||| An indented sub-report, to provide more details + SubReport (List ErrorReportPart) +%name ErrorReportPart part, p + +||| A representation of Idris's tactics that can be returned from custom +||| tactic implementations. Generate these using `applyTactic`. +data Tactic = + ||| Try the first tactic and resort to the second one on failure + Try Tactic Tactic | + ||| Only run if the goal has the right type + GoalType String Tactic | + ||| Resolve function name, find matching arguments in the + ||| context and compute the proof target + Refine TTName | + ||| Apply both tactics in sequence + Seq Tactic Tactic | + ||| Intelligently construct the proof target from the context + Trivial | + ||| Build a proof by applying contructors up to a maximum depth + Search Int | + ||| Resolve a type class + Instance | + ||| Infer the proof target from the context + Solve | + ||| introduce all variables into the context + Intros | + ||| Introduce a named variable into the context, use the + ||| first one if the given name is not found + Intro TTName | + ||| Invoke the reflected rep. of another tactic + ApplyTactic TT | + ||| Turn a value into its reflected representation + Reflect TT | + ||| Use a `%reflection` function + ByReflection TT | + ||| Turn a raw value back into a term + Fill Raw | + ||| Use the given value to conclude the proof + Exact TT | + ||| Focus on a particular hole + Focus TTName | + ||| Rewrite with an equality + Rewrite TT | + ||| Perform induction on a particular expression + Induction TT | + ||| Perform case analysis on a particular expression + Case TT | + ||| Name a reflected term + LetTac TTName TT | + ||| Name a reflected term and type it + LetTacTy TTName TT TT | + ||| Normalise the goal + Compute | + ||| Do nothing + Skip | + ||| Fail with an error message + Fail (List ErrorReportPart) | + ||| Attempt to fill the hole with source code information + SourceFC +%name Tactic tac, tac' + + +||| Things with a canonical representation in the TT datatype. +||| +||| This type class is intended to be used during proof automation and the +||| construction of custom tactics. +||| +||| @ a the type to be quoted +class Quotable a where + ||| A representation of the type `a`. + ||| + ||| This is to enable quoting polymorphic datatypes + quotedTy : TT + + ||| Quote a particular element of `a`. + ||| + ||| Each equation should look something like ```quote (Foo x y) = `(Foo ~(quote x) ~(quote y))``` + quote : a -> TT + +instance Quotable Nat where + quotedTy = `(Nat) + + quote Z = `(Z) + quote (S k) = `(S ~(quote k)) + +instance Quotable Int where + quotedTy = `(Int) + quote x = TConst (I x) + +instance Quotable Float where + quotedTy = `(Float) + quote x = TConst (Fl x) + +instance Quotable Char where + quotedTy = `(Char) + quote x = TConst (Ch x) + +instance Quotable Bits8 where + quotedTy = `(Bits8) + quote x = TConst (B8 x) + +instance Quotable Bits16 where + quotedTy = `(Bits16) + quote x = TConst (B16 x) + +instance Quotable Bits32 where + quotedTy = `(Bits32) + quote x = TConst (B32 x) + +instance Quotable Bits64 where + quotedTy = `(Bits64) + quote x = TConst (B64 x) + +instance Quotable Integer where + quotedTy = `(Integer) + quote x = TConst (BI x) + +instance Quotable Bits8x16 where + quotedTy = `(Bits8x16) + quote x = TConst (B8V x) + +instance Quotable Bits16x8 where + quotedTy = `(Bits16x8) + quote x = TConst (B16V x) + +instance Quotable Bits32x4 where + quotedTy = `(Bits32x4) + quote x = TConst (B32V x) + +instance Quotable Bits64x2 where + quotedTy = `(Bits64x2) + quote x = TConst (B64V x) + +instance Quotable String where + quotedTy = `(String) + quote x = TConst (Str x) + +instance Quotable NameType where + quotedTy = `(NameType) + quote Bound = `(Bound) + quote Ref = `(Ref) + quote (DCon x y) = `(DCon ~(quote x) ~(quote y)) + quote (TCon x y) = `(TCon ~(quote x) ~(quote y)) + +instance Quotable a => Quotable (List a) where + quotedTy = `(List ~(quotedTy {a=a})) + quote [] = `(List.Nil {a=~quotedTy}) + quote (x :: xs) = `(List.(::) {a=~quotedTy} ~(quote x) ~(quote xs)) + +instance Quotable TTName where + quotedTy = `(TTName) + quote (UN x) = `(UN ~(quote x)) + quote (NS n xs) = `(NS ~(quote n) ~(quote xs)) + quote (MN x y) = `(MN ~(quote x) ~(quote y)) + quote NErased = `(NErased) + +instance Quotable NativeTy where + quotedTy = `(NativeTy) + quote IT8 = `(Reflection.IT8) + quote IT16 = `(Reflection.IT16) + quote IT32 = `(Reflection.IT32) + quote IT64 = `(Reflection.IT64) + +instance Quotable Reflection.IntTy where + quotedTy = `(Reflection.IntTy) + quote (ITFixed x) = `(ITFixed ~(quote x)) + quote ITNative = `(Reflection.ITNative) + quote ITBig = `(ITBig) + quote ITChar = `(Reflection.ITChar) + quote (ITVec x y) = `(ITVec ~(quote x) ~(quote y)) + +instance Quotable ArithTy where + quotedTy = `(ArithTy) + quote (ATInt x) = `(ATInt ~(quote x)) + quote ATFloat = `(ATFloat) + +instance Quotable Const where + quotedTy = `(Const) + quote (I x) = `(I ~(quote x)) + quote (BI x) = `(BI ~(quote x)) + quote (Fl x) = `(Fl ~(quote x)) + quote (Ch x) = `(Ch ~(quote x)) + quote (Str x) = `(Str ~(quote x)) + quote (B8 x) = `(B8 ~(quote x)) + quote (B16 x) = `(B16 ~(quote x)) + quote (B32 x) = `(B32 ~(quote x)) + quote (B64 x) = `(B64 ~(quote x)) + quote (B8V xs) = `(B8V ~(quote xs)) + quote (B16V xs) = `(B16V ~(quote xs)) + quote (B32V xs) = `(B32V ~(quote xs)) + quote (B64V xs) = `(B64V ~(quote xs)) + quote (AType x) = `(AType ~(quote x)) + quote StrType = `(StrType) + quote PtrType = `(PtrType) + quote ManagedPtrType = `(ManagedPtrType) + quote BufferType = `(BufferType) + quote VoidType = `(VoidType) + quote Forgot = `(Forgot) + + +instance Quotable TTUExp where + quotedTy = `(TTUExp) + quote (UVar x) = `(UVar ~(quote x)) + quote (UVal x) = `(UVal ~(quote x)) + +mutual + instance Quotable TT where + quotedTy = `(TT) + quote (P nt n tm) = `(P ~(quote nt) ~(quote n) ~(quote tm)) + quote (V x) = `(V ~(quote x)) + quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm)) + quote (App f x) = `(App ~(quote f) ~(quote x)) + quote (TConst c) = `(TConst ~(quote c)) + quote (Proj tm x) = `(Proj ~(quote tm) ~(quote x)) + quote Erased = `(Erased) + quote Impossible = `(Impossible) + quote (TType uexp) = `(TType ~(quote uexp)) + + instance Quotable (Binder TT) where + quotedTy = `(Binder TT) + quote (Lam x) = `(Lam {a=TT} ~(assert_total (quote x))) + quote (Pi x k) = `(Pi {a=TT} ~(assert_total (quote x)) + ~(assert_total (quote k))) + quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x)) + ~(assert_total (quote y))) + quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x)) + ~(assert_total (quote y))) + quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x))) + quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x))) + quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x)) + ~(assert_total (quote y))) + quote (PVar x) = `(PVar {a=TT} ~(assert_total (quote x))) + quote (PVTy x) = `(PVTy {a=TT} ~(assert_total (quote x))) + + +instance Quotable ErrorReportPart where + quotedTy = `(ErrorReportPart) + quote (TextPart x) = `(TextPart ~(quote x)) + quote (NamePart n) = `(NamePart ~(quote n)) + quote (TermPart tm) = `(TermPart ~(quote tm)) + quote (SubReport xs) = `(SubReport ~(assert_total $ quote xs)) + +mutual + quoteRaw : Raw -> TT + quoteRaw (Var n) = `(Var ~(quote n)) + quoteRaw (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinder b) ~(quoteRaw tm)) + quoteRaw (RApp tm tm') = `(RApp ~(quoteRaw tm) ~(quoteRaw tm')) + quoteRaw RType = `(RType) + quoteRaw (RForce tm) = `(RForce ~(quoteRaw tm)) + quoteRaw (RConstant c) = `(RConstant ~(quote c)) + + quoteRawBinder : Binder Raw -> TT + quoteRawBinder (Lam x) = `(Lam {a=Raw} ~(quoteRaw x)) + quoteRawBinder (Pi x k) = `(Pi {a=Raw} ~(quoteRaw x) ~(quoteRaw k)) + quoteRawBinder (Let x y) = `(Let {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) + quoteRawBinder (NLet x y) = `(NLet {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) + quoteRawBinder (Hole x) = `(Hole {a=Raw} ~(quoteRaw x)) + quoteRawBinder (GHole x) = `(GHole {a=Raw} ~(quoteRaw x)) + quoteRawBinder (Guess x y) = `(Guess {a=Raw} ~(quoteRaw x) ~(quoteRaw y)) + quoteRawBinder (PVar x) = `(PVar {a=Raw} ~(quoteRaw x)) + quoteRawBinder (PVTy x) = `(PVTy {a=Raw} ~(quoteRaw x)) + +instance Quotable Raw where + quotedTy = `(Raw) + quote = quoteRaw + +instance Quotable (Binder Raw) where + quotedTy = `(Binder Raw) + quote = quoteRawBinder + +instance Quotable Tactic where + quotedTy = `(Tactic) + quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac')) + quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac)) + quote (Refine n) = `(Refine ~(quote n)) + quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac')) + quote Trivial = `(Trivial) + quote (Search x) = `(Search ~(quote x)) + quote Instance = `(Instance) + quote Solve = `(Solve) + quote Intros = `(Intros) + quote (Intro n) = `(Intro ~(quote n)) + quote (ApplyTactic tm) = `(ApplyTactic ~(quote tm)) + quote (Reflect tm) = `(Reflect ~(quote tm)) + quote (ByReflection tm) = `(ByReflection ~(quote tm)) + quote (Fill tm) = `(Fill ~(quote tm)) + quote (Exact tm) = `(Exact ~(quote tm)) + quote (Focus n) = `(Focus ~(quote n)) + quote (Rewrite tm) = `(Rewrite ~(quote tm)) + quote (Induction tm) = `(Induction ~(quote tm)) + quote (Case tm) = `(Case ~(quote tm)) + quote (LetTac n tm) = `(LetTac ~(quote n) ~(quote tm)) + quote (LetTacTy n tm tm') = `(LetTacTy ~(quote n) ~(quote tm) ~(quote tm')) + quote Compute = `(Compute) + quote Skip = `(Skip) + quote (Fail xs) = `(Fail ~(quote xs)) + quote SourceFC = `(SourceFC) diff --git a/libs/prelude/Language/Reflection/Errors.idr b/libs/prelude/Language/Reflection/Errors.idr new file mode 100644 --- /dev/null +++ b/libs/prelude/Language/Reflection/Errors.idr @@ -0,0 +1,48 @@ +module Language.Reflection.Errors + +import Builtins + +import Language.Reflection + +import Prelude.Bool +import Prelude.List +import Prelude.Maybe + +data Err = Msg String + | InternalMsg String + | CantUnify Bool TT TT Err (List (TTName, TT)) Int + -- Int is 'score' - how much we did unify + -- Bool indicates recoverability, True indicates more info may make + -- unification succeed + | InfiniteUnify TTName TT (List (TTName, TT)) + | CantConvert TT TT (List (TTName, TT)) + | CantSolveGoal TT (List (TTName, TT)) + | UnifyScope TTName TTName TT (List (TTName, TT)) + | CantInferType String + | NonFunctionType TT TT + | NotEquality TT TT + | TooManyArguments TTName + | CantIntroduce TT + | NoSuchVariable TTName + | WithFnType TT + | CantMatch TT + | NoTypeDecl TTName + | NotInjective TT TT TT + | CantResolve TT + | CantResolveAlts (List String) + | IncompleteTerm TT + | UniverseError + | ProgramLineComment + | Inaccessible TTName + | NonCollapsiblePostulate TTName + | AlreadyDefined TTName + | ProofSearchFail Err + | NoRewriting TT + | ProviderError String + | LoadingFailed String Err + +%name Err err, e + +-- Error reports become functions in List (String, TT) -> Err -> ErrorReport +ErrorHandler : Type +ErrorHandler = Err -> Maybe (List ErrorReportPart) diff --git a/libs/prelude/Prelude.idr b/libs/prelude/Prelude.idr --- a/libs/prelude/Prelude.idr +++ b/libs/prelude/Prelude.idr @@ -1,29 +1,32 @@ module Prelude -import Builtins -import IO +import public Builtins +import public IO -import Prelude.Bool -import Prelude.Classes -import Prelude.Cast -import Prelude.Nat -import Prelude.Fin -import Prelude.List -import Prelude.Maybe -import Prelude.Monad -import Prelude.Applicative -import Prelude.Functor -import Prelude.Either -import Prelude.Vect -import Prelude.Strings -import Prelude.Chars -import Prelude.Traversable -import Prelude.Bits -import Prelude.Stream -import Prelude.Uninhabited -import Prelude.Pairs +import public Prelude.Algebra +import public Prelude.Basics +import public Prelude.Bool +import public Prelude.Classes +import public Prelude.Cast +import public Prelude.Nat +import public Prelude.List +import public Prelude.Maybe +import public Prelude.Monad +import public Prelude.Applicative +import public Prelude.Foldable +import public Prelude.Functor +import public Prelude.Either +import public Prelude.Strings +import public Prelude.Chars +import public Prelude.Traversable +import public Prelude.Bits +import public Prelude.Uninhabited +import public Prelude.Pairs +import public Prelude.Stream -import Decidable.Equality +import public Decidable.Equality +import public Language.Reflection +import public Language.Reflection.Errors %access public %default total @@ -42,11 +45,6 @@ instance Show Float where show = prim__floatToStr -asciiTab : Vect 32 String -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"] firstCharIs : (Char -> Bool) -> String -> Bool firstCharIs p s with (strM s) @@ -67,12 +65,22 @@ showLitChar '\SO' = protectEsc (== 'H') "\\SO" showLitChar '\DEL' = ("\\DEL" ++) showLitChar '\\' = ("\\\\" ++) -showLitChar c = case (integerToFin (cast (cast {to=Int} c)) 32) of - Just k => strCons '\\' . ((index k asciiTab) ++) +showLitChar c = case getAt (cast (cast {to=Int} c)) asciiTab of + Just k => strCons '\\' . (k ++) Nothing => if (c > '\DEL') then strCons '\\' . protectEsc isDigit (show (cast {to=Int} c)) else strCons c + where asciiTab : List String + 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"] + getAt : Nat -> List String -> Maybe String + getAt Z (x :: xs) = Just x + getAt (S k) (x :: xs) = getAt k xs + getAt _ [] = Nothing + showLitString : List Char -> String -> String showLitString [] = id showLitString ('"'::cs) = ("\\\"" ++) . showLitString cs @@ -216,13 +224,6 @@ show' acc [x] = acc ++ show x show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs -instance Show a => Show (Vect n a) where - show xs = "[" ++ show' xs ++ "]" where - show' : Vect n a -> String - show' [] = "" - show' [x] = show x - show' (x :: xs) = show x ++ ", " ++ show' xs - instance Show a => Show (Maybe a) where show Nothing = "Nothing" show (Just x) = "Just " ++ show x @@ -274,15 +275,6 @@ fs <$> vs = concatMap (\f => map f vs) fs -instance Applicative (Vect k) where - pure = replicate _ - - fs <$> vs = zipWith apply fs vs - -instance Applicative Stream where - pure = repeat - (<$>) = zipWith apply - ---- Alternative instances instance Alternative Maybe where @@ -315,12 +307,6 @@ instance Monad List where m >>= f = concatMap f m -instance Monad (Vect n) where - m >>= f = diag (map f m) - -instance Monad Stream where - s >>= f = diag (map f s) - ---- Traversable instances instance Traversable Maybe where @@ -331,10 +317,6 @@ traverse f [] = pure List.Nil traverse f (x::xs) = [| List.(::) (f x) (traverse f xs) |] -instance Traversable (Vect n) where - traverse f [] = pure Vect.Nil - traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |] - ---- some mathematical operations ---- XXX this should probably go some place else, pow : (Num a) => a -> Nat -> a @@ -418,17 +400,6 @@ where go : List Nat -> List Int go [] = [] go (x :: xs) = n + (cast x * inc) :: go xs - -instance Enum (Fin (S n)) where - pred FZ = FZ - pred (FS n) = weaken n - succ n = case strengthen (FS n) of - Left _ => last - Right k => k - toNat n = cast n - fromNat {n=n} m = case natToFin m (S n) of - Just k => k - Nothing => last syntax "[" [start] ".." [end] "]" = enumFromTo start end diff --git a/libs/prelude/Prelude/Algebra.idr b/libs/prelude/Prelude/Algebra.idr --- a/libs/prelude/Prelude/Algebra.idr +++ b/libs/prelude/Prelude/Algebra.idr @@ -6,6 +6,7 @@ infixl 6 <-> infixl 6 <+> infixl 6 <*> +infixl 5 <#> %access public @@ -298,25 +299,31 @@ total fieldInverseIsInverseL : (l : a) -> l <*> inverseM l = unity total fieldInverseIsInverseR : (r : a) -> inverseM r <*> r = unity --- vector spaces. -||| A Vector Space over a Field can be considered as an additive Abeliean Group -||| of Vectors adjoined to the Field structure by distributivity laws relating -||| the two operations. Such that we satisfy the following laws: +||| A module over a ring is an additive abelian group of 'vectors' endowed with a +||| scale operation multiplying vectors by ring elements, and distributivity laws +||| relating the scale operation to both ring addition and module addition. +||| Must satisfy the following laws: ||| -||| + Unity for `<*>`: -||| forall a, a <*> unity == a -||| forall a, unity <*> a == a -||| + Distributivity of `<*>` and `<+>`: -||| forall a x y, a <*> (x <+> y) == (a <*> x) <+> (a <*> y) -||| forall a b x, (a <+> b) <*> x == (a <*> x) <+> (b <*> x) -class (Field a, AbelianGroup a) => VectorSpace a a where {} +||| + Compatibility of scalar multiplication with ring multiplication: +||| forall a b v, a <#> (b <#> v) = (a <*> b) <#> v +||| + Ring unity is the identity element of scalar multiplication: +||| forall v, unity <#> v = v +||| + Distributivity of `<#>` and `<+>`: +||| forall a v w, a <#> (v <+> w) == (a <#> v) <+> (a <#> w) +||| forall a b v, (a <+> b) <#> v == (a <#> v) <+> (b <#> v) +class (RingWithUnity a, AbelianGroup b) => Module a b where + (<#>) : a -> b -> b -class (VerifiedField a, VerifiedAbelianGroup a, VectorSpace a a) => VerifiedVectorSpace a a where - total vectorspaceScalarUnityIsUnityL : (l : a) -> l <*> unity = l - total vectorspaceScalarUnityIsUnityR : (r : a) -> unity <*> r = r - total vectorspaceScalarIsDistributiveWRTVectorAddition : (s : a) -> (x, y : a) -> s <*> (x <+> y) = (s <*> x) <+> (s <*> y) - total vectorspaceScalarIsDistributiveWRTFieldAddition : (s, t : a) -> (x : a) -> (s <+> t) <*> x = (s <*> x) <+> (t <*> x) +class (VerifiedRingWithUnity a, VerifiedAbelianGroup b, Module a b) => VerifiedModule a b where + total moduleScalarMultiplyComposition : (x,y : a) -> (v : b) -> x <#> (y <#> v) = (x <*> y) <#> v + total moduleScalarUnityIsUnity : (v : b) -> unity <#> v = v + total moduleScalarMultDistributiveWRTVectorAddition : (s : a) -> (v, w : b) -> s <#> (v <+> w) = (s <#> v) <+> (s <#> w) + total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v) +||| A vector space is a module over a ring that is also a field +class (Field a, Module a b) => VectorSpace a b where {} + +class (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {} -- XXX todo: -- Structures where "abs" make sense. 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,7 +1,9 @@ module Prelude.Applicative import Builtins + import Prelude.Basics +import Prelude.Bool import Prelude.Classes import Prelude.Functor @@ -16,6 +18,17 @@ instance Applicative id where pure a = a f <$> a = f a + +class (Applicative f, VerifiedFunctor f) => VerifiedApplicative (f : Type -> Type) where + applicativeMap : (x : f a) -> (g : a -> b) -> + map g x = pure g <$> x + applicativeIdentity : (x : f a) -> pure id <$> x = x + applicativeComposition : (x : f a) -> (g1 : f (a -> b)) -> (g2 : f (b -> c)) -> + ((pure (.) <$> g2) <$> g1) <$> x = g2 <$> (g1 <$> x) + applicativeHomomorphism : (x : a) -> (g : a -> b) -> + (<$>) {f} (pure g) (pure x) = pure {f} (g x) + applicativeInterchange : (x : a) -> (g : f (a -> b)) -> + g <$> pure x = pure (\g' : a -> b => g' x) <$> g infixl 2 <$ (<$) : Applicative f => f a -> f b -> f a 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 @@ -30,7 +30,7 @@ infixl 9 . ||| Function composition -(.) : {a, b, c : Type*} -> (b -> c) -> (a -> b) -> a -> c +(.) : (b -> c) -> (a -> b) -> a -> c (.) f g x = f (g x) ||| Takes in the first two arguments in reverse order. 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 @@ -1,12 +1,18 @@ module Prelude.Bits -import Prelude.Strings -import Prelude.Vect +import Builtins + +import Prelude.Basics import Prelude.Bool +import Prelude.Cast +import Prelude.Classes +import Prelude.Foldable +import Prelude.Nat +import Prelude.List +import Prelude.Strings %access public %default total - b8ToString : Bits8 -> String b8ToString c = pack (with List [c1, c2]) 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 @@ -15,21 +15,6 @@ boolElim True t e = t boolElim False t e = e -||| Ensure that some run-time Boolean test has been performed. -||| -||| This lifts a Boolean predicate to the type level. See the function `choose` -||| if you need to perform a Boolean test and convince the type checker of this -||| fact. -||| -||| If you find yourself using `So` for something other than primitive types, -||| it may be appropriate to define a type of evidence for the property that you -||| care about instead. -data So : Bool -> Type where - Oh : So True - -instance Uninhabited (So False) where - uninhabited Oh impossible - -- Syntactic sugar for boolean elimination. syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e) 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 @@ -57,7 +57,7 @@ -- ---------------------------------------------------------- [ Ordering Class ] -data Ordering = LT | EQ | GT +%elim data Ordering = LT | EQ | GT instance Eq Ordering where LT == LT = True 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 @@ -2,11 +2,14 @@ import Builtins +import Prelude.Basics +import Prelude.Bool +import Prelude.Classes import Prelude.Maybe import Prelude.List ||| A sum type -data Either a b = +%elim data Either a b = ||| One possibility of the sum, conventionally used to represent errors Left a | ||| The other possibility, conventionally used to represent success @@ -29,11 +32,6 @@ -------------------------------------------------------------------------------- -- 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 ||| Simply-typed eliminator for Either ||| @ f the action to take on Left diff --git a/libs/prelude/Prelude/Fin.idr b/libs/prelude/Prelude/Fin.idr deleted file mode 100644 --- a/libs/prelude/Prelude/Fin.idr +++ /dev/null @@ -1,152 +0,0 @@ -module Prelude.Fin - -import Prelude.Nat -import Prelude.Either -import Prelude.Uninhabited - -%default total - -||| Numbers strictly less than some bound. The name comes from "finite sets". -||| -||| It's probably not a good idea to use `Fin` for arithmetic, and they will be -||| exceedingly inefficient at run time. -||| @ 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' - (==) _ _ = False - -||| There are no elements of `Fin Z` -FinZAbsurd : Fin Z -> Void -FinZAbsurd FZ impossible - -FinZElim : Fin Z -> a -FinZElim x = void (FinZAbsurd x) - -||| Convert a Fin to a Nat -finToNat : Fin n -> Nat -finToNat FZ = Z -finToNat (FS k) = S (finToNat k) - -||| `finToNat` is injective -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 - -||| Convert a Fin to an Integer -finToInteger : Fin n -> Integer -finToInteger FZ = 0 -finToInteger (FS k) = 1 + finToInteger k - -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) - strengthen (FS k) | Left x = Left (FS x) - 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 - -total FSinjective : {f : Fin n} -> {f' : Fin n} -> (FS f = FS f') -> f = f' -FSinjective Refl = Refl - -instance Ord (Fin n) where - compare FZ FZ = EQ - compare FZ (FS _) = LT - compare (FS _) FZ = GT - compare (FS x) (FS y) = compare x y - -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) -natToFin Z (S j) = Just FZ -natToFin (S k) (S j) with (natToFin k j) - | Just k' = Just (FS k') - | Nothing = Nothing -natToFin _ _ = Nothing - -integerToFin : Integer -> (n : Nat) -> Maybe (Fin n) -integerToFin x Z = Nothing -- make sure 'n' is concrete, to save reduction! -integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing - -||| Proof that some `Maybe` is actually `Just` -data IsJust : Maybe a -> Type where - ItIsJust : IsJust (Just x) - -||| Allow overloading of Integer literals for Fin. -||| @ x the Integer that the user typed -||| @ prf an automatically-constructed proof that `x` is in bounds -fromInteger : (x : Integer) -> - {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/Foldable.idr b/libs/prelude/Prelude/Foldable.idr --- a/libs/prelude/Prelude/Foldable.idr +++ b/libs/prelude/Prelude/Foldable.idr @@ -2,6 +2,7 @@ import Builtins import Prelude.Bool +import Prelude.Basics import Prelude.Classes import Prelude.Algebra 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 @@ -10,5 +10,11 @@ ||| @ m the morphism map : (m : a -> b) -> f a -> f b +class Functor f => VerifiedFunctor (f : Type -> Type) where + functorIdentity : {a : Type} -> (x : f a) -> map id x = id x + functorComposition : {a : Type} -> {b : Type} -> (x : f a) -> + (g1 : a -> b) -> (g2 : b -> c) -> + map (g2 . g1) x = (map g2 . map g1) x + instance Functor id where map f a = f a 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 @@ -4,6 +4,8 @@ import Prelude.Algebra import Prelude.Basics +import Prelude.Bool +import Prelude.Classes import Prelude.Foldable import Prelude.Functor import Prelude.Maybe @@ -232,10 +234,6 @@ instance Monoid (List a) where neutral = [] --- XXX: unification failure --- instance VerifiedSemigroup (List a) where --- semigroupOpIsAssociative = appendAssociative - instance Functor List where map f [] = [] map f (x::xs) = f x :: map f xs @@ -810,6 +808,13 @@ ||| No list contains an element of the empty list. hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False hasAnyNilFalse l = ?hasAnyNilFalseBody + +instance VerifiedSemigroup (List a) where + semigroupOpIsAssociative = appendAssociative + +instance VerifiedMonoid (List a) where + monoidNeutralIsNeutralL = appendNilRightNeutral + monoidNeutralIsNeutralR xs = Refl -------------------------------------------------------------------------------- -- Proofs 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 @@ -2,7 +2,10 @@ import Builtins import Prelude.Algebra +import Prelude.Basics +import Prelude.Bool import Prelude.Cast +import Prelude.Classes import Prelude.Foldable %access public @@ -23,6 +26,10 @@ isJust : Maybe a -> Bool isJust Nothing = False isJust (Just j) = True + +||| Proof that some `Maybe` is actually `Just` +data IsJust : Maybe a -> Type where + ItIsJust : IsJust (Just x) -------------------------------------------------------------------------------- -- Misc 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 @@ -14,6 +14,16 @@ class Applicative m => Monad (m : Type -> Type) where (>>=) : m a -> (a -> m b) -> m b +class (Monad m, VerifiedApplicative m) => VerifiedMonad (m : Type -> Type) where + monadApplicative : (mf : m (a -> b)) -> (mx : m a) -> + mf <$> mx = mf >>= \f => + mx >>= \x => + pure (f x) + monadLeftIdentity : (x : a) -> (f : a -> m b) -> return x >>= f = f x + monadRightIdentity : (mx : m a) -> mx >>= return = mx + monadAssociativity : (mx : m a) -> (f : a -> m b) -> (g : b -> m c) -> + (mx >>= f) >>= g = mx >>= (\x => f x >>= g) + instance Monad id where a >>= f = f a 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 @@ -3,6 +3,7 @@ import Builtins import Prelude.Algebra +import Prelude.Basics import Prelude.Bool import Prelude.Cast import Prelude.Classes 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 @@ -1,7 +1,13 @@ module Prelude.Stream +import Builtins + +import Prelude.Basics import Prelude.Functor -import Prelude.Vect +import Prelude.Applicative +import Prelude.Monad +import Prelude.Nat +import Prelude.List %access public %default total @@ -27,7 +33,7 @@ ||| 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 : (n : Nat) -> (xs : Stream a) -> List a take Z _ = [] take (S n) (x :: xs) = x :: (take n xs) @@ -103,11 +109,10 @@ scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b scanr f (x :: xs) = f x (foldr f xs) :: scanr f xs -||| Produce a Stream repeating a sequence -||| @ xs the sequence to repeat -cycle : (xs : Vect (S n) a) -> Stream a -cycle xs = cycle_ xs xs - where cycle_ : Vect (S n) a -> Vect m a -> Stream a - cycle_ (x :: xs) [] = x :: cycle_ (x :: xs) xs - cycle_ xs (x :: ys) = x :: cycle_ xs ys +instance Applicative Stream where + pure = repeat + (<$>) = zipWith apply + +instance Monad Stream where + s >>= f = diag (map f s) 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 @@ -1,11 +1,19 @@ module Prelude.Strings import Builtins -import Prelude.List + +import Prelude.Algebra +import Prelude.Basics +import Prelude.Bool import Prelude.Chars import Prelude.Cast +import Prelude.Classes import Prelude.Either import Prelude.Foldable +import Prelude.Functor +import Prelude.List +import Prelude.Nat +import Decidable.Equality ||| Appends two strings together. ||| @@ -74,20 +82,20 @@ StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) ||| Version of 'strHead' that statically verifies that the string is not empty. -strHead' : (x : String) -> So (not (x == "")) -> Char +strHead' : (x : String) -> (not (x == "") = True) -> Char strHead' x p = assert_total $ prim__strHead x ||| Version of 'strTail' that statically verifies that the string is not empty. -strTail' : (x : String) -> So (not (x == "")) -> String +strTail' : (x : String) -> (not (x == "") = True) -> String strTail' x p = assert_total $ prim__strTail x -- we need the 'believe_me' because the operations are primitives strM : (x : String) -> StrM x -strM x with (choose (not (x == ""))) - strM x | (Left p) = really_believe_me $ +strM x with (decEq (not (x == "")) True) + strM x | (Yes p) = really_believe_me $ StrCons (assert_total (strHead' x p)) (assert_total (strTail' x p)) - strM x | (Right p) = really_believe_me StrNil + strM x | (No p) = really_believe_me StrNil -- annoyingly, we need these assert_totals because StrCons doesn't have -- a recursive argument, therefore the termination checker doesn't believe diff --git a/libs/prelude/Prelude/Traversable.idr b/libs/prelude/Prelude/Traversable.idr --- a/libs/prelude/Prelude/Traversable.idr +++ b/libs/prelude/Prelude/Traversable.idr @@ -1,7 +1,11 @@ module Prelude.Traversable +import Builtins + +import Prelude.Basics import Prelude.Applicative import Prelude.Foldable +import Prelude.Functor traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ f = foldr (($>) . f) (pure ()) diff --git a/libs/prelude/Prelude/Uninhabited.idr b/libs/prelude/Prelude/Uninhabited.idr --- a/libs/prelude/Prelude/Uninhabited.idr +++ b/libs/prelude/Prelude/Uninhabited.idr @@ -1,3 +1,6 @@ +||| Utilities for working with uninhabited types, to record explicit +||| locations for canonical proofs of emptiness. Typically, one should +||| use the `absurd` function. module Prelude.Uninhabited import Builtins diff --git a/libs/prelude/Prelude/Vect.idr b/libs/prelude/Prelude/Vect.idr deleted file mode 100644 --- a/libs/prelude/Prelude/Vect.idr +++ /dev/null @@ -1,548 +0,0 @@ -module Prelude.Vect - -import Prelude.Fin -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 - -infixr 7 :: - -%elim data Vect : Nat -> Type -> Type where - Nil : Vect Z a - (::) : (x : a) -> (xs : Vect n a) -> Vect (S n) a - --- Hints for interactive editing -%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 - - -||| Insert an element at a particular index -insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a -insertAt FZ y xs = y :: xs -insertAt (FS k) y (x::xs) = x :: insertAt k y xs -insertAt (FS k) y [] = absurd k - -||| 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 (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) -> Vect (n + m) a -> Vect n a -take Z xs = [] -take (S k) (x :: xs) = x :: take k xs - -||| Remove the first m elements of a Vect -||| @ m the number of elements to remove -drop : (n : Nat) -> Vect (n + m) a -> Vect m a -drop Z xs = xs -drop (S k) (x :: xs) = drop k xs - -||| Take the longest prefix of a Vect such that all elements satisfy some -||| Boolean predicate. -||| -||| @ p the predicate -takeWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) -takeWhile p [] = (_ ** []) -takeWhile p (x::xs) = - let (len ** ys) = takeWhile p xs - in if p x then - (S len ** x :: ys) - else - (_ ** []) - -||| Remove the longest prefix of a Vect such that all removed elements satisfy some -||| Boolean predicate. -||| -||| @ p the predicate -dropWhile : (p : a -> Bool) -> Vect n a -> (q ** Vect q a) -dropWhile p [] = (_ ** []) -dropWhile p (x::xs) = - if p x then - dropWhile p xs - else - (_ ** x::xs) - --------------------------------------------------------------------------------- --- Transformations --------------------------------------------------------------------------------- - -||| Reverse the order of the elements of a vector -reverse : Vect n a -> Vect n a -reverse xs = go [] xs - where go : Vect n a -> Vect m a -> Vect (n+m) a - go {n} acc [] = rewrite plusZeroRightNeutral n in acc - go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m - in go (x::acc) 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' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n - in 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 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 - -||| 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 - --------------------------------------------------------------------------------- --- 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 three equal-length vectors into a vector with some function -zipWith3 : (a -> b -> c -> d) -> Vect n a -> Vect n b -> Vect n c -> Vect n d -zipWith3 f [] [] [] = [] -zipWith3 f (x::xs) (y::ys) (z::zs) = f x y z :: zipWith3 f xs ys zs - -||| Combine two equal-length vectors pairwise -zip : Vect n a -> Vect n b -> Vect n (a, b) -zip = zipWith (\x,y => (x,y)) - -||| Combine three equal-length vectors elementwise into a vector of tuples -zip3 : Vect n a -> Vect n b -> Vect n c -> Vect n (a, b, c) -zip3 = zipWith3 (\x,y,z => (x,y,z)) - -||| 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) - -||| Convert a vector of three-tuples to a triplet of vectors -unzip3 : Vect n (a, b, c) -> (Vect n a, Vect n b, Vect n c) -unzip3 [] = ([], [], []) -unzip3 ((l,c,r)::xs) with (unzip3 xs) - | (lefts, centers, rights) = (l::lefts, c::centers, r::rights) - --------------------------------------------------------------------------------- --- Equality --------------------------------------------------------------------------------- - -instance (Eq a) => Eq (Vect n a) where - (==) [] [] = True - (==) (x::xs) (y::ys) = - if x == y then - xs == ys - else - False - - --------------------------------------------------------------------------------- --- Order --------------------------------------------------------------------------------- - -instance Ord a => Ord (Vect n a) where - compare [] [] = EQ - compare (x::xs) (y::ys) = - if x /= y then - compare x y - else - compare xs ys - - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - -instance Functor (Vect n) where - map f [] = [] - map f (x::xs) = f x :: map f xs - - -||| Map a partial function across a vector, returning those elements for which -||| the function had a value. -||| -||| The first projection of the resulting pair (ie the length) will always be -||| at most the length of the input vector. This is not, however, guaranteed -||| by the type. -||| -||| @ f the partial function (expressed by returning `Maybe`) -||| @ xs the vector to check for results -mapMaybe : (f : a -> Maybe b) -> (xs : Vect n a) -> (m : Nat ** Vect m b) -mapMaybe f [] = (_ ** []) -mapMaybe f (x::xs) = - let (len ** ys) = mapMaybe f xs - in case f x of - Just y => (S len ** y :: ys) - Nothing => ( len ** ys) - - --------------------------------------------------------------------------------- --- 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 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 - -||| Foldr without seeding the accumulator -foldr1 : (t -> t -> t) -> Vect (S n) t -> t -foldr1 f (x::xs) = foldr f x xs - -||| Foldl without seeding the accumulator -foldl1 : (t -> t -> t) -> Vect (S n) t -> t -foldl1 f (x::xs) = foldl f x xs --------------------------------------------------------------------------------- --- Scans --------------------------------------------------------------------------------- - -scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b -scanl f q [] = [q] -scanl f q (x::xs) = q :: scanl f (f q x) xs - --------------------------------------------------------------------------------- --- Membership tests --------------------------------------------------------------------------------- - -||| 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 - -||| 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 (==) - -||| 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 (==) - -||| 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 (==) - --------------------------------------------------------------------------------- --- Searching with a predicate --------------------------------------------------------------------------------- - -||| 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 - findIndex' : Nat -> (a -> Bool) -> Vect n a -> Maybe Nat - findIndex' cnt p [] = Nothing - findIndex' cnt p (x::xs) with (p x) - | 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 - total findIndices' : Nat -> (a -> Bool) -> Vect m a -> (p ** Vect p Nat) - findIndices' cnt p [] = (_ ** []) - findIndices' cnt p (x::xs) with (findIndices' (S cnt) p xs) - | (_ ** tail) = - if p x then - (_ ** cnt::tail) - else - (_ ** tail) - -elemIndexBy : (a -> a -> Bool) -> a -> Vect m a -> Maybe Nat -elemIndexBy p e = findIndex $ p e - -elemIndex : Eq a => a -> Vect m a -> Maybe Nat -elemIndex = elemIndexBy (==) - -total elemIndicesBy : (a -> a -> Bool) -> a -> Vect m a -> (p ** Vect p Nat) -elemIndicesBy p e = findIndices $ p e - -total elemIndices : Eq a => a -> Vect m a -> (p ** Vect p Nat) -elemIndices = elemIndicesBy (==) - --------------------------------------------------------------------------------- --- 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) - | (_ ** tail) = - if p x then - (_ ** x::tail) - 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 - nubBy' : Vect m a -> (a -> a -> Bool) -> Vect n a -> (p ** Vect p a) - nubBy' acc p [] = (_ ** []) - nubBy' acc p (x::xs) with (elemBy p x acc) - | True = nubBy' acc p xs - | 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 (==) - -deleteBy : (a -> a -> Bool) -> a -> Vect n a -> (p ** Vect p a) -deleteBy _ _ [] = (_ ** []) -deleteBy eq x (y::ys) = - let (len ** zs) = deleteBy eq x ys - in if x `eq` y then (_ ** ys) else (S len ** y ::zs) - -delete : (Eq a) => a -> Vect n a -> (p ** Vect p a) -delete = deleteBy (==) - --------------------------------------------------------------------------------- --- 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) -> (xs : Vect (n + m) a) -> (Vect n a, Vect m a) -splitAt n xs = (take n xs, drop n xs) - -partition : (a -> Bool) -> Vect n a -> ((p ** Vect p a), (q ** Vect q a)) -partition p [] = ((_ ** []), (_ ** [])) -partition p (x::xs) = - let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in - if p x then - ((S leftLen ** x::lefts), (rightLen ** rights)) - else - ((leftLen ** lefts), (S rightLen ** x::rights)) - --------------------------------------------------------------------------------- --- Predicates --------------------------------------------------------------------------------- - -isPrefixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool -isPrefixOfBy p [] right = True -isPrefixOfBy p left [] = False -isPrefixOfBy p (x::xs) (y::ys) with (p x y) - | True = isPrefixOfBy p xs ys - | False = False - -isPrefixOf : Eq a => Vect m a -> Vect n a -> Bool -isPrefixOf = isPrefixOfBy (==) - -isSuffixOfBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool -isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right) - -isSuffixOf : Eq a => Vect m a -> Vect n a -> Bool -isSuffixOf = isSuffixOfBy (==) - --------------------------------------------------------------------------------- --- Conversions --------------------------------------------------------------------------------- - -total maybeToVect : Maybe a -> (p ** Vect p a) -maybeToVect Nothing = (_ ** []) -maybeToVect (Just j) = (_ ** [j]) - -total vectToMaybe : Vect n a -> Maybe a -vectToMaybe [] = Nothing -vectToMaybe (x::xs) = Just x - --------------------------------------------------------------------------------- --- Misc --------------------------------------------------------------------------------- - -catMaybes : Vect n (Maybe a) -> (p ** Vect p a) -catMaybes [] = (_ ** []) -catMaybes (Nothing::xs) = catMaybes xs -catMaybes ((Just j)::xs) with (catMaybes xs) - | (_ ** tail) = (_ ** j::tail) - -diag : Vect n (Vect n a) -> Vect n a -diag [] = [] -diag ((x::xs)::xss) = x :: diag (map tail xss) - -range : Vect n (Fin n) -range {n=Z} = [] -range {n=S _} = FZ :: map FS range - -||| Transpose a Vect of Vects, turning rows into columns and vice versa. -||| -||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`. -transpose : Vect m (Vect n a) -> Vect n (Vect m a) -transpose [] = replicate _ [] -transpose (x :: xs) = zipWith (::) x (transpose xs) - --------------------------------------------------------------------------------- --- Properties --------------------------------------------------------------------------------- - -vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys) -vectConsCong x xs xs Refl = Refl - -vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs -vectNilRightNeutral [] = Refl -vectNilRightNeutral (x :: xs) = - vectConsCong _ _ _ (vectNilRightNeutral xs) - -vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z -vectAppendAssociative [] y z = Refl -vectAppendAssociative (x :: xs) ys zs = - vectConsCong _ _ _ (vectAppendAssociative xs ys zs) - - diff --git a/libs/prelude/prelude.ipkg b/libs/prelude/prelude.ipkg --- a/libs/prelude/prelude.ipkg +++ b/libs/prelude/prelude.ipkg @@ -4,11 +4,13 @@ modules = Builtins, Prelude, IO, Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast, - Prelude.Classes, Prelude.Nat, Prelude.Fin, Prelude.List, + Prelude.Classes, Prelude.Nat, Prelude.List, Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either, - Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor, + Prelude.Strings, Prelude.Chars, Prelude.Functor, Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream, Prelude.Uninhabited, Prelude.Pairs, + + Language.Reflection, Language.Reflection.Errors, Decidable.Equality diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -5,10 +5,10 @@ import System.Environment import System.Exit import System.FilePath ((), addTrailingPathSeparator) +import System.Directory import Data.Maybe import Data.Version -import Control.Monad.Trans.Error ( ErrorT(..) ) import Control.Monad.Trans.State.Strict ( execStateT, get, put ) import Control.Monad ( when ) @@ -46,6 +46,7 @@ when (ShowIncs `elem` opts) $ runIO showIncs when (ShowLibs `elem` opts) $ runIO showLibs when (ShowLibdir `elem` opts) $ runIO showLibdir + when (ShowPkgs `elem` opts) $ runIO showPkgs case opt getClient opts of [] -> return () (c:_) -> do setVerbose False @@ -81,7 +82,7 @@ showLibs :: IO b showLibs = do libFlags <- getLibFlags - putStrLn libFlags + putStrLn $ unwords libFlags exitWith ExitSuccess showLibdir :: IO b @@ -91,5 +92,10 @@ showIncs :: IO b showIncs = do incFlags <- getIncFlags - putStrLn incFlags + putStrLn $ unwords incFlags + exitWith ExitSuccess + +-- | List idris packages installed +showPkgs :: IO b +showPkgs = do mapM putStrLn =<< installedPackages exitWith ExitSuccess diff --git a/rts/Makefile b/rts/Makefile --- a/rts/Makefile +++ b/rts/Makefile @@ -8,6 +8,15 @@ CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\"" CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\"" +# NOTE: This works around glibc 2.11 not declaring pthread_mutexattr_settype +# and PTHREAD_MUTEX_RECURSIVE by default, causing compilation failures on +# Debian 6 and Ubuntu 10.04 LTS. +ifeq ($(OS), unix) +ifneq ($(shell ldd --version | head -n 1 | grep 2.11),) + CFLAGS += -D_GNU_SOURCE +endif +endif + ifeq ($(OS), windows) OBJS += windows/idris_stdfgn.o windows/idris_net.o else diff --git a/rts/idris_bitstring.c b/rts/idris_bitstring.c --- a/rts/idris_bitstring.c +++ b/rts/idris_bitstring.c @@ -1,8 +1,10 @@ +#include + #include "idris_rts.h" VAL idris_b8CopyForGC(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 1); + VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS8); cl->info.bits8 = A; return cl; @@ -10,7 +12,7 @@ VAL idris_b16CopyForGC(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 1); + VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS16); cl->info.bits16 = A; return cl; @@ -18,7 +20,7 @@ VAL idris_b32CopyForGC(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 1); + VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS32); cl->info.bits32 = A; return cl; @@ -26,7 +28,7 @@ VAL idris_b64CopyForGC(VM *vm, VAL a) { uint64_t A = a->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 1); + VAL cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS64); cl->info.bits64 = A; return cl; @@ -34,7 +36,7 @@ VAL idris_b8(VM *vm, VAL a) { uint8_t A = GETINT(a); - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl; @@ -42,7 +44,7 @@ VAL idris_b16(VM *vm, VAL a) { uint16_t A = GETINT(a); - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl; @@ -50,7 +52,7 @@ VAL idris_b32(VM *vm, VAL a) { uint32_t A = GETINT(a); - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl; @@ -58,7 +60,7 @@ VAL idris_b64(VM *vm, VAL a) { uint64_t A = GETINT(a); - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl; @@ -69,28 +71,28 @@ } VAL idris_b8const(VM *vm, uint8_t a) { - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = a; return cl; } VAL idris_b16const(VM *vm, uint16_t a) { - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = a; return cl; } VAL idris_b32const(VM *vm, uint32_t a) { - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = a; return cl; } VAL idris_b64const(VM *vm, uint64_t a) { - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = a; return cl; @@ -99,7 +101,7 @@ VAL idris_b8Plus(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A + B; return cl; @@ -108,7 +110,7 @@ VAL idris_b8Minus(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A - B; return cl; @@ -117,7 +119,7 @@ VAL idris_b8Times(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A * B; return cl; @@ -126,7 +128,7 @@ VAL idris_b8UDiv(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A / B; return cl; @@ -135,7 +137,7 @@ VAL idris_b8SDiv(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B)); return cl; @@ -144,7 +146,7 @@ VAL idris_b8URem(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A % B; return cl; @@ -153,7 +155,7 @@ VAL idris_b8SRem(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B)); return cl; @@ -181,7 +183,7 @@ VAL idris_b8Compl(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = ~ A; return cl; @@ -190,7 +192,7 @@ VAL idris_b8And(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A & B; return cl; @@ -199,7 +201,7 @@ VAL idris_b8Or(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A | B; return cl; @@ -208,7 +210,7 @@ VAL idris_b8Xor(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A ^ B; return cl; @@ -217,7 +219,7 @@ VAL idris_b8Shl(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A << B; return cl; @@ -226,7 +228,7 @@ VAL idris_b8LShr(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = A >> B; return cl; @@ -235,7 +237,7 @@ VAL idris_b8AShr(VM *vm, VAL a, VAL b) { uint8_t A = a->info.bits8; uint8_t B = b->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B)); return cl; @@ -244,7 +246,7 @@ VAL idris_b16Plus(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A + B; return cl; @@ -253,7 +255,7 @@ VAL idris_b16Minus(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A - B; return cl; @@ -262,7 +264,7 @@ VAL idris_b16Times(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A * B; return cl; @@ -271,7 +273,7 @@ VAL idris_b16UDiv(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A / B; return cl; @@ -280,7 +282,7 @@ VAL idris_b16SDiv(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B)); return cl; @@ -289,7 +291,7 @@ VAL idris_b16URem(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A % B; return cl; @@ -298,7 +300,7 @@ VAL idris_b16SRem(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B)); return cl; @@ -326,7 +328,7 @@ VAL idris_b16Compl(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = ~ A; return cl; @@ -335,7 +337,7 @@ VAL idris_b16And(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A & B; return cl; @@ -344,7 +346,7 @@ VAL idris_b16Or(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A | B; return cl; @@ -353,7 +355,7 @@ VAL idris_b16Xor(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A ^ B; return cl; @@ -362,7 +364,7 @@ VAL idris_b16Shl(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A << B; return cl; @@ -371,7 +373,7 @@ VAL idris_b16LShr(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = A >> B; return cl; @@ -380,7 +382,7 @@ VAL idris_b16AShr(VM *vm, VAL a, VAL b) { uint16_t A = a->info.bits16; uint16_t B = b->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B)); return cl; @@ -389,7 +391,7 @@ VAL idris_b32Plus(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A + B; return cl; @@ -398,7 +400,7 @@ VAL idris_b32Minus(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A - B; return cl; @@ -407,7 +409,7 @@ VAL idris_b32Times(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A * B; return cl; @@ -416,7 +418,7 @@ VAL idris_b32UDiv(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A / B; return cl; @@ -425,7 +427,7 @@ VAL idris_b32SDiv(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B)); return cl; @@ -434,7 +436,7 @@ VAL idris_b32URem(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A % B; return cl; @@ -443,7 +445,7 @@ VAL idris_b32SRem(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B)); return cl; @@ -471,7 +473,7 @@ VAL idris_b32Compl(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = ~ A; return cl; @@ -480,7 +482,7 @@ VAL idris_b32And(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A & B; return cl; @@ -489,7 +491,7 @@ VAL idris_b32Or(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A | B; return cl; @@ -498,7 +500,7 @@ VAL idris_b32Xor(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A ^ B; return cl; @@ -507,7 +509,7 @@ VAL idris_b32Shl(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A << B; return cl; @@ -516,7 +518,7 @@ VAL idris_b32LShr(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = A >> B; return cl; @@ -525,7 +527,7 @@ VAL idris_b32AShr(VM *vm, VAL a, VAL b) { uint32_t A = a->info.bits32; uint32_t B = b->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B)); return cl; @@ -534,7 +536,7 @@ VAL idris_b64Plus(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A + B; return cl; @@ -543,7 +545,7 @@ VAL idris_b64Minus(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A - B; return cl; @@ -552,7 +554,7 @@ VAL idris_b64Times(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A * B; return cl; @@ -561,7 +563,7 @@ VAL idris_b64UDiv(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A / B; return cl; @@ -570,7 +572,7 @@ VAL idris_b64SDiv(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B)); return cl; @@ -579,7 +581,7 @@ VAL idris_b64URem(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A % B; return cl; @@ -588,7 +590,7 @@ VAL idris_b64SRem(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B)); return cl; @@ -616,7 +618,7 @@ VAL idris_b64Compl(VM *vm, VAL a) { uint64_t A = a->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = ~ A; return cl; @@ -625,7 +627,7 @@ VAL idris_b64And(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A & B; return cl; @@ -634,7 +636,7 @@ VAL idris_b64Or(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A | B; return cl; @@ -643,7 +645,7 @@ VAL idris_b64Xor(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A ^ B; return cl; @@ -652,7 +654,7 @@ VAL idris_b64Shl(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A << B; return cl; @@ -661,7 +663,7 @@ VAL idris_b64LShr(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = A >> B; return cl; @@ -670,7 +672,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) { uint64_t A = a->info.bits64; uint64_t B = b->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B)); return cl; @@ -678,7 +680,7 @@ VAL idris_b8Z16(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl; @@ -686,7 +688,7 @@ VAL idris_b8Z32(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl; @@ -694,7 +696,7 @@ VAL idris_b8Z64(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl; @@ -702,7 +704,7 @@ VAL idris_b8S16(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A; return cl; @@ -710,7 +712,7 @@ VAL idris_b8S32(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A; return cl; @@ -718,7 +720,7 @@ VAL idris_b8S64(VM *vm, VAL a) { uint8_t A = a->info.bits8; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A; return cl; @@ -726,7 +728,7 @@ VAL idris_b16Z32(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl; @@ -734,7 +736,7 @@ VAL idris_b16Z64(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl; @@ -742,7 +744,7 @@ VAL idris_b16S32(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A; return cl; @@ -750,7 +752,7 @@ VAL idris_b16S64(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A; return cl; @@ -758,7 +760,7 @@ VAL idris_b16T8(VM *vm, VAL a) { uint16_t A = a->info.bits16; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl; @@ -766,7 +768,7 @@ VAL idris_b32Z64(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) A; return cl; @@ -774,7 +776,7 @@ VAL idris_b32S64(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS64); cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A; return cl; @@ -782,7 +784,7 @@ VAL idris_b32T8(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl; @@ -790,7 +792,7 @@ VAL idris_b32T16(VM *vm, VAL a) { uint32_t A = a->info.bits32; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl; @@ -798,7 +800,7 @@ VAL idris_b64T8(VM *vm, VAL a) { uint64_t A = a->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS8); cl->info.bits8 = (uint8_t) A; return cl; @@ -806,7 +808,7 @@ VAL idris_b64T16(VM *vm, VAL a) { uint64_t A = a->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS16); cl->info.bits16 = (uint16_t) A; return cl; @@ -814,9 +816,77 @@ VAL idris_b64T32(VM *vm, VAL a) { uint64_t A = a->info.bits64; - VAL cl = allocate(vm, sizeof(Closure), 0); + VAL cl = allocate(sizeof(Closure), 0); SETTY(cl, BITS32); cl->info.bits32 = (uint32_t) A; return cl; } +// SSE vectors +VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx) { + __m128i sse = *vec->info.bits128p; + uint8_t data[16]; + _mm_storeu_si128((__m128i*)&data, sse); + return MKB8(vm, data[idx->info.bits32]); +} + +VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx) { + __m128i sse = *vec->info.bits128p; + uint16_t data[8]; + _mm_storeu_si128((__m128i*)&data, sse); + return MKB16(vm, data[idx->info.bits32]); +} + +VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx) { + __m128i sse = *vec->info.bits128p; + uint32_t data[4]; + _mm_storeu_si128((__m128i*)&data, sse); + return MKB32(vm, data[idx->info.bits32]); +} + +VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx) { + __m128i sse = *vec->info.bits128p; + uint64_t data[2]; + _mm_storeu_si128((__m128i*)&data, sse); + return MKB64(vm, data[idx->info.bits32]); +} + +VAL idris_b8x16CopyForGC(VM *vm, VAL vec) { + __m128i sse = *vec->info.bits128p; + VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS8X16); + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + *cl->info.bits128p = sse; + return cl; +} + +VAL idris_b16x8CopyForGC(VM *vm, VAL vec) { + __m128i sse = *vec->info.bits128p; + VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS16X8); + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + *cl->info.bits128p = sse; + return cl; +} + +VAL idris_b32x4CopyForGC(VM *vm, VAL vec) { + __m128i sse = *vec->info.bits128p; + VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS32X4); + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + *cl->info.bits128p = sse; + return cl; +} + +VAL idris_b64x2CopyForGC(VM *vm, VAL vec) { + __m128i sse = *vec->info.bits128p; + VAL cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS64X2); + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + *cl->info.bits128p = sse; + return cl; +} diff --git a/rts/idris_bitstring.h b/rts/idris_bitstring.h --- a/rts/idris_bitstring.h +++ b/rts/idris_bitstring.h @@ -126,4 +126,14 @@ VAL idris_b64T16(VM *vm, VAL a); VAL idris_b64T32(VM *vm, VAL a); +VAL idris_IDXB8x16(VM* vm, VAL vec, VAL idx); +VAL idris_IDXB16x8(VM* vm, VAL vec, VAL idx); +VAL idris_IDXB32x4(VM* vm, VAL vec, VAL idx); +VAL idris_IDXB64x2(VM* vm, VAL vec, VAL idx); + +VAL idris_b8x16CopyForGC(VM *vm, VAL a); +VAL idris_b16x8CopyForGC(VM *vm, VAL a); +VAL idris_b32x4CopyForGC(VM *vm, VAL a); +VAL idris_b64x2CopyForGC(VM *vm, VAL a); + #endif diff --git a/rts/idris_gc.c b/rts/idris_gc.c --- a/rts/idris_gc.c +++ b/rts/idris_gc.c @@ -55,6 +55,18 @@ case BITS64: cl = idris_b64CopyForGC(vm, x); break; + case BITS8X16: + cl = idris_b8x16CopyForGC(vm, x); + break; + case BITS16X8: + cl = idris_b16x8CopyForGC(vm, x); + break; + case BITS32X4: + cl = idris_b32x4CopyForGC(vm, x); + break; + case BITS64X2: + cl = idris_b64x2CopyForGC(vm, x); + break; case FWD: return x->info.ptr; default: @@ -69,7 +81,7 @@ int i; int ar; char* scan = vm->heap.heap; - + while(scan < vm->heap.next) { size_t inc = *((size_t*)scan); VAL heap_item = (VAL)(scan+sizeof(size_t)); @@ -85,7 +97,7 @@ } break; case STROFFSET: - heap_item->info.str_offset->str + heap_item->info.str_offset->str = copy(vm, heap_item->info.str_offset->str); break; default: // Nothing to copy @@ -101,10 +113,11 @@ STATS_ENTER_GC(vm->stats, vm->heap.size) // printf("Collecting\n"); + if (vm->heap.old != NULL) + free(vm->heap.old); + char* newheap = malloc(vm->heap.size); char* oldheap = vm->heap.heap; - if (vm->heap.old != NULL) - free(vm->heap.old); vm->heap.heap = newheap; #ifdef FORCE_ALIGNMENT @@ -138,21 +151,21 @@ if ((vm->heap.next - vm->heap.heap) > vm->heap.size >> 1) { vm->heap.size += vm->heap.growth; - } + } vm->heap.old = oldheap; - + STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap) HEAP_CHECK(vm) } void idris_gcInfo(VM* vm, int doGC) { - printf("Stack: \n", vm->valstack, vm->valstack_top); + printf("Stack: \n", vm->valstack, vm->valstack_top); printf("Final heap size %d\n", (int)(vm->heap.size)); printf("Final heap use %d\n", (int)(vm->heap.next - vm->heap.heap)); if (doGC) { idris_gc(vm); } printf("Final heap use after GC %d\n", (int)(vm->heap.next - vm->heap.heap)); #ifdef IDRIS_ENABLE_STATS - printf("Total allocations %d\n", vm->stats.allocations); + printf("Total allocations %" PRIu64 "\n", vm->stats.allocations); #endif printf("Number of collections %d\n", vm->stats.collections); diff --git a/rts/idris_gmp.c b/rts/idris_gmp.c --- a/rts/idris_gmp.c +++ b/rts/idris_gmp.c @@ -7,15 +7,26 @@ #include #include +// TMP HACK! Require this much space in the heap before a GMP operation +// so it doesn't garbage collect in the middle. +// This is highly dodgy and needs to be done better because who knows if +// GMP will need to allocate more than 64k... better to work out how +// much space is needed (or find another way of preventing copying) +#define IDRIS_MAXGMP 65536 + +void init_gmpalloc() { + mp_set_memory_functions(idris_alloc, idris_realloc, idris_free); +} + VAL MKBIGI(int val) { return MKINT((i_int)val); } VAL MKBIGC(VM* vm, char* val) { + idris_requireAlloc(IDRIS_MAXGMP); mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint); @@ -28,9 +39,10 @@ } VAL MKBIGM(VM* vm, void* big) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint); @@ -43,9 +55,10 @@ } VAL MKBIGMc(VM* vm, void* big) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + - sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set(*bigint, *((mpz_t*)big)); @@ -57,8 +70,10 @@ } VAL MKBIGUI(VM* vm, unsigned long val) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_ui(*bigint, val); @@ -70,8 +85,10 @@ } VAL MKBIGSI(VM* vm, signed long val) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_si(*bigint, val); @@ -83,9 +100,11 @@ } VAL GETBIG(VM * vm, VAL x) { + idris_requireAlloc(IDRIS_MAXGMP); + if (ISINT(x)) { mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init(*bigint); @@ -106,8 +125,10 @@ } VAL bigAdd(VM* vm, VAL x, VAL y) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); @@ -116,8 +137,10 @@ } VAL bigSub(VM* vm, VAL x, VAL y) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); @@ -126,8 +149,10 @@ } VAL bigMul(VM* vm, VAL x, VAL y) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); @@ -136,8 +161,10 @@ } VAL bigDiv(VM* vm, VAL x, VAL y) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); @@ -146,8 +173,10 @@ } VAL bigMod(VM* vm, VAL x, VAL y) { + idris_requireAlloc(IDRIS_MAXGMP); + mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y))); SETTY(cl, BIGINT); @@ -229,6 +258,8 @@ } int bigEqConst(VAL x, int c) { + idris_requireAlloc(IDRIS_MAXGMP); + if (ISINT(x)) { return (GETINT(x) == c); } else { int rv = mpz_cmp_si(GETMPZ(x), c); @@ -321,7 +352,7 @@ double val = GETFLOAT(f); mpz_t* bigint; - VAL cl = allocate(vm, sizeof(Closure) + sizeof(mpz_t), 0); + VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0); bigint = (mpz_t*)(((char*)cl) + sizeof(Closure)); mpz_init_set_d(*bigint, val); diff --git a/rts/idris_gmp.h b/rts/idris_gmp.h --- a/rts/idris_gmp.h +++ b/rts/idris_gmp.h @@ -7,6 +7,9 @@ #include "mini-gmp.h" #endif +// Set memory allocation functions +void init_gmpalloc(); + VAL MKBIGI(int val); VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint); diff --git a/rts/idris_main.c b/rts/idris_main.c --- a/rts/idris_main.c +++ b/rts/idris_main.c @@ -1,6 +1,7 @@ #include "idris_opts.h" #include "idris_stats.h" #include "idris_rts.h" +#include "idris_gmp.h" // The default options should give satisfactory results under many circumstances. RTSOpts opts = { .init_heap_size = 4096000, @@ -15,8 +16,12 @@ __idris_argv = argv; VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1); - initNullaries(); + init_threadkeys(); + init_threaddata(vm); + init_gmpalloc(); + init_nullaries(); + _idris__123_runMain0_125_(vm, NULL); #ifdef IDRIS_DEBUG @@ -31,6 +36,6 @@ print_stats(&stats); } - freeNullaries(); + free_nullaries(); return EXIT_SUCCESS; } diff --git a/rts/idris_rts.c b/rts/idris_rts.c --- a/rts/idris_rts.c +++ b/rts/idris_rts.c @@ -11,8 +11,17 @@ #include "idris_gc.h" #include "idris_bitstring.h" +#ifdef HAS_PTHREAD +static pthread_key_t vm_key; +#else +static VM* global_vm; +#endif -VM* init_vm(int stack_size, size_t heap_size, +void free_key(VM *vm) { + // nothing to free, we just used the VM pointer which is freed elsewhere +} + +VM* init_vm(int stack_size, size_t heap_size, int max_threads // not implemented yet ) { @@ -54,11 +63,24 @@ vm->max_threads = max_threads; vm->processes = 0; + +#else + global_vm = vm; #endif STATS_LEAVE_INIT(vm->stats) return vm; } +void init_threadkeys() { + pthread_key_create(&vm_key, (void*)free_key); +} + +void init_threaddata(VM *vm) { +#ifdef HAS_PTHREAD + pthread_setspecific(vm_key, vm); +#endif +} + Stats terminate(VM* vm) { Stats stats = vm->stats; STATS_ENTER_EXIT(stats) @@ -78,23 +100,30 @@ return stats; } -void idris_requireAlloc(VM* vm, size_t size) { +void idris_requireAlloc(size_t size) { +#ifdef HAS_PTHREAD + VM* vm = pthread_getspecific(vm_key); +#else + VM* vm = global_vm; +#endif + if (!(vm->heap.next + size < vm->heap.end)) { idris_gc(vm); } #ifdef HAS_PTHREAD int lock = vm->processes > 0; if (lock) { // We only need to lock if we're in concurrent mode - pthread_mutex_lock(&vm->alloc_lock); + pthread_mutex_lock(&vm->alloc_lock); } #endif } -void idris_doneAlloc(VM* vm) { +void idris_doneAlloc() { #ifdef HAS_PTHREAD + VM* vm = pthread_getspecific(vm_key); int lock = vm->processes > 0; if (lock) { // We only need to lock if we're in concurrent mode - pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif } @@ -103,14 +132,31 @@ return (vm->heap.next + size + sizeof(size_t) < vm->heap.end); } -void* allocate(VM* vm, size_t size, int outerlock) { +void* idris_alloc(size_t size) { + return allocate(size, 0); +} + +void* idris_realloc(void* old, size_t old_size, size_t size) { + void* ptr = idris_alloc(size); + memcpy(ptr, old, old_size); + return ptr; +} + +void idris_free(void* ptr, size_t size) { +} + +void* allocate(size_t size, int outerlock) { // return malloc(size); + #ifdef HAS_PTHREAD + VM* vm = pthread_getspecific(vm_key); int lock = vm->processes > 0 && !outerlock; if (lock) { // not message passing - pthread_mutex_lock(&vm->alloc_lock); + pthread_mutex_lock(&vm->alloc_lock); } +#else + VM* vm = global_vm; #endif if ((size & 7)!=0) { @@ -130,7 +176,7 @@ memset(ptr, 0, size); #ifdef HAS_PTHREAD if (lock) { // not message passing - pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif return ptr; @@ -138,10 +184,10 @@ idris_gc(vm); #ifdef HAS_PTHREAD if (lock) { // not message passing - pthread_mutex_unlock(&vm->alloc_lock); + pthread_mutex_unlock(&vm->alloc_lock); } #endif - return allocate(vm, size, 0); + return allocate(size, 0); } } @@ -160,7 +206,7 @@ */ VAL MKFLOAT(VM* vm, double val) { - Closure* cl = allocate(vm, sizeof(Closure), 0); + Closure* cl = allocate(sizeof(Closure), 0); SETTY(cl, FLOAT); cl -> info.f = val; return cl; @@ -173,8 +219,8 @@ } else { len = strlen(str)+1; } - Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) + - sizeof(char)*len, 0); + Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) + + sizeof(char)*len, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); if (str == NULL) { @@ -192,33 +238,33 @@ } VAL MKPTR(VM* vm, void* ptr) { - Closure* cl = allocate(vm, sizeof(Closure), 0); + Closure* cl = allocate(sizeof(Closure), 0); SETTY(cl, PTR); cl -> info.ptr = ptr; return cl; } VAL MKMPTR(VM* vm, void* ptr, size_t size) { - Closure* cl = allocate(vm, sizeof(Closure) + - sizeof(ManagedPtr) + size, 0); + Closure* cl = allocate(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); + 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); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, FLOAT); cl -> info.f = val; return cl; } VAL MKSTRc(VM* vm, char* str) { - Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) + - sizeof(char)*strlen(str)+1, 1); + Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) + + sizeof(char)*strlen(str)+1, 1); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); @@ -227,51 +273,152 @@ } VAL MKPTRc(VM* vm, void* ptr) { - Closure* cl = allocate(vm, sizeof(Closure), 1); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, PTR); cl -> info.ptr = ptr; return cl; } VAL MKMPTRc(VM* vm, void* ptr, size_t size) { - Closure* cl = allocate(vm, sizeof(Closure) + - sizeof(ManagedPtr) + size, 1); + Closure* cl = allocate(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); + 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); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS8); cl -> info.bits8 = bits8; return cl; } VAL MKB16(VM* vm, uint16_t bits16) { - Closure* cl = allocate(vm, sizeof(Closure), 1); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS16); cl -> info.bits16 = bits16; return cl; } VAL MKB32(VM* vm, uint32_t bits32) { - Closure* cl = allocate(vm, sizeof(Closure), 1); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS32); cl -> info.bits32 = bits32; return cl; } VAL MKB64(VM* vm, uint64_t bits64) { - Closure* cl = allocate(vm, sizeof(Closure), 1); + Closure* cl = allocate(sizeof(Closure), 1); SETTY(cl, BITS64); cl -> info.bits64 = bits64; return cl; } +VAL MKB8x16const(VM* vm, + uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3, + uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7, + uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11, + uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15) { + Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1); + SETTY(cl, BITS8X16); + + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + + uint8_t data[16]; + data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3; + data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7; + data[8]=v8; data[9]=v9; data[10]=v10; data[11]=v11; + data[12]=v12; data[13]=v13; data[14]=v14; data[15]=v15; + + *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data); + + return cl; +} + +VAL MKB8x16(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3, + VAL v4, VAL v5, VAL v6, VAL v7, + VAL v8, VAL v9, VAL v10, VAL v11, + VAL v12, VAL v13, VAL v14, VAL v15) { + return MKB8x16const(vm, + v0->info.bits8, v1->info.bits8, v2->info.bits8, v3->info.bits8, + v4->info.bits8, v5->info.bits8, v6->info.bits8, v7->info.bits8, + v8->info.bits8, v9->info.bits8, v10->info.bits8, v11->info.bits8, + v12->info.bits8, v13->info.bits8, v14->info.bits8, v15->info.bits8); +} + +VAL MKB16x8const(VM* vm, + uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3, + uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7) { + Closure* cl = allocate(sizeof(Closure) + sizeof(__m128i), 1); + SETTY(cl, BITS16X8); + + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + + uint16_t data[8]; + data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3; + data[4]=v4; data[5]=v5; data[6]=v6; data[7]=v7; + + *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data); + return cl; + +} + +VAL MKB16x8(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3, + VAL v4, VAL v5, VAL v6, VAL v7) { + return MKB16x8const(vm, + v0->info.bits16, v1->info.bits16, v2->info.bits16, v3->info.bits16, + v4->info.bits16, v5->info.bits16, v6->info.bits16, v7->info.bits16); +} + +VAL MKB32x4const(VM* vm, + uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3) { + Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS64X2); + + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + + uint32_t data[4]; + data[0]=v0; data[1]=v1; data[2]=v2; data[3]=v3; + + *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data); + return cl; +} + +VAL MKB32x4(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3) { + return MKB32x4const(vm, + v0->info.bits32, v1->info.bits32, v2->info.bits32, v3->info.bits32); +} + +VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1) { + Closure* cl = allocate(sizeof(Closure) + 16 + sizeof(__m128i), 1); + SETTY(cl, BITS64X2); + + cl->info.bits128p = (__m128i*)ALIGN((uintptr_t)cl + sizeof(Closure), 16); + assert ((uintptr_t)cl->info.bits128p % 16 == 0); + + uint64_t data[2]; + data[0]=v0; data[1]=v1; + + *cl->info.bits128p = _mm_loadu_si128((__m128i*)&data); + return cl; +} + +VAL MKB64x2(VM* vm, VAL v0, VAL v1) { + return MKB64x2const(vm, + v0->info.bits64, + v1->info.bits64); +} + void PROJECT(VM* vm, VAL r, int loc, int arity) { int i; for(i = 0; i < arity; ++i) { @@ -304,7 +451,7 @@ void dumpVal(VAL v) { if (v==NULL) return; int i; - if (ISINT(v)) { + if (ISINT(v)) { printf("%d ", (int)(GETINT(v))); return; } @@ -347,24 +494,62 @@ VAL idris_castIntStr(VM* vm, VAL i) { int x = (int) GETINT(i); - Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0); + Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%d", x); return cl; } +VAL idris_castBitsStr(VM* vm, VAL i) { + Closure* cl; + ClosureType ty = i->ty; + + switch (ty) { + case BITS8: + // max length 8 bit unsigned int str 3 chars (256) + cl = allocate(sizeof(Closure) + sizeof(char)*4, 0); + cl->info.str = (char*)cl + sizeof(Closure); + sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8); + break; + case BITS16: + // max length 16 bit unsigned int str 5 chars (65,535) + cl = allocate(sizeof(Closure) + sizeof(char)*6, 0); + cl->info.str = (char*)cl + sizeof(Closure); + sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16); + break; + case BITS32: + // max length 32 bit unsigned int str 10 chars (4,294,967,295) + cl = allocate(sizeof(Closure) + sizeof(char)*11, 0); + cl->info.str = (char*)cl + sizeof(Closure); + sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32); + break; + case BITS64: + // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615) + cl = allocate(sizeof(Closure) + sizeof(char)*21, 0); + cl->info.str = (char*)cl + sizeof(Closure); + sprintf(cl->info.str, "%" PRIu64, (uint64_t)i->info.bits64); + break; + default: + fprintf(stderr, "Fatal Error: ClosureType %d, not an integer type", ty); + exit(EXIT_FAILURE); + } + + SETTY(cl, STRING); + return cl; +} + VAL idris_castStrInt(VM* vm, VAL i) { char *end; i_int v = strtol(GETSTR(i), &end, 10); - if (*end == '\0' || *end == '\n' || *end == '\r') + if (*end == '\0' || *end == '\n' || *end == '\r') return MKINT(v); - else - return MKINT(0); + else + return MKINT(0); } VAL idris_castFloatStr(VM* vm, VAL i) { - Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*32, 0); + Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%g", GETFLOAT(i)); @@ -380,12 +565,11 @@ char *ls = GETSTR(l); // dumpVal(l); // printf("\n"); - Closure* cl = allocate(vm, sizeof(Closure) + strlen(ls) + strlen(rs) + 1, - 0); + Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); strcpy(cl -> info.str, ls); - strcat(cl -> info.str, rs); + strcat(cl -> info.str, rs); return cl; } @@ -451,7 +635,7 @@ } VAL MKSTROFFc(VM* vm, StrOffset* off) { - Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 1); + Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1); SETTY(cl, STROFFSET); cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); @@ -465,7 +649,7 @@ // If there's no room, just copy the string, or we'll have a problem after // gc moves str if (space(vm, sizeof(Closure) + sizeof(StrOffset))) { - Closure* cl = allocate(vm, sizeof(Closure) + sizeof(StrOffset), 0); + Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0); SETTY(cl, STROFFSET); cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure)); @@ -489,8 +673,8 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) { char *xstr = GETSTR(xs); - Closure* cl = allocate(vm, sizeof(Closure) + - strlen(xstr) + 2, 0); + Closure* cl = allocate(sizeof(Closure) + + strlen(xstr) + 2, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); cl -> info.str[0] = (char)(GETINT(x)); @@ -504,8 +688,8 @@ VAL idris_strRev(VM* vm, VAL str) { char *xstr = GETSTR(str); - Closure* cl = allocate(vm, sizeof(Closure) + - strlen(xstr) + 1, 0); + Closure* cl = allocate(sizeof(Closure) + + strlen(xstr) + 1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); int y = 0; @@ -532,7 +716,7 @@ } VAL MKBUFFERc(VM* vm, Buffer* buf) { - Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1); + Closure* cl = allocate(sizeof(Closure) + sizeof *buf + buf->cap, 1); SETTY(cl, BUFFER); cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); memmove(cl->info.buf, buf, sizeof *buf + buf->fill); @@ -549,7 +733,7 @@ size |= size >> (1 << i); ++size; - Closure* cl = allocate(vm, size, 0); + Closure* cl = allocate(size, 0); SETTY(cl, BUFFER); cl->info.buf = (Buffer*)((void*)cl + sizeof(Closure)); cl->info.buf->cap = size - (sizeof(Closure) + sizeof(Buffer)); @@ -557,7 +741,7 @@ } // Following functions cast uint64_t to size_t, which may narrow! -VAL idris_allocate(VM* vm, VAL hint) { +VAL idris_buffer_allocate(VM* vm, VAL hint) { Closure* cl = internal_allocate(vm, hint->info.bits64); cl->info.buf->fill = 0; return cl; @@ -778,6 +962,8 @@ VM* vm = td->vm; VM* callvm = td->callvm; + init_threaddata(vm); + TOP(0) = td->arg; BASETOP(0); ADDTOP(1); @@ -793,7 +979,7 @@ } void* vmThread(VM* callvm, func f, VAL arg) { - VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, + VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap.size, callvm->max_threads); vm->processes=1; // since it can send and receive messages pthread_t t; @@ -809,7 +995,7 @@ td->callvm = callvm; td->fn = f; td->arg = copyTo(vm, arg); - + callvm->processes++; pthread_create(&t, &attr, runThread, td); @@ -817,7 +1003,7 @@ return vm; } -// VM is assumed to be a different vm from the one x lives on +// VM is assumed to be a different vm from the one x lives on VAL copyTo(VM* vm, VAL x) { int i, ar; @@ -882,28 +1068,28 @@ // FIXME: If GC kicks in in the middle of the copy, we're in trouble. // Probably best check there is enough room in advance. (How?) - // Also a problem if we're allocating at the same time as the + // Also a problem if we're allocating at the same time as the // destination thread (which is very likely) // Should the inbox be a different memory space? - + // So: we try to copy, if a collection happens, we do the copy again // under the assumption there's enough space this time. int gcs = dest->stats.collections; - pthread_mutex_lock(&dest->alloc_lock); + pthread_mutex_lock(&dest->alloc_lock); VAL dmsg = copyTo(dest, msg); - pthread_mutex_unlock(&dest->alloc_lock); + pthread_mutex_unlock(&dest->alloc_lock); if (dest->stats.collections > gcs) { // a collection will have invalidated the copy - pthread_mutex_lock(&dest->alloc_lock); + pthread_mutex_lock(&dest->alloc_lock); dmsg = copyTo(dest, msg); // try again now there's room... - pthread_mutex_unlock(&dest->alloc_lock); + pthread_mutex_unlock(&dest->alloc_lock); } pthread_mutex_lock(&(dest->inbox_lock)); *(dest->inbox_write) = dmsg; - + dest->inbox_write++; if (dest->inbox_write >= dest->inbox_end) { dest->inbox_write = dest->inbox; @@ -970,7 +1156,7 @@ VAL* nullary_cons; -void initNullaries() { +void init_nullaries() { int i; VAL cl; nullary_cons = malloc(256 * sizeof(VAL)); @@ -982,7 +1168,7 @@ } } -void freeNullaries() { +void free_nullaries() { int i; for(i = 0; i < 256; ++i) { free(nullary_cons[i]); diff --git a/rts/idris_rts.h b/rts/idris_rts.h --- a/rts/idris_rts.h +++ b/rts/idris_rts.h @@ -10,6 +10,8 @@ #endif #include +#include + #include "idris_heap.h" #include "idris_stats.h" @@ -21,11 +23,11 @@ #endif // Closures - typedef enum { CON, INT, BIGINT, FLOAT, STRING, STROFFSET, BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD, - MANAGEDPTR, BUFFER + MANAGEDPTR, BUFFER, BITS8X16, BITS16X8, BITS32X4, + BITS64X2 } ClosureType; typedef struct Closure *VAL; @@ -72,6 +74,7 @@ uint16_t bits16; uint32_t bits32; uint64_t bits64; + __m128i* bits128p; Buffer* buf; ManagedPtr* mptr; } info; @@ -82,7 +85,7 @@ VAL* valstack_top; VAL* valstack_base; VAL* stack_max; - + Heap heap; #ifdef HAS_PTHREAD pthread_mutex_t inbox_lock; @@ -106,27 +109,34 @@ } VM; // Create a new VM -VM* init_vm(int stack_size, size_t heap_size, +VM* init_vm(int stack_size, size_t heap_size, int max_threads); +// Initialise thread-local data for this VM +void init_threaddata(VM *vm); // Clean up a VM once it's no longer needed Stats terminate(VM* vm); -// Functions all take a pointer to their VM, and previous stack base, +// Set up key for thread-local data - called once from idris_main +void init_threadkeys(); + +// Functions all take a pointer to their VM, and previous stack base, // and return nothing. typedef void(*func)(VM*, VAL*); -// Register access +// Register access #define RVAL (vm->ret) #define LOC(x) (*(vm->valstack_base + (x))) #define TOP(x) (*(vm->valstack_top + (x))) #define REG1 (vm->reg1) -// Retrieving values +// align pointer +#define ALIGN(__p, __alignment) ((__p + __alignment - 1) & ~(__alignment - 1)) +// Retrieving values #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 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) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) ) @@ -184,6 +194,30 @@ VAL MKB32(VM* vm, uint32_t b); VAL MKB64(VM* vm, uint64_t b); +// SSE Vectors +VAL MKB8x16(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3, + VAL v4, VAL v5, VAL v6, VAL v7, + VAL v8, VAL v9, VAL v10, VAL v11, + VAL v12, VAL v13, VAL v14, VAL v15); +VAL MKB8x16const(VM* vm, + uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3, + uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7, + uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11, + uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15); +VAL MKB16x8(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3, + VAL v4, VAL v5, VAL v6, VAL v7); +VAL MKB16x8const(VM* vm, + uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3, + uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7); +VAL MKB32x4(VM* vm, + VAL v0, VAL v1, VAL v2, VAL v3); +VAL MKB32x4const(VM* vm, + uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3); +VAL MKB64x2(VM* vm, VAL v0, VAL v1); +VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1); + // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val); VAL MKSTROFFc(VM* vm, StrOffset* off); @@ -198,10 +232,10 @@ #define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a)) #define GETARG(x, i) ((x)->info.c.args)[i] -void PROJECT(VM* vm, VAL r, int loc, int arity); +void PROJECT(VM* vm, VAL r, int loc, int arity); void SLIDE(VM* vm, int args); -void* allocate(VM* vm, size_t size, int outerlock); +void* allocate(size_t size, int outerlock); // void* allocCon(VM* vm, int arity, int outerlock); // When allocating from C, call 'idris_requireAlloc' with a size to @@ -210,11 +244,18 @@ // idris_doneAlloc *must* be called when allocation from C is done (as it // may take a lock if other threads are running). -void idris_requireAlloc(VM* vm, size_t size); -void idris_doneAlloc(VM* vm); +void idris_requireAlloc(size_t size); +void idris_doneAlloc(); +// public interface to allocation (note that this may move other pointers +// if allocating beyond the limits given by idris_requireAlloc!) +// 'realloc' just calls alloc and copies; 'free' does nothing +void* idris_alloc(size_t size); +void* idris_realloc(void* old, size_t old_size, size_t size); +void idris_free(void* ptr, size_t size); + #define allocCon(cl, vm, t, a, o) \ - cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \ + cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \ SETTY(cl, CON); \ cl->info.c.tag_arity = ((t) << 8) | (a); @@ -226,8 +267,8 @@ #define NULL_CON(x) nullary_cons[x] extern VAL* nullary_cons; -void initNullaries(); -void freeNullaries(); +void init_nullaries(); +void free_nullaries(); void* vmThread(VM* callvm, func f, VAL arg); @@ -245,11 +286,11 @@ void dumpStack(VM* vm); // Casts - #define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x))) #define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x))) VAL idris_castIntStr(VM* vm, VAL i); +VAL idris_castBitsStr(VM* vm, VAL i); VAL idris_castStrInt(VM* vm, VAL i); VAL idris_castFloatStr(VM* vm, VAL i); VAL idris_castStrFloat(VM* vm, VAL i); @@ -261,7 +302,6 @@ void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size); // String primitives - VAL idris_concat(VM* vm, VAL l, VAL r); VAL idris_strlt(VM* vm, VAL l, VAL r); VAL idris_streq(VM* vm, VAL l, VAL r); @@ -275,7 +315,7 @@ VAL idris_strRev(VM* vm, VAL str); // Buffer primitives -VAL idris_allocate(VM* vm, VAL hint); +VAL idris_buffer_allocate(VM* vm, VAL hint); VAL idris_appendBuffer(VM* vm, VAL fst, VAL fstLen, VAL cnt, VAL sndLen, VAL sndOff, VAL snd); VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); @@ -312,23 +352,11 @@ int idris_numArgs(); const char *idris_getArg(int i); -// Handle stack overflow. +// Handle stack overflow. // Just reports an error and exits. void stackOverflow(); -// Some FFI help (functions and macros below are all which C code should -// use) - -// When allocating from C, call 'idris_requireAlloc' with a size to -// guarantee that no garbage collection will happen (and hence nothing -// will move) until at least size bytes have been allocated. -// idris_doneAlloc *must* be called when allocation from C is done (as it -// may take a lock if other threads are running). - -void idris_requireAlloc(VM* vm, size_t size); -void idris_doneAlloc(VM* vm); - // I think these names are nicer for an API... #define idris_constructor allocCon @@ -338,4 +366,4 @@ #include "idris_gmp.h" -#endif +#endif diff --git a/rts/idris_stats.c b/rts/idris_stats.c --- a/rts/idris_stats.c +++ b/rts/idris_stats.c @@ -10,16 +10,16 @@ clock_t mut = total - stats->init_time - stats->gc_time - stats->exit_time; double mut_sec = (double)mut / CLOCKS_PER_SEC; - int avg_chunk = 0; + uint64_t avg_chunk = 0; if (stats->alloc_count > 0) { - avg_chunk = (int)((double)stats->allocations / (double)stats->alloc_count); + avg_chunk = (uint64_t)((double)stats->allocations / (double)stats->alloc_count); } - int alloc_rate = 0; + uint64_t alloc_rate = 0; if (mut > 0) { - alloc_rate = (int)((double)(stats->allocations) / mut_sec); + alloc_rate = (uint64_t)((double)(stats->allocations) / mut_sec); } - + double gc_percent = 0.0; double productivity = 0.0; if (total > 0) { @@ -29,11 +29,11 @@ setlocale(LC_NUMERIC, ""); printf("\n"); - printf("%'20d bytes allocated in the heap\n", stats->allocations); - printf("%'20d bytes copied during GC\n", stats->copied); - printf("%'20d maximum heap size\n", stats->max_heap_size); - printf("%'20d chunks allocated in the heap\n", stats->alloc_count); - printf("%'20d average chunk size\n\n", avg_chunk); + printf("%'20" PRIu64 " bytes allocated in the heap\n", stats->allocations); + printf("%'20" PRIu64 " bytes copied during GC\n", stats->copied); + printf("%'20" PRIu32 " maximum heap size\n", stats->max_heap_size); + printf("%'20" PRIu32 " chunks allocated in the heap\n", stats->alloc_count); + printf("%'20" PRIu64 " average chunk size\n\n", avg_chunk); printf("GC called %d times\n\n", stats->collections); @@ -45,7 +45,7 @@ printf("%%GC time: %.2f%%\n\n", gc_percent); - printf("Alloc rate %'d bytes per MUT sec\n\n", alloc_rate); + printf("Alloc rate %'" PRIu64 " bytes per MUT sec\n\n", alloc_rate); printf("Productivity %.2f%%\n", productivity); } diff --git a/rts/idris_stats.h b/rts/idris_stats.h --- a/rts/idris_stats.h +++ b/rts/idris_stats.h @@ -3,16 +3,18 @@ #ifdef IDRIS_ENABLE_STATS #include +#include +#include #endif // TODO: measure user time, exclusive/inclusive stats typedef struct { #ifdef IDRIS_ENABLE_STATS - int allocations; // Size of allocated space in bytes for all execution time. - int alloc_count; // How many times alloc is called. - int copied; // Size of space copied during GC. - int max_heap_size; // Maximum heap size achieved. + uint64_t allocations; // Size of allocated space in bytes for all execution time. + uint32_t alloc_count; // How many times alloc is called. + uint64_t copied; // Size of space copied during GC. + uint32_t max_heap_size; // Maximum heap size achieved. clock_t init_time; // Time spent for vm initialization. clock_t exit_time; // Time spent for vm termination. @@ -20,7 +22,7 @@ clock_t max_gc_pause; // Time spent for longest gc. clock_t start_time; // Time of rts entry point. #endif // IDRIS_ENABLE_STATS - int collections; // How many times gc called. + uint32_t collections; // How many times gc called. } Stats; // without start time it's a monoid, can we remove start_time it somehow? void print_stats(const Stats * stats); @@ -35,7 +37,7 @@ #define STATS_INIT_STATS(stats) \ memset(&stats, 0, sizeof(Stats)); \ - stats.start_time = clock(); + stats.start_time = clock(); #define STATS_ALLOC(stats, size) \ stats.allocations += size; \ @@ -60,8 +62,8 @@ #else #define STATS_INIT_STATS(stats) memset(&stats, 0, sizeof(Stats)); -#define STATS_ENTER_INIT(stats) -#define STATS_LEAVE_INIT(stats) +#define STATS_ENTER_INIT(stats) +#define STATS_LEAVE_INIT(stats) #define STATS_ENTER_EXIT(stats) #define STATS_LEAVE_EXIT(stats) #define STATS_ALLOC(stats, size) diff --git a/src/IRTS/CodegenC.hs b/src/IRTS/CodegenC.hs --- a/src/IRTS/CodegenC.hs +++ b/src/IRTS/CodegenC.hs @@ -12,6 +12,7 @@ import Numeric import Data.Char import Data.List (intercalate) +import qualified Data.Vector.Unboxed as V import System.Process import System.Exit import System.IO @@ -24,24 +25,22 @@ (outputFile ci) (outputType ci) (includes ci) - (concatMap mkObj (compileObjs ci)) - (concatMap mkLib (compileLibs ci) ++ - concatMap incdir (importDirs ci)) - (concatMap mkFlag (compilerFlags ci)) + (compileObjs ci) + (map mkLib (compileLibs ci) ++ + map incdir (importDirs ci)) + (compilerFlags ci) (debugLevel ci) - where mkObj f = f ++ " " - mkLib l = "-l" ++ l ++ " " - mkFlag l = l ++ " " - incdir i = "-I" ++ i ++ " " + where mkLib l = "-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) + [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 @@ -64,35 +63,34 @@ comp <- getCC libFlags <- getLibFlags incFlags <- getIncFlags - let gcc = comp ++ " " ++ - gccDbg dbg ++ " " ++ - gccFlags ++ - -- # Any flags defined here which alter the RTS API must also be added to config.mk - " -DHAS_PTHREAD -DIDRIS_ENABLE_STATS" ++ - " -I. " ++ objs ++ " -x c " ++ - (if (exec == Executable) then "" else " -c ") ++ - " " ++ tmpn ++ - " " ++ libFlags ++ - " " ++ incFlags ++ - " " ++ libs ++ - " " ++ flags ++ - " -o " ++ out + let args = [gccDbg dbg] ++ + gccFlags ++ + -- # Any flags defined here which alter the RTS API must also be added to config.mk + ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS", + "-I."] ++ objs ++ ["-x", "c"] ++ + (if (exec == Executable) then [] else ["-c"]) ++ + [tmpn] ++ + concatMap words libFlags ++ + concatMap words incFlags ++ + concatMap words libs ++ + concatMap words flags ++ + ["-o", out] -- putStrLn gcc - exit <- system gcc + exit <- rawSystem comp args when (exit /= ExitSuccess) $ - putStrLn ("FAILURE: " ++ gcc) + putStrLn ("FAILURE: " ++ show comp ++ " " ++ show args) headers xs = concatMap (\h -> "#include <" ++ h ++ ">\n") - (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h", "assert.h"]) + (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"]) debug TRACE = "#define IDRIS_TRACE\n\n" debug _ = "" -- We're using signed integers now. Make sure we get consistent semantics -- out of them from gcc. See e.g. http://thiemonagel.de/2010/01/signed-integer-overflow/ -gccFlags = " -fwrapv -fno-strict-overflow" +gccFlags = ["-fwrapv", "-fno-strict-overflow"] gccDbg DEBUG = "-g" gccDbg TRACE = "-O2" @@ -152,7 +150,16 @@ 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)" + mkConst (B8V x) = let x' = V.toList x in "MKB8x16const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")" + mkConst (B16V x) = let x' = V.toList x in "MKB16x8const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "U") x') ++ ")" + mkConst (B32V x) = let x' = V.toList x in "MKB32x4const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "UL") x') ++ ")" + mkConst (B64V x) = let x' = V.toList x in "MKB64x2const(vm, " ++ intercalate ", " (map (\elem -> show elem ++ "ULL") x') ++ ")" + -- if it's a type constant, we won't use it, but equally it shouldn't + -- report an error. These might creep into generated for various reasons + -- (especially if erasure is disabled). + mkConst c | isTypeConst c = "MKINT(42424242)" + mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented" + bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (MKCON l loc tag []) | tag < 256 = indent i ++ creg l ++ " = NULL_CON(" ++ show tag ++ ");\n" @@ -167,7 +174,7 @@ setArgs i [] = "" setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++ "); " ++ setArgs (i + 1) xs - alloc Nothing tag + alloc Nothing tag = "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ ", " ++ show (length args) ++ ", 0);\n" alloc (Just old) tag @@ -273,7 +280,7 @@ (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n" where fcall (t, arg) = irts_c t (creg arg) bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed -bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);" +bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1); exit(-1);" -- bcc i _ = indent i ++ "// not done yet\n" @@ -392,6 +399,7 @@ doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")" doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")" doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")" +doOp v (LIntStr (ITFixed _)) [x] = v ++ "idris_castBitsStr(vm, " ++ creg x ++ ")" doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")" doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")" @@ -483,7 +491,7 @@ doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")" doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")" -doOp v LAllocate [x] = v ++ "idris_allocate(vm, " ++ creg x ++ ")" +doOp v LAllocate [x] = v ++ "idris_buffer_allocate(vm, " ++ creg x ++ ")" doOp v LAppendBuffer [a, b, c, d, e, f] = v ++ "idris_appendBuffer(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ "," ++ creg e ++ "," ++ creg f ++ ")" doOp v (LAppend ity en) [a, b, c, d] = v ++ "idris_append" ++ intTyName ity ++ show en ++ "(vm, " ++ creg a ++ "," ++ creg b ++ "," ++ creg c ++ "," ++ creg d ++ ")" doOp v (LPeek ity en) [x, y] = v ++ "idris_peek" ++ intTyName ity ++ show en ++ "(vm, " ++ creg x ++ "," ++ creg y ++ ")" @@ -496,16 +504,26 @@ 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 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) doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args +doOp v c@(LMkVec IT8 _) args = v ++ "MKB8x16(vm, " ++ (intercalate ", " (map creg args)) ++ ")" +doOp v c@(LMkVec IT16 _) args = v ++ "MKB16x8(vm, " ++ (intercalate ", " (map creg args)) ++ ")" +doOp v c@(LMkVec IT32 _) args = v ++ "MKB32x4(vm, " ++ (intercalate ", " (map creg args)) ++ ")" +doOp v c@(LMkVec IT64 _) args = v ++ "MKB64x2(vm, " ++ (intercalate ", " (map creg args)) ++ ")" + +doOp v c@(LIdxVec IT8 _) [p, i] = v ++ "idris_IDXB8x16(vm, " ++ creg p ++ ", " ++ creg i ++ ")" +doOp v c@(LIdxVec IT16 _) [p, i] = v ++ "idris_IDXB16x8(vm, " ++ creg p ++ ", " ++ creg i ++ ")" +doOp v c@(LIdxVec IT32 _) [p, i] = v ++ "idris_IDXB32x4(vm, " ++ creg p ++ ", " ++ creg i ++ ")" +doOp v c@(LIdxVec IT64 _) [p, i] = v ++ "idris_IDXB64x2(vm, " ++ creg p ++ ", " ++ creg i ++ ")" + doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")" doOp v LNoOp args = v ++ creg (last args) -doOp _ op _ = "FAIL /* " ++ show op ++ " */" +doOp _ op args = error "doOp of (" ++ show op ++ ") not implemented, arguments (" ++ show args ++ ")" flUnOp :: String -> String -> String flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))" diff --git a/src/IRTS/CodegenJavaScript.hs b/src/IRTS/CodegenJavaScript.hs --- a/src/IRTS/CodegenJavaScript.hs +++ b/src/IRTS/CodegenJavaScript.hs @@ -57,6 +57,10 @@ || (or $ map (needsBigInt . snd) c) || (or $ map (testConstForBigInt . fst) c) + testBCForBigInt (CASE _ _ c d) = + maybe False needsBigInt d + || (or $ map (needsBigInt . snd) c) + testBCForBigInt _ = False testConstForBigInt :: Const -> Bool @@ -495,13 +499,16 @@ | '\\' <- ch = "\\\\" | '\"' <- ch = "\\\"" | '\'' <- ch = "\\\'" - | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "") + | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "") + | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "") | otherwise = [ch] where fill :: String -> String - fill s = if length s == 1 - then '0' : s - else s + fill s = case length s of + 1 -> "000" ++ s + 2 -> "00" ++ s + 3 -> "0" ++ s + _ -> s asciiTab = ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL', diff --git a/src/IRTS/Compiler.hs b/src/IRTS/Compiler.hs --- a/src/IRTS/Compiler.hs +++ b/src/IRTS/Compiler.hs @@ -62,7 +62,7 @@ -- iputStrLn $ showSep "\n" (map show defs) -- Inlined top level LDecl made here let defsInlined = inlineAll defs - let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) + let defsUniq = map (allocUnique (addAlist defsInlined emptyContext)) defsInlined let (nexttag, tagged) = addTags 65536 (liftAll defsUniq) @@ -91,13 +91,13 @@ iLOG "Building output" case checked of - OK c -> do return $ CodegenInfo f outty triple cpu + OK c -> do return $ CodegenInfo f outty triple cpu hdrs impdirs objs libs flags NONE c (toAlist defuns) tagged -- runIO $ case codegen of -- ViaC -> codegenC cginfo --- ViaJava -> codegenJava cginfo +-- ViaJava -> codegenJava cginfo -- ViaJavaScript -> codegenJavaScript cginfo -- ViaNode -> codegenNode cginfo -- ViaLLVM -> codegenLLVM cginfo @@ -116,16 +116,16 @@ if ex then return f else return h generate :: Codegen -> FilePath -> CodegenInfo -> IO () -generate codegen mainmod ir +generate codegen mainmod ir = case codegen of -- Built-in code generators (FIXME: lift these out!) - Via "c" -> codegenC ir + Via "c" -> codegenC ir -- Any external code generator - Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod ++ - " -o " ++ outputFile ir - exit <- system cmd + Via cg -> do let cmd = "idris-" ++ cg + args = [mainmod, "-o", outputFile ir] + exit <- rawSystem cmd args when (exit /= ExitSuccess) $ - putStrLn ("FAILURE: " ++ show cmd) + putStrLn ("FAILURE: " ++ show cmd ++ " " ++ show args) Bytecode -> dumpBC (simpleDecls ir) (outputFile ir) irMain :: TT Name -> Idris LDecl @@ -195,7 +195,7 @@ where (args, sc) = cases_runtime cd - -- Always attempt to inline functions arising from 'case' expressions + -- Always attempt to inline functions arising from 'case' expressions caseName (SN (CaseN _)) = True caseName (SN (WithN _ _)) = True caseName (NS n _) = caseName n @@ -284,7 +284,7 @@ x' <- irTerm vs env x t' <- irTerm vs env t e' <- irTerm vs env e - return (LCase Shared x' + return (LCase Shared x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e' ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t' ]) @@ -425,7 +425,7 @@ irTerm vs env (Proj t (-1)) = do t' <- irTerm vs env t - return $ LOp (LMinus (ATInt ITBig)) + return $ LOp (LMinus (ATInt ITBig)) [t', LConst (BI 1)] irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i @@ -458,13 +458,13 @@ | fi == txt "FIntT" = mkIntIty (str intTy) - mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) + mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _))) | ff == txt "FFunction" , fa == txt "FAny" - , io == txt "IO" + , io == txt "IO" = FFunctionIO - mkIty' (App (App (P _ (UN ff) _) _) _) + mkIty' (App (App (P _ (UN ff) _) _) _) | ff == txt "FFunction" = FFunction @@ -472,7 +472,8 @@ -- would be better if these FInt types were evaluated at compile time -- TODO: add %eval directive for such things - + -- Issue #1742 on the issue tracker. + -- https://github.com/idris-lang/Idris-dev/issues/1742 mkIty "FFloat" = FArith ATFloat mkIty "FInt" = mkIntIty "ITNative" mkIty "FChar" = mkIntIty "ITChar" @@ -521,7 +522,7 @@ | delay == txt "Delay" = do sc' <- irSC vs $ mkForce n' n sc return $ LLet n' (LForce (LV (Glob n))) sc' - + -- There are two transformations in this case: -- -- 1. Newtype-case elimination: diff --git a/src/IRTS/System.hs b/src/IRTS/System.hs --- a/src/IRTS/System.hs +++ b/src/IRTS/System.hs @@ -38,31 +38,31 @@ getTargetDir = environment "TARGET" >>= maybe getDataDir return #if defined(FREEBSD) || defined(DRAGONFLY) -extraLib = " -L/usr/local/lib" +extraLib = ["-L/usr/local/lib"] #else -extraLib = "" +extraLib = [] #endif #ifdef IDRIS_GMP -gmpLib = " -lgmp" +gmpLib = ["-lgmp"] #else -gmpLib = "" +gmpLib = [] #endif getLibFlags = do dir <- getDataDir - return $ "-L" ++ (dir "rts") ++ - " -lidris_rts" ++ extraLib ++ gmpLib ++ " -lpthread" + return $ ["-L" ++ (dir "rts"), + "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"] getIdrisLibDir = do dir <- getDataDir return $ addTrailingPathSeparator dir #if defined(FREEBSD) || defined(DRAGONFLY) -extraInclude = " -I/usr/local/include" +extraInclude = ["-I/usr/local/include"] #else -extraInclude = "" +extraInclude = [] #endif getIncFlags = do dir <- getDataDir - return $ "-I" ++ dir "rts" ++ extraInclude + return $ ("-I" ++ dir "rts") : extraInclude getExecutablePom = do dir <- getDataDir return $ dir "java" "executable_pom.xml" diff --git a/src/Idris/AbsSyntax.hs b/src/Idris/AbsSyntax.hs --- a/src/Idris/AbsSyntax.hs +++ b/src/Idris/AbsSyntax.hs @@ -19,7 +19,7 @@ import Control.Applicative import Control.Monad.State -import Control.Monad.Error(throwError) +import Control.Monad.Except (throwError, catchError) import Data.List hiding (insert,union) import Data.Char @@ -32,7 +32,6 @@ import Debug.Trace -import Control.Monad.Error (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString, tryIOError) import Util.Pretty @@ -97,9 +96,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 } +addImported :: Bool -> FilePath -> Idris () +addImported pub f + = do i <- getIState + putIState $ i { idris_imported = nub $ (f, pub) : idris_imported i } addLangExt :: LanguageExt -> Idris () addLangExt TypeProviders = do i <- getIState @@ -114,12 +114,12 @@ -- Transforms are organised by the function being applied on the lhs of the -- transform, to make looking up appropriate transforms quicker addTrans :: Name -> (Term, Term) -> Idris () -addTrans basefn t +addTrans basefn t = do i <- getIState let t' = case lookupCtxtExact basefn (idris_transforms i) of Just def -> (t : def) Nothing -> [t] - putIState $ i { idris_transforms = addDef basefn t' + putIState $ i { idris_transforms = addDef basefn t' (idris_transforms i) } addErrRev :: (Term, Term) -> Idris () @@ -130,8 +130,8 @@ totcheck n = do i <- getIState; putIState $ i { idris_totcheck = idris_totcheck i ++ [n] } defer_totcheck :: (FC, Name) -> Idris () -defer_totcheck n - = do i <- getIState; +defer_totcheck n + = do i <- getIState; putIState $ i { idris_defertotcheck = nub (idris_defertotcheck i ++ [n]) } clear_totcheck :: Idris () @@ -183,7 +183,7 @@ putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) } addTyInferred :: Name -> Idris () -addTyInferred n +addTyInferred n = do i <- getIState putIState $ i { idris_tyinfodata = addDef n TIPartial (idris_tyinfodata i) } @@ -197,7 +197,7 @@ findMVApps x y = do let (fx, argsx) = unApply x let (fy, argsy) = unApply y - if (not (fx == fy)) + if (not (fx == fy)) then do tryAddMV fx y tryAddMV fy x @@ -211,17 +211,17 @@ tryAddMV _ _ = return () addConstraintRule :: Name -> Term -> Idris () - addConstraintRule n t + addConstraintRule n t = do ist <- get logLvl 1 $ "TI constraint: " ++ show (n, t) case lookupCtxt n (idris_tyinfodata ist) of - [TISolution ts] -> + [TISolution ts] -> do mapM_ (checkConsistent t) ts - let ti' = addDef n (TISolution (t : ts)) + let ti' = addDef n (TISolution (t : ts)) (idris_tyinfodata ist) put $ ist { idris_tyinfodata = ti' } - _ -> - do let ti' = addDef n (TISolution [t]) + _ -> + do let ti' = addDef n (TISolution [t]) (idris_tyinfodata ist) put $ ist { idris_tyinfodata = ti' } @@ -233,14 +233,14 @@ do let (fx, _) = unApply x let (fy, _) = unApply y case (fx, fy) of - (P (TCon _ _) n _, P (TCon _ _) n' _) -> errWhen (n/=n) + (P (TCon _ _) n _, P (TCon _ _) n' _) -> errWhen (n/=n) (P (TCon _ _) n _, Constant _) -> errWhen True (Constant _, P (TCon _ _) n' _) -> errWhen True - (P (DCon _ _ _) n _, P (DCon _ _ _) n' _) -> errWhen (n/=n) + (P (DCon _ _ _) n _, P (DCon _ _ _) n' _) -> errWhen (n/=n) _ -> return () - where errWhen True - = throwError (At fc + where errWhen True + = throwError (At fc (CantUnify False x y (Msg "") [] 0)) errWhen False = return () @@ -310,9 +310,21 @@ [ns] -> ns _ -> [] +-- Issue #1737 in the Issue Tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1737 addToCalledG :: Name -> [Name] -> Idris () addToCalledG n ns = return () -- TODO +push_estack :: Name -> Idris () +push_estack n = do i <- getIState + putIState (i { elab_stack = n : elab_stack i }) + +pop_estack :: Idris () +pop_estack = do i <- getIState + putIState (i { elab_stack = ptail (elab_stack i) }) + where ptail [] = [] + ptail (x : xs) = xs + -- Add a class instance function. Dodgy hack: Put integer instances first in the -- list so they are resolved by default. -- Dodgy hack 2: put constraint chasers (@@) last @@ -333,7 +345,7 @@ insI i (n : ns) | chaser n = i : n : ns | otherwise = n : insI i ns - chaser (UN nm) + chaser (UN nm) | ('@':'@':_) <- str nm = True chaser (NS n _) = chaser n chaser _ = False @@ -367,6 +379,7 @@ addNameIdx :: Name -> Idris (Int, Name) addNameIdx n = do i <- getIState let (i', x) = addNameIdx' i n + putIState i' return x addNameIdx' :: IState -> Name -> (IState, (Int, Name)) @@ -377,10 +390,18 @@ _ -> let i' = fst (idris_nameIdx i) + 1 in (i { idris_nameIdx = (i', addDef n (i', n) idxs) }, (i', n)) +getSymbol :: Name -> Idris Name +getSymbol n = do i <- getIState + case M.lookup n (idris_symbols i) of + Just n' -> return n' + Nothing -> do let sym' = M.insert n n (idris_symbols i) + put (i { idris_symbols = sym' }) + return n + getHdrs :: Codegen -> Idris [String] getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i) -getImported :: Idris [FilePath] +getImported :: Idris [(FilePath, Bool)] getImported = do i <- getIState; return (idris_imported i) setErrSpan :: FC -> Idris () @@ -421,6 +442,9 @@ runIO :: IO a -> Idris a runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return -- TODO: create specific Idris exceptions for specific IO errors such as "openFile: does not exist" +-- +-- Issue #1738 on the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1738 getName :: Idris Int getName = do i <- getIState; @@ -454,9 +478,9 @@ -- the .ibc, which is all we need after all the analysis is done) clearPTypes :: Idris () clearPTypes = do i <- get - let ctxt = tt_ctxt i + let ctxt = tt_ctxt i put (i { tt_ctxt = mapDefCtxt pErase ctxt }) - where pErase (CaseOp c t tys orig tot cds) + where pErase (CaseOp c t tys orig tot cds) = CaseOp c t tys orig [] (pErase' cds) pErase x = x pErase' (CaseDefs _ (cs, c) _ rs) @@ -474,8 +498,8 @@ isUndefined :: FC -> Name -> Idris Bool isUndefined fc n = do i <- getContext - case lookupTy n i of - (_:_) -> return False + case lookupTyExact n i of + Just _ -> return False _ -> return True setContext :: Context -> Idris () @@ -488,7 +512,7 @@ addConstraints fc (v, cs) = do i <- getIState let ctxt = tt_ctxt i - let ctxt' = ctxt { uconstraints = cs ++ uconstraints ctxt, + let ctxt' = ctxt { uconstraints = nub cs ++ uconstraints ctxt, next_tvar = v } let ics = zip cs (repeat fc) ++ idris_constraints i putIState $ i { tt_ctxt = ctxt', idris_constraints = ics } @@ -503,7 +527,7 @@ i <- getIState putIState $ i { idris_metavars = map (\(n, (i, top, _, isTopLevel)) -> (n, (top, i, isTopLevel))) ns ++ idris_metavars i } - where + where -- 'tidyNames' is to generate user accessible names in case they are -- needed in tactic scripts tidyNames used (Bind (MN i x) b sc) @@ -869,21 +893,21 @@ mkShadow (MN i n) = MN (i+1) n mkShadow (NS x s) = NS (mkShadow x) s - en (PLam n t s) + en (PLam fc n t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in - PLam n' (en t) (en (shadow n n' s)) - | otherwise = PLam n (en t) (en s) + PLam fc n' (en t) (en (shadow n n' s)) + | otherwise = PLam fc n (en t) (en s) en (PPi p n t s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp? PPi (enTacImp p) n' (en t) (en (shadow n n' s)) | otherwise = PPi (enTacImp p) n (en t) (en s) - en (PLet n ty v s) + en (PLet fc n ty v s) | n `elem` (map fst ps ++ ns) = let n' = mkShadow n in - PLet n' (en ty) (en v) (en (shadow n n' s)) - | otherwise = PLet n (en ty) (en v) (en s) + PLet fc n' (en ty) (en v) (en (shadow n n' s)) + | otherwise = PLet fc n (en ty) (en v) (en s) -- FIXME: Should only do this in a type signature! en (PDPair f p (PRef f' n) t r) | n `elem` (map fst ps ++ ns) && t /= Placeholder @@ -1022,14 +1046,14 @@ = PMutual f (map (expandParamsD rhs ist dec ps ns) pds) expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs decls) = PClass doc info f - (map (expandParams dec ps ns []) cs) + (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (mapsnd (expandParams dec ps ns [])) params) pDocs (map (expandParamsD rhs ist dec ps ns) decls) expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls) = PInstance info f - (map (expandParams dec ps ns []) cs) + (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs) n (map (expandParams dec ps ns []) params) (expandParams dec ps ns [] ty) @@ -1075,12 +1099,12 @@ addStatics n tm ptm = do let (statics, dynamics) = initStatics tm ptm ist <- getIState - let paramnames + let paramnames = nub $ case lookupCtxtExact n (idris_fninfo ist) of Just p -> getNamesFrom 0 (fn_params p) tm ++ concatMap (getParamNames ist) (map snd statics) _ -> concatMap (getParamNames ist) (map snd statics) - + let stnames = nub $ concatMap freeArgNames (map snd statics) let dnames = (nub $ concatMap freeArgNames (map snd dynamics)) \\ paramnames @@ -1100,13 +1124,13 @@ putIState $ i { idris_statics = addDef n stpos (idris_statics i) } addIBC (IBCStatic n) where - initStatics (Bind n (Pi ty _) sc) (PPi p n' t s) + initStatics (Bind n (Pi _ ty _) sc) (PPi p n' t s) | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' t s) in (static, (n, ty) : dynamic) - initStatics (Bind n (Pi ty _) sc) (PPi p n' _ s) + initStatics (Bind n (Pi _ ty _) sc) (PPi p n' _ s) = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in if pstatic p == Static then ((n, ty) : static, dynamic) - else if (not (searchArg p)) + else if (not (searchArg p)) then (static, (n, ty) : dynamic) else (static, dynamic) initStatics t pt = ([], []) @@ -1116,19 +1140,19 @@ Just ti -> getNamePos 0 (param_pos ti) args Nothing -> [] where getNamePos i ps [] = [] - getNamePos i ps (P _ n _ : as) + getNamePos i ps (P _ n _ : as) | i `elem` ps = n : getNamePos (i + 1) ps as getNamePos i ps (_ : as) = getNamePos (i + 1) ps as - getParamNames ist (Bind t (Pi (P _ n _) _) sc) + getParamNames ist (Bind t (Pi _ (P _ n _) _) sc) = n : getParamNames ist sc getParamNames ist _ = [] - getNamesFrom i ps (Bind n (Pi _ _) sc) + getNamesFrom i ps (Bind n (Pi _ _ _) sc) | i `elem` ps = n : getNamesFrom (i + 1) ps sc | otherwise = getNamesFrom (i + 1) ps sc getNamesFrom i ps sc = [] - freeArgNames (Bind n (Pi ty _) sc) + freeArgNames (Bind n (Pi _ ty _) sc) = nub $ freeNames ty ++ freeNames sc -- treat '->' as fn here freeArgNames tm = let (_, args) = unApply tm in concatMap freeNames args @@ -1140,7 +1164,7 @@ searchArg (TacImp _ _ _) = True searchArg _ = False - staticList sts (Bind n (Pi _ _) sc) = (n `elem` sts) : staticList sts sc + staticList sts (Bind n (Pi _ _ _) sc) = (n `elem` sts) : staticList sts sc staticList _ _ = [] -- Dealing with implicit arguments @@ -1199,11 +1223,11 @@ let ns = implicitNamesIn (map iname uimpls) ist t let badnames = filter (\n -> not (implicitable n) && n `notElem` (map iname uimpls)) ns - when (not (null badnames)) $ - throwError (At fc (Elaborating "type of " n + when (not (null badnames)) $ + throwError (At fc (Elaborating "type of " n (NoSuchVariable (head badnames)))) - let cs = getArgnames t -- get already bound names - let addimpls = filter (\n -> iname n `notElem` cs) uimpls + let cs = getArgnames t -- get already bound names + let addimpls = filter (\n -> iname n `notElem` cs) uimpls -- if all names in the arguments of addconsts appear in ns, -- add the constraint implicitly return (bindFree ns (doAdd addimpls ns t)) @@ -1218,15 +1242,15 @@ -- if all of args in ns, then add it doAdd (UImplicit n ty : cs) ns t | elem n ns - = PPi (Imp [] Dynamic False) n ty (doAdd cs ns t) + = PPi (Imp [] Dynamic False Nothing) n ty (doAdd cs ns t) | otherwise = doAdd cs ns t -- bind the free names which weren't in the using block bindFree [] tm = tm - bindFree (n:ns) tm + bindFree (n:ns) tm | elem n (map iname uimpls) = bindFree ns tm - | otherwise - = PPi (Imp [] Dynamic False) n Placeholder (bindFree ns tm) + | otherwise + = PPi (Imp [] Dynamic False Nothing) n Placeholder (bindFree ns tm) getArgnames (PPi _ n c sc) = n : getArgnames sc @@ -1241,21 +1265,22 @@ = (n, (p, t)) : collectImps sc collectImps _ = [] - getImps (Bind n (Pi t _) sc) imps + getImps (Bind n (Pi (Just _) _ _) sc) imps = getImps sc imps + getImps (Bind n (Pi _ t _) sc) imps | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps where - argInfo n (Imp opt _ _) t' + argInfo n (Imp opt _ _ _) t' = (True, PImp (getPriority i t') True opt n t') argInfo n (Exp opt _ _) t' = (InaccessibleArg `elem` opt, PExp (getPriority i t') opt n t') - argInfo n (Constraint opt _) t' + argInfo n (Constraint opt _) t' = (InaccessibleArg `elem` opt, PConstraint 10 opt n t') - argInfo n (TacImp opt _ scr) t' + argInfo n (TacImp opt _ scr) t' = (InaccessibleArg `elem` opt, PTacImplicit 10 opt n scr t') - getImps (Bind n (Pi t _) sc) imps = impBind n t : getImps sc imps + getImps (Bind n (Pi _ t _) sc) imps = impBind n t : getImps sc imps where impBind n t = (True, PImp 1 True [] n Placeholder) getImps sc tm = [] @@ -1265,6 +1290,9 @@ -- This has become a right mess already. Better redo it some time... -- TODO: This is obsoleted by the new way of elaborating types, but there's still -- a couple of places which use it. Clean them up! +-- +-- Issue 1739 in the issue tracker +-- https://github.com/idris-lang/Idris-dev/issues/1739 implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm implicit info syn n ptm = implicit' info syn [] n ptm @@ -1283,11 +1311,11 @@ where -- Detect unknown names in default arguments and throw error if found. defaultArgCheck :: [Name] -> [PArg] -> Idris () - defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params + defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params notFoundInDefault :: [Name] -> PArg -> Idris [Name] notFoundInDefault kns (PTacImplicit _ _ n script _) - = do i <- getIState + = do i <- getIState case notFound kns (namesIn [] i script) of Nothing -> return (n:kns) Just name -> throwError (NoSuchVariable name) @@ -1331,7 +1359,7 @@ = 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 _ _) n ty sc) + 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 : decls, @@ -1388,7 +1416,7 @@ = do (decls, ns) <- get let isn = concatMap (namesIn uvars ist) as put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) - imps top env (PLam n ty sc) + imps top env (PLam fc n ty sc) = do imps False env ty imps False (n:env) sc imps top env (PHidden tm) = imps False env tm @@ -1399,8 +1427,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 Nothing) n ty (pibind using ns sc) + Nothing -> PPi (Imp [] Dynamic False Nothing) n Placeholder (pibind using ns sc) -- Add implicit arguments in function calls @@ -1429,7 +1457,7 @@ | f `elem` infns = PInferRef fc f | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat qq ist fc f ds [] ai qq env ds (PHidden (PRef fc f)) - | not (f `elem` map fst env) = handleErr $ aiFn inpat False qq ist fc f ds [] + | not (f `elem` map fst env) = PHidden (handleErr $ aiFn inpat False qq ist fc f ds []) ai qq env ds (PEq fc lt rt l r) = let lt' = ai qq env ds lt rt' = ai qq env ds rt @@ -1480,15 +1508,24 @@ -- definition which is passed through addImpl again with more scope -- information PCase fc c' os - ai qq env ds (PLam n ty sc) - = let ty' = ai qq env ds ty - sc' = ai qq ((n, Just ty):env) ds sc in - PLam n ty' sc' - ai qq env ds (PLet n ty val sc) - = let ty' = ai qq env ds ty - val' = ai qq env ds val - sc' = ai qq ((n, Just ty):env) ds sc in - PLet n ty' val' sc' + -- If the name in a lambda is a constructor name, do this as a 'case' + -- instead (it is harmless to do so, especially since the lambda will + -- be lifted anyway!) + ai qq env ds (PLam fc n ty sc) + = case lookupDef n (tt_ctxt ist) of + [] -> let ty' = ai qq env ds ty + sc' = ai qq ((n, Just ty):env) ds sc in + PLam fc n ty' sc' + _ -> ai qq env ds (PLam fc (sMN 0 "lamp") ty + (PCase fc (PRef fc (sMN 0 "lamp") ) + [(PRef fc n, sc)])) + ai qq env ds (PLet fc n ty val sc) + = case lookupDef n (tt_ctxt ist) of + [] -> let ty' = ai qq env ds ty + val' = ai qq env ds val + sc' = ai qq ((n, Just ty):env) ds sc in + PLet fc n ty' val' sc' + _ -> ai qq env ds (PCase fc val [(PRef fc n, sc)]) ai qq env ds (PPi p n ty sc) = let ty' = ai qq env ds ty sc' = ai qq ((n, Just ty):env) ds sc in @@ -1545,7 +1582,7 @@ let nh = filter (\(n, _) -> notHidden n) ns let ns' = case trimAlts ds nh of [] -> nh - x -> x + x -> x case ns' of [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as) [] -> if f `elem` (map fst (idris_metavars ist)) @@ -1557,7 +1594,7 @@ (insertImpl ns as)) alts where trimAlts [] alts = alts - trimAlts ns alts + trimAlts ns alts = filter (\(x, _) -> any (\d -> d `isPrefixOf` nspace x) ns) alts nspace (NS _ s) = s @@ -1568,8 +1605,8 @@ _ -> True getAccessibility n - = case lookupDefAcc n False (tt_ctxt ist) of - [(n,t)] -> t + = case lookupDefAccExact n False (tt_ctxt ist) of + Just (n,t) -> t _ -> Public insertImpl :: [PArg] -> [PArg] -> [PArg] @@ -1612,6 +1649,8 @@ insImpAcc (M.insert n sc pnas) ps given imps insImpAcc _ expected [] imps = imps -- so that unused implicits give error -- TODO: report here, and prune alternatives + -- Issue #1740 in the Issue Tracker +-- https://github.com/idris-lang/Idris-dev/issues/1740 insImpAcc _ _ given imps = given ++ imps find n [] acc = Nothing @@ -1622,8 +1661,6 @@ find n (g : gs) acc = find n gs (g : acc) -- replace non-linear occurrences with _ --- ASSUMPTION: This is called before adding 'alternatives' because otherwise --- it is hard to get right! stripLinear :: IState -> PTerm -> PTerm stripLinear i tm = evalState (sl tm) [] where @@ -1633,18 +1670,26 @@ = return $ PRef fc f | otherwise = do ns <- get if (f `elem` ns) - then return Placeholder + then return $ PHidden (PRef fc f) -- Placeholder else do put (f : ns) return (PRef fc f) sl (PPatvar fc f) = do ns <- get if (f `elem` ns) - then return Placeholder + then return $ PHidden (PPatvar fc f) -- Placeholder else do put (f : ns) return (PPatvar fc f) - 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 + -- Assumption is that variables are all the same in each alternative + sl t@(PAlternative b as) = do ns <- get + as' <- slAlts ns as + return (PAlternative b as') + where slAlts ns (a : as) = do put ns + a' <- sl a + as' <- slAlts ns as + return (a' : as') + slAlts ns [] = return [] + sl (PPair fc p l r) = do l' <- sl l; r' <- sl r; return (PPair fc p l' r') + 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) = do t' <- sl t @@ -1667,17 +1712,26 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where su :: PTerm -> PTerm su (PRef fc f) - | (Bind n (Pi t _) sc :_) <- lookupTy f (tt_ctxt i) + | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i) = Placeholder - su (PApp fc fn args) - = PApp fc fn (fmap (fmap su) args) - su (PAlternative b alts) + su (PApp fc f@(PRef _ fn) args) + | isDConName fn ctxt + = PApp fc f (fmap (fmap su) args) + su (PApp fc f args) + = PHidden (PApp fc f args) + su (PAlternative b alts) = let alts' = filter (/= Placeholder) (map su alts) in 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 p l t r) = PDPair fc p (su l) (su t) (su r) + su t@(PLam fc _ _ _) = PHidden t + su t@(PPi _ _ _ _) = PHidden t + su t@(PEq _ _ _ _ _) = PHidden t su t = t + + ctxt = tt_ctxt i + stripUnmatchable i tm = tm mkPApp fc a f [] = f @@ -1766,7 +1820,7 @@ match (PApp _ x []) (PRef f n) = match x (PRef f n) match (PRef _ n) tm@(PRef _ n') | n == n' && not names && - (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) + (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] -- if one namespace is missing, drop the other @@ -1777,7 +1831,7 @@ | not names && (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)] - match (PEq _ _ _ l r) (PEq _ _ _ l' r') + match (PEq _ _ _ l r) (PEq _ _ _ l' r') = do ml <- match' l l' mr <- match' r r' return (ml ++ mr) @@ -1818,14 +1872,22 @@ match (PPi _ _ t s) (PPi _ _ t' s') = do mt <- match' t t' ms <- match' s s' return (mt ++ ms) - match (PLam _ t s) (PLam _ t' s') = do mt <- match' t t' - ms <- match' s s' - return (mt ++ ms) - match (PLet _ t ty s) (PLet _ t' ty' s') = do mt <- match' t t' - mty <- match' ty ty' - ms <- match' s s' - return (mt ++ mty ++ ms) - match (PHidden x) (PHidden y) = match' x y + match (PLam _ _ t s) (PLam _ _ t' s') = do mt <- match' t t' + ms <- match' s s' + return (mt ++ ms) + match (PLet _ _ t ty s) (PLet _ _ t' ty' s') = do mt <- match' t t' + mty <- match' ty ty' + ms <- match' s s' + return (mt ++ mty ++ ms) + match (PHidden x) (PHidden y) + | RightOK xs <- match x y = return xs -- to collect variables + | otherwise = return [] -- Otherwise hidden things are unmatchable + match (PHidden x) y + | RightOK xs <- match x y = return xs + | otherwise = return [] + match x (PHidden y) + | RightOK xs <- match x y = return xs + | otherwise = return [] match (PUnifyLog x) y = match' x y match x (PUnifyLog y) = match' x y match (PNoImplicits x) y = match' x y @@ -1859,7 +1921,7 @@ substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm substMatchShadow n shs tm t = sm shs t where sm xs (PRef _ n') | n == n' = tm - sm xs (PLam x t sc) = PLam x (sm xs t) (sm xs sc) + sm xs (PLam fc x t sc) = PLam fc x (sm xs t) (sm xs sc) sm xs (PPi p x t sc) | x `elem` xs = let x' = nextName x in @@ -1886,9 +1948,9 @@ shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where sm (PRef fc x) | n == x = PRef fc n' - sm (PLam x t sc) | n /= x = PLam x (sm t) (sm sc) + sm (PLam fc x t sc) | n /= x = PLam fc x (sm t) (sm sc) sm (PPi p x t sc) | n /=x = PPi p x (sm t) (sm sc) - sm (PLet x t v sc) | n /= x = PLet x (sm t) (sm v) (sm sc) + sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc) sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as) sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as) sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as) @@ -1927,7 +1989,7 @@ mkUniqT tac = return tac mkUniq :: PTerm -> State (S.Set Name) PTerm - mkUniq (PLam n ty sc) + mkUniq (PLam fc n ty sc) = do env <- get (n', sc') <- if n `S.member` env @@ -1938,7 +2000,7 @@ put (S.insert n' env) ty' <- mkUniq ty sc'' <- mkUniq sc' - return $! PLam n' ty' sc'' + return $! PLam fc n' ty' sc'' mkUniq (PPi p n ty sc) = do env <- get (n', sc') <- @@ -1951,7 +2013,7 @@ ty' <- mkUniq ty sc'' <- mkUniq sc' return $! PPi p n' ty' sc'' - mkUniq (PLet n ty val sc) + mkUniq (PLet fc n ty val sc) = do env <- get (n', sc') <- if n `S.member` env @@ -1962,7 +2024,7 @@ put (S.insert n' env) ty' <- mkUniq ty; val' <- mkUniq val sc'' <- mkUniq sc' - return $! PLet n' ty' val' sc'' + return $! PLet fc n' ty' val' sc'' mkUniq (PApp fc t args) = do t' <- mkUniq t args' <- mapM mkUniqA args @@ -2002,5 +2064,3 @@ mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts) mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts) mkUniq t = return t - - diff --git a/src/Idris/AbsSyntaxTree.hs b/src/Idris/AbsSyntaxTree.hs --- a/src/Idris/AbsSyntaxTree.hs +++ b/src/Idris/AbsSyntaxTree.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveFunctor, - TypeSynonymInstances, PatternGuards #-} + DeriveDataTypeable, TypeSynonymInstances, PatternGuards #-} module Idris.AbsSyntaxTree where @@ -19,18 +19,20 @@ import System.IO import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Error +import Control.Monad.Trans.Except +import Data.Data (Data) +import Data.Function (on) import Data.List hiding (group) import Data.Char -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.Text as T -import qualified Data.Map as M import Data.Either import qualified Data.Set as S import Data.Word (Word) import Data.Maybe (fromMaybe, mapMaybe) import Data.Traversable (Traversable) +import Data.Typeable import Data.Foldable (Foldable) import Debug.Trace @@ -45,16 +47,17 @@ -- rec_elabDecl is used to pass the top level elaborator into other elaborators, -- so that we can have mutually recursive elaborators in separate modules without --- having to much about with cyclic modules. +-- having to muck about with cyclic modules. data ElabInfo = EInfo { params :: [(Name, PTerm)], inblock :: Ctxt [Name], -- names in the block, and their params liftname :: Name -> Name, - namespace :: Maybe [String], + namespace :: Maybe [String], + elabFC :: Maybe FC, rec_elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris () } toplevel :: ElabInfo -toplevel = EInfo [] emptyContext id Nothing (\_ _ _ -> fail "Not implemented") +toplevel = EInfo [] emptyContext id Nothing Nothing (\_ _ _ -> fail "Not implemented") eInfoNames :: ElabInfo -> [Name] eInfoNames info = map fst (params info) ++ M.keys (inblock info) @@ -164,6 +167,9 @@ idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name], idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]), + idris_moduledocs :: Ctxt (Docstring DocTerm), + -- ^ module documentation is saved in a special MN so the context + -- mechanism can be used for disambiguation idris_tyinfodata :: Ctxt TIData, idris_fninfo :: Ctxt FnInfo, idris_transforms :: Ctxt [(Term, Term)], @@ -177,7 +183,7 @@ idris_metavars :: [(Name, (Maybe Name, Int, Bool))], -- ^ The currently defined but not proven metavariables idris_coercions :: [Name], idris_errRev :: [(Term, Term)], - syntax_rules :: [Syntax], + syntax_rules :: SyntaxRules, syntax_keywords :: [String], imported :: [FilePath], -- ^ The imported modules idris_scprims :: [(Name, (Int, PrimFn))], @@ -185,7 +191,7 @@ idris_libs :: [(Codegen, String)], idris_cgflags :: [(Codegen, String)], idris_hdrs :: [(Codegen, String)], - idris_imported :: [FilePath], -- ^ Imported ibc file names + idris_imported :: [(FilePath, Bool)], -- ^ Imported ibc file names, whether public proof_list :: [(Name, [String])], errSpan :: Maybe FC, parserWarnings :: [(FC, Err)], @@ -212,7 +218,9 @@ idris_postulates :: S.Set Name, idris_whocalls :: Maybe (M.Map Name [Name]), idris_callswho :: Maybe (M.Map Name [Name]), - idris_repl_defs :: [Name] -- ^ List of names that were defined in the repl, and can be re-/un-defined + idris_repl_defs :: [Name], -- ^ List of names that were defined in the repl, and can be re-/un-defined + elab_stack :: [Name], -- ^ Stack of names currently being elaborated + idris_symbols :: M.Map Name Name -- ^ Symbol table (preserves sharing of names) } -- Required for parsers library, and therefore trifecta @@ -257,7 +265,7 @@ | IBCMetavar Name | IBCSyntax Syntax | IBCKeyword String - | IBCImport FilePath + | IBCImport (Bool, FilePath) -- True = import public | IBCImportDir FilePath | IBCObj Codegen FilePath | IBCLib Codegen String @@ -282,23 +290,25 @@ | IBCPostulate Name | IBCTotCheckErr FC String | IBCParsedRegion FC + | IBCModDocs Name -- ^ The name is the special name used to track module docs deriving Show -- | The initial state for the compiler idrisInit :: IState -idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext +idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] + emptyContext emptyContext emptyContext emptyContext + [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] [] [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty - AutomaticWidth S.empty Nothing Nothing [] + AutomaticWidth S.empty Nothing Nothing [] [] M.empty -- | The monad for the main REPL - reading and processing files and updating -- global state (hence the IO inner monad). --type Idris = WriterT [Either String (IO ())] (State IState a)) -type Idris = StateT IState (ErrorT Err IO) +type Idris = StateT IState (ExceptT Err IO) -- Commands in the REPL @@ -310,6 +320,9 @@ -- | ViaLLVM | Bytecode deriving (Show, Eq) +{-! +deriving instance NFData Codegen +!-} -- | REPL commands data Command = Quit @@ -344,8 +357,7 @@ | DynamicLink FilePath | ListDynamic | Pattelab PTerm - | DebugInfo Name - | Search PTerm + | Search [String] PTerm | CaseSplitAt Bool Int Name | AddClauseFrom Bool Int Name | AddProofClauseFrom Bool Int Name @@ -363,7 +375,7 @@ | ColourOff | ListErrorHandlers | SetConsoleWidth ConsoleWidth - | Apropos String + | Apropos [String] String | WhoCalls Name | CallsWho Name | MakeDoc String -- IdrisDoc @@ -371,6 +383,9 @@ | PrintDef Name | PPrint OutputFmt Int PTerm | TransformInfo Name + -- Debugging commands + | DebugInfo Name + | DebugUnify PTerm PTerm data OutputFmt = HTMLOutput | LaTeXOutput @@ -383,6 +398,7 @@ | ShowLibs | ShowLibdir | ShowIncs + | ShowPkgs | NoBasePkgs | NoPrelude | NoBuiltins -- only for the really primitive stuff! @@ -409,6 +425,7 @@ | PkgREPL String | PkgMkDoc String -- IdrisDoc | PkgTest String + | PkgIndex FilePath | WarnOnly | Pkg String | BCAsm String @@ -464,7 +481,7 @@ data Static = Static | Dynamic - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) {-! deriving instance Binary Static deriving instance NFData Static @@ -473,7 +490,9 @@ -- Mark bindings with their explicitness, and laziness data Plicity = Imp { pargopts :: [ArgOpt], pstatic :: Static, - pparam :: Bool } + pparam :: Bool, + pscoped :: Maybe ImplicitInfo -- Nothing, if top level + } | Exp { pargopts :: [ArgOpt], pstatic :: Static, pparam :: Bool } -- this is a param (rather than index) @@ -482,14 +501,20 @@ | TacImp { pargopts :: [ArgOpt], pstatic :: Static, pscript :: PTerm } - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) {-! deriving instance Binary Plicity deriving instance NFData Plicity !-} -impl = Imp [] Dynamic False +is_scoped :: Plicity -> Maybe ImplicitInfo +is_scoped (Imp _ _ _ s) = s +is_scoped _ = Nothing + +impl = Imp [] Dynamic False Nothing +forall_imp = Imp [] Dynamic False (Just (Impl False)) +forall_constraint = Imp [] Dynamic False (Just (Impl True)) expl = Exp [] Dynamic False expl_param = Exp [] Dynamic True constraint = Constraint [] Static @@ -552,14 +577,14 @@ | PNamespace String [PDecl' t] -- ^ New namespace | PRecord (Docstring (Either Err PTerm)) SyntaxInfo FC Name t DataOpts (Docstring (Either Err PTerm)) Name t -- ^ Record declaration | PClass (Docstring (Either Err PTerm)) SyntaxInfo FC - [t] -- constraints + [(Name, t)] -- constraints Name [(Name, t)] -- parameters [(Name, Docstring (Either Err PTerm))] -- parameter docstrings [PDecl' t] -- declarations -- ^ Type class: arguments are documentation, syntax info, source location, constraints, -- class name, parameters, method declarations - | PInstance SyntaxInfo FC [t] -- constraints + | PInstance SyntaxInfo FC [(Name, t)] -- constraints Name -- class [t] -- parameters t -- full instance type @@ -581,8 +606,15 @@ !-} -- For elaborator state -type ElabD a = Elab' [PDecl] a +data EState = EState { + case_decls :: [PDecl], + delayed_elab :: [Elab' EState ()] + } +initEState = EState [] [] + +type ElabD a = Elab' EState a + -- | One clause of a top-level definition. Term arguments to constructors are: -- -- 1. The whole application (missing for PClauseR and PWithR because they're within a "with" clause) @@ -702,16 +734,16 @@ -- (map (updateDNs ns) ds) -- updateDNs ns c = c -data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show) +data PunInfo = IsType | IsTerm | TypeOrTerm deriving (Eq, Show, Data, Typeable) -- | High level language terms data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level language | PRef FC Name -- ^ A reference to a variable | PInferRef FC Name -- ^ A name to be defined later | PPatvar FC Name -- ^ A pattern variable - | PLam Name PTerm PTerm -- ^ A lambda abstraction + | PLam FC Name PTerm PTerm -- ^ A lambda abstraction | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2 - | PLet Name PTerm PTerm PTerm -- ^ A let binding + | PLet FC Name PTerm PTerm PTerm -- ^ A let binding | PTyped PTerm PTerm -- ^ Term with explicit type | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x | PAppBind FC PTerm [PArg] -- ^ implicitly bound application @@ -724,6 +756,7 @@ | PRewrite FC PTerm PTerm (Maybe PTerm) -- ^ "rewrite" syntax, with optional result type | PPair FC PunInfo PTerm PTerm -- ^ A pair (a, b) and whether it's a product type or a pair (solved by elaboration) | PDPair FC PunInfo PTerm PTerm PTerm -- ^ A dependent pair (tm : a ** b) and whether it's a sigma type or a pair that inhabits one (solved by elaboration) + | PAs FC Name PTerm -- ^ @-pattern, valid LHS only | PAlternative Bool [PTerm] -- ^ True if only one may work. (| A, B, C|) | PHidden PTerm -- ^ Irrelevant or hidden pattern | PType -- ^ 'Type' type @@ -745,7 +778,7 @@ | PNoImplicits PTerm -- ^ never run implicit converions on the term | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term]) | PUnquote PTerm -- ^ ,Term - deriving Eq + deriving (Eq, Data, Typeable) {-! @@ -755,9 +788,9 @@ mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm mapPT f t = f (mpt t) where - mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s) + mpt (PLam fc n t s) = PLam fc n (mapPT f t) (mapPT f s) mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s) - mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s) + mpt (PLet fc n ty v s) = PLet fc n (mapPT f ty) (mapPT f v) (mapPT f s) mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g) mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as) @@ -806,7 +839,8 @@ | Skip | TFail [ErrorReportPart] | Qed | Abandon - deriving (Show, Eq, Functor, Foldable, Traversable) + | SourceFC + deriving (Show, Eq, Functor, Foldable, Traversable, Data, Typeable) {-! deriving instance Binary PTactic' deriving instance NFData PTactic' @@ -836,6 +870,7 @@ size Abandon = 1 size Skip = 1 size (TFail ts) = 1 + size ts + size SourceFC = 1 type PTactic = PTactic' PTerm @@ -844,7 +879,7 @@ | DoBindP FC t t [(t,t)] | DoLet FC Name t t | DoLetP FC t t - deriving (Eq, Functor) + deriving (Eq, Functor, Data, Typeable) {-! deriving instance Binary PDo' deriving instance NFData PDo' @@ -880,10 +915,10 @@ pname :: Name, getScript :: t, getTm :: t } - deriving (Show, Eq, Functor) + deriving (Show, Eq, Functor, Data, Typeable) data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) instance Sized a => Sized (PArg' a) where size (PImp p _ l nm trm) = 1 + size nm + size trm @@ -928,6 +963,7 @@ deriving Show {-! deriving instance Binary FnInfo +deriving instance NFData FnInfo !-} data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting @@ -985,6 +1021,9 @@ syntaxNames (Rule syms _ _) = mapMaybe ename syms where ename (Keyword n) = Just n ename _ = Nothing + +syntaxSymbols :: Syntax -> [SSymbol] +syntaxSymbols (Rule ss _ _) = ss {-! deriving instance Binary Syntax deriving instance NFData Syntax @@ -995,7 +1034,7 @@ | Binding Name | Expr Name | SimpleExpr Name - deriving Show + deriving (Show, Eq) {-! @@ -1003,6 +1042,46 @@ deriving instance NFData SSymbol !-} +newtype SyntaxRules = SyntaxRules { syntaxRulesList :: [Syntax] } + +emptySyntaxRules :: SyntaxRules +emptySyntaxRules = SyntaxRules [] + +updateSyntaxRules :: [Syntax] -> SyntaxRules -> SyntaxRules +updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules + where + newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr) + + ruleSort [] [] = EQ + ruleSort [] _ = LT + ruleSort _ [] = GT + ruleSort (s1:ss1) (s2:ss2) = + case symCompare s1 s2 of + EQ -> ruleSort ss1 ss2 + r -> r + + -- Better than creating Ord instance for SSymbol since + -- in general this ordering does not really make sense. + symCompare (Keyword n1) (Keyword n2) = compare n1 n2 + symCompare (Keyword _) _ = LT + symCompare (Symbol _) (Keyword _) = GT + symCompare (Symbol s1) (Symbol s2) = compare s1 s2 + symCompare (Symbol _) _ = LT + symCompare (Binding _) (Keyword _) = GT + symCompare (Binding _) (Symbol _) = GT + symCompare (Binding b1) (Binding b2) = compare b1 b2 + symCompare (Binding _) _ = LT + symCompare (Expr _) (Keyword _) = GT + symCompare (Expr _) (Symbol _) = GT + symCompare (Expr _) (Binding _) = GT + symCompare (Expr e1) (Expr e2) = compare e1 e2 + symCompare (Expr _) _ = LT + symCompare (SimpleExpr _) (Keyword _) = GT + symCompare (SimpleExpr _) (Symbol _) = GT + symCompare (SimpleExpr _) (Binding _) = GT + symCompare (SimpleExpr _) (Expr _) = GT + symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2 + initDSL = DSL (PRef f (sUN ">>=")) (PRef f (sUN "return")) (PRef f (sUN "<$>")) @@ -1071,7 +1150,7 @@ getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc - where toTy (Lam t) = Pi t (TType (UVar 0)) + where toTy (Lam t) = Pi Nothing t (TType (UVar 0)) toTy (PVar t) = PVTy t toTy b = b getInferType (App (App _ ty) _) = ty @@ -1092,8 +1171,8 @@ "of type `Void` in scope." falseTy = sUN "Void" -pairTy = sUN "Pair" -pairCon = sUN "MkPair" +pairTy = sNS (sUN "Pair") ["Builtins"] +pairCon = sNS (sUN "MkPair") ["Builtins"] eqTy = sUN "=" eqCon = sUN "Refl" @@ -1133,9 +1212,15 @@ eqOpts = [] +-- | The special name to be used in the module documentation context - +-- not for use in the main definition context. The namespace around it +-- will determine the module to which the docs adhere. +modDocName :: Name +modDocName = sMN 0 "ModuleDocs" + -- Defined in builtins.idr -sigmaTy = sUN "Sigma" -existsCon = sUN "MkSigma" +sigmaTy = sNS (sUN "Sigma") ["Builtins"] +existsCon = sNS (sUN "MkSigma") ["Builtins"] piBind :: [(Name, PTerm)] -> PTerm -> PTerm piBind = piBindp expl @@ -1218,8 +1303,10 @@ -> [FixDecl] -- ^^ Fixity declarations -> PTerm -- ^^ the term to pretty-print -> Doc OutputAnnotation -pprintPTerm ppo bnd docArgs infixes = prettySe 10 bnd +pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd where + startPrec = 0 + funcAppPrec = 10 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation prettySe p bnd (PQuote r) = text "![" <> pretty r <> text "]" @@ -1228,45 +1315,45 @@ | Just str <- slist p bnd e = str | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n)) prettySe p bnd (PRef fc n) = prettyName True (ppopt_impl ppo) bnd n - prettySe p bnd (PLam n ty sc) = - bracket p 2 . group . align . hang 2 $ + prettySe p bnd (PLam fc n ty sc) = + bracket p startPrec . group . align . hang 2 $ text "\\" <> bindingOf n False <+> text "=>" <$> - prettySe 10 ((n, False):bnd) sc - prettySe p bnd (PLet n ty v sc) = - bracket p 2 . group . align $ - kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe 10 bnd v) - kwd "in" <+> (group . align . hang 2 $ prettySe 10 ((n, False):bnd) sc) + prettySe startPrec ((n, False):bnd) sc + prettySe p bnd (PLet fc n ty v sc) = + bracket p startPrec . group . align $ + kwd "let" <+> (group . align . hang 2 $ bindingOf n False <+> text "=" <$> prettySe startPrec bnd v) + kwd "in" <+> (group . align . hang 2 $ prettySe startPrec ((n, False):bnd) sc) prettySe p bnd (PPi (Exp l s _) n ty sc) | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs = - bracket p 2 . group $ - enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+> - st <> text "->" <$> prettySe 10 ((n, False):bnd) sc + bracket p startPrec . group $ + enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe startPrec bnd ty) <+> + st <> text "->" <$> prettySe startPrec ((n, False):bnd) sc | otherwise = - bracket p 2 . group $ - group (prettySe 1 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc) + bracket p startPrec . group $ + group (prettySe (startPrec + 1) bnd ty <+> st) <> text "->" <$> group (prettySe startPrec ((n, False):bnd) sc) where st = 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 _ fa) n ty sc) | ppopt_impl ppo = - bracket p 2 $ - lbrace <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+> - st <> text "->" prettySe 10 ((n, True):bnd) sc - | otherwise = prettySe 10 ((n, True):bnd) sc + bracket p startPrec $ + lbrace <> bindingOf n True <+> colon <+> prettySe startPrec bnd ty <> rbrace <+> + st <> text "->" prettySe startPrec ((n, True):bnd) sc + | otherwise = prettySe startPrec ((n, True):bnd) sc where st = case s of Static -> text "[static]" <> space _ -> empty prettySe p bnd (PPi (Constraint _ _) n ty sc) = - bracket p 2 $ - prettySe 10 bnd ty <+> text "=>" prettySe 10 ((n, True):bnd) sc + bracket p startPrec $ + prettySe (startPrec + 1) bnd ty <+> text "=>" prettySe startPrec ((n, True):bnd) sc prettySe p bnd (PPi (TacImp _ _ s) n ty sc) = - bracket p 2 $ - lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <> - rbrace <+> text "->" prettySe 10 ((n, True):bnd) sc + bracket p startPrec $ + lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe startPrec bnd ty <> + rbrace <+> text "->" prettySe startPrec ((n, True):bnd) sc prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args | UN nm <- basename f , not (ppopt_impl ppo) && null (getShowArgs args) = @@ -1279,49 +1366,63 @@ (not (ppopt_impl ppo)) && (not $ isAlpha (thead nm)) = case getShowArgs args of [] -> opName True - [x] -> group (opName True <$> group (prettySe 0 bnd (getTm x))) - [l,r] -> let precedence = fromMaybe 20 (fmap prec f) + [x] -> group (opName True <$> group (prettySe startPrec bnd (getTm x))) + [l,r] -> let precedence = maybe (startPrec - 1) prec f in bracket p precedence $ inFix (getTm l) (getTm r) (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) -> - bracket p 1 $ + bracket p funcAppPrec $ enclose lparen rparen (inFix (getTm l) (getTm r)) <+> align (group (vsep (map (prettyArgS bnd) rest))) as -> opName True <+> align (vsep (map (prettyArgS bnd) as)) where opName isPrefix = prettyName isPrefix (ppopt_impl ppo) bnd op f = getFixity (opStr op) - left l = case f of - Nothing -> prettySe (-1) bnd l - Just (Infixl p') -> prettySe p' bnd l - Just f' -> prettySe (prec f'-1) bnd l - right r = case f of - Nothing -> prettySe (-1) bnd r - Just (Infixr p') -> prettySe p' bnd r - Just f' -> prettySe (prec f'-1) bnd r + left = case f of + Nothing -> funcAppPrec + 1 + Just (Infixl p') -> p' + Just f' -> prec f' + 1 + right = case f of + Nothing -> funcAppPrec + 1 + Just (Infixr p') -> p' + Just f' -> prec f' + 1 inFix l r = align . group $ - (left l <+> opName False) <$> group (right r) + (prettySe left bnd l <+> opName False) <$> + group (prettySe right bnd r) prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo | PConstant (Idris.Core.TT.Str str) <- getTm tm, f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $ - char '\'' <> prettySe 10 bnd (PRef fc (sUN str)) + char '\'' <> prettySe startPrec bnd (PRef fc (sUN str)) prettySe p bnd (PApp _ f as) = -- Normal prefix applications let args = getShowArgs as - fp = prettySe 1 bnd f + fp = prettySe (startPrec + 1) bnd f + shownArgs = if ppopt_impl ppo then as else args in - bracket p 1 . group $ - if ppopt_impl ppo - then if null as - then fp - else fp <+> align (vsep (map (prettyArgS bnd) as)) - else if null args - then fp - else fp <+> align (vsep (map (prettyArgS bnd) args)) - prettySe p bnd (PCase _ scr opts) = - kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody + bracket p funcAppPrec . group $ + if null shownArgs + then fp + else fp <+> align (vsep (map (prettyArgS bnd) shownArgs)) + prettySe p bnd (PCase _ scr cases) = + align $ kwd "case" <+> prettySe startPrec bnd scr <+> kwd "of" <$> + indent 2 (vsep (map ppcase cases)) where - prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts + ppcase (l, r) = let prettyCase = prettySe startPrec + ([(n, False) | n <- vars l] ++ bnd) + in nest nestingSize $ + prettyCase l <+> text "=>" <+> prettyCase r + -- Warning: this is a bit of a hack. At this stage, we don't have the + -- global context, so we can't determine which names are constructors, + -- which are types, and which are pattern variables on the LHS of the + -- case pattern. We use the heuristic that names without a namespace + -- are patvars, because right now case blocks in PTerms are always + -- delaborated from TT before being sent to the pretty-printer. If they + -- start getting printed directly, THIS WILL BREAK. + -- Potential solution: add a list of known patvars to the cases in + -- PCase, and have the delaborator fill it out, kind of like the pun + -- disambiguation on PDPair. + vars tm = filter noNS (allNamesIn tm) + noNS (NS _ _) = False + noNS _ = True - 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 (PHidden tm) = text "." <> prettySe funcAppPrec bnd tm prettySe p bnd (PRefl _ _) = annName eqCon $ text "Refl" prettySe p bnd (PResolveTC _) = text "resolvetc" prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()" @@ -1329,7 +1430,7 @@ prettySe p bnd (PTrue _ TypeOrTerm) = text "()" prettySe p bnd (PEq _ lt rt l r) | ppopt_impl ppo = - bracket p 1 $ + bracket p eqPrec $ enclose lparen rparen eq <+> align (group (vsep (map (prettyArgS bnd) [PImp 0 False [] (sUN "A") lt, @@ -1337,47 +1438,42 @@ PExp 0 [] (sUN "x") l, PExp 0 [] (sUN "y") r]))) | otherwise = - bracket p 2 . align . group $ - prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r) + bracket p eqPrec . align . group $ + prettyTerm l <+> eq <$> group (prettyTerm r) where eq = annName eqTy (text "=") + eqPrec = startPrec + prettyTerm = prettySe (eqPrec + 1) bnd prettySe p bnd (PRewrite _ l r _) = - bracket p 2 $ - text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r + bracket p startPrec $ + text "rewrite" <+> prettySe (startPrec + 1) bnd l <+> text "in" <+> prettySe startPrec bnd r prettySe p bnd (PTyped l r) = - lparen <> prettySe 10 bnd l <+> colon <+> prettySe 10 bnd r <> rparen + lparen <> prettySe startPrec bnd l <+> colon <+> prettySe startPrec bnd r <> rparen 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 + map (prettySe startPrec 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 <> - 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 <> - annName existsCon rparen + prettySe p bnd (PDPair _ pun l t r) = + annotated lparen <> + left <+> + annotated (text "**") <+> + prettySe startPrec (addBinding bnd) r <> + annotated rparen + where annotated = case pun of + IsType -> annName sigmaTy + IsTerm -> annName existsCon + TypeOrTerm -> id + (left, addBinding) = case (l, pun) of + (PRef _ n, IsType) -> (bindingOf n False, ((n, False) :)) + _ -> (prettySe startPrec bnd l, id ) prettySe p bnd (PAlternative a as) = lparen <> text "|" <> prettyAs <> text "|" <> rparen where prettyAs = - foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as + foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe startPrec bnd) as prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type" prettySe p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u) prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c)) @@ -1405,10 +1501,10 @@ 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 <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace + prettyArgSe bnd arg = prettySe (funcAppPrec + 1) bnd arg + prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe startPrec bnd val <> rbrace + prettyArgSc bnd val = lbrace <> lbrace <> prettySe startPrec bnd val <> rbrace <> rbrace + prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe startPrec bnd val <> rbrace annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation annName n = annotate (AnnName n Nothing Nothing Nothing) @@ -1465,7 +1561,7 @@ snat _ _ = Nothing bracket outer inner doc - | inner > outer = lparen <> doc <> rparen + | outer > inner = lparen <> doc <> rparen | otherwise = doc kwd = annotate AnnKeyword . text @@ -1489,13 +1585,15 @@ -> [(Name, Bool)] -- ^^ the current bound variables and whether they are implicit -> Name -- ^^ the name to pprint -> Doc OutputAnnotation -prettyName infixParen showNS bnd n +prettyName infixParen showNS bnd n + | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_" + | (UN n') <- n, isPrefixOf "_" $ T.unpack n' = text "_" | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName where fullName = text nameSpace <> parenthesise (text (baseName n)) baseName (UN n) = T.unpack n baseName (NS n ns) = baseName n - baseName (MN i s) = T.unpack s + baseName (MN i s) = T.unpack s baseName other = show other nameSpace = case n of (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else "" @@ -1617,9 +1715,9 @@ instance Sized PTerm where size (PQuote rawTerm) = size rawTerm size (PRef fc name) = size name - size (PLam name ty bdy) = 1 + size ty + size bdy + size (PLam fc name ty bdy) = 1 + size ty + size bdy size (PPi plicity name ty bdy) = 1 + size ty + size bdy - size (PLet name ty def bdy) = 1 + size ty + size def + size bdy + size (PLet fc name ty def bdy) = 1 + size ty + size def + size bdy size (PTyped trm ty) = 1 + size trm + size ty size (PApp fc name args) = 1 + size args size (PAppBind fc name args) = 1 + size args @@ -1664,7 +1762,7 @@ ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) - ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PHidden tm) = ni env tm ni env (PEq _ _ _ l r) = ni env l ++ ni env r @@ -1689,8 +1787,8 @@ ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as) ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as) ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os) - ni (PLam n ty sc) = n : (ni ty ++ ni sc) - ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc) + ni (PLam fc n ty sc) = n : (ni ty ++ ni sc) + ni (PLet fc n ty val sc) = n : (ni ty ++ ni val ++ ni sc) ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc)) ni (PEq _ _ _ l r) = ni l ++ ni r ni (PRewrite _ l r _) = ni l ++ ni r @@ -1726,7 +1824,7 @@ -- names in 'os', not counting the names bound in the cases (nub (concatMap (ni env) (map snd os)) \\ nub (concatMap (ni env) (map fst os))) - ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r @@ -1756,7 +1854,7 @@ -- names in 'os', not counting the names bound in the cases (nub (concatMap (ni env) (map snd os)) \\ nub (concatMap (ni env) (map fst os))) - ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r @@ -1787,7 +1885,7 @@ ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as) ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os) - ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc + ni env (PLam fc n ty sc) = ni env ty ++ ni (n:env) sc ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc ni env (PEq _ _ _ l r) = ni env l ++ ni env r ni env (PRewrite _ l r _) = ni env l ++ ni env r diff --git a/src/Idris/Apropos.hs b/src/Idris/Apropos.hs --- a/src/Idris/Apropos.hs +++ b/src/Idris/Apropos.hs @@ -1,12 +1,12 @@ -module Idris.Apropos where +module Idris.Apropos (apropos, aproposModules) 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 Idris.Docstrings (Docstring, DocTerm, containsText) -import Data.List (nub) +import Data.List (nub, nubBy, intersperse) import qualified Data.Text as T -- | Find definitions that are relevant to all space-delimited components of @@ -22,11 +22,25 @@ docs = toAlist (idris_docstrings ist) in nub (map fst (isAproposAll parts defs) ++ map fst (isAproposAll parts docs)) - where isAproposAll [] xs = xs + where isAproposAll [] xs = xs isAproposAll (what:more) xs = filter (isApropos what) (isAproposAll more xs) parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what +-- | Find modules whose names or docstrings contain all the +-- space-delimited components of some string. +aproposModules :: IState -> T.Text -> [(String, Docstring DocTerm)] +aproposModules ist what = let mods = toAlist (idris_moduledocs ist) + found = nubBy (\x y -> fst x == fst y) + (isAproposAll parts mods) + in map unModName found + where isAproposAll [] xs = xs + isAproposAll (what:more) xs = filter (\(n,d) -> isApropos what n || isApropos what d) + (isAproposAll more xs) + parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what + unModName (NS _ ns, d) = ((concat . intersperse "." . map T.unpack . reverse) ns, d) + unModName (n, d) = ("<>", d) + textIn :: T.Text -> T.Text -> Bool textIn a b = T.isInfixOf (T.toLower a) (T.toLower b) @@ -52,7 +66,7 @@ instance Apropos (Binder (TT Name)) where isApropos str (Lam ty) = str == T.pack "\\" || isApropos str ty - isApropos str (Pi ty _) = str == T.pack "->" || isApropos str ty + isApropos str (Pi _ ty _) = str == T.pack "->" || isApropos str ty isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val isApropos str _ = False -- these shouldn't occur in defined libraries diff --git a/src/Idris/CaseSplit.hs b/src/Idris/CaseSplit.hs --- a/src/Idris/CaseSplit.hs +++ b/src/Idris/CaseSplit.hs @@ -57,7 +57,9 @@ = do ist <- getIState -- Make sure all the names in the term are accessible mapM_ (\n -> setAccessibility n Public) (allNamesIn t') - (tm, ty, pats) <- elabValBind recinfo ELHS True (addImplPat ist t') + -- ETyDecl rather then ELHS because there'll be explicit type + -- matching + (tm, ty, pats) <- elabValBind recinfo ETyDecl True (addImplPat ist t') -- ASSUMPTION: tm is in normal form after elabValBind, so we don't -- need to do anything special to find out what family each argument -- is in @@ -181,7 +183,7 @@ = case lookupTy n (tt_ctxt ist) of [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing _ -> repeat Nothing - where tyName (Bind _ (Pi _ _) _) = Just (sUN "->") + where tyName (Bind _ (Pi _ _ _) _) = Just (sUN "->") tyName t | (P _ n _, _) <- unApply t = Just n | otherwise = Nothing argTys _ _ = repeat Nothing @@ -359,7 +361,7 @@ getNameFrom i used (PPi _ _ _ _) = uniqueNameFrom (mkSupply [sUN "f", sUN "g"]) used getNameFrom i used (PApp fc f as) = getNameFrom i used f - getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom [sUN "prf"] used + getNameFrom i used (PEq _ _ _ _ _) = uniqueNameFrom (mkSupply [sUN "prf"]) used getNameFrom i used (PRef fc f) = case getNameHints i f of [] -> uniqueName (sUN "x") used diff --git a/src/Idris/Chaser.hs b/src/Idris/Chaser.hs --- a/src/Idris/Chaser.hs +++ b/src/Idris/Chaser.hs @@ -126,7 +126,7 @@ if exist then do ibct <- runIO $ getModificationTime ibc srct <- runIO $ getModificationTime src - return (srct > ibct) + return (srct >= ibct) else return False children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree] @@ -135,10 +135,10 @@ if exist then do file_in <- runIO $ readFile f file <- if lit then tclift $ unlit f file_in else return file_in - (_, modules, _) <- parseImports f file + (_, _, modules, _) <- parseImports f file -- The chaser should never report warnings from sub-modules clearParserWarnings - ms <- mapM (btree done) [realName | (realName, alias, fc) <- modules] + ms <- mapM (btree done) [realName | (_, realName, alias, fc) <- modules] return (concat ms) else return [] -- IBC with no source available -- (\c -> return []) -- error, can't chase modules here diff --git a/src/Idris/CmdOptions.hs b/src/Idris/CmdOptions.hs --- a/src/Idris/CmdOptions.hs +++ b/src/Idris/CmdOptions.hs @@ -23,7 +23,8 @@ return $ preProcOpts opts [] where idrisHeader = PP.hsep [PP.text "Idris version", PP.text ver, PP.text ", (C) The Idris Community 2014"] - idrisProgDesc = PP.vsep [PP.text "Idris is a general purpose pure functional programming language with dependent", + idrisProgDesc = PP.vsep [PP.empty, + PP.text "Idris is a general purpose pure functional programming language with dependent", PP.text "types. Dependent types allow types to be predicated on values, meaning that", PP.text "some aspects of a program’s behaviour can be specified precisely in the type.", PP.text "It is compiled, with eager evaluation. Its features are influenced by Haskell", @@ -43,8 +44,7 @@ "+ Cumulative universes", "+ Simple foreign function interface (to C)", "+ Hugs style interactive environment" - ], - PP.empty] + ]] idrisFooter = PP.vsep [PP.text "It is important to note that Idris is first and foremost a research tool", PP.text "and project. Thus the tooling provided and resulting programs created", PP.text "should not necessarily be seen as production ready nor for industrial use.", @@ -75,12 +75,12 @@ <|> flag' IdeslaveSocket (long "ideslave-socket") <|> (Client <$> strOption (long "client")) <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level")) - <|> flag' NoBasePkgs (long "nobasepkgs") - <|> flag' NoPrelude (long "noprelude") - <|> flag' NoBuiltins (long "nobuiltins") + <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package") + <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude") + <|> flag' NoBuiltins (long "nobuiltins" <> help "Do not use the builtin functions") <|> flag' NoREPL (long "check" <> help "Typecheck only, don't start the REPL") <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file")) --- <|> flag' TypeCase (long "typecase") + -- <|> flag' TypeCase (long "typecase") <|> flag' TypeInType (long "typeintype") <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default") <|> flag' DefaultPartial (long "partial") @@ -89,18 +89,19 @@ <|> flag' NoCoverage (long "nocoverage") <|> flag' ErrContext (long "errorcontext") <|> flag' ShowLibs (long "link" <> help "Display link flags") + <|> flag' ShowPkgs (long "listlibs" <> help "Display installed libraries") <|> flag' ShowLibdir (long "libdir" <> help "Display library directory") <|> flag' ShowIncs (long "include" <> help "Display the includes flags") <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity") <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory")) <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths")) <|> flag' WarnOnly (long "warn") - <|> (Pkg <$> strOption (short 'p' <> long "package")) + <|> (Pkg <$> strOption (short 'p' <> long "package" <> help "Add package as a dependency")) <|> (Port <$> strOption (long "port" <> metavar "PORT" <> help "REPL TCP port")) -- Package commands <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package")) <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package")) - <|> (PkgREPL <$> strOption (long "repl")) + <|> (PkgREPL <$> strOption (long "repl" <> metavar "IPKG" <> help "Launch REPL, only for executables")) <|> (PkgClean <$> strOption (long "clean" <> metavar "IPKG" <> help "Clean package")) <|> (PkgMkDoc <$> strOption (long "mkdoc" <> metavar "IPKG" <> help "Generate IdrisDoc for package")) <|> (PkgCheck <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only")) @@ -122,7 +123,7 @@ <|> flag' (OptLevel 1) (long "O1") <|> flag' (OptLevel 0) (long "O0") <|> flag' (AddOpt PETransform) (long "partial-eval") - <|> flag' (RemoveOpt PETransform) (long "no-partial-eval") + <|> flag' (RemoveOpt PETransform) (long "no-partial-eval" <> help "Switch off partial evaluation, mainly for debugging purposes") <|> (OptLevel <$> option auto (short 'O' <> long "level")) <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)")) <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)")) diff --git a/src/Idris/Colours.hs b/src/Idris/Colours.hs --- a/src/Idris/Colours.hs +++ b/src/Idris/Colours.hs @@ -52,6 +52,17 @@ fg Nothing = [] fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c] +-- | Set the colour of a string using POSIX escape codes, with trailing '\STX' denoting the end +-- (required by Haskeline in the prompt string) +colouriseWithSTX :: IdrisColour -> String -> String +colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX" + where sgr = fg c ++ + (if u then [SetUnderlining SingleUnderline] else []) ++ + (if b then [SetConsoleIntensity BoldIntensity] else []) ++ + (if i then [SetItalicized True] else []) + fg Nothing = [] + fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c] + colouriseKwd :: ColourTheme -> String -> String colouriseKwd t = colourise (keywordColour t) @@ -71,7 +82,7 @@ colouriseData t = colourise (dataColour t) colourisePrompt :: ColourTheme -> String -> String -colourisePrompt t = colourise (promptColour t) +colourisePrompt t = colouriseWithSTX (promptColour t) colouriseKeyword :: ColourTheme -> String -> String colouriseKeyword t = colourise (keywordColour t) diff --git a/src/Idris/Completion.hs b/src/Idris/Completion.hs --- a/src/Idris/Completion.hs +++ b/src/Idris/Completion.hs @@ -4,11 +4,15 @@ import Idris.Core.Evaluate (ctxtAlist) import Idris.Core.TT +import Idris.AbsSyntax (runIO) import Idris.AbsSyntaxTree import Idris.Help +import Idris.Imports (installedPackages) import Idris.Colours import Idris.ParseHelpers(opChars) - +import qualified Idris.ParseExpr (constants, tactics) +import Idris.ParseExpr (TacticArg (..)) +import Idris.REPLParser (allHelp) import Control.Monad.State.Strict import Data.List @@ -19,41 +23,11 @@ import System.Console.ANSI (Color) -fst3 :: (a, b, c) -> a -fst3 (a, b, c) = a - -commands = concatMap fst3 (help ++ extraHelp) - --- | A specification of the arguments that tactics can take -data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n - | ExprTArg - | AltsTArg +commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ] --- | A list of available tactics and their argument requirements tacticArgs :: [(String, Maybe TacticArg)] -tacticArgs = [ ("intro", Nothing) -- FIXME syntax for intro (fresh name) - , ("refine", Just ExprTArg) - , ("mrefine", Just ExprTArg) - , ("rewrite", Just ExprTArg) - , ("let", Nothing) -- FIXME syntax for let - , ("focus", Just ExprTArg) - , ("exact", Just ExprTArg) - , ("equiv", Just ExprTArg) - , ("applyTactic", Just ExprTArg) - , ("byReflection", Just ExprTArg) - , ("reflect", Just ExprTArg) - , ("fill", Just ExprTArg) - , ("try", Just AltsTArg) - , ("induction", Just ExprTArg) - , ("case", Just ExprTArg) - , (":t", Just ExprTArg) - , (":type", Just ExprTArg) - , (":e", Just ExprTArg) - , (":eval", Just ExprTArg) - ] ++ map (\x -> (x, Nothing)) [ - "intros", "compute", "trivial", "search", "solve", "attack", - "unify", "state", "term", "undo", "qed", "abandon", ":q" - ] +tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics + , name <- names ] tactics = map fst tacticArgs -- | Convert a name into a string usable for completion. Filters out names @@ -66,16 +40,15 @@ nameString _ = Nothing -- FIXME: Respect module imports +-- Issue #1767 in the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1767 -- | Get the user-visible names from the current interpreter state. names :: Idris [String] names = do i <- get let ctxt = tt_ctxt i return . nub $ mapMaybe (nameString . fst) (ctxtAlist ctxt) ++ - -- Explicitly add primitive types, as these are special-cased in the parser - ["Int", "Integer", "Float", "Char", "String", "Type", - "Ptr", "Bits8", "Bits16", "Bits32", "Bits64", - "Bits8x16", "Bits16x8", "Bits32x4", "Bits64x2"] + "Type" : map fst Idris.ParseExpr.constants metavars :: Idris [String] metavars = do i <- get @@ -124,7 +97,7 @@ isWhitespace = (flip elem) " \t\n" lookupInHelp :: String -> Maybe CmdArg -lookupInHelp cmd = lookupInHelp' cmd help +lookupInHelp cmd = lookupInHelp' cmd allHelp where lookupInHelp' cmd ((cmds, arg, _):xs) | elem cmd cmds = Just arg | otherwise = lookupInHelp' cmd xs lookupInHelp' cmd [] = Nothing @@ -155,6 +128,8 @@ completeColourFormat = let getCmpl = completeWith (colours ++ formats) in completeWord Nothing " \t" (return . getCmpl) +-- The FIXMEs are Issue #1768 on the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1768 -- | Get the completion function for a particular command completeCmd :: String -> CompletionFunc Idris completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lookupInHelp cmd @@ -169,9 +144,11 @@ completeArg NoArg = noCompletion (prev, next) completeArg ConsoleWidthArg = completeConsoleWidth (prev, next) completeArg DeclArg = completeExpr [] (prev, next) + completeArg PkgArgs = completePkg (prev, next) completeArg (ManyArgs a) = completeArg a completeArg (OptionalArg a) = completeArg a completeArg (SeqArgs a b) = completeArg a + completeArg _ = noCompletion (prev, next) completeCmdName = return $ ("", completeWith commands cmd) -- | Complete REPL commands and defined identifiers @@ -182,14 +159,22 @@ where firstWord = fst $ break isWhitespace $ dropWhile isWhitespace $ reverse prev +completePkg :: CompletionFunc Idris +completePkg = completeWord Nothing " \t()" completeP + where completeP p = do pkgs <- runIO installedPackages + return $ completeWith pkgs p + +-- The TODOs are Issue #1769 on the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1769 completeTactic :: [String] -> String -> CompletionFunc Idris 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! - completeArg (Just ExprTArg) = completeExpr as (prev, next) - completeArg (Just AltsTArg) = noCompletion (prev, next) -- TODO + completeArg Nothing = noCompletion (prev, next) + completeArg (Just NameTArg) = noCompletion (prev, next) -- this is for binding new names! + completeArg (Just ExprTArg) = completeExpr as (prev, next) + completeArg (Just StringLitTArg) = noCompletion (prev, next) + completeArg (Just AltsTArg) = noCompletion (prev, next) -- TODO -- | Complete tactics and their arguments proverCompletion :: [String] -- ^ The names of current local assumptions diff --git a/src/Idris/Core/Binary.hs b/src/Idris/Core/Binary.hs --- a/src/Idris/Core/Binary.hs +++ b/src/Idris/Core/Binary.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Binary instances for the core datatypes -} module Idris.Core.Binary where @@ -118,6 +118,10 @@ put (ReflectionFailed str e) = do putWord8 33 put str put e + put (WithFnType t) = do putWord8 34 + put t + put (CantMatch t) = do putWord8 35 + put t get = do i <- getWord8 case i of @@ -171,6 +175,8 @@ return $ ReflectionError x y 33 -> do x <- get ; y <- get return $ ReflectionFailed x y + 34 -> fmap WithFnType get + 35 -> fmap CantMatch get _ -> error "Corrupted binary data for Err'" ----- Generated by 'derive' @@ -397,15 +403,23 @@ return (RUType x1) _ -> error "Corrupted binary data for Raw" +instance Binary ImplicitInfo where + put x + = case x of + Impl x1 -> put x1 + get + = do x1 <- get + return (Impl x1) instance (Binary b) => Binary (Binder b) where put x = case x of Lam x1 -> do putWord8 0 put x1 - Pi x1 x2 -> do putWord8 1 - put x1 - put x2 + Pi x1 x2 x3 -> do putWord8 1 + put x1 + put x2 + put x3 Let x1 x2 -> do putWord8 2 put x1 put x2 @@ -431,7 +445,8 @@ return (Lam x1) 1 -> do x1 <- get x2 <- get - return (Pi x1 x2) + x3 <- get + return (Pi x1 x2 x3) 2 -> do x1 <- get x2 <- get return (Let x1 x2) 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 @@ -41,7 +41,7 @@ deriving instance NFData SC' !-} -data CaseType = Updatable | Shared +data CaseType = Updatable | Shared deriving (Eq, Ord, Show) type SC = SC' Term @@ -184,7 +184,7 @@ 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 + | (P (TCon _ _) n _, args) <- unApply fn = [] -- type constructors not used at runtime | otherwise = nub $ directUse f ++ directUse a directUse (Proj x i) = nub $ directUse x directUse _ = [] @@ -233,20 +233,20 @@ -- Generate a simple case tree -- Work Right to Left -simpleCase :: Bool -> Bool -> Bool -> +simpleCase :: Bool -> SC -> Bool -> Phase -> FC -> [Int] -> [Type] -> [([Name], Term, Term)] -> ErasureInfo -> TC CaseDef -simpleCase tc cover reflect phase fc inacc argtys cs erInfo - = sc' tc cover phase fc (filter (\(_, _, r) -> +simpleCase tc defcase reflect phase fc inacc argtys cs erInfo + = sc' tc defcase phase fc (filter (\(_, _, r) -> case r of Impossible -> False _ -> True) cs) where - sc' tc cover phase fc [] + sc' tc defcase phase fc [] = return $ CaseDef [] (UnmatchedCase "No pattern clauses") [] - sc' tc cover phase fc cs + sc' tc defcase phase fc cs = let proj = phase == RunTime vnames = fstT (head cs) pats = map (\ (avs, l, r) -> @@ -258,16 +258,11 @@ ns = take numargs args (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats (tree, st) = runCaseBuilder erInfo - (match ns' ps' (defaultCase cover)) + (match ns' ps' defcase) ([], numargs, []) t = CaseDef ns (prune proj (depatt ns' tree)) (fstT st) in - if proj then return (stripLambdas t) + if proj then return (stripLambdas t) else return t --- FIXME: This check is not quite right in some cases, and is breaking --- perfectly valid code! --- if checkSameTypes (lstT st) tree --- then return t --- else Error (At fc (Msg "Typecase is not allowed")) Error err -> Error (At fc err) where args = map (\i -> sMN i "e") [0..] defaultCase True = STerm Erased @@ -311,23 +306,25 @@ -- FIXME: All we're actually doing here is checking that we haven't arrived -- at a specific constructor for a polymorphic argument. I *think* this -- is sufficient, but if it turns out not to be, fix it! +-- +-- Issue #1718 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1718 isType n t | (P (TCon _ _) _ _, _) <- unApply t = True isType n t | (P Ref _ _, _) <- unApply t = True isType n t = False -isConstType (I _) (AType (ATInt ITNative)) = True -isConstType (BI _) (AType (ATInt ITBig)) = True -isConstType (Fl _) (AType ATFloat) = True -isConstType (Ch _) (AType (ATInt ITChar)) = True -isConstType (Str _) StrType = True -isConstType (B8 _) (AType (ATInt _)) = True -isConstType (B16 _) (AType (ATInt _)) = True -isConstType (B32 _) (AType (ATInt _)) = True -isConstType (B64 _) (AType (ATInt _)) = True -isConstType (B8V _) (AType (ATInt _)) = True -isConstType (B16V _) (AType (ATInt _)) = True -isConstType (B32V _) (AType (ATInt _)) = True -isConstType (B64V _) (AType (ATInt _)) = True +isConstType (I _) (AType (ATInt ITNative)) = True +isConstType (BI _) (AType (ATInt ITBig)) = True +isConstType (Fl _) (AType ATFloat) = True +isConstType (Ch _) (AType (ATInt ITChar)) = True +isConstType (Str _) StrType = True +isConstType (B8 _) (AType (ATInt _)) = True +isConstType (B16 _) (AType (ATInt _)) = True +isConstType (B32 _) (AType (ATInt _)) = True +isConstType (B64 _) (AType (ATInt _)) = True +isConstType (B8V _) (AType (ATInt _)) = True +isConstType (B16V _) (AType (ATInt _)) = True +isConstType (B32V _) (AType (ATInt _)) = True +isConstType (B64V _) (AType (ATInt _)) = True isConstType _ _ = False data Pat = PCon Bool Name Int [Pat] @@ -370,13 +367,10 @@ toPat' [] (P Bound n ty) = PV n ty toPat' args (App f a) = toPat' (a : args) f - toPat' [] (Constant (AType _)) = PTyPat - toPat' [] (Constant StrType) = PTyPat - toPat' [] (Constant PtrType) = PTyPat - toPat' [] (Constant VoidType) = PTyPat - toPat' [] (Constant x) = PConst x + toPat' [] (Constant x) | isTypeConst x = PTyPat + | otherwise = PConst x - toPat' [] (Bind n (Pi t _) sc) + toPat' [] (Bind n (Pi _ t _) sc) | reflect && noOccurrence n sc = PReflected (sUN "->") [toPat' [] t, toPat' [] sc] @@ -430,10 +424,10 @@ -- constructor tags between families, and no constructor/constant -- clash, because otherwise we can't reliable make the -- case distinction on evaluation - (patnames_ord, patnames_rest) + (patnames_ord, patnames_rest) = Data.List.partition (noClash . map snd) patnames -- note: sortBy . reverse is not nonsense because sortBy is stable - pats' = transpose (sortBy moreDistinct (reverse patnames_ord) + pats' = transpose (sortBy moreDistinct (reverse patnames_ord) ++ patnames_rest) in (getNOrder pats', zipWith rebuild pats' cs) where @@ -523,7 +517,7 @@ altGroups (ConGroup _ (CConst c) args : cs) = (:) <$> altConstGroup c args <*> altGroups cs - altGroup n i args + altGroup n i args = do inacc <- inaccessibleArgs n (newVars, accVars, inaccVars, nextCs) <- argsToAlt inacc args matchCs <- match (accVars ++ vs ++ inaccVars) nextCs err @@ -556,7 +550,7 @@ -- Create names for new variables arising from the given patterns. getNewVars :: [Pat] -> CaseBuilder [Name] getNewVars [] = return [] - getNewVars ((PV n t) : ns) = do v <- getVar "e" + getNewVars ((PV n t) : ns) = do v <- getVar "e" nsv <- getNewVars ns -- Record the type of the variable. @@ -666,6 +660,7 @@ applyMaps ms t = t -- FIXME: Do this for SucCase too +-- Issue #1719 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1719 prune :: Bool -- ^ Convert single branches to projections (only useful at runtime) -> SC -> SC prune proj (Case up n alts) = case alts' of @@ -689,9 +684,9 @@ -- with sc as@[ConCase cn i args sc] | proj -> let sc' = prune proj sc in - if any (isUsed sc') args + if any (isUsed sc') args then Case up n [ConCase cn i args sc'] - else sc' + else sc' [SucCase cn sc] | proj @@ -795,4 +790,3 @@ = DefaultCase (mkForceSC n arg rhs) forceTm n arg t = subst n arg t - diff --git a/src/Idris/Core/Constraints.hs b/src/Idris/Core/Constraints.hs --- a/src/Idris/Core/Constraints.hs +++ b/src/Idris/Core/Constraints.hs @@ -6,7 +6,6 @@ import Control.Applicative import Control.Arrow -import Control.Monad.Error import Control.Monad.RWS import Control.Monad.State import Data.List @@ -56,15 +55,16 @@ = Error $ At fc UniverseError -- FIXME: Make informative -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path)) + -- Issue #1725 on the issue tracker. + -- https://github.com/idris-lang/Idris-dev/issues/1725 -- if we reach a cycle but we're at the same universe level, it's -- fine, because they must all be equal, so stop. | inc == 0 && cv `elem` map fst path = return () - | otherwise + | otherwise = case M.lookup cv r of Nothing -> return () Just cs -> mapM_ (next r ((cv, fc):path) inc) cs next r path inc (ULT l x, fc) = check fc r path (inc + 1) x next r path inc (ULE l x, fc) = check fc r path inc x - 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 @@ -1,7 +1,10 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + module Idris.Core.DeepSeq where import Idris.Core.TT import Idris.Core.CaseTree +import Idris.Core.Evaluate import Control.DeepSeq @@ -11,6 +14,7 @@ rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf NErased = () rnf (SN x1) = rnf x1 `seq` () + rnf (SymRef x1) = rnf x1 `seq` () instance NFData SpecialName where rnf (WhereN x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () @@ -22,11 +26,17 @@ rnf (ElimN x1) = rnf x1 `seq` () rnf (InstanceCtorN x1) = rnf x1 `seq` () +instance NFData Universe where + rnf NullType = () + rnf UniqueType = () + rnf AllTypes = () + instance NFData Raw where rnf (Var x1) = rnf x1 `seq` () rnf (RBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf RType = () + rnf (RUType x1) = rnf x1 `seq` () rnf (RForce x1) = rnf x1 `seq` () rnf (RConstant x1) = x1 `seq` () @@ -45,9 +55,20 @@ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (UnifyScope x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () + rnf (ElaboratingArg x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (CantInferType x1) = rnf x1 `seq` () + rnf (CantMatch x1) = rnf x1 `seq` () + rnf (ReflectionError x1 x2) = x1 `seq` rnf x2 `seq` () + rnf (ReflectionFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (CantSolveGoal x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (UniqueError x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (UniqueKindError x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (NotEquality x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (NonFunctionType x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (CantIntroduce x1) = rnf x1 `seq` () + rnf (TooManyArguments x1) = rnf x1 `seq` () + rnf (WithFnType x1) = rnf x1 `seq` () rnf (NoSuchVariable x1) = rnf x1 `seq` () rnf (NoTypeDecl x1) = rnf x1 `seq` () rnf (NotInjective x1 x2 x3) @@ -68,9 +89,12 @@ rnf (ProviderError x1) = rnf x1 `seq` () rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData ImplicitInfo where + rnf (Impl x1) = rnf x1 `seq` () + instance (NFData b) => NFData (Binder b) where rnf (Lam x1) = rnf x1 `seq` () - rnf (Pi x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Pi x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (Let x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (NLet x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Hole x1) = rnf x1 `seq` () @@ -89,17 +113,98 @@ rnf (DCon x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (TCon x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData NativeTy where + rnf IT8 = () + rnf IT16 = () + rnf IT32 = () + rnf IT64 = () + +instance NFData IntTy where + rnf (ITFixed x1) = rnf x1 `seq` () + rnf ITNative = () + rnf ITBig = () + rnf ITChar = () + rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance NFData ArithTy where + rnf (ATInt x1) = rnf x1 `seq` () + rnf ATFloat = () + +instance NFData Const where + rnf (I x1) = rnf x1 `seq` () + rnf (BI x1) = rnf x1 `seq` () + rnf (Fl x1) = rnf x1 `seq` () + rnf (Ch x1) = rnf x1 `seq` () + rnf (Str x1) = rnf x1 `seq` () + rnf (B8 x1) = rnf x1 `seq` () + rnf (B16 x1) = rnf x1 `seq` () + rnf (B32 x1) = rnf x1 `seq` () + rnf (B64 x1) = rnf x1 `seq` () + rnf (B8V x1) = rnf x1 `seq` () + rnf (B16V x1) = rnf x1 `seq` () + rnf (B32V x1) = rnf x1 `seq` () + rnf (B64V x1) = rnf x1 `seq` () + rnf (AType x1) = rnf x1 `seq` () + rnf StrType = () + rnf PtrType = () + rnf ManagedPtrType = () + rnf BufferType = () + rnf VoidType = () + rnf Forgot = () + instance (NFData n) => NFData (TT n) where rnf (P x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (V x1) = rnf x1 `seq` () rnf (Bind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (App x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (Constant x1) = x1 `seq` () + rnf (Constant x1) = rnf x1 `seq` () rnf (Proj x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Erased = () rnf Impossible = () rnf (TType x1) = rnf x1 `seq` () rnf (UType _) = () + +instance NFData Accessibility where + rnf Public = () + rnf Frozen = () + rnf Hidden = () + + +instance NFData Totality where + rnf (Total x1) = rnf x1 `seq` () + rnf Productive = () + rnf (Partial x1) = rnf x1 `seq` () + rnf Unchecked = () + +instance NFData PReason where + rnf (Other x1) = rnf x1 `seq` () + rnf Itself = () + rnf NotCovering = () + rnf NotPositive = () + rnf (UseUndef x1) = rnf x1 `seq` () + rnf ExternalIO = () + rnf BelieveMe = () + rnf (Mutual x1) = rnf x1 `seq` () + rnf NotProductive = () + +instance NFData MetaInformation where + rnf EmptyMI = () + rnf (DataMI x1) = rnf x1 `seq` () + +instance NFData Def where + rnf (Function x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (TyDecl x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (Operator x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (CaseOp x1 x2 x3 x4 x5 x6) + = rnf x1 `seq` + rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` () + +instance NFData CaseInfo where + rnf (CaseInfo x1 x2) = rnf x1 `seq` rnf x2 `seq` () + +instance NFData CaseDefs where + rnf (CaseDefs x1 x2 x3 x4) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () instance (NFData t) => NFData (SC' t) where rnf (Case _ x1 x2) = rnf x1 `seq` rnf x2 `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 @@ -213,12 +213,26 @@ get_probs = do ES p _ _ <- get return $! (problems (fst p)) +-- Return recently solved names (that is, the names solved since the +-- last call to get_recents) +get_recents :: Elab' aux [Name] +get_recents = do ES (p, a) l prev <- get + put (ES (p { recents = [] }, a) l prev) + return (recents p) + -- get the current goal type goal :: Elab' aux Type goal = do ES p _ _ <- get b <- lift $ goalAtFocus (fst p) return $! (binderTy b) +is_guess :: Elab' aux Bool +is_guess = do ES p _ _ <- get + b <- lift $ goalAtFocus (fst p) + case b of + Guess _ _ -> return True + _ -> return False + -- Get the guess at the current hole, if there is one get_guess :: Elab' aux Type get_guess = do ES p _ _ <- get @@ -254,7 +268,7 @@ isInj ctxt (App f a) = isInj ctxt f isInj ctxt (Constant _) = True isInj ctxt (TType _) = True - isInj ctxt (Bind _ (Pi _ _) sc) = True + isInj ctxt (Bind _ (Pi _ _ _) sc) = True isInj ctxt _ = False -- get instance argument names @@ -262,6 +276,11 @@ get_instances = do ES p _ _ <- get return $! (instances (fst p)) +-- get auto argument names +get_autos :: Elab' aux [(Name, [Name])] +get_autos = do ES p _ _ <- get + return $! (autos (fst p)) + -- given a desired hole name, return a unique hole name unique_hole = unique_hole' False @@ -350,8 +369,8 @@ introTy :: Raw -> Maybe Name -> Elab' aux () introTy ty n = processTactic' (IntroTy ty n) -forall :: Name -> Raw -> Elab' aux () -forall n t = processTactic' (Forall n t) +forall :: Name -> Maybe ImplicitInfo -> Raw -> Elab' aux () +forall n i t = processTactic' (Forall n i t) letbind :: Name -> Raw -> Raw -> Elab' aux () letbind n t v = processTactic' (LetBind n t v) @@ -393,6 +412,34 @@ movelast :: Name -> Elab' aux () movelast n = processTactic' (MoveLast n) +dotterm :: Elab' aux () +dotterm = do ES (p, a) s m <- get + tm <- get_term + case holes p of + [] -> return () + (h : hs) -> + do let outer = findOuter h [] tm + let p' = p { dotted = (h, outer) : dotted p } +-- trace ("DOTTING " ++ show (h, outer) ++ "\n" ++ +-- show tm) $ + put $ ES (p', a) s m + where + findOuter h env (P _ n _) | h == n = env + findOuter h env (Bind n b sc) + = union (foB b) + (findOuter h env (instantiate (P Bound n (binderTy b)) sc)) + where foB (Guess t v) = union (findOuter h env t) (findOuter h (n:env) v) + foB (Let t v) = union (findOuter h env t) (findOuter h env v) + foB b = findOuter h env (binderTy b) + findOuter h env (App f a) + = union (findOuter h env f) (findOuter h env a) + findOuter h env _ = [] + + +get_dotterm :: Elab' aux [(Name, [Name])] +get_dotterm = do ES (p, a) s m <- get + return (dotted p) + -- | Set the zipper in the proof state to point at the current sub term -- (This currently happens automatically, so this will have no effect...) zipHere :: Elab' aux () @@ -416,6 +463,9 @@ instanceArg :: Name -> Elab' aux () instanceArg n = processTactic' (Instance n) +autoArg :: Name -> Elab' aux () +autoArg n = processTactic' (AutoArg n) + setinj :: Name -> Elab' aux () setinj n = processTactic' (SetInjective n) @@ -443,7 +493,9 @@ env <- get_env -- let claims = getArgs ty imps -- claims <- mkClaims (normalise ctxt env ty) imps [] - claims <- mkClaims (finalise ty) imps [] (map fst env) + claims <- mkClaims (finalise ty) + (normalise ctxt env (finalise ty)) + imps [] (map fst env) ES (p, a) s prev <- get -- reverse the claims we made so that args go left to right let n = length (filter not imps) @@ -452,11 +504,12 @@ return $! claims where mkClaims :: Type -- ^ The type of the operation being applied + -> Type -- ^ Normalised version if we need it -> [Bool] -- ^ Whether the arguments are implicit -> [(Name, Name)] -- ^ Accumulator for produced claims -> [Name] -- ^ Hypotheses -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp. - mkClaims (Bind n' (Pi t_in _) sc) (i : is) claims hs = + mkClaims (Bind n' (Pi _ t_in _) sc) (Bind _ _ scn) (i : is) claims hs = do let t = rebind hs t_in n <- getNameFrom (mkMN n') -- when (null claims) (start_unify n) @@ -464,9 +517,11 @@ -- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show (fn, hs)) $ claim n (forget t) when i (movelast n) - mkClaims sc' is ((n', n) : claims) hs - mkClaims t [] claims _ = return $! (reverse claims) - mkClaims _ _ _ _ + mkClaims sc' scn is ((n', n) : claims) hs + -- if we run out of arguments, we need the normalised version... + mkClaims t tn@(Bind _ _ sc) (i : is) cs hs = mkClaims tn tn (i : is) cs hs + mkClaims t _ [] claims _ = return $! (reverse claims) + mkClaims _ _ _ _ _ | Var n <- fn = do ctxt <- get_context case lookupTy n ctxt of @@ -564,7 +619,7 @@ priOrder _ Nothing = GT priOrder (Just (x, _)) (Just (y, _)) = compare x y - doClaims (Bind n' (Pi t _) sc) (i : is) claims = + doClaims (Bind n' (Pi _ t _) sc) (i : is) claims = do n <- unique_hole (mkMN n') when (null claims) (start_unify n) let sc' = instantiate (P Bound n t) sc @@ -599,13 +654,13 @@ checkPiGoal n = do g <- goal case g of - Bind _ (Pi _ _) _ -> return () + Bind _ (Pi _ _ _) _ -> return () _ -> do a <- getNameFrom (sMN 0 "pargTy") b <- getNameFrom (sMN 0 "pretTy") f <- getNameFrom (sMN 0 "pf") claim a RType claim b RType - claim f (RBind n (Pi (Var a) RType) (Var b)) + claim f (RBind n (Pi Nothing (Var a) RType) (Var b)) movelast a movelast b fill (Var f) @@ -620,7 +675,7 @@ s <- getNameFrom (sMN 0 "s") claim a RType claim b RType - claim f (RBind (sMN 0 "aX") (Pi (Var a) RType) (Var b)) + claim f (RBind (sMN 0 "aX") (Pi Nothing (Var a) RType) (Var b)) tm <- get_term start_unify s claim s (Var a) @@ -643,11 +698,11 @@ -- Abstract over an argument of unknown type, giving a name for the hole -- which we'll fill with the argument type too. -arg :: Name -> Name -> Elab' aux () -arg n tyhole = do ty <- unique_hole tyhole - claim ty RType - movelast ty - forall n (Var ty) +arg :: Name -> Maybe ImplicitInfo -> Name -> Elab' aux () +arg n i tyhole = do ty <- unique_hole tyhole + claim ty RType + movelast ty + forall n i (Var ty) -- try a tactic, if it adds any unification problem, return an error no_errors :: Elab' aux () -> Maybe Err -> Elab' aux () @@ -665,7 +720,7 @@ ps' <- get_probs if (length ps' > length ps) then case reverse ps' of - ((x, y, env, inerr, while, _) : _) -> + ((x, y, _, env, inerr, while, _) : _) -> let env' = map (\(x, b) -> (x, binderTy b)) env in lift $ tfail $ case err of @@ -712,6 +767,7 @@ = -- traceWhen r (show err) $ r || proofSearch recoverableErr (CantSolveGoal _ _) = False + recoverableErr (CantResolveAlts _) = False recoverableErr (ProofSearchFail (Msg _)) = True recoverableErr (ProofSearchFail _) = False recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e @@ -722,9 +778,10 @@ tryWhen True a b = try a b tryWhen False a b = a - --- Try a selection of tactics. Exactly one must work, all others must fail +-- Bool says whether it's okay to create new unification problems. If set +-- to False, then the whole tactic fails if there are any new problems tryAll :: [(Elab' aux a, Name)] -> Elab' aux a +tryAll [(x, _)] = x tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs where cantResolve :: Elab' aux a @@ -743,10 +800,10 @@ ps <- get_probs case prunStateT pmax True ps x s of 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 + 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 tryAll' cs pmax (better err f) xs @@ -762,9 +819,9 @@ -> Bool -> [a] -> Control.Monad.State.Strict.StateT - (ElabState t) (TC' Err) t1 + (ElabState t) TC t1 -> ElabState t - -> TC' Err ((t1, Int, Idris.Core.Unify.Fails), ElabState t) + -> TC ((t1, Int, Idris.Core.Unify.Fails), ElabState t) prunStateT pmax zok ps x s = case runStateT x s of OK (v, s'@(ES (p, _) _ _)) -> @@ -772,12 +829,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 + ((_,_,_,_,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 @@ -8,10 +8,10 @@ Context, initContext, ctxtAlist, uconstraints, next_tvar, addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl, addDatatype, addCasedef, simplifyCasedef, addOperator, - lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, + lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal, mapDefCtxt, - lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName, + lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, isTConName, isConName, isFnName, Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions, isUniverse) where @@ -25,7 +25,8 @@ import Idris.Core.CaseTree data EvalState = ES { limited :: [(Name, Int)], - nexthole :: Int } + nexthole :: Int, + blocking :: Bool } deriving Show type Eval a = State EvalState a @@ -37,7 +38,7 @@ | RunTT deriving (Show, Eq) -initEval = ES [] 0 +initEval = ES [] 0 False -- VALUES (as HOAS) --------------------------------------------------------- -- | A HOAS representation of values @@ -91,7 +92,7 @@ -- Return a specialised name, and an updated list of reductions available, -- so that the caller can tell how much specialisation was achieved. -specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> +specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> (TT Name, [(Name, Int)]) specialise ctxt env limits t = let (tm, st) = @@ -161,11 +162,12 @@ -- usable _ _ ns@((MN 0 "STOP", _) : _) = return (False, ns) usable False n [] = return (True, []) usable True n ns - = do ES ls num <- get - case lookup n ls of - Just 0 -> return (False, ns) - Just i -> return (True, ns) - _ -> return (False, ns) + = do ES ls num b <- get + if b then return (False, ns) + else case lookup n ls of + Just 0 -> return (False, ns) + Just i -> return (True, ns) + _ -> return (False, ns) usable False n ns = case lookup n ns of Just 0 -> return (False, ns) @@ -174,13 +176,17 @@ fnCount :: Int -> Name -> Eval () -fnCount inc n - = do ES ls num <- get +fnCount inc n + = do ES ls num b <- get case lookup n ls of Just i -> do put $ ES ((n, (i - inc)) : - filter (\ (n', _) -> n/=n') ls) num + filter (\ (n', _) -> n/=n') ls) num b _ -> return () +setBlock :: Bool -> Eval () +setBlock b = do ES ls num _ <- get + put (ES ls num b) + deduct = fnCount 1 reinstate = fnCount (-1) @@ -249,7 +255,7 @@ ev ntimes stk top env (V i) | i < length env && i >= 0 = return $ snd (env !! i) | otherwise = return $ VV i - ev ntimes stk top env (Bind n (Let t v) sc) + ev ntimes stk top env (Bind n (Let t v) sc) | not runtime || occurrences n sc < 2 = do v' <- ev ntimes stk top env v --(finalise v) sc' <- ev ntimes stk top ((n, v') : env) sc @@ -277,17 +283,19 @@ 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 + 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 + when spec $ setBlock True 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 + when spec $ setBlock False 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) @@ -303,7 +311,7 @@ t' <- ev ntimes stk top env t -- tfull' <- reapply ntimes stk top env t' [] return (doProj t' (getValArgs t')) - where doProj t' (VP (DCon _ _ _) _ _, args) + where doProj t' (VP (DCon _ _ _) _ _, args) | i >= 0 && i < length args = args!!i doProj t' _ = VProj t' i @@ -330,7 +338,7 @@ _ -> case args of (a : as) -> return $ unload env f (a : as) [] -> return f - reapply ntimes stk top env (VApp f a) args + reapply ntimes stk top env (VApp f a) args = reapply ntimes stk top env f (a : args) reapply ntimes stk top env v args = return v @@ -348,7 +356,7 @@ do let val = lookupDefAcc n (spec || atRepl) ctxt case val of [(CaseOp ci _ _ _ _ cd, acc)] - | acc /= Frozen || sUN "assert_total" `elem` stk -> + | acc /= Frozen || sUN "assert_total" `elem` stk -> -- unoptimised version let (ns, tree) = getCases cd in if blockSimplify ci n stk @@ -394,7 +402,7 @@ t <- evTree ntimes stk top env (zip ns args') tree when spec $ case t of Nothing -> reinstate n -- Blocked, count n again - Just _ -> return () + Just _ -> return () -- (zipWith (\n , t) -> (n, t)) ns args') tree return (t, rest) | otherwise = return (Nothing, args) @@ -408,7 +416,7 @@ (amap ++ env) etm return $ Just etm' evTree ntimes stk top env amap (ProjCase t alts) - = do t' <- ev ntimes stk top env t + = do t' <- ev ntimes stk top env t doCase ntimes stk top env amap t' alts evTree ntimes stk top env amap (Case _ n alts) = case lookup n amap of @@ -451,7 +459,7 @@ | Just v <- findDefault alts = return $ Just (amap, v) chooseAlt env _ (VP _ n _, args) alts amap | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc) - chooseAlt env _ (VBind _ _ (Pi s k) t, []) alts amap + chooseAlt env _ (VBind _ _ (Pi i s k) t, []) alts amap | Just (ns, sc) <- findFn (sUN "->") alts = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern return $ Just (updateAmap (zip ns [s, t']) amap, sc) @@ -563,9 +571,9 @@ convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, []) -convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool +convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs TC Bool convEq ctxt holes topx topy = ceq [] topx topy where - ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool + ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC 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 @@ -583,10 +591,10 @@ ceq ps x (Bind n (PVTy t) sc) = ceq ps x sc ceq ps (V x) (V y) = return (x == y) - ceq ps (V x) (P _ y _) + ceq ps (V x) (P _ y _) | x >= 0 && length ps > x = return (fst (ps!!x) == y) | otherwise = return False - ceq ps (P _ x _) (V y) + ceq ps (P _ x _) (V y) | y >= 0 && length ps > y = return (x == snd (ps!!y)) | otherwise = return False ceq ps (Bind n xb xs) (Bind n' yb ys) @@ -594,7 +602,7 @@ where ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') - ceqB ps (Pi v t) (Pi v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') + ceqB ps (Pi i v t) (Pi i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t') ceqB ps b b' = ceq ps (binderTy b) (binderTy b') ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) ceq ps (Constant x) (Constant y) = return (x == y) @@ -684,6 +692,15 @@ {-! deriving instance Binary CaseDefs !-} +{-! +deriving instance NFData Def +!-} +{-! +deriving instance NFData CaseInfo +!-} +{-! +deriving instance NFData CaseDefs +!-} instance Show Def where show (Function ty tm) = "Function: " ++ show (ty, tm) @@ -709,6 +726,9 @@ data Accessibility = Public | Frozen | Hidden deriving (Show, Eq) +{-! +deriving instance NFData Accessibility +!-} -- | The result of totality checking data Totality = Total [Int] -- ^ well-founded arguments @@ -716,11 +736,17 @@ | Partial PReason | Unchecked deriving Eq +{-! +deriving instance NFData Totality +!-} -- | Reasons why a function may not be total data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name | ExternalIO | BelieveMe | Mutual [Name] | NotProductive deriving (Show, Eq) +{-! +deriving instance NFData PReason +!-} instance Show Totality where show (Total args)= "Total" -- ++ show args ++ " decreasing arguments" @@ -825,8 +851,12 @@ (TyDecl (DCon tag (arity ty') unique) ty, Public, Unchecked, EmptyMI) ctxt) -- FIXME: Too many arguments! Refactor all these Bools. +-- +-- Issue #1724 on the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1724 addCasedef :: Name -> ErasureInfo -> CaseInfo -> - Bool -> Bool -> Bool -> Bool -> + Bool -> SC -> -- default case + Bool -> Bool -> [Type] -> -- argument types [Int] -> -- inaccessible arguments [Either Term (Term, Term)] -> @@ -872,7 +902,7 @@ [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] -> let ps_in' = map simpl ps_in pdef = map debind ps_in' in - case simpleCase False True False CompileTime emptyFC [] atys pdef ei of + case simpleCase False (STerm Erased) False CompileTime emptyFC [] atys pdef ei of OK (CaseDef args sc _) -> addDef n (CaseOp ci ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }), @@ -959,9 +989,18 @@ Just (CaseOp _ _ _ _ _ _, _, _, _) -> True _ -> False +isTCDict :: Name -> Context -> Bool +isTCDict n ctxt + = let def = lookupCtxtExact n (definitions ctxt) in + case def of + Just (Function _ _, _, _, _) -> False + Just (Operator _ _ _, _, _, _) -> False + Just (CaseOp ci _ _ _ _ _, _, _, _) -> tc_dictionary ci + _ -> False + lookupP :: Name -> Context -> [Term] lookupP n ctxt - = do def <- lookupCtxt n (definitions ctxt) + = do def <- lookupCtxt n (definitions ctxt) p <- case def of (Function ty tm, a, _, _) -> return (P Ref n ty, a) (TyDecl nt ty, a, _, _) -> return (P nt n ty, a) 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 @@ -22,7 +22,7 @@ import Control.Exception import Control.Monad.Trans import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Error +import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad hiding (forM) import Data.Maybe import Data.Bits @@ -88,7 +88,7 @@ b' <- fixBinder b Bind n' b' <$> toTT body' where fixBinder (Lam t) = Lam <$> toTT t - fixBinder (Pi t k) = Pi <$> toTT t <*> toTT k + fixBinder (Pi i t k) = Pi i <$> toTT t <*> toTT k fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2 fixBinder (Hole t) = Hole <$> toTT t @@ -126,10 +126,10 @@ initState = do ist <- getIState return $ ExecState (idris_dynamic_libs ist) [] -type Exec = ErrorT Err (StateT ExecState IO) +type Exec = ExceptT Err (StateT ExecState IO) runExec :: Exec a -> ExecState -> IO (Either Err a) -runExec ex st = fst <$> runStateT (runErrorT ex) st +runExec ex st = fst <$> runStateT (runExceptT ex) st getExecState :: Exec ExecState getExecState = lift get @@ -263,6 +263,13 @@ "The argument to idris_readStr should be a handle, but it was " ++ show handle ++ ". Are all cases covered?" +execApp env ctxt (EP _ fp _) (_:fn:_:rest) + | fp == mkfprim, + Just (FFun "getchar" _ _) <- foreignFromTT fn + = do -- The C API returns an Int which Idris library code + -- converts; thus, we must make an int here. + ch <- execIO $ fmap (ioWrap . EConstant . I . fromEnum) getChar + execApp env ctxt ch rest execApp env ctxt (EP _ fp _) (_:fn:rest) | fp == mkfprim, Just (FFun "idris_time" _ _) <- foreignFromTT fn @@ -525,7 +532,6 @@ call' (Fun _ h) args FPtr = EPtr <$> (execIO $ callFFI h (retPtr retVoid) (prepArgs args)) call' (Fun _ h) args FUnit = do _ <- execIO $ callFFI h retVoid (prepArgs args) return $ EP Ref unitCon EErased --- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other) prepArgs = map prepArg @@ -536,6 +542,8 @@ prepArg (EConstant (B64 i)) = argCLong (fromIntegral i) prepArg (EConstant (Fl f)) = argCDouble (realToFrac f) prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars + -- Issue #1720 on the issue tracker. + -- https://github.com/idris-lang/Idris-dev/issues/1720 prepArg (EConstant (Str s)) = argString s prepArg (EPtr p) = argPtr p prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined 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 @@ -31,16 +31,20 @@ dontunify :: [Name], -- explicitly given by programmer, leave it unified :: (Name, [(Name, Term)]), notunified :: [(Name, Term)], + dotted :: [(Name, [Name])], -- dot pattern holes + environment + -- either hole or something in env must turn up in the 'notunified' list during elaboration solved :: Maybe (Name, Term), problems :: Fails, injective :: [Name], deferred :: [Name], -- names we'll need to define instances :: [Name], -- instance arguments (for type classes) + autos :: [(Name, [Name])], -- unsolved 'auto' implicits with their holes previous :: Maybe ProofState, -- for undo context :: Context, plog :: String, unifylog :: Bool, done :: Bool, + recents :: [Name], while_elaborating :: [FailContext] } @@ -65,7 +69,7 @@ | CheckIn Raw | Intro (Maybe Name) | IntroTy Raw (Maybe Name) - | Forall Name Raw + | Forall Name (Maybe ImplicitInfo) Raw | LetBind Name Raw Raw | ExpandLet Name Term | Rewrite Raw @@ -78,6 +82,7 @@ | Defer [Name] Name | DeferType Name Raw [Name] | Instance Name + | AutoArg Name | SetInjective Name | MoveLast Name | MatchProblems Bool @@ -90,10 +95,12 @@ -- Some utilites on proof and tactic states instance Show ProofState where - show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) - = show nm ++ ": no more goals" - show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) - = let OK g = goal (Just h) tm + show ps | [] <- holes ps + = show (thname ps) ++ ": no more goals" + show ps | (h : hs) <- holes ps + = let tm = pterm ps + nm = thname ps + OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++ showPs wkenv (reverse wkenv) ++ "\n" ++ @@ -115,10 +122,12 @@ showG ps b = showEnv ps (binderTy b) instance Pretty ProofState OutputAnnotation where - pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = - pretty nm <+> colon <+> text " no more goals." - pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) = - let OK g = goal (Just h) tm in + pretty ps | [] <- holes ps = + pretty (thname ps) <+> colon <+> text " no more goals." + pretty ps | (h : hs) <- holes ps = + let tm = pterm ps + OK g = goal (Just h) tm + nm = thname ps in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs <+> prettyPs wkEnv (reverse wkEnv) <+> @@ -141,7 +150,7 @@ holeName i = sMN i "hole" qshow :: Fails -> String -qshow fs = show (map (\ (x, y, _, _, _, t) -> (t, x, y)) fs) +qshow fs = show (map (\ (x, y, hs, _, _, _, t) -> (t, x, y, hs)) fs) match_unify' :: Context -> Env -> TT Name -> TT Name -> StateT TState TC [(Name, TT Name)] @@ -151,10 +160,10 @@ let dont = dontunify ps let inj = injective ps traceWhen (unifylog ps) - ("Matching " ++ show (topx, topy) ++ + ("Matching " ++ show (topx, topy) ++ " in " ++ show env ++ "\nHoles: " ++ show (holes ps) - ++ "\n" + ++ "\n" ++ "\n" ++ show (getProofTerm (pterm ps)) ++ "\n\n" ) $ case match_unify ctxt env topx topy inj (holes ps) while of @@ -165,12 +174,13 @@ return u Error e -> traceWhen (unifylog ps) ("No match " ++ show e) $ - do put (ps { problems = (topx, topy, env, e, while, Match) : + do put (ps { problems = (topx, topy, True, + env, e, while, Match) : problems ps }) return [] -- traceWhen (unifylog ps) -- ("Matched " ++ show (topx, topy) ++ " without " ++ show dont ++ --- "\nSolved: " ++ show u +-- "\nSolved: " ++ show u -- ++ "\nCurrent problems:\n" ++ qshow (problems ps) -- -- ++ show (pterm ps) -- ++ "\n----------") $ @@ -183,7 +193,7 @@ | Just t' <- lookup n ns = do ps <- get let probs = problems ps - put (ps { problems = probs ++ [(t,t',env,Msg "New problem", + put (ps { problems = probs ++ [(t,t',True,env,Msg "New problem", [], Unify)] }) merge acc ns | otherwise = merge ((n, t): acc) ns @@ -203,10 +213,10 @@ "\nHoles: " ++ show (holes ps) ++ "\nInjective: " ++ show (injective ps) ++ "\n") $ - lift $ unify ctxt env topx topy inj (holes ps) + lift $ unify ctxt env topx topy inj (holes ps) (map fst (notunified ps)) while let notu = filter (\ (n, t) -> case t of - P _ _ _ -> False +-- P _ _ _ -> False _ -> n `elem` dont) u traceWhen (unifylog ps) ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++ @@ -222,12 +232,8 @@ -- problem for each. uns <- mergeSolutions env (u' ++ ns) ps <- get - let (ns', probs') = updateProblems (context ps) uns - (fails ++ problems ps) - (injective ps) - (holes ps) - (map fst (notunified ps)) - let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps) + let (ns', probs') = updateProblems ps uns (fails ++ problems ps) + let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps) traceWhen (unifylog ps) ("Now solved: " ++ show ns' ++ "\nNow problems: " ++ qshow (probs' ++ probs_notu)) $ @@ -283,10 +289,10 @@ newProof n ctxt ty = let h = holeName 0 ty' = vToP ty in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty') - (P Bound h ty'))) ty [] (h, []) [] + (P Bound h ty'))) ty [] (h, []) [] [] Nothing [] [] - [] [] - Nothing ctxt "" False False [] + [] [] [] + Nothing ctxt "" False False [] [] type TState = ProofState -- [TacticAction]) type RunTactic = RunTactic' TState @@ -381,6 +387,16 @@ instances = x:is }) return (Bind x (Hole t) sc) +autoArg :: Name -> RunTactic +autoArg n ctxt env (Bind x (Hole t) sc) + = do action (\ps -> case lookup x (autos ps) of + Nothing -> + let hs = holes ps in + ps { holes = (hs \\ [x]) ++ [x], + autos = (x, refsIn t) : autos ps } + Just _ -> ps) + return (Bind x (Hole t) sc) + setinj :: Name -> RunTactic setinj n ctxt env (Bind x b sc) = do action (\ps -> let is = injective ps in @@ -396,7 +412,7 @@ (mkApp (P Ref n ty) (map getP (reverse env')))) where mkTy [] t = t - mkTy ((n,b) : bs) t = Bind n (Pi (binderTy b) (TType (UVar 0))) (mkTy bs t) + mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar 0))) (mkTy bs t) getP (n, b) = P Bound n (binderTy b) @@ -416,7 +432,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 @@ -485,18 +501,27 @@ solve ctxt env (Bind x (Guess ty val) sc) = do ps <- get let (uh, uns) = unified ps - case lookup x (notunified ps) of - Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $ - match_unify' ctxt env tm val - _ -> return [] + dropdots <- + case lookup x (notunified ps) of + Just tm -> -- trace ("NEED MATCH: " ++ show (x, tm, val) ++ "\nIN " ++ show (pterm ps)) $ + do match_unify' ctxt env tm val + return [x] + _ -> return [] action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping hole " ++ show x) $ holes ps \\ [x], solved = Just (x, val), notunified = updateNotunified [(x,val)] (notunified ps), - instances = instances ps \\ [x] }) - let tm' = subst x val sc in + recents = x : recents ps, + instances = instances ps \\ [x], + dotted = dropUnified dropdots (dotted ps) }) + let tm' = subst x val sc in return tm' + where dropUnified ddots [] = [] + dropUnified ddots ((x, es) : ds) + | x `elem` ddots || any (\e -> e `elem` ddots) es + = dropUnified ddots ds + | otherwise = (x, es) : dropUnified ddots ds solve _ _ h@(Bind x t sc) = do ps <- get case findType x sc of @@ -504,7 +529,7 @@ _ -> lift $ tfail (IncompleteTerm h) where findType x (Bind n (Let t v) sc) = findType x v `mplus` findType x sc - findType x (Bind n t sc) + findType x (Bind n t sc) | P _ x' _ <- binderTy t, x == x' = Just n | otherwise = findType x sc findType x _ = Nothing @@ -515,17 +540,17 @@ Just name -> name Nothing -> x let t' = case t of - x@(Bind y (Pi s _) _) -> x + x@(Bind y (Pi _ s _) _) -> x _ -> hnf ctxt env t (tyv, tyt) <- lift $ check ctxt env ty -- ns <- lift $ unify ctxt env tyv t' case t' of - Bind y (Pi s _) t -> let t' = subst y (P Bound n s) t in - do ns <- unify' ctxt env s tyv - ps <- get - let (uh, uns) = unified ps --- put (ps { unified = (uh, uns ++ ns) }) - return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) + Bind y (Pi _ s _) t -> let t' = subst y (P Bound n s) t in + do ns <- unify' ctxt env s tyv + ps <- get + let (uh, uns) = unified ps +-- put (ps { unified = (uh, uns ++ ns) }) + return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' introTy ty n ctxt env _ = fail "Can't introduce here." @@ -535,31 +560,32 @@ Just name -> name Nothing -> x let t' = case t of - x@(Bind y (Pi s _) _) -> x + x@(Bind y (Pi _ s _) _) -> x _ -> hnf ctxt env t case t' of - Bind y (Pi s _) t -> -- trace ("in type " ++ show t') $ + Bind y (Pi _ s _) t -> -- trace ("in type " ++ show t') $ let t' = subst y (P Bound n s) t in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) _ -> lift $ tfail $ CantIntroduce t' intro n ctxt env _ = fail "Can't introduce here." -forall :: Name -> Raw -> RunTactic -forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = +forall :: Name -> Maybe ImplicitInfo -> Raw -> RunTactic +forall n impl ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty unify' ctxt env tyt (TType (UVar 0)) unify' ctxt env t (TType (UVar 0)) - return $ Bind n (Pi tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t)) -forall n ty ctxt env _ = fail "Can't pi bind here" + return $ Bind n (Pi impl tyv (TType (UVar 0))) (Bind x (Hole t) (P Bound x t)) +forall n impl ty ctxt env _ = fail "Can't pi bind here" patvar :: Name -> RunTactic -patvar n ctxt env (Bind x (Hole t) sc) = +patvar n ctxt env (Bind x (Hole t) sc) = do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $ holes ps \\ [x], solved = Just (x, P Bound n t), notunified = updateNotunified [(x,P Bound n t)] (notunified ps), - injective = addInj n x (injective 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 @@ -590,7 +616,7 @@ [lt, l, r, p, tmv, xp])) (scv, sct) <- lift $ check ctxt env sc return scv - _ -> lift $ tfail (NotEquality tmv tmt') + _ -> lift $ tfail (NotEquality tmv tmt') where rname = sMN 0 "replaced" rewrite _ _ _ _ = fail "Can't rewrite here" @@ -647,7 +673,8 @@ consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs) let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0))) (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv]))) - action (\ps -> ps {holes = holes ps \\ [x]}) + action (\ps -> ps {holes = holes ps \\ [x], + recents = x : recents ps }) mapM_ addConsHole (reverse consargs') let res' = forget $ res (scv, sct) <- lift $ check ctxt env res' @@ -739,7 +766,8 @@ let (_, ns) = unified ps let unify = dropGiven (dontunify ps) ns (holes ps) action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping holes " ++ show (map fst unify)) $ - holes ps \\ map fst unify }) + holes ps \\ map fst unify, + recents = recents ps ++ map fst unify }) action (\ps -> ps { pterm = updateSolved unify (pterm ps) }) return (updateSolvedTerm unify tm) @@ -764,12 +792,13 @@ updateEnv [] e = e updateEnv ns [] = [] -updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env +updateEnv ns ((n, b) : env) + = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env updateError [] err = err updateError ns (At f e) = At f (updateError ns e) updateError ns (Elaborating s n e) = Elaborating s n (updateError ns e) -updateError ns (ElaboratingArg f a env e) +updateError ns (ElaboratingArg f a env e) = ElaboratingArg f a env (updateError ns e) updateError ns (CantUnify b l r e xs sc) = CantUnify b (updateSolvedTerm ns l) (updateSolvedTerm ns r) (updateError ns e) xs sc @@ -777,16 +806,16 @@ solveInProblems x val [] = [] solveInProblems x val ((l, r, env, err) : ps) - = ((psubst x val l, psubst x val r, + = ((psubst x val l, psubst x val r, updateEnv [(x, val)] env, err) : solveInProblems x val ps) -mergeNotunified :: Env -> [(Name, Term)] -> ([(Name, Term)], Fails) -mergeNotunified env ns = mnu ns [] [] where +mergeNotunified :: Env -> [Name] -> [(Name, Term)] -> ([(Name, Term)], Fails) +mergeNotunified env holes ns = mnu ns [] [] where mnu [] ns_acc ps_acc = (reverse ns_acc, reverse ps_acc) mnu ((n, t):ns) ns_acc ps_acc | Just t' <- lookup n ns, t /= t' - = mnu ns ((n,t') : ns_acc) - ((t,t',env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc) + = mnu ns ((n,t') : ns_acc) + ((t,t',True, env,CantUnify True t t' (Msg "") [] 0, [],Match) : ps_acc) | otherwise = mnu ns ((n,t) : ns_acc) ps_acc updateNotunified [] nu = nu @@ -795,40 +824,53 @@ up ((n, t) : nus) = let t' = updateSolvedTerm ns t in ((n, t') : up nus) --- FIXME: Why not just pass the whole proof state? -updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name] -> [Name] - -> ([(Name, TT Name)], Fails) +updateProblems :: ProofState -> [(Name, TT Name)] -> Fails + -> ([(Name, TT Name)], Fails) -- updateProblems ctxt [] ps inj holes = ([], ps) -updateProblems ctxt ns ps inj holes usupp = up ns ps where +updateProblems ps updates probs = up updates probs where + hs = holes ps + inj = injective ps + ctxt = context ps + usupp = map fst (notunified ps) + up ns [] = (ns, []) - up ns ((x, y, env, err, while, um) : ps) = - let x' = updateSolvedTerm ns x - y' = updateSolvedTerm ns y + up ns (prob@(x, y, ready, env, err, while, um) : ps) = + let (x', newx) = updateSolvedTerm' ns x + (y', newy) = updateSolvedTerm' ns y err' = updateError ns err env' = updateEnv ns env in --- trace ("Updating " ++ show (x',y')) $ - case unify ctxt env' x' y' inj holes usupp while of - OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $ + if newx || newy || ready || + any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then + case unify ctxt env' x' y' inj hs usupp while of + OK (v, []) -> -- trace ("DID " ++ show (x',y',ready,v)) $ up (ns ++ v) ps - e -> -- trace ("Failed " ++ show e) $ - let (ns', ps') = up ns ps in - (ns', (x',y',env',err', while, um) : ps') + e -> -- trace ("FAILED " ++ show (x',y',ready,e)) $ + let (ns', ps') = up ns ps in + (ns', (x',y', False, env',err', while, um) : ps') + else -- trace ("SKIPPING " ++ show (x,y,ready)) $ + let (ns', ps') = up ns ps in + (ns', (x',y', False, env',err', while, um) : ps') -- attempt to solve remaining problems with match_unify --- matchProblems :: Bool -> Elab' aux () -matchProblems all ns ctxt ps inj holes = up ns ps where +matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails + -> ([(Name, TT Name)], Fails) +matchProblems all ps updates probs = up updates probs where + hs = holes ps + inj = injective ps + ctxt = context ps + up ns [] = (ns, []) - up ns ((x, y, env, err, while, um) : ps) + up ns ((x, y, ready, env, err, while, um) : ps) | all || um == Match = let x' = updateSolvedTerm ns x y' = updateSolvedTerm ns y err' = updateError ns err env' = updateEnv ns env in - case match_unify ctxt env' x' y' inj holes while of + case match_unify ctxt env' x' y' inj hs 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', while, um) : ps') + (ns', (x', y', True, env', err', while, um) : ps') up ns (p : ps) = let (ns', ps') = up ns ps in (ns', p : ps') @@ -847,55 +889,47 @@ = let (h, ns_in) = unified ps ns = dropGiven (dontunify ps) ns_in (holes ps) ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns - (ns'', probs') = updateProblems (context ps) ns' (problems ps) - (injective ps) (holes ps) - (map fst (notunified ps)) + (ns'', probs') = updateProblems ps ns' (problems ps) tm' = updateSolved ns'' (pterm ps) in - traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $ - return (ps { pterm = tm', - unified = (h, []), - problems = probs', - notunified = updateNotunified ns'' (notunified ps), - holes = holes ps \\ map fst ns'' }, "") + traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $ + return (ps { pterm = tm', + unified = (h, []), + problems = probs', + notunified = updateNotunified ns'' (notunified ps), + recents = recents ps ++ map fst ns'', + holes = holes ps \\ map fst ns'' }, "") processTactic UnifyAll ps = let tm' = updateSolved (notunified ps) (pterm ps) in return (ps { pterm = tm', notunified = [], + recents = recents ps ++ map fst (notunified ps), holes = holes ps \\ map fst (notunified ps) }, "") processTactic (Reorder n) ps = do ps' <- execStateT (tactic (Just n) reorder_claims) ps return (ps' { previous = Just ps, plog = "" }, plog ps') processTactic (ComputeLet n) ps = return (ps { pterm = mkProofTerm $ - computeLet (context ps) n + computeLet (context ps) n (getProofTerm (pterm ps)) }, "") processTactic UnifyProblems ps - = let (ns', probs') = updateProblems (context ps) [] - (problems ps) - (injective ps) - (holes ps) - (map fst (notunified ps)) - pterm' = updateSolved ns' (pterm ps) in - traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $ - 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) + = do let (ns', probs') = updateProblems ps [] (problems ps) + pterm' = updateSolved ns' (pterm ps) + traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $ + return (ps { pterm = pterm', solved = Nothing, problems = probs', + previous = Just ps, plog = "", + notunified = updateNotunified ns' (notunified ps), + recents = recents ps ++ map fst ns', + holes = holes ps \\ (map fst ns') }, plog ps) 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 - traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $ - 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) + = do let (ns', probs') = matchProblems all ps [] (problems ps) + (ns'', probs'') = matchProblems all ps ns' probs' + pterm' = updateSolved ns'' (pterm ps) + traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $ + return (ps { pterm = pterm', solved = Nothing, problems = probs'', + previous = Just ps, plog = "", + notunified = updateNotunified ns'' (notunified ps), + recents = recents ps ++ map fst ns'', + holes = holes ps \\ (map fst ns'') }, plog ps) processTactic t ps = case holes ps of [] -> fail "Nothing to fill in." @@ -904,11 +938,7 @@ = case solved ps' of Just s -> traceWhen (unifylog ps') ("SOLVED " ++ show s) $ - updateProblems (context ps') - [s] (problems ps') - (injective ps') - (holes ps') - (map fst (notunified ps)) + updateProblems ps [s] (problems ps') _ -> ([], problems ps') -- rechecking problems may find more solutions, so -- apply them here @@ -919,6 +949,7 @@ problems = probs', notunified = updateNotunified ns' (notunified ps'), previous = Just ps, plog = "", + recents = recents ps' ++ map fst ns', holes = holes ps' \\ (map fst ns')}, plog ps') process :: Tactic -> Name -> StateT TState TC () @@ -942,7 +973,7 @@ mktac HNF_Compute = hnf_compute mktac (Intro n) = intro n mktac (IntroTy ty n) = introTy ty n - mktac (Forall n t) = forall n t + mktac (Forall n i t) = forall n i t mktac (LetBind n t v) = letbind n t v mktac (ExpandLet n b) = expandLet n b mktac (Rewrite t) = rewrite t @@ -957,5 +988,6 @@ mktac (Defer ns n) = defer ns n mktac (DeferType n t a) = deferType n t a mktac (Instance n) = instanceArg n + mktac (AutoArg n) = autoArg n mktac (SetInjective n) = setinj n mktac (MoveLast n) = movelast n diff --git a/src/Idris/Core/ProofTerm.hs b/src/Idris/Core/ProofTerm.hs --- a/src/Idris/Core/ProofTerm.hs +++ b/src/Idris/Core/ProofTerm.hs @@ -5,7 +5,7 @@ evaluation/checking inside the proof system, etc. --} module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm, - updateSolved, updateSolvedTerm, + updateSolved, updateSolvedTerm, updateSolvedTerm', bound_in, bound_in_term, refocus, Hole, RunTactic', goal, atHole) where @@ -124,13 +124,15 @@ hole _ = False updateSolvedTerm :: [(Name, Term)] -> Term -> Term -updateSolvedTerm [] x = x -updateSolvedTerm xs x = -- updateSolved' xs x where +updateSolvedTerm xs x = fst $ updateSolvedTerm' xs x + +updateSolvedTerm' [] x = (x, False) +updateSolvedTerm' xs x = -- updateSolved' xs x where -- This version below saves allocations, because it doesn't need to reallocate -- the term if there are no updates to do. -- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is -- the wrong combinator. Feel free to tidy up as long as it's still as cheap :). - fst $ updateSolved' xs x where + updateSolved' xs x where updateSolved' [] x = (x, False) updateSolved' xs (Bind n (Hole ty) t) | Just v <- lookup n xs @@ -180,8 +182,8 @@ updateSolvedPath [] t = t updateSolvedPath ns Top = Top -updateSolvedPath ns (AppL p r) = AppL p (updateSolvedTerm ns r) -updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) p +updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r) +updateSolvedPath ns (AppR l p) = AppR (updateSolvedTerm ns l) (updateSolvedPath ns p) updateSolvedPath ns (InBind n b sc) = InBind n (updateSolvedPathB b) (updateSolvedTerm ns sc) where diff --git a/src/Idris/Core/TC.hs b/src/Idris/Core/TC.hs deleted file mode 100644 --- a/src/Idris/Core/TC.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - -module Idris.Core.TC(TC'(..)) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.Error(Error(..)) - -data TC' e a = OK !a - | Error e - deriving (Eq, Functor) - -bindTC :: TC' e a -> (a -> TC' e b) -> TC' e b -bindTC x k = case x of - OK v -> k v - Error e -> Error e -{-# INLINE bindTC #-} - -instance Error e => Monad (TC' e) where - return x = OK x - x >>= k = bindTC x k - fail e = Error (strMsg e) - -instance Error e => MonadPlus (TC' e) where - mzero = fail "Unknown error" - (OK x) `mplus` _ = OK x - _ `mplus` (OK y) = OK y - err `mplus` _ = err - - -instance Error e => Applicative (TC' e) where - pure = return - (<*>) = ap - -instance Error e => Alternative (TC' e) where - empty = mzero - (<|>) = mplus 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, DeriveFunctor, DeriveDataTypeable #-} {-| TT is the core language of Idris. The language has: @@ -18,15 +18,16 @@ programs with implicit syntax into fully explicit terms. -} -module Idris.Core.TT(module Idris.Core.TT, module Idris.Core.TC) where - -import Idris.Core.TC +module Idris.Core.TT where +import Control.Applicative (Applicative (..), Alternative) +import qualified Control.Applicative as A (Alternative (..)) import Control.Monad.State.Strict -import Control.Monad.Trans.Error (Error(..)) +import Control.Monad.Trans.Except (Except (..)) import Debug.Trace import qualified Data.Map.Strict as Map import Data.Char +import Data.Data (Data) import Numeric (showIntAtBase) import qualified Data.Text as T import Data.List hiding (insert) @@ -34,6 +35,7 @@ import Data.Maybe (listToMaybe) import Data.Foldable (Foldable) import Data.Traversable (Traversable) +import Data.Typeable (Typeable) import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import qualified Data.Binary as B @@ -51,6 +53,7 @@ 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 } + deriving (Data, Typeable) -- | Ignore source location equality (so deriving classes do not compare FCs) instance Eq FC where @@ -111,7 +114,7 @@ | NamePart Name | TermPart Term | SubReport [ErrorReportPart] - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) -- Please remember to keep Err synchronised with @@ -136,6 +139,7 @@ | TooManyArguments Name | CantIntroduce t | NoSuchVariable Name + | WithFnType t | NoTypeDecl Name | NotInjective t t t | CantResolve t @@ -146,6 +150,7 @@ | UniqueKindError Universe Name | ProgramLineComment | Inaccessible Name + | CantMatch t | NonCollapsiblePostulate Name | AlreadyDefined Name | ProofSearchFail (Err' t) @@ -157,10 +162,40 @@ | LoadingFailed String (Err' t) | ReflectionError [[ErrorReportPart]] (Err' t) | ReflectionFailed String (Err' t) - deriving (Eq, Functor) + deriving (Eq, Functor, Data, Typeable) type Err = Err' Term +data TC a = OK !a + | Error Err + deriving (Eq, Functor) + +bindTC :: TC a -> (a -> TC b) -> TC b +bindTC x k = case x of + OK v -> k v + Error e -> Error e +{-# INLINE bindTC #-} + +instance Monad TC where + return x = OK x + x >>= k = bindTC x k + fail e = Error (InternalMsg e) + +instance MonadPlus TC where + mzero = fail "Unknown error" + (OK x) `mplus` _ = OK x + _ `mplus` (OK y) = OK y + err `mplus` _ = err + + +instance Applicative TC where + pure = return + (<*>) = ap + +instance Alternative TC where + empty = mzero + (<|>) = mplus + {-! deriving instance NFData Err !-} @@ -209,7 +244,7 @@ instance Show Err where show (Msg s) = s show (InternalMsg s) = "Internal error: " ++ show s - show (CantUnify rec l r e sc i) = "CantUnify " ++ show rec ++ " " ++ + show (CantUnify rcv l r e sc i) = "CantUnify " ++ show rcv ++ " " ++ show l ++ " " ++ show r ++ " " ++ show e ++ " in " ++ show sc ++ " " ++ show i show (CantSolveGoal g _) = "CantSolve " ++ show g @@ -233,11 +268,6 @@ pretty err@(LoadingFailed _ _) = text (show err) pretty _ = text "Error" -instance Error Err where - strMsg = InternalMsg - -type TC = TC' Err - instance (Pretty a OutputAnnotation) => Pretty (TC a) OutputAnnotation where pretty (OK ok) = pretty ok pretty (Error err) = @@ -280,7 +310,7 @@ | NErased -- ^ Name of something which is never used in scope | SN SpecialName -- ^ Decorated function names | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation) - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) txt :: String -> T.Text txt = T.pack @@ -317,7 +347,7 @@ | CaseN Name | ElimN Name | InstanceCtorN Name - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary SpecialName deriving instance NFData SpecialName @@ -467,7 +497,7 @@ addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) data NativeTy = IT8 | IT16 | IT32 | IT64 - deriving (Show, Eq, Ord, Enum) + deriving (Show, Eq, Ord, Enum, Data, Typeable) instance Pretty NativeTy OutputAnnotation where pretty IT8 = text "Bits8" @@ -477,7 +507,7 @@ data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar | ITVec NativeTy Int - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Data, Typeable) intTyName :: IntTy -> String intTyName ITNative = "Int" @@ -486,8 +516,8 @@ intTyName (ITChar) = "Char" intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count -data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors - deriving (Show, Eq, Ord) +data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors https://github.com/idris-lang/Idris-dev/issues/1723 + deriving (Show, Eq, Ord, Data, Typeable) {-! deriving instance NFData IntTy deriving instance NFData NativeTy @@ -521,12 +551,21 @@ | B32V (Vector Word32) | B64V (Vector Word64) | AType ArithTy | StrType | PtrType | ManagedPtrType | BufferType | VoidType | Forgot - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) {-! deriving instance Binary Const deriving instance NFData Const !-} +isTypeConst :: Const -> Bool +isTypeConst (AType _) = True +isTypeConst StrType = True +isTypeConst ManagedPtrType = True +isTypeConst BufferType = True +isTypeConst PtrType = True +isTypeConst VoidType = True +isTypeConst _ = False + instance Sized Const where size _ = 1 @@ -603,7 +642,7 @@ constDocs prim = "Undocumented" data Universe = NullType | UniqueType | AllTypes - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) instance Show Universe where show UniqueType = "UniqueType" @@ -617,7 +656,7 @@ | RUType Universe | RForce Raw | RConstant Const - deriving (Show, Eq) + deriving (Show, Eq, Data, Typeable) instance Sized Raw where size (Var name) = 1 @@ -636,6 +675,14 @@ deriving instance NFData Raw !-} +data ImplicitInfo = Impl { tcinstance :: Bool } + deriving (Show, Eq, Ord, Data, Typeable) + +{-! +deriving instance Binary ImplicitInfo +deriving instance NFData ImplicitInfo +!-} + -- The type parameter `b` will normally be something like `TT Name` or just -- `Raw`. We do not make a type-level distinction between TT terms that happen -- to be TT types and TT terms that are not TT types. @@ -643,9 +690,13 @@ -- the types of bindings (and their values, if any); the attached identifiers are part -- of the 'Bind' constructor for the 'TT' type. data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}} - | Pi { binderTy :: !b, + | Pi { binderImpl :: Maybe ImplicitInfo, + binderTy :: !b, binderKind :: !b } - {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ -} + {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@ + The 'binderImpl' flag says whether it was a scoped implicit + (i.e. forall bound) in the high level Idris, but otherwise + has no relevance in TT. -} | Let { binderTy :: !b, binderVal :: b {-^ value for bound variable-}} -- ^ A binding that occurs in a @let@ expression @@ -659,7 +710,7 @@ | PVar { binderTy :: !b } -- ^ A pattern variable | PVTy { binderTy :: !b } - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable) {-! deriving instance Binary Binder deriving instance NFData Binder @@ -667,7 +718,7 @@ instance Sized a => Sized (Binder a) where size (Lam ty) = 1 + size ty - size (Pi ty _) = 1 + size ty + size (Pi _ ty _) = 1 + size ty size (Let ty val) = 1 + size ty + size val size (NLet ty val) = 1 + size ty + size val size (Hole ty) = 1 + size ty @@ -681,7 +732,7 @@ fmapMB f (NLet t v) = liftM2 NLet (f t) (f v) fmapMB f (Guess t v) = liftM2 Guess (f t) (f v) fmapMB f (Lam t) = liftM Lam (f t) -fmapMB f (Pi t k) = liftM2 Pi (f t) (f k) +fmapMB f (Pi i t k) = liftM2 (Pi i) (f t) (f k) fmapMB f (Hole t) = liftM Hole (f t) fmapMB f (GHole i t) = liftM (GHole i) (f t) fmapMB f (PVar t) = liftM PVar (f t) @@ -701,7 +752,7 @@ -- | Universe expressions for universe checking data UExp = UVar Int -- ^ universe variable | UVal Int -- ^ explicit universe level - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) {-! deriving instance NFData UExp !-} @@ -738,7 +789,7 @@ | Ref | DCon {nt_tag :: Int, nt_arity :: Int, nt_unique :: Bool} -- ^ Data constructor | TCon {nt_tag :: Int, nt_arity :: Int} -- ^ Type constructor - deriving (Show, Ord) + deriving (Show, Ord, Data, Typeable) {-! deriving instance Binary NameType deriving instance NFData NameType @@ -773,7 +824,7 @@ | Impossible -- ^ special case for totality checking | TType UExp -- ^ the type of types at some level | UType Universe -- ^ Uniqueness type universe (disjoint from TType) - deriving (Ord, Functor) + deriving (Ord, Functor, Data, Typeable) {-! deriving instance Binary TT deriving instance NFData TT @@ -792,7 +843,7 @@ | otherwise = 1 termsize n (V _) = 1 -- for `Bind` terms, we can erroneously declare a term - -- "recursive => really big" if the name of the bound + -- "recursive => really big" if the name of the bound -- variable is the same as the name we're using -- So generate a different name in that case. termsize n (Bind n' (Let t v) sc) @@ -848,7 +899,7 @@ isInjective (P (TCon _ _) _ _) = True isInjective (Constant _) = True isInjective (TType x) = True -isInjective (Bind _ (Pi _ _) sc) = True +isInjective (Bind _ (Pi _ _ _) sc) = True isInjective (App f a) = isInjective f isInjective _ = False @@ -971,19 +1022,19 @@ subst' i t@(Bind x b sc) | x /= n = let (b', ub) = substB' i b (sc', usc) = subst' (i+1) sc in - if ub || usc then (Bind x b' sc', True) else (t, False) - subst' i t@(App f a) = let (f', uf) = subst' i f + if ub || usc then (Bind x b' sc', True) else (t, False) + subst' i t@(App f a) = let (f', uf) = subst' i f (a', ua) = subst' i a in if uf || ua then (App f' a', True) else (t, False) subst' i t@(Proj x idx) = let (x', u) = subst' i x in if u then (Proj x' idx, u) else (t, False) subst' i t = (t, False) - substB' i b@(Let t v) = let (t', ut) = subst' i t + substB' i b@(Let t v) = let (t', ut) = subst' i t (v', uv) = subst' i v in if ut || uv then (Let t' v', True) else (b, False) - substB' i b@(Guess t v) = let (t', ut) = subst' i t + substB' i b@(Guess t v) = let (t', ut) = subst' i t (v', uv) = subst' i v in if ut || uv then (Guess t' v', True) else (b, False) @@ -1051,17 +1102,19 @@ -- | Returns all names used free in the term freeNames :: Eq n => TT n -> [n] -freeNames (P _ n _) = [n] -freeNames (Bind n (Let t v) sc) = nub $ freeNames v ++ (freeNames sc \\ [n]) - ++ freeNames t -freeNames (Bind n b sc) = nub $ freeNames (binderTy b) ++ (freeNames sc \\ [n]) -freeNames (App f a) = nub $ freeNames f ++ freeNames a -freeNames (Proj x i) = nub $ freeNames x -freeNames _ = [] +freeNames t = nub $ freeNames' t + where + freeNames' (P _ n _) = [n] + freeNames' (Bind n (Let t v) sc) = freeNames' v ++ (freeNames' sc \\ [n]) + ++ freeNames' t + freeNames' (Bind n b sc) = freeNames' (binderTy b) ++ (freeNames' sc \\ [n]) + freeNames' (App f a) = freeNames' f ++ freeNames' a + freeNames' (Proj x i) = freeNames' x + freeNames' _ = [] -- | Return the arity of a (normalised) type arity :: TT n -> Int -arity (Bind n (Pi t _) sc) = 1 + arity sc +arity (Bind n (Pi _ t _) sc) = 1 + arity sc arity _ = 0 -- | Deconstruct an application; returns the function and a list of arguments @@ -1090,7 +1143,7 @@ -- Bruijn indices. forget :: TT Name -> Raw forget tm = forgetEnv [] tm - + forgetEnv :: [Name] -> TT Name -> Raw forgetEnv env (P _ n _) = Var n forgetEnv env (V i) = Var (env !! i) @@ -1119,16 +1172,19 @@ -- | Return a list of pairs of the names of the outermost 'Pi'-bound -- variables in the given term, together with their types. getArgTys :: TT n -> [(n, TT n)] -getArgTys (Bind n (Pi t _) sc) = (n, t) : getArgTys sc +getArgTys (Bind n (PVar _) sc) = getArgTys sc +getArgTys (Bind n (PVTy _) sc) = getArgTys sc +getArgTys (Bind n (Pi _ t _) sc) = (n, t) : getArgTys sc getArgTys _ = [] getRetTy :: TT n -> TT n getRetTy (Bind n (PVar _) sc) = getRetTy sc getRetTy (Bind n (PVTy _) sc) = getRetTy sc -getRetTy (Bind n (Pi _ _) sc) = getRetTy sc +getRetTy (Bind n (Pi _ _ _) sc) = getRetTy sc getRetTy sc = sc uniqueNameFrom :: [Name] -> [Name] -> Name +uniqueNameFrom [] hs = uniqueName (nextName (sUN "x")) hs uniqueNameFrom (s : supply) hs | s `elem` hs = uniqueNameFrom supply hs | otherwise = s @@ -1164,8 +1220,12 @@ where nextName' (WhereN i f x) = WhereN i f (nextName x) nextName' (WithN i n) = WithN i (nextName n) + nextName' (InstanceN n ns) = InstanceN (nextName n) ns + nextName' (ParentN n ns) = ParentN (nextName n) ns nextName' (CaseN n) = CaseN (nextName n) + nextName' (ElimN n) = ElimN (nextName n) nextName' (MethodN n) = MethodN (nextName n) + nextName' (InstanceCtorN n) = InstanceCtorN (nextName n) type Term = TT Name type Type = Term @@ -1237,7 +1297,7 @@ else lbracket <+> text (show i) <+> rbracket | otherwise = text "unbound" <+> text (show i) <+> text "!" - prettySe p env (Bind n b@(Pi t _) sc) debug + prettySe p env (Bind n b@(Pi _ t _) sc) debug | noOccurrence n sc && not debug = bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug prettySe p env (Bind n b sc) debug = @@ -1253,7 +1313,7 @@ -- Render a `Binder` and its name prettySb env n (Lam t) = prettyB env "λ" "=>" n t prettySb env n (Hole t) = prettyB env "?defer" "." n t - prettySb env n (Pi t _) = prettyB env "(" ") ->" n t + prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t prettySb env n (PVar t) = prettyB env "pat" "." n t prettySb env n (PVTy t) = prettyB env "pty" "." n t prettySb env n (Let t v) = prettyBv env "let" "in" n t v @@ -1279,7 +1339,7 @@ = (show $ fst $ env!!i) ++ if dbg then "{" ++ show i ++ "}" else "" | otherwise = "!!V " ++ show i ++ "!!" - se p env (Bind n b@(Pi t k) sc) + se p env (Bind n b@(Pi _ t k) sc) | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc where arrow (TType _) = " -> " arrow u = " [" ++ show u ++ "] -> " @@ -1295,7 +1355,7 @@ sb env n (Lam t) = showb env "\\ " " => " n t sb env n (Hole t) = showb env "? " ". " n t sb env n (GHole i t) = showb env "?defer " ". " n t - sb env n (Pi t _) = showb env "(" ") -> " n t + sb env n (Pi _ t _) = showb env "(" ") -> " n t sb env n (PVar t) = showb env "pat " ". " n t sb env n (PVTy t) = showb env "pty " ". " n t sb env n (Let t v) = showbv env "let " " in " n t v @@ -1355,36 +1415,37 @@ op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc - op ps (Bind n (Pi t k) sc) = op ((n, Pi t k) : ps) sc + op ps (Bind n (Pi i t k) sc) = op ((n, Pi i t k) : ps) sc op ps sc = bindAll (sortP ps) sc sortP ps = pick [] (reverse ps) - namesIn (P _ n _) = [n] - namesIn (Bind n b t) = nub $ nb b ++ (namesIn t \\ [n]) - where nb (Let t v) = nub (namesIn t) ++ nub (namesIn v) - nb (Guess t v) = nub (namesIn t) ++ nub (namesIn v) - nb t = namesIn (binderTy t) - namesIn (App f a) = nub (namesIn f ++ namesIn a) - namesIn _ = [] - pick acc [] = reverse acc pick acc ((n, t) : ps) = pick (insert n t acc) ps insert n t [] = [(n, t)] insert n t ((n',t') : ps) - | n `elem` (namesIn (binderTy t') ++ - concatMap namesIn (map (binderTy . snd) ps)) + | n `elem` (refsIn (binderTy t') ++ + concatMap refsIn (map (binderTy . snd) ps)) = (n', t') : insert n t ps | otherwise = (n,t):(n',t'):ps +refsIn :: TT Name -> [Name] +refsIn (P _ n _) = [n] +refsIn (Bind n b t) = nub $ nb b ++ refsIn t + where nb (Let t v) = nub (refsIn t) ++ nub (refsIn v) + nb (Guess t v) = nub (refsIn t) ++ nub (refsIn v) + nb t = refsIn (binderTy t) +refsIn (App f a) = nub (refsIn f ++ refsIn a) +refsIn _ = [] + -- Make sure all the pattern bindings are as far out as possible liftPats :: Term -> Term liftPats tm = let (tm', ps) = runState (getPats tm) [] in orderPats $ bindPats (reverse ps) tm' where bindPats [] tm = tm - bindPats ((n, t):ps) tm + bindPats ((n, t):ps) tm | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm) | otherwise = bindPats ps tm @@ -1400,10 +1461,10 @@ v' <- getPats v sc' <- getPats sc return (Bind n (Let t' v') sc') - getPats (Bind n (Pi t k) sc) = do t' <- getPats t - k' <- getPats k - sc' <- getPats sc - return (Bind n (Pi t' k') sc') + getPats (Bind n (Pi i t k) sc) = do t' <- getPats t + k' <- getPats k + sc' <- getPats sc + return (Bind n (Pi i t' k') sc') getPats (Bind n (Lam t) sc) = do t' <- getPats t sc' <- getPats sc return (Bind n (Lam t') sc') 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 @@ -53,7 +53,7 @@ recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck = recheck_borrowing False [] -recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term -> +recheck_borrowing :: Bool -> [Name] -> Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck_borrowing uniq_check bs ctxt env tm orig = let v = next_tvar ctxt in @@ -65,7 +65,7 @@ return (tm, ty, constraints) check :: Context -> Env -> Raw -> TC (Term, Type) -check ctxt env tm +check ctxt env tm = evalStateT (check' True ctxt env tm) (0, []) -- Holes allowed check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type) @@ -87,18 +87,18 @@ = do (fv, fty) <- chk u env f (av, aty) <- chk u env a let fty' = case uniqueBinders (map fst env) (finalise fty) of - ty@(Bind x (Pi s k) t) -> ty + ty@(Bind x (Pi i s k) t) -> ty _ -> uniqueBinders (map fst env) $ case hnf ctxt env fty of - ty@(Bind x (Pi s k) t) -> ty + ty@(Bind x (Pi i s k) t) -> ty _ -> normalise ctxt env fty case fty' of - Bind x (Pi s k) t -> + Bind x (Pi i s k) t -> do convertsC ctxt env aty s let apty = simplify initContext env (Bind x (Let aty av) t) return (App fv av, apty) - t -> lift $ tfail $ NonFunctionType fv fty + t -> lift $ tfail $ NonFunctionType fv fty chk u env RType | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get @@ -107,7 +107,9 @@ return (TType (UVar v), TType (UVar (v+1))) chk u env (RUType un) | holes = return (UType un, TType (UVal 0)) - | otherwise = do -- TODO! (v, cs) <- get + | otherwise = do -- TODO! Issue #1715 on the issue tracker. + -- https://github.com/idris-lang/Idris-dev/issues/1715 + -- (v, cs) <- get -- let c = ULT (UVar v) (UVar (v+1)) -- put (v+2, (c:cs)) -- return (TType (UVar v), TType (UVar (v+1))) @@ -131,36 +133,35 @@ constType _ = TType (UVal 0) chk u env (RForce t) = do (_, ty) <- chk u env t return (Erased, ty) - chk u env (RBind n (Pi s k) t) + chk u env (RBind n (Pi i s k) t) = do (sv, st) <- chk u env s (kv, kt) <- chk u env k - (tv, tt) <- chk st ((n, Pi sv kv) : env) t --- let tv = mkUniquePi kv tv_in + (tv, tt) <- chk st ((n, Pi i sv kv) : env) t (v, cs) <- get case (normalise ctxt env st, normalise ctxt env tt) of (TType su, TType tu) -> do when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs) let k' = st `smaller` kv `smaller` TType (UVar v) `smaller` u - return (Bind n (Pi (uniqueBinders (map fst env) sv) k') + return (Bind n (Pi i (uniqueBinders (map fst env) sv) k') (pToV n tv), k') (un, un') -> let k' = st `smaller` kv `smaller` un `smaller` un' `smaller` u in - return (Bind n (Pi (uniqueBinders (map fst env) sv) k') + return (Bind n (Pi i (uniqueBinders (map fst env) sv) k') (pToV n tv), k') - where mkUniquePi kv (Bind n (Pi s k) sc) + where mkUniquePi kv (Bind n (Pi i s k) sc) = let k' = smaller kv k in - Bind n (Pi s k') (mkUniquePi k' sc) - mkUniquePi kv (Bind n (Lam t) sc) + Bind n (Pi i s k') (mkUniquePi k' sc) + mkUniquePi kv (Bind n (Lam t) sc) = Bind n (Lam (mkUniquePi kv t)) (mkUniquePi kv sc) - mkUniquePi kv (Bind n (Let t v) sc) + mkUniquePi kv (Bind n (Let t v) sc) = Bind n (Let (mkUniquePi kv t) v) (mkUniquePi kv sc) mkUniquePi kv t = t -- Kind of the whole thing is the kind of the most unique thing -- in the environment (because uniqueness taints everything...) mostUnique [] k = k - mostUnique (Pi _ pk : es) k = mostUnique es (smaller pk k) + mostUnique (Pi _ _ pk : es) k = mostUnique es (smaller pk k) mostUnique (_ : es) k = mostUnique es k chk u env (RBind n b sc) @@ -229,9 +230,9 @@ return (PVTy tv, tt') discharge n (Lam t) bt scv sct - = return (Bind n (Lam t) scv, Bind n (Pi t bt) sct) - discharge n (Pi t k) bt scv sct - = return (Bind n (Pi t k) scv, sct) + = return (Bind n (Lam t) scv, Bind n (Pi Nothing t bt) sct) + discharge n (Pi i t k) bt scv sct + = return (Bind n (Pi i t k) scv, sct) discharge n (Let t v) bt scv sct = return (Bind n (Let t v) scv, Bind n (Let t v) sct) discharge n (NLet t v) bt scv sct @@ -257,9 +258,9 @@ -- If any binders are of kind 'UniqueType' or 'AllTypes' and the name appears -- in the scope more than once, this is an error. checkUnique :: [Name] -> Context -> Env -> Term -> TC () -checkUnique borrowed ctxt env tm +checkUnique borrowed ctxt env tm = evalStateT (chkBinders env (explicitNames tm)) [] - where + where isVar (P _ _ _) = True isVar (V _) = True isVar _ = False @@ -272,10 +273,10 @@ chkBinders env (App (App (P _ (NS (UN lend) [owner]) _) t) a) | isVar a && owner == txt "Ownership" && (lend == txt "lend" || lend == txt "Read") - = do chkBinders env t -- Check the type normally + = do chkBinders env t -- Check the type normally st <- get -- Remove the 'LendOnly' names from the unusable set - put (filter (\(n, (ok, _)) -> ok /= LendOnly) st) + put (filter (\(n, (ok, _)) -> ok /= LendOnly) st) chkBinders env a put st -- Reset the old state after checking the argument chkBinders env (App f a) = do chkBinders env f; chkBinders env a @@ -288,14 +289,16 @@ chkBinders ((n, b) : env) t chkBinders env t = return () - chkBinderName :: Env -> Name -> Binder Term -> + chkBinderName :: Env -> Name -> Binder Term -> StateT [(Name, (UniqueUse, Universe))] TC () chkBinderName env n b = do let rawty = forgetEnv (map fst env) (binderTy b) (_, kind) <- lift $ check ctxt env rawty -- FIXME: Cache in binder? + -- Issue #1714 on the issue tracker + -- https://github.com/idris-lang/Idris-dev/issues/1714 case kind of UType UniqueType -> do ns <- get - if n `elem` borrowed + if n `elem` borrowed then put ((n, (LendOnly, NullType)) : ns) else put ((n, (Once, UniqueType)) : ns) UType NullType -> do ns <- get @@ -304,13 +307,12 @@ put ((n, (Once, AllTypes)) : ns) _ -> return () - chkName n + chkName n = do ns <- get case lookup n ns of Nothing -> return () Just (Many, k) -> return () Just (Never, k) -> lift $ tfail (UniqueError k n) Just (LendOnly, k) -> lift $ tfail (UniqueError k n) - Just (Once, k) -> put ((n, (Never, k)) : + Just (Once, k) -> put ((n, (Never, k)) : filter (\x -> fst x /= n) ns) - 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 @@ -29,11 +29,13 @@ deriving (Eq, Show) type Injs = [(TT Name, TT Name, TT Name)] -type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)] +type Fails = [(TT Name, TT Name, -- unification error + Bool, -- ready to retry yet + Env, Err, [FailContext], FailAt)] unrecoverable :: Fails -> Bool -unrecoverable = any bad - where bad (_,_,_, err, _, _) = unrec err +unrecoverable = any bad + where bad (_,_,_,_, err, _, _) = unrec err unrec (CantUnify r _ _ _ _ _) = not r unrec (At _ e) = unrec e @@ -64,40 +66,54 @@ 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)) + OK (v, UI _ []) -> + do v' <- trimSolutions topx topy from env v + return (map (renameBinders env) v') res -> let topxn = renameBindersTm env (normalise ctxt env topx) topyn = renameBindersTm env (normalise ctxt env topy) in case runStateT (un [] topxn topyn) - (UI 0 []) of + (UI 0 []) of OK (v, UI _ fails) -> - return (map (renameBinders env) (trimSolutions v)) + do v' <- trimSolutions topx topy from env v + return (map (renameBinders env) v') Error e -> -- just normalise the term we're matching against case runStateT (un [] topxn topy) - (UI 0 []) of + (UI 0 []) of OK (v, UI _ fails) -> - return (map (renameBinders env) (trimSolutions v)) + do v' <- trimSolutions topx topy from env v + return (map (renameBinders env) v') _ -> tfail e where - -- This rule is highly dubious... it certainly produces a valid answer - -- but it scares me. However, matching is never guaranteed to give a unique - -- answer, merely a valid one, so perhaps we're okay. - -- In other words: it may vanish without warning some day :) un :: [((Name, Name), TT Name)] -> TT Name -> TT Name -> StateT UInfo TC [(Name, TT Name)] - un names x tm@(App (P _ f (Bind fn (Pi t _) sc)) a) + -- This rule is highly dubious... it certainly produces a valid answer + -- but it scares me. However, matching is never guaranteed to give a unique + -- answer, merely a valid one, so perhaps we're okay. + -- In other words: it may vanish without warning some day :) + un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) + | (P (TCon _ _) _ _, _) <- unApply x, + holeIn env f || f `elem` holes + = let n' = uniqueName (sMN 0 "mv") (map fst env) in + checkCycle names (f, Bind n' (Lam t) x) + un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x + | (P (TCon _ _) _ _, _) <- unApply x, + holeIn env f || f `elem` holes + = let n' = uniqueName fn (map fst env) in + checkCycle names (f, Bind n' (Lam t) x) + un names x tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes = let n' = uniqueName (sMN 0 "mv") (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) - un names tm@(App (P _ f (Bind fn (Pi t _) sc)) a) x + checkCycle names (f, Bind n' (Lam t) x) + un names tm@(App (P _ f (Bind fn (Pi _ t _) sc)) a) x | (P (DCon _ _ _) _ _, _) <- unApply x, holeIn env f || f `elem` holes = let n' = uniqueName fn (map fst env) in - checkCycle names (f, Bind n' (Lam t) x) + checkCycle names (f, Bind n' (Lam t) x) un names tx@(P _ x _) tm | tx /= tm && holeIn env x || x `elem` holes @@ -106,12 +122,12 @@ | ty /= tm && holeIn env y || y `elem` holes = do sc 1; checkCycle names (y, tm) un bnames (V i) (P _ x _) - | length bnames > i, - fst (fst (bnames!!i)) == x || + | length bnames > i, + fst (fst (bnames!!i)) == x || snd (fst (bnames!!i)) == x = do sc 1; return [] un bnames (P _ x _) (V i) | length bnames > i, - fst (fst (bnames!!i)) == x || + fst (fst (bnames!!i)) == x || snd (fst (bnames!!i)) == x = do sc 1; return [] un bnames (Bind x bx sx) (Bind y by sy) | notHole bx && notHole by = do h1 <- uB bnames bx by @@ -124,12 +140,12 @@ un names x y | OK True <- convEq' ctxt holes x y = do sc 1; return [] | otherwise = do UI s f <- get - let r = recoverable (normalise ctxt env x) + 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, from, Match) : f)) + else do put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err @@ -137,14 +153,16 @@ h2 <- un bnames vx vy combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = un bnames tx ty - uB bnames (Pi tx _) (Pi ty _) = un bnames tx ty + uB bnames (Pi _ tx _) (Pi _ ty _) = un bnames tx ty uB bnames x y = do UI s f <- get - let r = recoverable (normalise ctxt env (binderTy x)) + 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)) + put (UI s ((binderTy x, binderTy y, + False, + env, err, from, Match) : f)) return [] notHole (Hole _) = False @@ -152,16 +170,17 @@ -- TODO: there's an annoying amount of repetition between this and the -- main unification function. Consider lifting it out. + -- Issue #1721 on the issue tracker: https://github.com/idris-lang/Idris-dev/issues/1721 sc i = do UI s f <- get put (UI (s+i) f) unifyFail x y = do UI s f <- get - let r = recoverable (normalise ctxt env x) + 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)) + put (UI s ((x, y, True, env, err, from, Match) : f)) lift $ tfail err combine bnames as [] = return as combine bnames as ((n, t) : bs) @@ -192,23 +211,23 @@ where inst [] tm = tm inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm) - bind i ns 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 (x, t) = (x, renameBindersTm env t) renameBindersTm :: Env -> TT Name -> TT Name renameBindersTm env tm = uniqueBinders (map fst env) tm where uniqueBinders env (Bind n b sc) - | n `elem` env + | n `elem` env = let n' = uniqueName n env in explicitHole $ Bind n' (fmap (uniqueBinders env) b) (uniqueBinders (n':env) (rename n n' sc)) - | otherwise = Bind n (fmap (uniqueBinders (n:env)) b) + | 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 @@ -218,26 +237,34 @@ rename n n' (App f a) = App (rename n n' f) (rename n n' a) rename n n' t = t - explicitHole (Bind n (Hole ty) sc) + explicitHole (Bind n (Hole ty) sc) = Bind n (Hole ty) (instantiate (P Bound n ty) sc) explicitHole t = t -trimSolutions ns = followSols (dropPairs ns) +trimSolutions topx topy from env topns = followSols [] (dropPairs topns) where dropPairs [] = [] dropPairs (n@(x, P _ x' _) : ns) | x == x' = dropPairs ns | otherwise - = n : dropPairs + = n : dropPairs (filter (\t -> case t of (n, P _ n' _) -> not (n == x' && n' == x) _ -> True) ns) dropPairs (n : ns) = n : dropPairs ns - followSols [] = [] - followSols ((n, P _ t _) : ns) + followSols vs [] = return [] + followSols vs ((n, P _ t _) : ns) | Just t' <- lookup t ns - = followSols ((n, t') : ns) -- Are we guaranteed no cycles? - followSols (n : ns) = n : followSols ns + = do vs' <- case t' of + P _ tn _ -> + if (n, tn) `elem` vs then -- cycle + tfail (cantUnify from False topx topy + (Msg "") (errEnv env) 0) + else return ((n, tn) : vs) + _ -> return vs + followSols vs' ((n, t') : ns) + followSols vs (n : ns) = do ns' <- followSols vs ns + return $ n : ns' expandLets env (x, tm) = (x, doSubst (reverse env) tm) where @@ -253,28 +280,28 @@ hasv (Bind x b sc) = hasv (binderTy b) || hasv sc hasv _ = False -unify :: Context -> Env -> TT Name -> TT Name -> +unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [Name] -> [FailContext] -> TC ([(Name, TT Name)], Fails) unify ctxt env topx topy inj holes usersupp from = --- traceWhen (hasv topx || hasv topy) +-- traceWhen (hasv topx || hasv topy) -- ("Unifying " ++ show topx ++ "\nAND\n" ++ show topy ++ "\n") $ -- don't bother if topx and topy are different at the head - case runStateT (un False [] (renameBindersTm env topx) + case runStateT (un False [] (renameBindersTm env topx) (renameBindersTm env topy)) (UI 0 []) of - OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v), - []) + OK (v, UI _ []) -> do v' <- trimSolutions topx topy from env v + return (map (renameBinders env) v', []) res -> 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 + (UI 0 []) of OK (v, UI _ fails) -> - return (map (renameBinders env) (trimSolutions v), - reverse fails) + do v' <- trimSolutions topx topy from env v + return (map (renameBinders env) v', reverse fails) -- Error e@(CantUnify False _ _ _ _ _) -> tfail e - Error e -> tfail e + Error e -> tfail e where headDiff (P (DCon _ _ _) x _) (P (DCon _ _ _) y _) = x /= y headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y @@ -287,8 +314,8 @@ injective (App f a) = injective f -- && injective a injective _ = False --- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK - injectiveVar (P _ n _) = n `elem` inj +-- injectiveVar (P _ (MN _ _) _) = True -- TMP HACK + injectiveVar (P _ n _) = n `elem` inj injectiveVar (App f a) = injectiveVar f -- && injective a injectiveVar _ = False @@ -364,7 +391,7 @@ then unifyTmpFail xtm tm else do sc 1 return x - | pureTerm tm, not (injective xtm) && injective tm + | pureTerm tm, not (injective xtm) && injective tm = do checkCycle bnames (x, tm) unifyTmpFail xtm tm un' fn bnames tm ytm@(P _ y _) @@ -378,16 +405,16 @@ then unifyTmpFail tm ytm else do sc 1 return x - | pureTerm tm, not (injective ytm) && injective tm + | pureTerm tm, not (injective ytm) && injective tm = do checkCycle bnames (y, tm) unifyTmpFail tm ytm un' fn bnames (V i) (P _ x _) | length bnames > i, - fst ((map fst bnames)!!i) == x || + fst ((map fst bnames)!!i) == x || snd ((map fst bnames)!!i) == x = do sc 1; return [] un' fn bnames (P _ x _) (V i) | length bnames > i, - fst ((map fst bnames)!!i) == x || + 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 @@ -414,41 +441,45 @@ -- f D unifies with t -> D. This is dubious, but it helps with type -- class resolution for type classes over functions. - un' fn bnames (App f x) (Bind n (Pi t k) y) + un' fn bnames (App f x) (Bind n (Pi i t k) y) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames x y - uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t k) (V 1))) + uf <- un' False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) + (Bind n (Pi i t k) (V 1))) combine bnames ux uf - - un' fn bnames (Bind n (Pi t k) y) (App f x) + + un' fn bnames (Bind n (Pi i t k) y) (App f x) | noOccurrence n y && injectiveApp f = do ux <- un' False bnames y x - uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) - (Bind n (Pi t k) (V 1))) f + uf <- un' False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar 0))) + (Bind n (Pi i t k) (V 1))) f combine bnames ux uf - + un' fn bnames (Bind x bx sx) (Bind y by sy) | 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 (Pi _ _ _) (Pi _ _ _) = True sameBinder _ _ = False un' fn bnames x y | OK True <- convEq' ctxt holes x y = do sc 1; return [] - | isUniverse x && isUniverse y = do sc 1; return [] + | isUniverse x && isUniverse y = do sc 1; return [] | otherwise = do UI s f <- get - let r = recoverable (normalise ctxt env x) + 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, from, Unify) : f)) + else do put (UI s ((x, y, True, env, err, from, Unify) : f)) return [] -- lift $ tfail err unApp fn bnames appx@(App fx ax) appy@(App fy ay) + -- shortcut for the common case where we just want to check the + -- arguments are correct + | (injectiveApp fx && fx == fy) + = un' False bnames ax ay | (injectiveApp fx && injectiveApp fy) || (injectiveApp fx && metavarApp fy && ax == ay) || (injectiveApp fy && metavarApp fx && ax == ay) @@ -519,7 +550,7 @@ _ -> False metavar t = case t of - P _ x _ -> (x `notElem` usersupp && + P _ x _ -> (x `notElem` usersupp && (x `elem` holes || holeIn env x)) || globmetavar t _ -> False @@ -539,7 +570,7 @@ 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)) + put (UI s ((topx, topy, True, env, err, from, Unify) : f)) return [] -- shortcut failure, if we *know* nothing can fix it @@ -547,7 +578,7 @@ 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)) + put (UI s ((topx, topy, True, env, err, from, Unify) : f)) lift $ tfail err @@ -562,16 +593,18 @@ sc 1 combine bnames h1 h2 uB bnames (Lam tx) (Lam ty) = do sc 1; un' False bnames tx ty - uB bnames (Pi tx _) (Pi ty _) = do sc 1; un' False bnames tx ty + uB bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' False bnames tx ty uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty uB bnames x y = do UI s f <- get - let r = recoverable (normalise ctxt env (binderTy x)) + 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)) + put (UI s ((binderTy x, binderTy y, + False, + env, err, from, Unify) : f)) return [] -- lift $ tfail err checkCycle ns p@(x, P _ _ _) = return [p] @@ -590,9 +623,9 @@ else return [(x, bind v ns tm)] where inst [] tm = tm inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm) - checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR") + checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR") - bind i ns 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)) @@ -639,7 +672,9 @@ -- FIXME: Depending on how overloading gets used, this may cause problems. Better -- rethink overloading properly... -- ASSUMPTION: inputs are in normal form - +-- +-- Issue #1722 on the issue tracker https://github.com/idris-lang/Idris-dev/issues/1722 +-- recoverable t@(App _ _) _ | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy'" = False recoverable _ t@(App _ _) @@ -658,13 +693,13 @@ recoverable p@(P _ n _) (App f a) = recoverable p f recoverable (App f a) p@(P _ _ _) = recoverable f p recoverable (App f a) (App f' a') - | f == f' = recoverable a a' + | f == f' = recoverable a a' recoverable (App f a) (App f' a') = recoverable f f' -- && recoverable a a' -recoverable f (Bind _ (Pi _ _) sc) +recoverable f (Bind _ (Pi _ _ _) sc) | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False -recoverable (Bind _ (Pi _ _) sc) f +recoverable (Bind _ (Pi _ _ _) sc) f | (P (DCon _ _ _) _ _, _) <- unApply f = False | (P (TCon _ _) _ _, _) <- unApply f = False recoverable (Bind _ (Lam _) sc) f = recoverable sc f @@ -685,4 +720,3 @@ Just (PVar _) -> True Just (PVTy _) -> True _ -> False - diff --git a/src/Idris/Coverage.hs b/src/Idris/Coverage.hs --- a/src/Idris/Coverage.hs +++ b/src/Idris/Coverage.hs @@ -56,7 +56,8 @@ = do i <- getIState 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 lhs_tms' = zipWith mergePlaceholders lhs_tms + (map (stripUnmatchable i) given) let lhss = map pUnApply lhs_tms' let argss = transpose lhss @@ -72,7 +73,7 @@ -- there may be more case splitting that the idris_implicits record -- suggests) let parg = case lookupCtxt n (idris_implicits i) of - (p : _) -> + (p : _) -> p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder) _ -> repeat (pexp Placeholder) let tryclauses = mkClauses parg all_args @@ -93,7 +94,7 @@ -- 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 + noMatch i tm = all (\x -> case matchClause i (stripUnmatchable i (delab' i x True True)) tm of Right ms -> False Left miss -> True) xs @@ -122,7 +123,8 @@ -- FIXME: Just look for which one is the deepest, then generate all -- possibilities up to that depth. - +-- This and below issues for this function are tracked as Issue #1741 on the issue tracker. +-- https://github.com/idris-lang/Idris-dev/issues/1741 genAll :: IState -> [PTerm] -> [PTerm] genAll i args = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of @@ -162,10 +164,6 @@ lotsOfChars = map Ch ['a'..] lotsOfStrings = map Str (map (("some string " ++).show) [1..]) - conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i) - conForm (PRef fc n) = isConName n (tt_ctxt i) - conForm _ = False - nubMap f acc [] = acc nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs @@ -182,7 +180,7 @@ ([pimp (sUN "a") Placeholder True, pimp (sUN "P") Placeholder True] ++ [pexp t,pexp v]) o - otherPats o@(PConstant c) = return o + otherPats o@(PConstant c) = inventConsts [o] -- return o otherPats arg = return Placeholder ops fc n xs o @@ -264,13 +262,13 @@ addIBC (IBCTotCheckErr fc msg) [Partial _] -> case lookupCtxt n (idris_callgraph i) of - [cg] -> mapM_ (checkAllCovering fc (n : done) top) + [cg] -> mapM_ (checkAllCovering fc (n : done) top) (map fst (calls cg)) _ -> return () x -> return () -- stop if total checkAllCovering _ _ _ _ = return () --- Check if, in a given group of type declarations mut_ns, +-- Check if, in a given group of type declarations mut_ns, -- the constructor cn : ty is strictly positive, -- and update the context accordingly @@ -288,12 +286,12 @@ where args t = [0..length (getArgTys t)-1] - cp (Bind n (Pi aty _) sc) = posArg aty && cp sc + cp (Bind n (Pi _ aty _) sc) = posArg aty && cp sc cp t | (P _ n' _, args) <- unApply t, - n' `elem` mut_ns = all noRec args + n' `elem` mut_ns = all noRec args cp _ = True - posArg (Bind _ (Pi nty _) sc) + posArg (Bind _ (Pi _ nty _) sc) | (P _ n' _, args) <- unApply nty = n' `notElem` mut_ns && all noRec args && posArg sc posArg t | (P _ n' _, args) <- unApply t, @@ -439,7 +437,7 @@ i <- getIState let opts = case lookupCtxt n (idris_flags i) of [fs] -> fs - _ -> [] + _ -> [] when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n t <- checkTotality [] fc n case t of @@ -507,11 +505,11 @@ | (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. + -- immediate call, as long as the call is guarded. -- Then check its arguments | (P _ (UN del) _, [_,_,arg]) <- unApply ap, Guarded <- guarded, - del == txt "Delay" + del == txt "Delay" = let (capp, args) = unApply arg in concatMap (\x -> findCalls guarded x pvs pargs) args | (P _ n _, args) <- unApply ap @@ -525,19 +523,21 @@ 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 Unguarded t pvs pargs ++ + findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs + findCalls guarded (Bind n t e) pvs pargs + = findCalls Unguarded (binderTy t) pvs pargs ++ + findCalls guarded e (n : pvs) pargs findCalls guarded (P _ f _ ) pvs pargs | not (f `elem` pvs) = [(f, [])] findCalls _ _ _ _ = [] - expandToArity n args + expandToArity n args = case lookupTy n (tt_ctxt ist) of [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args _ -> args - where expand i (Bind n (Pi _ _) sc) (x : xs) = x : expand (i + 1) sc xs - expand i (Bind n (Pi _ _) sc) [] = Just (i, Same) : expand (i + 1) sc [] + where expand i (Bind n (Pi _ _ _) sc) (x : xs) = x : expand (i + 1) sc xs + expand i (Bind n (Pi _ _ _) sc) [] = Just (i, Same) : expand (i + 1) sc [] expand i _ xs = xs mkChange n args pargs = [(n, expandToArity n (sizes args))] @@ -609,7 +609,7 @@ return (noPartial tot) [] -> do logLvl 5 $ "No paths for " ++ show n return Unchecked - where getArity ist n + where getArity ist n = case lookupTy n (tt_ctxt ist) of [ty] -> arity (normalise (tt_ctxt ist) [] ty) _ -> error "Can't happen: checkSizeChange.getArity" @@ -674,14 +674,14 @@ Total [] else Partial (Mutual (map (fst . fst . fst) path ++ [f])) | e `elem` map (fst . fst) path - && not (f `elem` map fst es) + && not (f `elem` map fst es) = Partial (Mutual (map (fst . fst . fst) path ++ [f])) | [Unchecked] <- lookupTotal f (tt_ctxt ist) = let argspos = case collapseNothing (zip nextargs [0..]) of [] -> [(Nothing, 0)] x -> x -- trace (show (argspos, nextargs, path)) $ - pathres = + pathres = do (a, pos) <- argspos case a of Nothing -> -- don't know, but if the @@ -704,7 +704,7 @@ _ -> trace ("Shouldn't happen " ++ show e) $ return (Partial Itself) else return Unchecked in --- trace (show (desc, argspos, path, es, pathres)) $ +-- trace (show (desc, argspos, path, es, pathres)) $ collapse' Unchecked pathres | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a @@ -734,4 +734,3 @@ collapse' def (d : xs) = collapse' d xs -- collapse' Unchecked [] = Total [] collapse' def [] = def - diff --git a/src/Idris/DSL.hs b/src/Idris/DSL.hs --- a/src/Idris/DSL.hs +++ b/src/Idris/DSL.hs @@ -18,16 +18,16 @@ t' -- addImpl i t' expandDo :: DSL -> PTerm -> PTerm -expandDo dsl (PLam n ty tm) +expandDo dsl (PLam fc n ty tm) | Just lam <- dsl_lambda dsl - = let sc = PApp (fileFC "(dsl)") lam [pexp (var dsl n tm 0)] in + = let sc = PApp fc lam [pexp (var dsl n tm 0)] in expandDo dsl sc -expandDo dsl (PLam n ty tm) = PLam n (expandDo dsl ty) (expandDo dsl tm) -expandDo dsl (PLet n ty v tm) +expandDo dsl (PLam fc n ty tm) = PLam fc n (expandDo dsl ty) (expandDo dsl tm) +expandDo dsl (PLet fc n ty v tm) | Just letb <- dsl_let dsl = let sc = PApp (fileFC "(dsl)") letb [pexp v, pexp (var dsl n tm 0)] in expandDo dsl sc -expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm) +expandDo dsl (PLet fc n ty v tm) = PLet fc n (expandDo dsl ty) (expandDo dsl v) (expandDo dsl tm) expandDo dsl (PPi p n ty tm) | Just pi <- dsl_pi dsl = let sc = PApp (fileFC "(dsl)") pi [pexp ty, pexp (var dsl n tm 0)] in @@ -60,19 +60,19 @@ block b [DoExp fc tm] = tm 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))] + = PApp fc b [pexp tm, pexp (PLam fc n Placeholder (block b rest))] block b (DoBindP fc p tm alts : rest) - = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder + = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") Placeholder (PCase fc (PRef fc (sMN 0 "bpat")) ((p, block b rest) : alts)))] block b (DoLet fc n ty tm : rest) - = PLet n ty tm (block b rest) + = PLet fc n ty tm (block b rest) block b (DoLetP fc p tm : rest) = PCase fc tm [(p, block b rest)] block b (DoExp fc tm : rest) = PApp fc b [pexp tm, - pexp (PLam (sMN 0 "bindx") Placeholder (block b rest))] + pexp (PLam fc (sMN 0 "bindx") Placeholder (block b rest))] block b _ = PElabError (Msg "Invalid statement in do block") expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e @@ -84,14 +84,14 @@ case dsl_var dsl of Nothing -> PElabError (Msg "No 'variable' defined in dsl") Just v -> PApp fc v [pexp (mkVar fc i)] - v' i (PLam n ty sc) + v' i (PLam fc n ty sc) | Nothing <- dsl_lambda dsl - = PLam n ty (v' i sc) - | otherwise = PLam n (v' i ty) (v' (i + 1) sc) - v' i (PLet n ty val sc) + = PLam fc n ty (v' i sc) + | otherwise = PLam fc n (v' i ty) (v' (i + 1) sc) + v' i (PLet fc n ty val sc) | Nothing <- dsl_let dsl - = PLet n (v' i ty) (v' i val) (v' i sc) - | otherwise = PLet n (v' i ty) (v' i val) (v' (i + 1) sc) + = PLet fc n (v' i ty) (v' i val) (v' i sc) + | otherwise = PLet fc n (v' i ty) (v' i val) (v' (i + 1) sc) v' i (PPi p n ty sc) | Nothing <- dsl_pi dsl = PPi p n (v' i ty) (v' i sc) @@ -146,9 +146,9 @@ = do t' <- db' t args' <- mapM dbArg args return (PApp fc t' args') - db' (PLam n ty sc) = return (PLam n ty (debind b sc)) - db' (PLet n ty v sc) = do v' <- db' v - return (PLet n ty v' (debind b sc)) + db' (PLam fc n ty sc) = return (PLam fc n ty (debind b sc)) + db' (PLet fc n ty v sc) = do v' <- db' v + return (PLet fc n ty v' (debind b sc)) db' (PCase fc s opts) = do s' <- db' s return (PCase fc s' (map (pmap (debind b)) opts)) db' (PPair fc p l r) = do l' <- db' l @@ -170,6 +170,6 @@ bindAll [] tm = tm bindAll ((n, fc, t) : bs) tm - = PApp fc b [pexp t, pexp (PLam n Placeholder (bindAll bs tm))] + = PApp fc b [pexp t, pexp (PLam fc n Placeholder (bindAll bs tm))] diff --git a/src/Idris/DeepSeq.hs b/src/Idris/DeepSeq.hs --- a/src/Idris/DeepSeq.hs +++ b/src/Idris/DeepSeq.hs @@ -1,6 +1,9 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + module Idris.DeepSeq(module Idris.DeepSeq, module Idris.Core.DeepSeq) where import Idris.Core.DeepSeq +import Idris.Docstrings import Idris.Core.TT import Idris.AbsSyntaxTree @@ -48,24 +51,13 @@ rnf CT.PeriodFollowing = () rnf CT.ParenFollowing = () --- All generated by 'derive' - -instance NFData IntTy where - rnf (ITFixed x1) = rnf x1 `seq` () - rnf ITNative = () - rnf ITBig = () - rnf ITChar = () - rnf (ITVec x1 x2) = rnf x1 `seq` rnf x2 `seq` () +instance NFData DocTerm where + rnf Unchecked = () + rnf (Checked x1) = rnf x1 `seq` () + rnf (Example x1) = rnf x1 `seq` () + rnf (Failing x1) = rnf x1 `seq` () -instance NFData NativeTy where - rnf IT8 = () - rnf IT16 = () - rnf IT32 = () - rnf IT64 = () - -instance NFData ArithTy where - rnf (ATInt x1) = rnf x1 `seq` () - rnf ATFloat = () +-- All generated by 'derive' instance NFData SizeChange where rnf Smaller = () @@ -73,6 +65,13 @@ rnf Bigger = () rnf Unknown = () +instance NFData FnInfo where + rnf (FnInfo x1) = rnf x1 `seq` () + +instance NFData Codegen where + rnf (Via x1) = rnf x1 `seq` () + rnf Bytecode = () + instance NFData CGInfo where rnf (CGInfo x1 x2 x3 x4 x5) = rnf x1 `seq` @@ -95,8 +94,8 @@ rnf _ = () instance NFData Plicity where - rnf (Imp x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (Imp 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) @@ -108,18 +107,24 @@ rnf Inlinable = () rnf TotalFn = () rnf PartialFn = () + rnf CoveringFn = () rnf Coinductive = () rnf AssertTotal = () rnf Dictionary = () rnf Implicit = () + rnf NoImplicit = () rnf (CExport x1) = rnf x1 `seq` () + rnf ErrorHandler = () + rnf ErrorReverse = () rnf Reflection = () rnf (Specialise x1) = rnf x1 `seq` () + rnf Constructor = () instance NFData DataOpt where rnf Codata = () rnf DefaultEliminator = () rnf DefaultCaseFun = () + rnf DataErrRev = () instance (NFData t) => NFData (PDecl' t) where rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () @@ -191,10 +196,10 @@ rnf (PRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PInferRef x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PPatvar x1 x2) = rnf x1 `seq` rnf x2 `seq` () - rnf (PLam x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (PLam _ x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PPi x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () - rnf (PLet x1 x2 x3 x4) + rnf (PLet _ x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () @@ -210,6 +215,7 @@ rnf (PPair 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 (PAs x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () rnf (PAlternative x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PHidden x1) = rnf x1 `seq` () rnf PType = () @@ -227,8 +233,11 @@ rnf (PElabError x1) = rnf x1 `seq` () rnf PImpossible = () rnf (PCoerced x1) = rnf x1 `seq` () + rnf (PDisamb x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (PUnifyLog x1) = rnf x1 `seq` () rnf (PNoImplicits x1) = rnf x1 `seq` () + rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PUnquote x1) = rnf x1 `seq` () instance (NFData t) => NFData (PTactic' t) where rnf (Intro x1) = rnf x1 `seq` () @@ -236,6 +245,7 @@ rnf (Focus x1) = rnf x1 `seq` () rnf (Refine x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (Rewrite x1) = rnf x1 `seq` () + rnf DoUnify = () rnf (Induction x1) = rnf x1 `seq` () rnf (CaseTac x1) = rnf x1 `seq` () rnf (Equiv x1) = rnf x1 `seq` () @@ -245,6 +255,7 @@ rnf (Exact x1) = rnf x1 `seq` () rnf Compute = () rnf Trivial = () + rnf TCInstance = () rnf (ProofSearch r r1 r2 x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Solve = () @@ -255,13 +266,19 @@ rnf (Try x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (TSeq x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf (ApplyTactic x1) = rnf x1 `seq` () + rnf (ByReflection x1) = rnf x1 `seq` () rnf (Reflect x1) = rnf x1 `seq` () rnf (Fill x1) = rnf x1 `seq` () rnf (GoalType x1 x2) = rnf x1 `seq` rnf x2 `seq` () rnf Qed = () rnf Abandon = () + rnf (TCheck x1) = rnf x1 `seq` () + rnf (TEval x1) = rnf x1 `seq` () + rnf (TDocStr x1) = x1 `seq` () + rnf (TSearch x1) = rnf x1 `seq` () rnf Skip = () rnf (TFail x1) = rnf x1 `seq` () + rnf SourceFC = () instance NFData ErrorReportPart where rnf (TermPart x1) = rnf x1 `seq` () diff --git a/src/Idris/Delaborate.hs b/src/Idris/Delaborate.hs --- a/src/Idris/Delaborate.hs +++ b/src/Idris/Delaborate.hs @@ -56,22 +56,32 @@ Just (Just _, mi, _) -> mkMVApp n [] _ -> PRef un n de env _ (Bind n (Lam ty) sc) - = PLam n (de env [] ty) (de ((n,n):env) [] sc) - de env ((PImp { argopts = opts }):is) (Bind n (Pi ty _) sc) - = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc) - de env (PConstraint _ _ _ _:is) (Bind n (Pi ty _) sc) + = PLam un n (de env [] ty) (de ((n,n):env) [] sc) + de env is (Bind n (Pi (Just impl) ty _) sc) + | tcinstance impl = PPi constraint n (de env [] ty) (de ((n,n):env) is sc) - de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty _) sc) + | otherwise + = PPi (Imp [] Dynamic False (Just impl)) n (de env [] ty) (de ((n,n):env) is sc) + de env ((PImp { argopts = opts }):is) (Bind n (Pi _ ty _) sc) + = PPi (Imp opts Dynamic False Nothing) 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) = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc) - de env (plic:is) (Bind n (Pi ty _) sc) + de env (plic:is) (Bind n (Pi _ ty _) sc) = PPi (Exp (argopts plic) Dynamic False) n (de env [] ty) (de ((n,n):env) is sc) - de env [] (Bind n (Pi ty _) sc) + de env [] (Bind n (Pi _ ty _) sc) = PPi expl n (de env [] ty) (de ((n,n):env) [] sc) - de env _ (Bind n (Let ty val) sc) - = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc) + + de env imps (Bind n (Let ty val) sc) + | isCaseApp sc + , (P _ cOp _, args) <- unApply sc + , Just caseblock <- delabCase env imps n val cOp args = caseblock + | otherwise = + PLet un 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 plic (Bind n bb sc) = de ((n,n):env) [] sc @@ -128,6 +138,29 @@ imp (PConstraint p l n _) arg = PConstraint p l n arg imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg + isCaseApp tm | P _ n _ <- fst (unApply tm) = isCN n + | otherwise = False + where isCN (NS n _) = isCN n + isCN (SN (CaseN _)) = True + isCN _ = False + + delabCase :: [(Name, Name)] -> [PArg] -> Name -> Term -> Name -> [Term] -> Maybe PTerm + delabCase env imps scvar scrutinee caseName caseArgs = + do cases <- case lookupCtxt caseName (idris_patdefs ist) of + [(cases, _)] -> return cases + _ -> Nothing + return $ PCase un (de env imps scrutinee) + [ (de (env ++ map (\n -> (n, n)) vars) imps (splitArg lhs), + de (env ++ map (\n -> (n, n)) vars) imps rhs) + | (vars, lhs, rhs) <- cases + ] + where splitArg tm | (_, args) <- unApply tm = nonVar (reverse args) + | otherwise = tm + nonVar [] = error "Tried to delaborate empty case list" + nonVar [x] = x + nonVar (x@(App _ _) : _) = x + nonVar (x@(P (DCon _ _ _) _ _) : _) = x + nonVar (x:xs) = nonVar xs -- | How far to indent sub-errors errorIndent :: Int errorIndent = 8 @@ -177,20 +210,26 @@ ++ zip nms (repeat False)) y)) <> case e of Msg "" -> empty + -- if the specific error is the same as the one we just printed, + -- there's no need to print it + CantUnify _ x_in' y_in' _ _ _ | x_in == x_in' && y_in == y_in' -> empty _ -> line <> line <> text "Specifically:" <> indented (pprintErr' i e) <> if (opt_errContext (idris_options i)) then showSc i sc else empty -pprintErr' i (CantConvert x y env) = +pprintErr' i (CantConvert x_in y_in env) = + let (x_ns, y_ns, nms) = renameMNs x_in y_in + (x, y) = addImplicitDiffs (delab i (flagUnique x_ns)) + (delab i (flagUnique y_ns)) in text "Can't convert" <> - indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) - (delab i (flagUnique x)))) <$> + indented (annTm x_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + x)) <$> text "with" <> - indented (annTm y (pprintTerm' i (map (\ (n, b) -> (n, False)) env) - (delab i (flagUnique y)))) <> + indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env) + y)) <> if (opt_errContext (idris_options i)) then line <> showSc i env else empty - where flagUnique (Bind n (Pi t k@(UType u)) sc) + where flagUnique (Bind n (Pi i t k@(UType u)) sc) = App (P Ref (sUN (show u)) Erased) - (Bind n (Pi (flagUnique t) k) (flagUnique sc)) + (Bind n (Pi i (flagUnique t) k) (flagUnique sc)) flagUnique (App f a) = App (flagUnique f) (flagUnique a) flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc) flagUnique t = t @@ -229,6 +268,10 @@ align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as))) pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n +pprintErr' i (WithFnType ty) = + text "Can't match on a function: type is" <+> annTm ty (pprintTerm i (delab i ty)) +pprintErr' i (CantMatch t) = + text "Can't match on" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> annTm t (pprintTerm i (delab i t)) pprintErr' i UniverseError = text "Universe inconsistency" pprintErr' i (UniqueError NullType n) @@ -296,10 +339,6 @@ -- Make sure the machine invented names are shown helpfully to the user, so -- that any names which differ internally also differ visibly --- FIXME: I can't actually contrive an error to test this! Will revisit later... --- --- Issue #1590 in the Issue tracker. --- https://github.com/idris-lang/Idris-dev/issues/1590 renameMNs :: Term -> Term -> (Term, Term, [Name]) renameMNs x y = let ns = nub $ allTTNames x ++ allTTNames y newnames = evalState (getRenames [] ns) 1 in @@ -307,13 +346,23 @@ where getRenames :: [(Name, Name)] -> [Name] -> State Int [(Name, Name)] getRenames acc [] = return acc - getRenames acc (n@(MN i x) : xs) | UN x `elem` xs + getRenames acc (n@(MN i x) : xs) | rpt x xs = do idx <- get put (idx + 1) let x' = sUN (str x ++ show idx) getRenames ((n, x') : acc) xs + getRenames acc (n@(UN x) : xs) | rpt x xs + = do idx <- get + put (idx + 1) + let x' = sUN (str x ++ show idx) + getRenames ((n, x') : acc) xs getRenames acc (x : xs) = getRenames acc xs + rpt x [] = False + rpt x (UN y : xs) | x == y = True + rpt x (MN i y : xs) | x == y = True + rpt x (_ : xs) = rpt x xs + rename :: [(Name, Name)] -> Term -> Term rename ns (P nt x t) | Just x' <- lookup x ns = P nt x' t rename ns (App f a) = App (rename ns f) (rename ns a) @@ -346,10 +395,11 @@ getTm = b' } : bs') else (a { getTm = a' } : as', b { getTm = b' } : bs') - addI (PLam n a b) (PLam n' c d) + addShows xs ys = (xs, ys) + addI (PLam fc n a b) (PLam fc' n' c d) = let (a', c') = addI a c (b', d') = addI b d in - (PLam n a' b', PLam n' c' d') + (PLam fc n a' b', PLam fc' n' c' d') addI (PPi p n a b) (PPi p' n' c d) = let (a', c') = addI a c (b', d') = addI b d in @@ -399,7 +449,7 @@ and (zipWith expLike (getExps as) (getExps as')) expLike (PPi _ n s t) (PPi _ n' s' t') = n == n' && expLike s s' && expLike t t' - expLike (PLam n s t) (PLam n' s' t') + expLike (PLam _ n s t) (PLam _ n' s' t') = n == n' && expLike s s' && expLike t t' expLike (PPair _ _ x y) (PPair _ _ x' y') = expLike x x' && expLike y y' expLike (PDPair _ _ x _ y) (PDPair _ _ x' _ y') = expLike x x' && expLike y y' @@ -479,3 +529,5 @@ showbasic (MN _ s) = str s showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n showbasic (SN s) = show s +showbasic n = show n + diff --git a/src/Idris/Docs.hs b/src/Idris/Docs.hs --- a/src/Idris/Docs.hs +++ b/src/Idris/Docs.hs @@ -31,6 +31,8 @@ [(Name, Maybe (Docstring DocTerm))] -- parameters and their docstrings [PTerm] -- instances [PTerm] -- superclasses + | ModDoc [String] -- Module name + (Docstring DocTerm) showDoc ist d | nullDocstring d = empty @@ -138,7 +140,19 @@ then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params) else hsep (punctuate comma (map (prettyName True False params' . fst) params)) +pprintDocs ist (ModDoc mod docs) + = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$> + renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs + +-- | Given a fully-qualified, disambiguated name, construct the +-- documentation object for it getDocs :: Name -> Idris Docs +getDocs n@(NS n' ns) | n' == modDocName + = do i <- getIState + case lookupCtxtExact n (idris_moduledocs i) of + Just doc -> return $ ModDoc (reverse (map T.unpack ns)) doc + Nothing -> fail $ "Module docs for " ++ show (reverse (map T.unpack ns)) ++ + " do not exist! This shouldn't have happened and is a bug." getDocs n = do i <- getIState case lookupCtxt n (idris_classes i) of diff --git a/src/Idris/Docstrings.hs b/src/Idris/Docstrings.hs --- a/src/Idris/Docstrings.hs +++ b/src/Idris/Docstrings.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -- | Wrapper around Markdown library module Idris.Docstrings ( diff --git a/src/Idris/Elab/AsPat.hs b/src/Idris/Elab/AsPat.hs new file mode 100644 --- /dev/null +++ b/src/Idris/Elab/AsPat.hs @@ -0,0 +1,48 @@ +module Idris.Elab.AsPat(desugarAs) where + +import Idris.Core.TT +import Idris.AbsSyntax + +import Control.Applicative +import Control.Monad.State.Strict + +import Data.Generics.Uniplate.Data (transformM) + +-- | Desugar by changing x@y on lhs to let x = y in ... or rhs +desugarAs :: PTerm -> PTerm -> (PTerm, PTerm) +desugarAs lhs rhs + = let (lhs', pats) = runState (collectAs (replaceUnderscore lhs)) [] in + (lhs', bindPats pats rhs) + where + bindPats :: [(Name, FC, PTerm)] -> PTerm -> PTerm + bindPats [] rhs = rhs + bindPats ((n, fc, tm) : ps) rhs + = PLet fc n Placeholder tm (bindPats ps rhs) + +collectAs :: PTerm -> State [(Name, FC, PTerm)] PTerm +collectAs (PAs fc n tm) = do tm' <- collectAs tm + pats <- get + put (pats ++ [(n, fc, tm')]) + return tm' +collectAs (PApp fc t as) + = do as_tm <- mapM collectAs (map getTm as) + let as' = zipWith (\a tm -> a { getTm = tm }) as as_tm + return (PApp fc t as') -- only valid on args +collectAs x = return x + +-- | Replace _-patterns under @-patterns with fresh names that can be +-- used on the RHS +replaceUnderscore :: PTerm -> PTerm +replaceUnderscore tm = evalState (transformM (underAs replaceUnderscore') tm) 0 + where + underAs :: (PTerm -> State Int PTerm) -> PTerm -> State Int PTerm + underAs f (PAs fc n tm) = PAs fc n <$> transformM f tm + underAs f x = return x + + fresh :: State Int Name + fresh = modify (+1) >> flip sMN "underscorePatVar" <$> get + + + replaceUnderscore' :: PTerm -> State Int PTerm + replaceUnderscore' Placeholder = PRef emptyFC <$> fresh + replaceUnderscore' tm = return tm diff --git a/src/Idris/Elab/Class.hs b/src/Idris/Elab/Class.hs --- a/src/Idris/Elab/Class.hs +++ b/src/Idris/Elab/Class.hs @@ -53,7 +53,7 @@ data MArgTy = IA | EA | CA deriving Show elabClass :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) -> - FC -> [PTerm] -> + FC -> [(Name, PTerm)] -> Name -> [(Name, PTerm)] -> [(Name, Docstring (Either Err PTerm))] -> [PDecl] -> Idris () elabClass info syn_in doc fc constraints tn ps pDocs ds = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn) @@ -115,7 +115,7 @@ $ tfail (At fc (Msg $ "Default superclass instances can't have constraints.")) i <- getIState let t = PApp fc (PRef fc n) (map pexp ps) - let isConstrained = any (== t) constraints + let isConstrained = any (== t) (map snd constraints) when (not isConstrained) . tclift $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class.")) return () @@ -124,8 +124,8 @@ impbind [] x = x impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) - conbind :: [PTerm] -> PTerm -> PTerm - conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x) + conbind :: [(Name, PTerm)] -> PTerm -> PTerm + conbind ((c, ty) : ns) x = PPi constraint c ty (conbind ns x) conbind [] x = x getMName (PTy _ _ _ _ _ n _) = nsroot n @@ -133,7 +133,8 @@ = do t' <- implicit' info syn allmeths n t logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t' return ( (n, (toExp (map fst ps) Exp t')), - (n, (doc, o, (toExp (map fst ps) Imp t'))), + (n, (doc, o, (toExp (map fst ps) + (\ l s p -> Imp l s p Nothing) t'))), (n, (syn, o, t) ) ) tdecl _ _ = ifail "Not allowed in a class declaration" @@ -160,15 +161,15 @@ clause _ = False -- Generate a function for chasing a dictionary constraint - cfun :: Name -> PTerm -> SyntaxInfo -> [a] -> PTerm -> Idris [PDecl' PTerm] - cfun cn c syn all con + cfun :: Name -> PTerm -> SyntaxInfo -> [a] -> (Name, PTerm) -> Idris [PDecl' PTerm] + cfun cn c syn all (cnm, con) = do let cfn = sUN ('@':'@':show cn ++ "#" ++ show con) -- SN (ParentN cn (show con)) let mnames = take (length all) $ map (\x -> sMN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames) let lhs = PApp fc (PRef fc cfn) [pconst capp] let rhs = PResolveTC (fileFC "HACK") - let ty = PPi constraint (sMN 0 "pc") c con + let ty = PPi constraint cnm c con iLOG (showTmImpls ty) iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs) i <- getIState @@ -200,7 +201,7 @@ 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 (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 _ = [] @@ -218,13 +219,13 @@ 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 { pstatic = Static }) (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) toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc) diff --git a/src/Idris/Elab/Clause.hs b/src/Idris/Elab/Clause.hs --- a/src/Idris/Elab/Clause.hs +++ b/src/Idris/Elab/Clause.hs @@ -19,6 +19,7 @@ import Idris.Output (iputStrLn, pshow, iWarn, iRenderResult) import IRTS.Lang +import Idris.Elab.AsPat import Idris.Elab.Type import Idris.Elab.Transform import Idris.Elab.Utils @@ -40,6 +41,7 @@ import Control.DeepSeq import Control.Monad import Control.Monad.State.Strict as State +import qualified Control.Monad.State.Lazy as LState import Data.List import Data.Maybe import Debug.Trace @@ -56,8 +58,10 @@ -- | Elaborate a collection of left-hand and right-hand pairs - that is, a -- top-level definition. elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () -elabClauses info fc opts n_in cs = let n = liftname info n_in in - do ctxt <- getContext +elabClauses info' fc opts n_in cs = + do let n = liftname info n_in + info = info' { elabFC = Just fc } + ctxt <- getContext ist <- getIState optimise <- getOptimise let petrans = PETransform `elem` optimise @@ -155,7 +159,7 @@ erInfo <- getErasureInfo <$> getIState tree@(CaseDef scargs sc _) <- tclift $ - simpleCase tcase False reflect CompileTime fc inacc atys pdef erInfo + simpleCase tcase (UnmatchedCase "Error") reflect CompileTime fc inacc atys pdef erInfo cov <- coverage pmissing <- if cov && not (hasDefault cs) @@ -202,8 +206,14 @@ ":warning - Unreachable case: " ++ show (delab ist x)) xs let knowncovering = (pcover && cov) || AssertTotal `elem` opts + let defaultcase = if knowncovering + then STerm Erased + else UnmatchedCase $ "*** " ++ + show fc ++ + ":unmatched case in " ++ show n ++ + " ***" - tree' <- tclift $ simpleCase tcase knowncovering reflect + tree' <- tclift $ simpleCase tcase defaultcase reflect RunTime fc inacc atys pdef' erInfo logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree logLvl 3 $ "Optimised: " ++ show tree' @@ -215,7 +225,7 @@ let caseInfo = CaseInfo (inlinable opts) (dictionary opts) case lookupTy n ctxt of [ty] -> do updateContext (addCasedef n erInfo caseInfo - tcase knowncovering + tcase defaultcase reflect (AssertTotal `elem` opts) atys @@ -442,7 +452,7 @@ i <- getIState let lhs = addImplPat i lhs_in -- if the LHS type checks, it is possible - case elaborate ctxt (sMN 0 "patLHS") infP [] + case elaborate ctxt (sMN 0 "patLHS") infP initEState (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of OK ((lhs', _, _), _) -> do let lhs_tm = orderPats (getInferTerm lhs') @@ -494,6 +504,7 @@ ntRec x y | Ref <- x = True | Ref <- y = True + | (Bound, Bound) <- (x, y) = True | otherwise = False -- name is different, unrecoverable propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm @@ -541,9 +552,11 @@ (Msg $ show lhs_in ++ " is a valid case")) False -> do ptm <- mkPatTm lhs_in return (Left ptm, lhs) -elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock) +elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as whereblock) = do let tcgen = Dictionary `elem` opts + push_estack fname ctxt <- getContext + let (lhs_in, rhs_in) = desugarAs lhs_in_as rhs_in_as -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings @@ -557,21 +570,23 @@ [t] -> t _ -> [] let params = getParamsInType i [] fn_is fn_ty - let lhs = mkLHSapp $ stripUnmatchable i $ - propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in)) + let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $ + propagateParams i params fn_ty (addImplPat i lhs_in) +-- let lhs = mkLHSapp $ +-- propagateParams i params fn_ty (addImplPat i lhs_in) logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs) logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++ "\n" ++ show (fn_ty, fn_is)) (((lhs', dlhs, []), probs, inj), _) <- - tclift $ elaborate ctxt (sMN 0 "patLHS") infP [] + tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState (do res <- errAt "left hand side of " fname (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) probs <- get_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' @@ -618,7 +633,7 @@ let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all - let winfo = pinfo info newargs defs windex + let winfo = (pinfo info newargs defs windex) { elabFC = Just fc } let wb = map (mkStatic static_names) $ map (expandParamsD False ist decorate newargs defs) whereblock @@ -638,7 +653,7 @@ ctxt <- getContext -- new context with where block added logLvl 5 "STARTING CHECK" ((rhs', defer, is, probs), _) <- - tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty [] + tclift $ elaborate ctxt (sMN 0 "patRHS") clhsty initEState (do pbinds ist lhs_tm mapM_ setinj (nub (params ++ inj)) setNextName @@ -648,13 +663,13 @@ (erun fc $ psolve lhs_tm) hs <- get_holes aux <- getAux - mapM_ (elabCaseHole aux) hs + mapM_ (elabCaseHole (case_decls aux)) hs tt <- get_term let (tm, ds) = runState (collectDeferred (Just fname) tt) [] 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' @@ -682,8 +697,12 @@ then recheckC_borrowing True borrowed fc [] rhs' else return (rhs', clhsty) logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty - case converts ctxt [] clhsty crhsty of - OK _ -> return () + ctxt <- getContext + let constv = next_tvar ctxt + case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of + OK (_, cs) -> do addConstraints fc cs + logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs + return () Error e -> ierror (At fc (CantUnify False clhsty crhsty e [] 0)) i <- getIState checkInferred fc (delab' i crhs True True) rhs @@ -701,6 +720,7 @@ when (rev || ErrorReverse `elem` opts) $ do addIBC (IBCErrRev (crhs, clhs)) addErrRev (crhs, clhs) + pop_estack return $ (Right (clhs, crhs), lhs) where pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo @@ -789,10 +809,10 @@ [t] -> t _ -> [] let params = getParamsInType i [] fn_is fn_ty - let lhs = propagateParams i params fn_ty (addImplPat i (stripLinear i lhs_in)) + let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in) logLvl 2 ("LHS: " ++ show lhs) ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (sMN 0 "patLHS") infP [] + tclift $ elaborate ctxt (sMN 0 "patLHS") infP initEState (errAt "left hand side of with in " fname (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) ) let lhs_tm = orderPats (getInferTerm lhs') @@ -808,7 +828,7 @@ -- Elaborate wval in this context ((wval', defer, is), _) <- tclift $ elaborate ctxt (sMN 0 "withRHS") - (bindTyArgs PVTy bargs infP) [] + (bindTyArgs PVTy bargs infP) initEState (do pbinds i lhs_tm setNextName -- TODO: may want where here - see winfo abpve @@ -826,6 +846,13 @@ let cwvaltyN = explicitNames (normalise ctxt [] cwvalty) let cwvalN = explicitNames (normalise ctxt [] cwval) logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty) + -- We're going to assume the with type is not a function shortly, + -- so report an error if it is (you can't match on a function anyway + -- so this doesn't lose anything) + case getArgTys cwvaltyN of + [] -> return () + (_:_) -> ierror $ At fc (WithFnType cwvalty) + let pvars = map fst (getPBtys cwvalty) -- we need the unelaborated term to get the names it depends on -- rather than a de Bruijn index. @@ -840,7 +867,7 @@ let wargval = getRetTy cwvalN let wargtype = getRetTy cwvaltyN logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype) - let wtype = bindTyArgs (flip Pi (TType (UVar 0))) (bargs_pre ++ + let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++ (sMN 0 "warg", wargtype) : map (abstract (sMN 0 "warg") wargval wargtype) bargs_post) (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty) @@ -881,7 +908,7 @@ ctxt <- getContext -- New context with block added i <- getIState ((rhs', defer, is), _) <- - tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty [] + tclift $ elaborate ctxt (sMN 0 "wpatRHS") clhsty initEState (do pbinds i lhs_tm setNextName (_, d, is) <- erun fc (build i info ERHS opts fname rhs) @@ -896,7 +923,7 @@ (crhs, crhsty) <- recheckC fc [] rhs' return $ (Right (clhs, crhs), lhs) where - getImps (Bind n (Pi _ _) t) = pexp Placeholder : getImps t + getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t getImps _ = [] mkAuxC wname lhs ns ns' (PClauses fc o n cs) diff --git a/src/Idris/Elab/Data.hs b/src/Idris/Elab/Data.hs --- a/src/Idris/Elab/Data.hs +++ b/src/Idris/Elab/Data.hs @@ -66,9 +66,10 @@ undef <- isUndefined fc n (cty, _, t, inacc) <- buildType info syn fc [] n t_in -- if n is defined already, make sure it is just a type declaration - -- with the same type we've just elaborated + -- with the same type we've just elaborated, and no constructors + -- yet i <- getIState - checkDefinedAs fc n cty (tt_ctxt i) + checkDefinedAs fc n cty i -- temporary, to check cons when undef $ updateContext (addTyDecl n (TCon 0 0) cty) let cnameinfo = cinfo info (map cname dcons) @@ -124,14 +125,18 @@ [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt } _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt } - checkDefinedAs fc n t ctxt - = case lookupDef n ctxt of + checkDefinedAs fc n t i + = let defined = tclift $ tfail (At fc (AlreadyDefined n)) + ctxt = tt_ctxt i in + case lookupDef n ctxt of [] -> return () [TyDecl _ ty] -> case converts ctxt [] t ty of - OK () -> return () - _ -> tclift $ tfail (At fc (AlreadyDefined n)) - _ -> tclift $ tfail (At fc (AlreadyDefined n)) + OK () -> case lookupCtxtExact n (idris_datatypes i) of + Nothing -> return () + _ -> defined + _ -> defined + _ -> defined -- parameters are names which are unchanged across the structure, -- which appear exactly once in the return type of a constructor @@ -172,7 +177,7 @@ getDataApp f@(App _ _) | (P _ d _, args) <- unApply f = if (d == n) then [mParam args args] else [] - getDataApp (Bind n (Pi t _) sc) + getDataApp (Bind n (Pi _ t _) sc) = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc) getDataApp _ = [] @@ -222,6 +227,10 @@ logLvl 5 $ "Inaccessible args: " ++ show inacc logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty' + -- Add to the context (this is temporary, so that later constructors + -- can be indexed by it) + updateContext (addTyDecl n (DCon 0 0 False) cty) + addIBC (IBCDef n) checkDocs fc argDocs t doc' <- elabDocTerms info doc @@ -265,10 +274,10 @@ = tclift $ tfail (At fc (UniqueKindError NullType n)) checkUniqueKind (UType UniqueType) (UType UniqueType) = return () checkUniqueKind (UType UniqueType) (UType AllTypes) = return () - checkUniqueKind (UType UniqueType) (TType _) + checkUniqueKind (UType UniqueType) _ = tclift $ tfail (At fc (UniqueKindError UniqueType n)) checkUniqueKind (UType AllTypes) _ = return () - checkUniqueKind (TType _) _ = return () + checkUniqueKind _ _ = return () type EliminatorState = StateT (Map.Map String Int) Idris diff --git a/src/Idris/Elab/Instance.hs b/src/Idris/Elab/Instance.hs --- a/src/Idris/Elab/Instance.hs +++ b/src/Idris/Elab/Instance.hs @@ -52,7 +52,7 @@ elabInstance :: ElabInfo -> SyntaxInfo -> ElabWhat -> -- phase - FC -> [PTerm] -> -- constraints + FC -> [(Name, PTerm)] -> -- constraints Name -> -- the class [PTerm] -> -- class parameters (i.e. instance) PTerm -> -- full instance type @@ -66,7 +66,7 @@ cs -> tclift $ tfail $ At fc (CantResolveAlts (map fst cs)) let constraint = PApp fc (PRef fc n) (map pexp ps) - let iname = mkiname n ps expn + let iname = mkiname n (namespace info) ps expn let emptyclass = null (class_methods ci) when (what /= EDefns || (null ds && not emptyclass)) $ do nty <- elabType' True info syn emptyDocstring [] fc [] iname t @@ -140,9 +140,11 @@ [PConstant (AType (ATInt ITNative))] -> True _ -> False - mkiname n' ps' expn' = + mkiname n' ns ps' expn' = case expn' of - Nothing -> SN (sInstanceN n' (map show ps')) + Nothing -> case ns of + Nothing -> SN (sInstanceN n' (map show ps')) + Just m -> sNS (SN (sInstanceN n' (map show ps'))) m Just nm -> nm substInstance ips pnames (PInstance syn _ cs n ps t expn ds) @@ -150,7 +152,7 @@ isOverlapping i (PInstance syn _ _ n ps t expn _) = case lookupCtxtName n (idris_classes i) of - [(n, ci)] -> let iname = (mkiname n ps expn) in + [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in case lookupTy iname (tt_ctxt i) of [] -> elabFindOverlapping i ci iname syn t (_:_) -> return True @@ -166,7 +168,7 @@ let ty = addImpl i ty' ctxt <- getContext ((tyT, _, _), _) <- - tclift $ elaborate ctxt iname (TType (UVal 0)) [] + tclift $ elaborate ctxt iname (TType (UVal 0)) initEState (errAt "type of " iname (erun fc (build i info ERHS [] iname ty))) ctxt <- getContext (cty, _) <- recheckC fc [] tyT @@ -193,11 +195,11 @@ mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty)) lamBind i (PPi (Constraint _ _) _ _ sc) sc' - = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc') + = PLam fc (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') + = PLam fc (sMN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc - methArgs i (PPi (Imp _ _ _) n ty 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 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc @@ -223,11 +225,12 @@ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t - conbind (ty : ns) x = PPi (constraint) -- { pstatic = Dynamic }) - (sMN 0 "class") ty (conbind ns x) + conbind :: [(Name, PTerm)] -> PTerm -> PTerm + conbind ((c,ty) : ns) x = PPi constraint c ty (conbind ns x) conbind [] x = x - coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc) + coninsert :: [(Name, PTerm)] -> PTerm -> PTerm + coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc) coninsert cs sc = conbind cs sc insertDefaults :: IState -> Name -> diff --git a/src/Idris/Elab/Record.hs b/src/Idris/Elab/Record.hs --- a/src/Idris/Elab/Record.hs +++ b/src/Idris/Elab/Record.hs @@ -130,13 +130,13 @@ -- ++ "\n" ++ pshow i v putIState i) - getBoundImpls (PPi (Imp _ _ _) n ty sc) = (n, ty) : getBoundImpls sc + getBoundImpls (PPi (Imp _ _ _ _) n ty sc) = (n, ty) : getBoundImpls sc getBoundImpls _ = [] - 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 p) n ty sc) - = getImplB (\x -> k (PPi (Imp l s p) n ty x)) sc + getImplB k (PPi (Imp l s p fa) n ty sc) + = getImplB (\x -> k (PPi (Imp l s p fa) n ty x)) sc getImplB k (PPi _ n ty sc) = getImplB k sc getImplB k _ = k diff --git a/src/Idris/Elab/Transform.hs b/src/Idris/Elab/Transform.hs --- a/src/Idris/Elab/Transform.hs +++ b/src/Idris/Elab/Transform.hs @@ -54,26 +54,30 @@ i <- getIState let lhs = addImplPat i lhs_in ((lhs', dlhs, []), _) <- - tclift $ elaborate ctxt (sMN 0 "transLHS") infP [] + tclift $ elaborate ctxt (sMN 0 "transLHS") infP initEState (erun fc (buildTC i info ELHS [] (sUN "transform") (infTerm lhs))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let newargs = pvars i lhs_tm - (clhs_tm, clhs_ty) <- recheckC fc [] lhs_tm + (clhs_tm_in, clhs_ty) <- recheckC fc [] lhs_tm + let clhs_tm = renamepats pnames clhs_tm_in logLvl 3 ("Transform LHS " ++ show clhs_tm) + let rhs = addImplBound i (map fst newargs) rhs_in ((rhs', defer), _) <- - tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty [] + tclift $ elaborate ctxt (sMN 0 "transRHS") clhs_ty initEState (do pbinds i lhs_tm setNextName erun fc (build i info ERHS [] (sUN "transform") rhs) erun fc $ psolve lhs_tm tt <- get_term return (runState (collectDeferred Nothing tt) [])) - (crhs_tm, crhs_ty) <- recheckC fc [] rhs' + (crhs_tm_in, crhs_ty) <- recheckC fc [] rhs' + let crhs_tm = renamepats pnames crhs_tm_in logLvl 3 ("Transform RHS " ++ show crhs_tm) + -- Types must always convert case converts ctxt [] clhs_ty crhs_ty of OK _ -> return () @@ -93,6 +97,14 @@ where depat (Bind n (PVar t) sc) = depat (instantiate (P Bound n t) sc) depat x = x + + renamepats (n' : ns) (Bind n (PVar t) sc) + = Bind n' (PVar t) (renamepats ns sc) -- all Vs + renamepats _ sc = sc + + -- names for transformation variables. Need to ensure these don't clash + -- with any other names when applying rules, so rename here. + pnames = map (\i -> sMN i ("tvar" ++ show i)) [0..] elabTransform info fc safe lhs_in rhs_in = ierror (At fc (Msg "Invalid transformation rule (must be function application)")) diff --git a/src/Idris/Elab/Type.hs b/src/Idris/Elab/Type.hs --- a/src/Idris/Elab/Type.hs +++ b/src/Idris/Elab/Type.hs @@ -66,7 +66,7 @@ logLvl 3 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty ((tyT', defer, is), log) <- - tclift $ elaborate ctxt n (TType (UVal 0)) [] + tclift $ elaborate ctxt n (TType (UVal 0)) initEState (errAt "type of " n (erun fc (build i info ETyDecl [] n ty))) let tyT = patToImp tyT' @@ -104,11 +104,11 @@ return (cty, ckind, ty, inacc) where - patToImp (Bind n (PVar t) sc) = Bind n (Pi t (TType (UVar 0))) (patToImp sc) + patToImp (Bind n (PVar t) sc) = Bind n (Pi Nothing t (TType (UVar 0))) (patToImp sc) patToImp (Bind n b sc) = Bind n b (patToImp sc) patToImp t = t - param_pos i ns (Bind n (Pi t _) sc) + param_pos i ns (Bind n (Pi _ t _) sc) | n `elem` ns = i : param_pos (i + 1) ns sc | otherwise = param_pos (i + 1) ns sc param_pos i ns t = [] @@ -196,7 +196,7 @@ lst = txt "List" errrep = txt "ErrorReportPart" - tyIsHandler (Bind _ (Pi (P _ (NS (UN e) ns1) _) _) + tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _) (App (P _ (NS (UN m) ns2) _) (App (P _ (NS (UN l) ns3) _) (P _ (NS (UN r) ns4) _)))) diff --git a/src/Idris/Elab/Utils.hs b/src/Idris/Elab/Utils.hs --- a/src/Idris/Elab/Utils.hs +++ b/src/Idris/Elab/Utils.hs @@ -30,6 +30,7 @@ (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env (forget t) t of Error e -> tfail (At fc e) OK x -> return x + logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs addConstraints fc cs return (tm, ty) @@ -48,14 +49,14 @@ -- Get the list of (index, name) of inaccessible arguments from an elaborated -- type inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)] -inaccessibleImps i (Bind n (Pi t _) sc) (inacc : ins) +inaccessibleImps i (Bind n (Pi _ t _) sc) (inacc : ins) | inacc = (i, n) : inaccessibleImps (i + 1) sc ins | otherwise = inaccessibleImps (i + 1) sc ins inaccessibleImps _ _ _ = [] -- Get the list of (index, name) of inaccessible arguments from the type. inaccessibleArgs :: Int -> PTerm -> [(Int, Name)] -inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t) +inaccessibleArgs i (PPi (Imp _ _ _ _) n Placeholder t) = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit inaccessibleArgs i (PPi plicity n ty t) | InaccessibleArg `elem` pargopts plicity @@ -154,10 +155,13 @@ pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc pvars ist _ = [] -getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t _) sc) +getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi _ t _) sc) = nub $ getFixedInType i env [] t ++ getFixedInType i (n : env) is (instantiate (P Bound n t) sc) -getFixedInType i env (_ : is) (Bind n (Pi t _) sc) + ++ case t of + P _ n _ -> if n `elem` env then [n] else [] + _ -> [] +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 @@ -171,7 +175,7 @@ getFixedInType i env is a getFixedInType i _ _ _ = [] -getFlexInType i env ps (Bind n (Pi t _) sc) +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) @@ -229,11 +233,11 @@ use n = do ns <- get; put (n : ns) - getUniqB env us (Let t v) = do getUniq env us t; getUniq env us v - getUniqB env us (Guess t v) = do getUniq env us t; getUniq env us v - getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v - getUniqB env us (NLet t v) = do getUniq env us t; getUniq env us v - getUniqB env us b = getUniq env us (binderTy b) + getUniqB env us (Let t v) = getUniq env us v + getUniqB env us (Guess t v) = getUniq env us v +-- getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v + getUniqB env us (NLet t v) = getUniq env us v + getUniqB env us b = return () -- getUniq env us (binderTy b) -- In a functional application, return the names which are used -- directly in a static position @@ -252,7 +256,7 @@ getStaticNames _ _ = [] getStatics :: [Name] -> Term -> [Bool] -getStatics ns (Bind n (Pi _ _) t) +getStatics ns (Bind n (Pi _ _ _) t) | n `elem` ns = True : getStatics ns t | otherwise = False : getStatics ns t getStatics _ _ = [] diff --git a/src/Idris/Elab/Value.hs b/src/Idris/Elab/Value.hs --- a/src/Idris/Elab/Value.hs +++ b/src/Idris/Elab/Value.hs @@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -Werror #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms) where import Idris.AbsSyntax @@ -64,7 +64,7 @@ -- * elaboration as a function a -> b ((tm', defer, is), _) <- - tclift (elaborate ctxt (sMN 0 "val") infP [] + tclift (elaborate ctxt (sMN 0 "val") infP initEState (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm))) let vtm = orderPats (getInferTerm tm') diff --git a/src/Idris/ElabDecls.hs b/src/Idris/ElabDecls.hs --- a/src/Idris/ElabDecls.hs +++ b/src/Idris/ElabDecls.hs @@ -62,7 +62,7 @@ -- Top level elaborator info, supporting recursive elaboration recinfo :: ElabInfo -recinfo = EInfo [] emptyContext id Nothing elabDecl' +recinfo = EInfo [] emptyContext id Nothing Nothing elabDecl' -- | Return the elaborated term which calls 'main' elabMain :: Idris Term @@ -103,9 +103,9 @@ p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing - believeTy = Bind (sUN "a") (Pi (TType (UVar (-2))) (TType (UVar (-1)))) - (Bind (sUN "b") (Pi (TType (UVar (-2))) (TType (UVar (-1)))) - (Bind (sUN "x") (Pi (V 1) (TType (UVar (-1)))) (V 1))) + believeTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1)))) + (Bind (sUN "b") (Pi Nothing (TType (UVar (-2))) (TType (UVar (-1)))) + (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-1)))) (V 1))) elabBelieveMe = do let prim__believe_me = sUN "prim__believe_me" updateContext (addOperator prim__believe_me believeTy 3 p_believeMe) @@ -126,10 +126,10 @@ vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased vnRefl = VP (DCon 0 2 False) eqCon VErased - synEqTy = Bind (sUN "a") (Pi (TType (UVar (-3))) (TType (UVar (-2)))) - (Bind (sUN "b") (Pi (TType (UVar (-3))) (TType (UVar (-2)))) - (Bind (sUN "x") (Pi (V 1) (TType (UVar (-2)))) - (Bind (sUN "y") (Pi (V 1) (TType (UVar (-2)))) + synEqTy = Bind (sUN "a") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2)))) + (Bind (sUN "b") (Pi Nothing (TType (UVar (-3))) (TType (UVar (-2)))) + (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar (-2)))) + (Bind (sUN "y") (Pi Nothing (V 1) (TType (UVar (-2)))) (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased) [V 3, V 2, V 1, V 0]])))) elabSynEq diff --git a/src/Idris/ElabQuasiquote.hs b/src/Idris/ElabQuasiquote.hs --- a/src/Idris/ElabQuasiquote.hs +++ b/src/Idris/ElabQuasiquote.hs @@ -70,19 +70,19 @@ extractUnquotes :: Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)]) -extractUnquotes n (PLam name ty body) +extractUnquotes n (PLam fc name ty body) = do (ty', ex1) <- extractUnquotes n ty (body', ex2) <- extractUnquotes n body - return (PLam name ty' body', ex1 ++ ex2) + return (PLam fc name ty' body', ex1 ++ ex2) extractUnquotes n (PPi plicity name ty body) = do (ty', ex1) <- extractUnquotes n ty (body', ex2) <- extractUnquotes n body return (PPi plicity name ty' body', ex1 ++ ex2) -extractUnquotes n (PLet name ty val body) +extractUnquotes n (PLet fc name ty val body) = do (ty', ex1) <- extractUnquotes n ty (val', ex2) <- extractUnquotes n val (body', ex3) <- extractUnquotes n body - return (PLet name ty' val' body', ex1 ++ ex2 ++ ex3) + return (PLet fc name ty' val' body', ex1 ++ ex2 ++ ex3) extractUnquotes n (PTyped tm ty) = do (tm', ex1) <- extractUnquotes n tm (ty', ex2) <- extractUnquotes n ty diff --git a/src/Idris/ElabTerm.hs b/src/Idris/ElabTerm.hs --- a/src/Idris/ElabTerm.hs +++ b/src/Idris/ElabTerm.hs @@ -52,8 +52,11 @@ let inf = case lookupCtxt fn (idris_tyinfodata ist) of [TIPartial] -> True _ -> False - ivs <- get_instances + + when (not pattern) $ solveAutos ist fn True + hs <- get_holes + ivs <- get_instances ptm <- get_term -- Resolve remaining type classes. Two passes - first to get the -- default Num instances, second to clean up the rest @@ -84,14 +87,14 @@ probs <- get_probs case probs of [] -> return () - ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $ - if inf then return () - else lift (Error e) + ((_,_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $ + if inf then return () + else lift (Error e) when tydecl (do update_term orderPats mkPat) -- update_term liftPats) - is <- getAux + EState is _ <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog @@ -125,9 +128,14 @@ tm <- get_term case probs of [] -> return () - ((_,_,_,e,_,_):es) -> if inf then return () - else lift (Error e) - is <- getAux + ((_,_,_,_,e,_,_):es) -> if inf then return () + else lift (Error e) + dots <- get_dotterm + -- 'dots' are the PHidden things which have not been solved by + -- unification + when (not (null dots)) $ + lift (Error (CantMatch (getInferTerm tm))) + EState is _ <- getAux tt <- get_term let (tm, ds) = runState (collectDeferred (Just fn) tt) [] log <- getLog @@ -135,6 +143,45 @@ else return (tm, ds, is) where pattern = emode == ELHS +-- return whether arguments of the given constructor name can be +-- matched on. If they're polymorphic, no, unless the type has beed made +-- concrete by the time we get around to elaborating the argument. +getUnmatchable :: Context -> Name -> [Bool] +getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon + = case lookupTyExact n ctxt of + Nothing -> [] + Just ty -> checkArgs [] [] ty + where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool] + checkArgs env ns (Bind n (Pi _ t _) sc) + = let env' = case t of + TType _ -> n : env + _ -> env in + checkArgs env' (intersect env (refsIn t) : ns) + (instantiate (P Bound n t) sc) + checkArgs env ns t + = map (not . null) (reverse ns) + +getUnmatchable ctxt n = [] + +data ElabCtxt = ElabCtxt { e_inarg :: Bool, + e_guarded :: Bool, + e_intype :: Bool, + e_qq :: Bool, + e_nomatching :: Bool -- ^ can't pattern match + } + +initElabCtxt = ElabCtxt False False False False False + +goal_polymorphic :: ElabD Bool +goal_polymorphic = + do ty <- goal + case ty of + P _ n _ -> do env <- get_env + case lookup n env of + Nothing -> return False + _ -> return True + _ -> return False + -- Returns the set of declarations we need to add to complete the definition -- (most likely case blocks to elaborate) @@ -144,7 +191,10 @@ = do let loglvl = opt_logLevel (idris_options ist) when (loglvl > 5) $ unifyLog True compute -- expand type synonyms, etc - elabE (False, False, False, False) tm -- (in argument, guarded, in type, in qquote) + let fc = maybe "(unknown)" + elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote) + est <- getAux + sequence_ (delayed_elab est) end_unify ptm <- get_term when pattern -- convert remaining holes to pattern vars @@ -166,11 +216,11 @@ toElab ina arg = case getTm arg of Placeholder -> Nothing - v -> Just (priority arg, elabE ina v) + v -> Just (priority arg, elabE ina (elabFC info) v) toElab' ina arg = case getTm arg of Placeholder -> Nothing - v -> Just (elabE ina v) + v -> Just (elabE ina (elabFC info) v) mkPat = do hs <- get_holes tm <- get_term @@ -182,31 +232,41 @@ -- and forces/delays. If you make a recursive call in elab', it is -- normally correct to call elabE - the ones that don't are desugarings -- typically - elabE :: (Bool, Bool, Bool, Bool) -> PTerm -> ElabD () - 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') $ - 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 + elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD () + elabE ina fc' t = + --do g <- goal + --trace ("Elaborating " ++ show t ++ " : " ++ show g) $ + do solved <- get_recents + as <- get_autos + -- If any of the autos use variables which have recently been solved, + -- have another go at solving them now. + mapM_ (\(a, ns) -> if any (\n -> n `elem` solved) ns + then solveAuto ist fn False a + else return ()) as + + itm <- if not pattern then insertImpLam t else return t + ct <- insertCoerce ina itm + 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') $ + let fc = fileFC "Force" + env <- get_env + handleError (forceErr env) + (elab' ina fc' t') + (elab' ina fc' (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 @@ -234,36 +294,43 @@ -- "guarded" means immediately under a constructor, to help find patvars - elab' :: (Bool, Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type, in a quasiquote) + elab' :: ElabCtxt -- ^ (in an argument, guarded, in a type, in a quasiquote) + -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable -> PTerm -- ^ The term to elaborate -> ElabD () - elab' ina (PNoImplicits t) = elab' ina t -- skip elabE step - elab' ina PType = do apply RType []; solve - elab' ina (PUniverse u) = do apply (RUType u) []; solve + elab' ina fc (PNoImplicits t) = elab' ina fc t -- skip elabE step + elab' ina fc PType = do apply RType []; solve + elab' ina fc (PUniverse u) = do apply (RUType u) []; solve -- elab' (_,_,inty) (PConstant c) -- | constType c && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed") - elab' ina (PConstant c) = do apply (RConstant c) []; solve - elab' ina (PQuote r) = do fill r; solve - elab' ina (PTrue fc _) = + elab' ina fc tm@(PConstant c) + | pattern && not reflection && not (e_qq ina) && not (e_intype ina) + && isTypeConst c + = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm) + | pattern && not reflection && e_nomatching ina + = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm) + | otherwise = do apply (RConstant c) []; solve + elab' ina fc (PQuote r) = do fill r; solve + elab' ina _ (PTrue fc _) = do hnf_compute g <- goal case g of - TType _ -> elab' ina (PRef fc unitTy) - _ -> elab' ina (PRef fc unitCon) - elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes + TType _ -> elab' ina (Just fc) (PRef fc unitTy) + _ -> elab' ina (Just fc) (PRef fc unitCon) + elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes = do g <- goal; resolveTC False 5 g fn ist - elab' ina (PResolveTC fc) + elab' ina fc (PResolveTC fc') = do c <- getNameFrom (sMN 0 "class") instanceArg c - elab' ina (PRefl fc t) - = elab' ina (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True, - pimp (sMN 0 "x") t False]) - elab' ina (PEq fc Placeholder Placeholder l r) + elab' ina _ (PRefl fc t) + = elab' ina (Just fc) (PApp fc (PRef fc eqCon) [pimp (sMN 0 "A") Placeholder True, + pimp (sMN 0 "x") t False]) + elab' ina _ (PEq fc Placeholder Placeholder l r) = try (do tyn <- getNameFrom (sMN 0 "aqty") claim tyn RType movelast tyn - elab' ina (PApp fc (PRef fc eqTy) + elab' ina (Just fc) (PApp fc (PRef fc eqTy) [pimp (sUN "A") (PRef fc tyn) True, pimp (sUN "B") (PRef fc tyn) False, pexp l, pexp r])) @@ -273,26 +340,26 @@ movelast atyn claim btyn RType movelast btyn - elab' ina (PApp fc (PRef fc eqTy) - [pimp (sUN "A") (PRef fc atyn) True, - pimp (sUN "B") (PRef fc btyn) False, - pexp l, pexp r])) + elab' ina (Just fc) (PApp fc (PRef fc eqTy) + [pimp (sUN "A") (PRef fc atyn) True, + pimp (sUN "B") (PRef fc btyn) False, + pexp l, pexp r])) - elab' ina (PEq fc lt rt l r) = elab' ina (PApp fc (PRef fc eqTy) - [pimp (sUN "A") lt True, - pimp (sUN "B") rt False, - pexp l, pexp r]) - elab' ina@(_, a, inty, qq) (PPair fc _ l r) + elab' ina _ (PEq fc lt rt l r) = elab' ina (Just fc) (PApp fc (PRef fc eqTy) + [pimp (sUN "A") lt True, + pimp (sUN "B") rt False, + pexp l, pexp r]) + elab' ina _ (PPair fc _ l r) = do hnf_compute g <- goal case g of - TType _ -> elab' ina (PApp fc (PRef fc pairTy) + TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy) [pexp l,pexp r]) - _ -> elab' ina (PApp fc (PRef fc pairCon) + _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon) [pimp (sUN "A") Placeholder False, pimp (sUN "B") Placeholder False, pexp l, pexp r]) - elab' ina (PDPair fc p l@(PRef _ n) t r) + elab' ina _ (PDPair fc p l@(PRef _ n) t r) = case t of Placeholder -> do hnf_compute @@ -301,18 +368,18 @@ TType _ -> asType _ -> asValue _ -> asType - where asType = elab' ina (PApp fc (PRef fc sigmaTy) + where asType = elab' ina (Just fc) (PApp fc (PRef fc sigmaTy) [pexp t, - pexp (PLam n Placeholder r)]) - asValue = elab' ina (PApp fc (PRef fc existsCon) + pexp (PLam fc n Placeholder r)]) + asValue = elab' ina (Just fc) (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) + elab' ina _ (PDPair fc p l t r) = elab' ina (Just fc) (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) + elab' ina fc (PAlternative True as) = do hnf_compute ty <- goal ctxt <- get_context @@ -322,26 +389,35 @@ -- trace (-- show tc ++ " " ++ show as ++ "\n ==> " ++ -- show (length as') ++ "\n" ++ -- showSep ", " (map showTmImpls as') ++ "\nEND") $ - tryAll (zip (map (elab' ina) as') (map showHd as')) + tryAll (zip (map (elab' ina fc) as') (map showHd as')) where showHd (PApp _ (PRef _ n) _) = n showHd (PRef _ n) = n showHd (PApp _ h _) = showHd h showHd x = NErased -- We probably should do something better than this here - elab' ina (PAlternative False as) + elab' ina fc (PAlternative False as) = trySeq as where -- if none work, take the error from the first - trySeq (x : xs) = let e1 = elab' ina x in + trySeq (x : xs) = let e1 = elab' ina fc x in try' e1 (trySeq' e1 xs) True trySeq' deferr [] = proofFail deferr trySeq' deferr (x : xs) - = try' (elab' ina x) (trySeq' deferr xs) True - elab' ina (PPatvar fc n) | bindfree = do patvar n; -- update_term liftPats + = try' (do elab' ina fc x + solveAutos ist fn False) (trySeq' deferr xs) True + elab' ina _ (PPatvar fc n) | bindfree = do patvar n; update_term liftPats -- elab' (_, _, inty) (PRef fc f) -- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty -- = lift $ tfail (Msg "Typecase is not allowed") - elab' (ina, guarded, inty, qq) (PRef fc n) - | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not qq - = do ctxt <- get_context + elab' ec _ tm@(PRef fc n) + | pattern && not reflection && not (e_qq ec) && not (e_intype ec) + && isTConName n (tt_ctxt ist) + = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm) + | pattern && not reflection && e_nomatching ec + = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm) + | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec) + = do let ina = e_inarg ec + guarded = e_guarded ec + inty = e_intype ec + ctxt <- get_context let defined = case lookupTy n ctxt of [] -> False _ -> True @@ -351,16 +427,29 @@ else if (defined && not guarded) then do apply (Var n) []; solve else try (do apply (Var n) []; solve) - (do patvar n; ) -- update_term liftPats) + (do patvar n; update_term liftPats) where inparamBlock n = case lookupCtxtName n (inblock info) of [] -> False _ -> True bindable (NS _ _) = False bindable (UN xs) = True bindable n = implicitable n - elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f []) - elab' ina (PRef fc n) = erun fc $ do apply (Var n) []; solve - elab' ina@(_, a, inty, qq) (PLam n Placeholder sc) + elab' ina _ f@(PInferRef fc n) = elab' ina (Just fc) (PApp fc f []) + elab' ina fc' tm@(PRef fc n) + | pattern && not reflection && not (e_qq ina) && not (e_intype ina) + && isTConName n (tt_ctxt ist) + = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm) + | pattern && not reflection && e_nomatching ina + = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm) + | otherwise = + do fty <- get_type (Var n) -- check for implicits + ctxt <- get_context + env <- get_env + let a' = insertScopedImps fc (normalise ctxt env fty) [] + if null a' + then erun fc $ do apply (Var n) []; solve + else elab' ina fc' (PApp fc tm []) + elab' ina _ (PLam fc n Placeholder sc) = do -- if n is a type constructor name, this makes no sense... ctxt <- get_context when (isTConName n ctxt) $ @@ -368,8 +457,8 @@ checkPiGoal n attack; intro (Just n); -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) - elabE (True, a, inty, qq) sc; solve - elab' ina@(_, a, inty, qq) (PLam n ty sc) + elabE (ina { e_inarg = True } ) (Just fc) sc; solve + elab' ec _ (PLam fc n ty sc) = do tyn <- getNameFrom (sMN 0 "lamty") -- if n is a type constructor name, this makes no sense... ctxt <- get_context @@ -383,23 +472,27 @@ hs <- get_holes introTy (Var tyn) (Just n) focus tyn - elabE (True, a, True, qq) ty - elabE (True, a, inty, qq) sc + + elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty + elabE (ec { e_inarg = True }) (Just fc) sc solve - elab' ina@(_, a, _, qq) (PPi _ n Placeholder sc) - = do attack; arg n (sMN 0 "ty"); elabE (True, a, True, qq) sc; solve - elab' ina@(_, a, _, qq) (PPi _ n ty sc) + elab' ina fc (PPi p n Placeholder sc) + = do attack; arg n (is_scoped p) (sMN 0 "ty") + elabE (ina { e_inarg = True, e_intype = True }) fc sc + solve + elab' ina fc (PPi p n ty sc) = do attack; tyn <- getNameFrom (sMN 0 "ty") claim tyn RType n' <- case n of MN _ _ -> unique_hole n _ -> return n - forall n' (Var tyn) + forall n' (is_scoped p) (Var tyn) focus tyn - elabE (True, a, True, qq) ty - elabE (True, a, True, qq) sc + let ec' = ina { e_inarg = True, e_intype = True } + elabE ec' fc ty + elabE ec' fc sc solve - elab' ina@(_, a, inty, qq) (PLet n ty val sc) + elab' ina _ (PLet fc n ty val sc) = do attack ivs <- get_instances tyn <- getNameFrom (sMN 0 "letty") @@ -412,18 +505,19 @@ Placeholder -> return () _ -> do focus tyn explicit tyn - elabE (True, a, True, qq) ty + elabE (ina { e_inarg = True, e_intype = True }) + (Just fc) ty focus valn - elabE (True, a, True, qq) val + elabE (ina { e_inarg = True, e_intype = True }) + (Just fc) val ivs' <- get_instances env <- get_env - elabE (True, a, inty, qq) sc + elabE (ina { e_inarg = True }) (Just fc) sc when (not pattern) $ mapM_ (\n -> do focus n g <- goal hs <- get_holes if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g) - -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) then try (resolveTC True 7 g fn ist) (movelast n) else movelast n) @@ -433,7 +527,7 @@ expandLet n (case lookup n env of Just (Let t v) -> v) solve - elab' ina@(_, a, inty, qq) (PGoal fc r n sc) = do + elab' ina _ (PGoal fc r n sc) = do rty <- goal attack tyn <- getNameFrom (sMN 0 "letty") @@ -442,14 +536,14 @@ claim valn (Var tyn) letbind n (Var tyn) (Var valn) focus valn - elabE (True, a, True, qq) (PApp fc r [pexp (delab ist rty)]) + elabE (ina { e_inarg = True, e_intype = True }) (Just fc) (PApp fc r [pexp (delab ist rty)]) env <- get_env computeLet n - elabE (True, a, inty, qq) sc + elabE (ina { e_inarg = True }) (Just fc) sc solve --- elab' ina (PLet n Placeholder +-- elab' ina fc (PLet n Placeholder -- (PApp fc r [pexp (delab ist rty)]) sc) - elab' ina tm@(PApp fc (PInferRef _ f) args) = do + elab' ina _ tm@(PApp fc (PInferRef _ f) args) = do rty <- goal ds <- get_deferred ctxt <- get_context @@ -478,7 +572,7 @@ ans <- claimArgTys env xs return ((aval, (True, (Var an))) : ans) fnTy [] ret = forget ret - fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt RType) (fnTy xs ret) + fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi Nothing xt RType) (fnTy xs ret) localVar env (PRef _ x) = case lookup x env of @@ -486,7 +580,8 @@ _ -> Nothing localVar env _ = Nothing - elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def) + elabIArg ((n, (True, ty)), def) = + do focus n; elabE ina (Just fc) (getTm def) elabIArg _ = return () -- already done, just a name mkN n@(NS _ _) = n @@ -495,7 +590,7 @@ Just xs@(_:_) -> sNS n xs _ -> n - elab' ina (PMatchApp fc fn) + elab' ina _ (PMatchApp fc fn) = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of [(n, args)] -> return (n, map (const True) args) _ -> lift $ tfail (NoSuchVariable fn) @@ -507,12 +602,28 @@ -- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq -- = lift $ tfail (Msg "Typecase is not allowed") -- if f is local, just do a simple_app - elab' (ina, g, inty, qq) tm@(PApp fc (PRef _ f) args) + elab' ina _ tm@(PApp fc (PRef _ f) args_in) + | pattern && not reflection && e_nomatching ina + = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm) + | otherwise = do env <- get_env - if (f `elem` map fst env && length args == 1) + ty <- goal + fty <- get_type (Var f) + ctxt <- get_context + let args = insertScopedImps fc (normalise ctxt env fty) args_in + let unmatchableArgs = if pattern + then getUnmatchable (tt_ctxt ist) f + else [] + -- Dot it if we're in a pattern and it isn't a constructor +-- when (pattern && not (isDConName f ctxt) && f /= fn) $ dotterm + + when (pattern && not reflection && not (e_qq ina) && not (e_intype ina) + && isTConName f (tt_ctxt ist)) $ + lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm) + if (f `elem` map fst env && length args == 1 && length args_in == 1) then -- simple app, as below - do simple_app (elabE (ina, g, inty, qq) (PRef fc f)) - (elabE (True, g, inty, qq) (getTm (head args))) + do simple_app (elabE ina (Just fc) (PRef fc f)) + (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args))) (show tm) solve else @@ -528,7 +639,6 @@ _ -> do mapM_ setInjective (map getTm args) -- maybe more things are solvable now unifyProblems - ctxt <- get_context let guarded = isConName f ctxt -- trace ("args is " ++ show args) $ return () ns <- apply (Var f) (map isph args) @@ -541,21 +651,22 @@ let (ns', eargs) = unzip $ sortBy cmpArg (zip ns args) ulog <- getUnifyLog - elabArgs ist (ina || not isinf, guarded, inty, qq) - [] fc False f ns' + elabArgs ist (ina { e_inarg = e_inarg ina || not isinf }) + [] fc False f + (zip ns' (unmatchableArgs ++ repeat False)) (f == sUN "Force") (map (\x -> getTm x) eargs) -- TODO: remove this False arg solve ivs' <- get_instances -- Attempt to resolve any type classes which have 'complete' types, -- i.e. no holes in them - when (not pattern || (ina && not tcgen && not guarded)) $ + when (not pattern || (e_inarg ina && not tcgen && + not (e_guarded ina))) $ mapM_ (\n -> do focus n g <- goal env <- get_env hs <- get_holes if all (\n -> not (n `elem` hs)) (freeNames g) - -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) then try (resolveTC False 7 g fn ist) (movelast n) else movelast n) @@ -577,16 +688,18 @@ PAlternative False _ -> 5 PAlternative True _ -> 2 PTactics _ -> 150 - PLam _ _ _ -> 3 + PLam _ _ _ _ -> 3 PRewrite _ _ _ _ -> 4 PResolveTC _ -> 0 + PHidden _ -> 150 _ -> 1 constraint (PConstraint _ _ _ _) = True constraint _ = False -- Score a point for every level where there is a non-constructor - -- function (so higher score --> done later) + -- function (so higher score --> done later), and lots of points + -- if there is a PHidden since this should be unifiable. -- Only relevant when on lhs conDepth d t | not pattern = 0 conDepth d (PRef _ f) | isConName f (tt_ctxt ist) = 0 @@ -595,6 +708,7 @@ = 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 (PHidden _) = 150 conDepth d Placeholder = 0 conDepth d (PResolveTC _) = 0 conDepth d t = max (100 - d) 1 @@ -630,14 +744,15 @@ setInjective (PApp _ (PRef _ n) _) = setinj n setInjective _ = return () - elab' ina@(_, a, inty, qq) tm@(PApp fc f [arg]) + elab' ina _ tm@(PApp fc f [arg]) = erun fc $ - do simple_app (elabE ina f) (elabE (True, a, inty, qq) (getTm arg)) + do simple_app (elabE ina (Just fc) f) (elabE (ina { e_inarg = True }) (Just fc) (getTm arg)) (show tm) solve - elab' ina Placeholder = do (h : hs) <- get_holes - movelast h - elab' ina (PMetavar n) = + elab' ina fc Placeholder + = do (h : hs) <- get_holes + movelast h + elab' ina fc (PMetavar n) = do ptm <- get_term -- When building the metavar application, leave out the unique -- names which have been used elsewhere in the term, since we @@ -651,12 +766,12 @@ mkN n = case namespace info of Just xs@(_:_) -> sNS n xs _ -> n - elab' ina (PProof ts) = do compute; mapM_ (runTac True ist fn) ts - elab' ina (PTactics 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) + elab' ina fc (PProof ts) = do compute; mapM_ (runTac True ist (elabFC info) fn) ts + elab' ina fc (PTactics ts) + | not pattern = do mapM_ (runTac False ist fc fn) ts + | otherwise = elab' ina fc Placeholder + elab' ina fc (PElabError e) = lift $ tfail e + elab' ina _ (PRewrite fc r sc newg) = do attack tyn <- getNameFrom (sMN 0 "rty") claim tyn RType @@ -665,14 +780,14 @@ letn <- getNameFrom (sMN 0 "_rewrite_rule") letbind letn (Var tyn) (Var valn) focus valn - elab' ina r + elab' ina (Just fc) r compute g <- goal rewrite (Var letn) g' <- goal when (g == g') $ lift $ tfail (NoRewriting g) case newg of - Nothing -> elab' ina sc + Nothing -> elab' ina (Just fc) sc Just t -> doEquiv t sc solve where doEquiv t sc = @@ -684,12 +799,12 @@ letn <- getNameFrom (sMN 0 "equiv_val") letbind letn (Var tyn) (Var valn) focus tyn - elab' ina t + elab' ina (Just fc) t focus valn - elab' ina sc - elab' ina (PRef fc letn) + elab' ina (Just fc) sc + elab' ina (Just fc) (PRef fc letn) solve - elab' ina@(_, a, inty, qq) c@(PCase fc scr opts) + elab' ina _ c@(PCase fc scr opts) = do attack tyn <- getNameFrom (sMN 0 "scty") claim tyn RType @@ -698,7 +813,7 @@ claim valn (Var tyn) letbind scvn (Var tyn) (Var valn) focus valn - elabE (True, a, inty, qq) scr + elabE (ina { e_inarg = True }) (Just fc) scr -- Solve any remaining implicits - we need to solve as many -- as possible before making the 'case' type unifyProblems @@ -714,7 +829,7 @@ cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname --- elab' ina (PMetavar cname') +-- elab' ina fc (PMetavar cname') attack; defer argsDropped cname'; solve -- if the scrutinee is one of the 'args' in env, we should @@ -723,7 +838,7 @@ (caseBlock fc cname' (map (isScr scr) (reverse args')) opts) -- elaborate case - updateAux (newdef : ) + updateAux (\e -> e { case_decls = newdef : case_decls e } ) -- if we haven't got the type yet, hopefully we'll get it later! movelast tyn solve @@ -760,26 +875,10 @@ = n `elem` ns || any (\x -> x `elem` ns) (allTTNames (binderTy b)) - -- FIXME: This probably doesn't help us here, but leaving - -- it in temporarily... if this comment is still here in master, - -- please delete the code! - chaseDeps env acc [] = filter (\(n, _) -> n `elem` acc) env - chaseDeps env acc ((n,b) : args) - = let ns = allTTNames (binderTy b) in - extendAcc ns acc args - where - extendAcc [] acc args = chaseDeps env acc args - extendAcc (n:ns) acc args - | elem n acc = extendAcc ns acc args - | otherwise = case lookup n env of - Just b -> extendAcc ns (n : acc) - ((n,b) : args) - Nothing -> extendAcc ns acc args - - elab' ina (PUnifyLog t) = do unifyLog True - elab' ina t - unifyLog False - elab' (ina, g, inty, qq) (PQuasiquote t goal) -- TODO: goal type + elab' ina fc (PUnifyLog t) = do unifyLog True + elab' ina fc t + unifyLog False + elab' ina fc (PQuasiquote t goal) -- TODO: goal type = do -- First extract the unquoted subterms, replacing them with fresh -- names in the quasiquoted term. Claim their reflections to be -- of type TT. @@ -824,11 +923,11 @@ case goal of Nothing -> return () Just gTy -> do focus qTy - elabE (ina, g, inty, True) gTy + elabE (ina { e_qq = True }) fc gTy -- Elaborate the quasiquoted term into the hole focus qTm - elabE (ina, g, inty, True) t + elabE (ina { e_qq = True }) fc t end_unify -- We now have an elaborated term. Reflect it and solve the @@ -854,12 +953,29 @@ elabUnquote (n, tm) = do focus n - elabE (ina, g, inty, False) tm + elabE (ina { e_qq = False }) fc tm - elab' ina (PUnquote t) = fail "Found unquote outside of quasiquote" - elab' ina x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x + elab' ina fc (PUnquote t) = fail "Found unquote outside of quasiquote" + elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here" + elab' ina fc (PHidden t) + | reflection = elab' ina fc t + | otherwise + = do (h : hs) <- get_holes + -- Dotting a hole means that either the hole or any outer + -- hole (a hole outside any occurrence of it) + -- must be solvable by unification as well as being filled + -- in directly. + -- Delay dotted things to the end, then when we elaborate them + -- we can check the result against what was inferred + movelast h + delayElab $ do focus h + dotterm + elab' ina fc t + elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x + delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] }) + isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term)) isScr (PRef _ n) (n', b) = (n', (n == n', b)) isScr _ (n', b) = (n', (False, b)) @@ -943,6 +1059,27 @@ notImplicitable (PCase _ _ _) = True notImplicitable _ = False + insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs + | tcinstance i + = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs + | otherwise + = pimp n Placeholder True : insertScopedImps fc sc xs + insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs) + = x : insertScopedImps fc sc xs + insertScopedImps _ _ xs = xs + + insertImpLam t = + do ty <- goal + env <- get_env + let ty' = normalise (tt_ctxt ist) env ty + addLam ty' t + where + -- just one level at a time + addLam (Bind n (Pi (Just _) _ _) sc) t + = do impn <- unique_hole (sMN 0 "imp") + return (PLam emptyFC impn Placeholder t) + addLam _ t = return t + insertCoerce ina t@(PCase _ _ _) = return t insertCoerce ina t | notImplicitable t = return t insertCoerce ina t = @@ -965,22 +1102,28 @@ -- | Elaborate the arguments to a function elabArgs :: IState -- ^ The current Idris state - -> (Bool, Bool, Bool, Bool) -- ^ (in an argument, guarded, in a type, in a qquote) + -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote) -> [Bool] -> FC -- ^ Source location -> Bool -> Name -- ^ Name of the function being applied - -> [(Name, Name)] -- ^ (Argument Name, Hole Name) + -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable) -> Bool -- ^ under a 'force' - -> [PTerm] -- ^ (Laziness, argument) + -> [PTerm] -- ^ argument -> ElabD () 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 (t : args) - = elabArg argName holeName t - where elabArg argName holeName t = - do now_elaborating fc f argName + elabArgs ist ina failed fc r f (((argName, holeName), unm):ns) force (t : args) + = do hs <- get_holes + if holeName `elem` hs then + do focus holeName + case t of + Placeholder -> do movelast holeName + elabArgs ist ina failed fc r f ns force args + _ -> elabArg t + else elabArgs ist ina failed fc r f ns force args + where elabArg t = + do -- solveAutos ist fn False + now_elaborating fc f argName wrapErr f argName $ do hs <- get_holes tm <- get_term @@ -989,13 +1132,14 @@ 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; - g <- goal - ulog <- getUnifyLog - traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $ - elab ina t; return failed - False -> return failed + do focus holeName; + g <- goal + -- Can't pattern match on polymorphic goals + poly <- goal_polymorphic + ulog <- getUnifyLog + traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $ + elab (ina { e_nomatching = unm && poly }) (Just fc) t + return failed done_elaborating_arg f argName elabArgs ist ina failed fc r f ns force args wrapErr f argName action = @@ -1049,6 +1193,7 @@ | otherwise = locallyBound ts getName (PRef _ n) = Just n getName (PApp _ f _) = getName f + getName (PHidden t) = getName t getName _ = Nothing pruneByType env (P _ n _) ctxt as @@ -1066,6 +1211,7 @@ headIs var f (PApp _ (PRef _ f') _) = typeHead var f f' headIs var f (PApp _ f' _) = headIs var f f' headIs var f (PPi _ _ _ sc) = headIs var f sc + headIs var f (PHidden t) = headIs var f t headIs _ _ _ = True -- keep if it's not an application typeHead var f f' @@ -1090,20 +1236,39 @@ _ -> [] | otherwise = [] +-- Try again to solve auto implicits +solveAuto :: IState -> Name -> Bool -> Name -> ElabD () +solveAuto ist fn ambigok n + = do hs <- get_holes + when (n `elem` hs) $ do + focus n + g <- goal + isg <- is_guess -- if it's a guess, we're working on it recursively, so stop + when (not isg) $ + proofSearch' ist True ambigok 100 True Nothing fn [] + +solveAutos :: IState -> Name -> Bool -> ElabD () +solveAutos ist fn ambigok + = do autos <- get_autos + mapM_ (solveAuto ist fn ambigok) (map fst autos) + trivial' ist = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist -proofSearch' ist rec depth prv top n hints +proofSearch' ist rec ambigok depth prv top n hints = do unifyProblems - proofSearch rec prv depth + proofSearch rec prv ambigok (not prv) depth (elab ist toplevel ERHS [] (sMN 0 "tac")) top n hints ist +-- Resolve type classes. This will only pick up 'normal' instances, never +-- named instances (hence using 'tcname' to check it's a generated instance +-- name). resolveTC :: Bool -> Int -> Term -> Name -> IState -> ElabD () resolveTC = resTC' [] resTC' tcs def 0 topg fn ist = fail $ "Can't resolve type class" resTC' tcs def 1 topg fn ist = try' (trivial' ist) (resolveTC def 0 topg fn ist) True resTC' tcs defaultOn depth topg fn ist - = do hnf_compute + = do compute g <- goal ptm <- get_term ulog <- getUnifyLog @@ -1113,12 +1278,13 @@ (do t <- goal let (tc, ttypes) = unApply t scopeOnly <- needsDefault t tc ttypes + let stk = elab_stack ist let insts_in = findInstances ist t let insts = if scopeOnly then filter chaser insts_in else insts_in tm <- get_term let depth' = if scopeOnly then 2 else depth - blunderbuss t depth' insts) True + blunderbuss t depth' stk (stk ++ insts)) True where elabTC n | n /= fn && tcname n = (resolve n depth, show n) | otherwise = (fail "Can't resolve", show n) @@ -1145,13 +1311,13 @@ boundVar (P Bound _ _) = True boundVar _ = False - blunderbuss t d [] = do -- c <- get_env + blunderbuss t d stk [] = do -- c <- get_env -- ps <- get_probs lift $ tfail $ CantResolve topg - blunderbuss t d (n:ns) - | n /= fn && tcname n = try' (resolve n d) - (blunderbuss t d ns) True - | otherwise = blunderbuss t d ns + blunderbuss t d stk (n:ns) + | n /= fn && (n `elem` stk || tcname n) + = try' (resolve n d) (blunderbuss t d stk ns) True + | otherwise = blunderbuss t d stk ns resolve n depth | depth == 0 = fail $ "Can't resolve type class" @@ -1227,8 +1393,8 @@ -- Running tactics directly -- if a tactic adds unification problems, return an error -runTac :: Bool -> IState -> Name -> PTactic -> ElabD () -runTac autoSolve ist fn tac +runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD () +runTac autoSolve ist perhapsFC fn tac = do env <- get_env g <- goal let tac' = fmap (addImplBound ist (map fst env)) tac @@ -1347,7 +1513,7 @@ runT Trivial = do trivial' ist; when autoSolve solveAll runT TCInstance = runT (Exact (PResolveTC emptyFC)) runT (ProofSearch rec prover depth top hints) - = do proofSearch' ist rec depth prover top fn hints + = do proofSearch' ist rec False depth prover top fn hints when autoSolve solveAll runT (Focus n) = focus n runT Solve = solve @@ -1381,9 +1547,9 @@ where tacticTy = Var (reflm "Tactic") listTy = Var (sNS (sUN "List") ["List", "Prelude"]) scriptTy = (RBind (sMN 0 "__pi_arg") - (Pi (RApp listTy envTupleType) RType) + (Pi Nothing (RApp listTy envTupleType) RType) (RBind (sMN 1 "__pi_arg") - (Pi (Var $ reflm "TT") RType) tacticTy)) + (Pi Nothing (Var $ reflm "TT") RType) tacticTy)) runT (ByReflection tm) -- run the reflection function 'tm' on the -- goal, then apply the resulting reflected Tactic = do tgoal <- goal @@ -1427,7 +1593,7 @@ ctxt <- get_context env <- get_env let value' = hnf ctxt env value - runTac autoSolve ist fn (Exact $ PQuote (reflect value')) + runTac autoSolve ist perhapsFC fn (Exact $ PQuote (reflect value')) runT (Fill v) = do attack -- let x = fill x in ... tyn <- getNameFrom (sMN 0 "letty") claim tyn RType @@ -1442,7 +1608,7 @@ env <- get_env let value' = normalise ctxt env value rawValue <- reifyRaw value' - runTac autoSolve ist fn (Exact $ PQuote rawValue) + runTac autoSolve ist perhapsFC fn (Exact $ PQuote rawValue) runT (GoalType n tac) = do g <- goal case unApply g of (P _ n' _, _) -> @@ -1454,10 +1620,31 @@ return () runT Skip = return () runT (TFail err) = lift . tfail $ ReflectionError [err] (Msg "") + runT SourceFC = + case perhapsFC of + Nothing -> lift . tfail $ Msg "There is no source location available." + Just fc -> + do let intTy = RConstant (AType (ATInt ITNative)) + fill $ raw_apply (Var (reflm "FileLoc")) + [ RConstant (Str (fc_fname fc)) + , raw_apply (Var pairCon) $ + [intTy, intTy] ++ + map (RConstant . I) + [ fst (fc_start fc) + , snd (fc_start fc) + ] + , raw_apply (Var pairCon) $ + [intTy, intTy] ++ + map (RConstant . I) + [ fst (fc_end fc) + , snd (fc_end fc) + ] + ] + solve runT x = fail $ "Not implemented " ++ show x runReflected t = do t' <- reify ist t - runTac autoSolve ist fn t' + runTac autoSolve ist perhapsFC fn t' -- | Prefix a name with the "Language.Reflection" namespace reflm :: String -> Name @@ -1472,6 +1659,7 @@ reify _ (P _ n _) | n == reflm "Solve" = return Solve reify _ (P _ n _) | n == reflm "Compute" = return Compute reify _ (P _ n _) | n == reflm "Skip" = return Skip +reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC reify ist t@(App _ _) | (P _ f _, args) <- unApply t = reifyApp ist f args reify _ t = fail ("Unknown tactic " ++ show t) @@ -1634,7 +1822,7 @@ reifyTTBinderApp reif f [t] | f == reflm "Lam" = liftM Lam (reif t) reifyTTBinderApp reif f [t, k] - | f == reflm "Pi" = liftM2 Pi (reif t) (reif k) + | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k) reifyTTBinderApp reif f [x, y] | f == reflm "Let" = liftM2 Let (reif x) (reif y) reifyTTBinderApp reif f [x, y] @@ -1777,7 +1965,7 @@ fill $ reflCall "Lam" [Var (reflm "TT"), Var t'] solve focus t'; reflectQuotePattern unq t - reflectBinderQuotePattern unq (Pi t k) + reflectBinderQuotePattern unq (Pi _ t k) = do t' <- claimTT (sMN 0 "ty") ; movelast t' k' <- claimTT (sMN 0 "k"); movelast k'; fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k'] @@ -1927,7 +2115,7 @@ reflectBinderQuote :: [Name] -> Binder Term -> Raw reflectBinderQuote unq (Lam t) = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t] -reflectBinderQuote unq (Pi t k) +reflectBinderQuote unq (Pi _ t k) = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t, reflectQuote unq k] reflectBinderQuote unq (Let x y) = reflCall "Let" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y] @@ -2079,6 +2267,8 @@ reflectErr (TooManyArguments n) = raw_apply (Var $ reflErrName "TooManyArguments") [reflectName n] reflectErr (CantIntroduce t) = raw_apply (Var $ reflErrName "CantIntroduce") [reflect t] reflectErr (NoSuchVariable n) = raw_apply (Var $ reflErrName "NoSuchVariable") [reflectName n] +reflectErr (WithFnType t) = raw_apply (Var $ reflErrName "WithFnType") [reflect t] +reflectErr (CantMatch t) = raw_apply (Var $ reflErrName "CantMatch") [reflect t] reflectErr (NoTypeDecl n) = raw_apply (Var $ reflErrName "NoTypeDecl") [reflectName n] reflectErr (NotInjective t1 t2 t3) = raw_apply (Var $ reflErrName "NotInjective") @@ -2190,7 +2380,7 @@ Right (TextPart msg) reifyReportPart (App (P (DCon _ _ _) n _) ttn) | n == reflm "NamePart" = - case runElab [] (reifyTTName ttn) (initElaborator NErased initContext Erased) of + case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $ "could not reify name term " ++ show ttn ++ @@ -2198,7 +2388,7 @@ OK (n', _)-> Right $ NamePart n' reifyReportPart (App (P (DCon _ _ _) n _) tm) | n == reflm "TermPart" = - case runElab [] (reifyTT tm) (initElaborator NErased initContext Erased) of + case runElab initEState (reifyTT tm) (initElaborator NErased initContext Erased) of Error e -> Left . InternalMsg $ "could not reify reflected term " ++ show tm ++ diff --git a/src/Idris/Erasure.hs b/src/Idris/Erasure.hs --- a/src/Idris/Erasure.hs +++ b/src/Idris/Erasure.hs @@ -300,7 +300,7 @@ casedVar = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs) getDepsAlt :: Name -> [Name] -> Vars -> VarInfo -> CaseAlt -> Deps - getDepsAlt fn es vs var (FnCase n ns sc) = error "an FnCase encountered" -- TODO: what's this? + getDepsAlt fn es vs var (FnCase n ns sc) = M.empty -- can't use FnCase at runtime getDepsAlt fn es vs var (ConstCase c sc) = getDepsSC fn es vs sc getDepsAlt fn es vs var (DefaultCase sc) = getDepsSC fn es vs sc getDepsAlt fn es vs var (SucCase n sc) @@ -354,7 +354,7 @@ -- here we just push IM.empty on the de bruijn stack -- the args will be marked as used at the usage site | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body - | Pi ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body + | Pi _ ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body -- let-bound variables can get partially evaluated -- it is sufficient just to plug the Cond in when the bound names are used diff --git a/src/Idris/Error.hs b/src/Idris/Error.hs --- a/src/Idris/Error.hs +++ b/src/Idris/Error.hs @@ -17,7 +17,7 @@ import System.Console.Haskeline.MonadException import Control.Monad (when) import Control.Monad.State.Strict -import Control.Monad.Error (throwError, catchError) +import Control.Monad.Except (throwError, catchError) import System.IO.Error(isUserError, ioeGetErrorString) import Data.Char import Data.List (intercalate, isPrefixOf) @@ -28,8 +28,10 @@ iucheck :: Idris () iucheck = do tit <- typeInType + ist <- getIState + let cs = idris_constraints ist + logLvl 7 $ "ALL CONSTRAINTS: " ++ show cs when (not tit) $ - do ist <- getIState (tclift $ ucheck (idris_constraints ist)) `idrisCatch` (\e -> do setErrSpan (getErrSpan e) iputStrLn (pshow ist e)) @@ -87,9 +89,9 @@ warnDisamb ist (PRef _ _) = return () warnDisamb ist (PInferRef _ _) = return () warnDisamb ist (PPatvar _ _) = return () -warnDisamb ist (PLam _ t b) = warnDisamb ist t >> warnDisamb ist b +warnDisamb ist (PLam _ _ t b) = warnDisamb ist t >> warnDisamb ist b warnDisamb ist (PPi _ _ t b) = warnDisamb ist t >> warnDisamb ist b -warnDisamb ist (PLet _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b +warnDisamb ist (PLet _ _ x t b) = warnDisamb ist x >> warnDisamb ist t >> warnDisamb ist b warnDisamb ist (PTyped x t) = warnDisamb ist x >> warnDisamb ist t warnDisamb ist (PApp _ t args) = warnDisamb ist t >> mapM_ (warnDisamb ist . getTm) args @@ -145,3 +147,4 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >> Foldable.mapM_ (warnDisamb ist) goal warnDisamb ist (PUnquote tm) = warnDisamb ist tm +warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm diff --git a/src/Idris/Help.hs b/src/Idris/Help.hs --- a/src/Idris/Help.hs +++ b/src/Idris/Help.hs @@ -1,9 +1,10 @@ -module Idris.Help (CmdArg(..), help, extraHelp) where +module Idris.Help (CmdArg(..), extraHelp) where data CmdArg = ExprArg -- ^ The command takes an expression | NameArg -- ^ The command takes a name | FileArg -- ^ The command takes a file | ModuleArg -- ^ The command takes a module name + | PkgArgs -- ^ The command takes a list of package names | NumberArg -- ^ The command takes a number | NamespaceArg -- ^ The command takes a namespace name | OptionArg -- ^ The command takes an option @@ -22,6 +23,7 @@ show NameArg = "" show FileArg = "" show ModuleArg = "" + show PkgArgs = "" show NumberArg = "" show NamespaceArg = "" show OptionArg = "