idris 0.9.5.1 → 0.9.6
raw patch · 89 files changed
+4443/−1588 lines, 89 filesdep +splitdep ~parsecsetup-changed
Dependencies added: split
Dependency ranges changed: parsec
Files
- Setup.hs +18/−8
- idris.cabal +7/−4
- lib/Builtins.idr +23/−6
- lib/Control/Arrow.idr +21/−3
- lib/Control/Category.idr +11/−5
- lib/Control/Monad/Identity.idr +11/−1
- lib/Control/Monad/State.idr +17/−4
- lib/Data/Bits.idr +25/−0
- lib/Data/Morphisms.idr +45/−0
- lib/Data/Word.idr +19/−0
- lib/Debug/Trace.idr +8/−0
- lib/IO.idr +5/−5
- lib/Language/Reflection.idr +10/−2
- lib/Network/Cgi.idr +14/−3
- lib/Prelude.idr +70/−30
- lib/Prelude/Applicative.idr +35/−2
- lib/Prelude/Chars.idr +3/−0
- lib/Prelude/Complex.idr +1/−1
- lib/Prelude/Fin.idr +15/−4
- lib/Prelude/Functor.idr +4/−0
- lib/Prelude/Heap.idr +4/−2
- lib/Prelude/List.idr +8/−6
- lib/Prelude/Maybe.idr +26/−0
- lib/Prelude/Monad.idr +4/−31
- lib/Prelude/Morphisms.idr +0/−7
- lib/Prelude/Nat.idr +6/−6
- lib/Prelude/Strings.idr +33/−8
- lib/Prelude/Vect.idr +22/−1
- lib/System/Concurrency/Process.idr +69/−0
- lib/System/Concurrency/Raw.idr +2/−0
- lib/base.ipkg +5/−2
- rts/Makefile +1/−1
- rts/idris_gc.c +18/−24
- rts/idris_gc.h +2/−2
- rts/idris_gmp.c +64/−15
- rts/idris_gmp.h +4/−0
- rts/idris_main.c +2/−2
- rts/idris_rts.c +91/−55
- rts/idris_rts.h +31/−15
- rts/idris_stdfgn.c +10/−1
- rts/libidris_rts.a binary
- src/Core/CaseTree.hs +80/−35
- src/Core/Constraints.hs +61/−61
- src/Core/CoreParser.hs +402/−8
- src/Core/Elaborate.hs +80/−21
- src/Core/Evaluate.hs +111/−95
- src/Core/ProofShell.hs +1/−1
- src/Core/ProofState.hs +83/−46
- src/Core/TT.hs +72/−28
- src/Core/Typecheck.hs +54/−36
- src/Core/Unify.hs +46/−18
- src/IRTS/Bytecode.hs +10/−4
- src/IRTS/CodegenC.hs +118/−41
- src/IRTS/CodegenCommon.hs +22/−0
- src/IRTS/CodegenJava.hs +4/−2
- src/IRTS/CodegenJavaScript.hs +501/−0
- src/IRTS/Compiler.hs +100/−34
- src/IRTS/Defunctionalise.hs +124/−60
- src/IRTS/DumpBC.hs +76/−0
- src/IRTS/LParser.hs +20/−13
- src/IRTS/Lang.hs +24/−10
- src/IRTS/Simplified.hs +20/−0
- src/Idris/AbsSyntax.hs +199/−120
- src/Idris/AbsSyntaxTree.hs +164/−87
- src/Idris/Compiler.hs +1/−1
- src/Idris/Coverage.hs +58/−39
- src/Idris/Delaborate.hs +14/−8
- src/Idris/Docs.hs +113/−0
- src/Idris/ElabDecls.hs +388/−238
- src/Idris/ElabTerm.hs +190/−63
- src/Idris/Error.hs +6/−0
- src/Idris/IBC.hs +123/−38
- src/Idris/Imports.hs +4/−4
- src/Idris/Parser.hs +200/−124
- src/Idris/Primitives.hs +62/−9
- src/Idris/Prover.hs +4/−4
- src/Idris/REPL.hs +50/−12
- src/Idris/REPLParser.hs +7/−3
- src/Idris/Unlit.hs +2/−1
- src/Main.hs +17/−13
- src/Pkg/PParser.hs +1/−1
- src/Pkg/Package.hs +32/−37
- src/Util/System.hs +24/−6
- tutorial/examples/binary.idr +2/−2
- tutorial/examples/idiom.idr +1/−1
- tutorial/examples/interp.idr +4/−4
- tutorial/examples/theorems.idr +1/−1
- tutorial/examples/universe.idr +2/−2
- tutorial/examples/views.idr +1/−1
Setup.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} import Distribution.Simple import Distribution.Simple.InstallDirs as I import Distribution.Simple.LocalBuildInfo as L@@ -6,30 +7,41 @@ import Distribution.PackageDescription import System.Exit-import System.FilePath ((</>))+import System.FilePath ((</>), splitDirectories)+import qualified System.FilePath.Posix as Px import System.Process -- After Idris is built, we need to check and install the prelude and other libs make verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "make" +#ifdef mingw32_HOST_OS+-- make on mingw32 exepects unix style separators+(<//>) = (Px.</>)+idrisCmd local = Px.joinPath $ splitDirectories $ + ".." <//> buildDir local <//> "idris" <//> "idris"+#else+idrisCmd local = ".." </> buildDir local </> "idris" </> "idris"+#endif+ cleanStdLib verbosity = make verbosity [ "-C", "lib", "clean" ] installStdLib pkg local verbosity copy = do let dirs = L.absoluteInstallDirs pkg local copy let idir = datadir dirs- let icmd = ".." </> buildDir local </> "idris" </> "idris"+ let icmd = idrisCmd local putStrLn $ "Installing libraries in " ++ idir make verbosity [ "-C", "lib", "install" , "TARGET=" ++ idir , "IDRIS=" ++ icmd ]- putStrLn $ "Installing run time system in " ++ idir ++ "/rts"+ let idirRts = idir </> "rts"+ putStrLn $ "Installing run time system in " ++ idirRts make verbosity [ "-C", "rts", "install"- , "TARGET=" ++ idir ++ "/rts"+ , "TARGET=" ++ idirRts , "IDRIS=" ++ icmd ] @@ -39,14 +51,14 @@ -- the file after configure. removeLibIdris local verbosity- = do let icmd = ".." </> buildDir local </> "idris" </> "idris"+ = do let icmd = idrisCmd local make verbosity [ "-C", "rts", "clean" , "IDRIS=" ++ icmd ] checkStdLib local verbosity- = do let icmd = ".." </> buildDir local </> "idris" </> "idris"+ = do let icmd = idrisCmd local putStrLn $ "Building libraries..." make verbosity [ "-C", "lib", "check"@@ -73,5 +85,3 @@ , postBuild = \ _ flags _ lbi -> do checkStdLib lbi (S.fromFlag $ S.buildVerbosity flags) }--
idris.cabal view
@@ -1,5 +1,5 @@ Name: idris-Version: 0.9.5.1+Version: 0.9.6 License: BSD3 License-file: LICENSE Author: Edwin Brady@@ -51,6 +51,7 @@ lib/Network/*.idr lib/Control/*.idr lib/Control/Monad/*.idr lib/Language/*.idr lib/System/Concurrency/*.idr+ lib/Data/*.idr lib/Debug/*.idr tutorial/examples/*.idr lib/base.ipkg config.mk rts/*.c rts/*.h rts/Makefile@@ -75,7 +76,7 @@ Idris.Compiler, Idris.Prover, Idris.ElabTerm, Idris.Coverage, Idris.IBC, Idris.Unlit, Idris.DataOpts, Idris.Transforms, Idris.DSL, - Idris.UnusedArgs,+ Idris.UnusedArgs, Idris.Docs, Util.Pretty, Util.System, Pkg.Package, Pkg.PParser,@@ -83,11 +84,13 @@ IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified, IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner, IRTS.Compiler, IRTS.CodegenJava, IRTS.BCImp,+ IRTS.CodegenJavaScript,+ IRTS.CodegenCommon, IRTS.DumpBC Paths_idris - Build-depends: base>=4 && <5, parsec, mtl, Cabal, - haskeline>=0.7,+ Build-depends: base>=4 && <5, parsec>=3, mtl, Cabal, + haskeline>=0.7, split, directory, containers, process, transformers, filepath, directory, binary, bytestring, pretty
lib/Builtins.idr view
@@ -1,24 +1,27 @@ %access public %default total -data Exists : (a : Set) -> (P : a -> Set) -> Set where- Ex_intro : {P : a -> Set} -> (x : a) -> P x -> Exists a P+data Exists : (a : Type) -> (P : a -> Type) -> Type where+ Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists a P -getWitness : {P : a -> Set} -> Exists a P -> a+getWitness : {P : a -> Type} -> Exists a P -> a getWitness (a ** v) = a -getProof : {P : a -> Set} -> (s : Exists a P) -> P (getWitness s)+getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s) getProof (a ** v) = v FalseElim : _|_ -> a -- For rewrite tactic-replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Set} -> x = y -> P x -> P y+replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y replace refl prf = prf sym : {l:a} -> {r:a} -> l = r -> r = l sym refl = refl +trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c+trans refl refl = refl+ lazy : a -> a lazy x = x -- compiled specially @@ -31,6 +34,7 @@ trace_malloc : a -> a trace_malloc x = x -- compiled specially +abstract believe_me : a -> b -- compiled specially as id, use with care! believe_me x = prim__believe_me _ _ x @@ -39,6 +43,9 @@ id : a -> a id x = x +the : (a : Type) -> a -> a+the _ = id+ const : a -> b -> a const x _ = x @@ -70,7 +77,7 @@ boolElim True t e = t boolElim False t e = e -data so : Bool -> Set where oh : so True+data so : Bool -> Type where oh : so True syntax if [test] then [t] else [e] = boolElim test t e syntax [test] "?" [t] ":" [e] = if test then t else e@@ -126,6 +133,12 @@ instance Eq String where (==) = boolOp prim__eqString +instance Eq Bool where+ True == True = True+ True == False = False+ False == True = False+ False == False = True+ instance (Eq a, Eq b) => Eq (a, b) where (==) (a, c) (b, d) = (a == b) && (c == d) @@ -241,6 +254,10 @@ partial div : Int -> Int -> Int div = prim__divInt++partial+mod : Int -> Int -> Int+mod = prim__modInt (/) : Float -> Float -> Float
lib/Control/Arrow.idr view
@@ -1,21 +1,39 @@ module Category.Arrow -import Prelude.Morphisms+import Data.Morphisms import Control.Category +%access public+ infixr 3 *** infixr 3 &&& -class Category arr => Arrow (arr : Set -> Set -> Set) where+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) (***) : arr a b -> arr a' b' -> arr (a, a') (b, b') (&&&) : arr a b -> arr a b' -> arr a (b, b') -instance Arrow Morphism where+instance Arrow Homomorphism where arrow f = Homo f first (Homo f) = Homo $ \(a, b) => (f a, b) second (Homo f) = Homo $ \(a, b) => (a, f b) (Homo f) *** (Homo g) = Homo $ \(a, b) => (f a, g b) (Homo f) &&& (Homo g) = Homo $ \a => (f a, g a)++instance Monad m => Arrow (Kleislimorphism m) where+ arrow f = Kleisli (return . f)+ first (Kleisli f) = Kleisli $ \(a, b) => do x <- f a+ return (x, b)++ second (Kleisli f) = Kleisli $ \(a, b) => do x <- f b+ return (a, x)++ (Kleisli f) *** (Kleisli g) = Kleisli $ \(a, b) => do x <- f a+ y <- g b+ return (x, y)++ (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a+ y <- g a+ return (x, y)
lib/Control/Category.idr view
@@ -1,14 +1,20 @@ module Control.Category -import Prelude.Morphisms+import Data.Morphisms -class Category (cat : Set -> Set -> Set) where+%access public++class Category (cat : Type -> Type -> Type) where id : cat a a (.) : cat b c -> cat a b -> cat a c -instance Category Morphism where- id = Homo Builtins.id- (Homo f) . (Homo g) = Homo $ Builtins.(.) f g+instance Category Homomorphism where+ id = Homo Builtins.id+ (Homo f) . (Homo g) = Homo (f . g)++instance Monad m => Category (Kleislimorphism m) where+ id = Kleisli (return . id)+ (Kleisli f) . (Kleisli g) = Kleisli $ \a => g a >>= f infixr 1 >>> (>>>) : Category cat => cat a b -> cat b c -> cat a c
lib/Control/Monad/Identity.idr view
@@ -1,9 +1,19 @@ module Control.Monad.Identity +import Prelude.Functor+import Prelude.Applicative import Prelude.Monad -public record Identity : Set -> Set where+public record Identity : Type -> Type where Id : (runIdentity : a) -> Identity a++instance Functor Identity where+ fmap fn (Id a) = Id (fn a)++instance Applicative Identity where+ pure x = Id x+ + (Id f) <$> (Id g) = Id (f g) instance Monad Identity where return x = Id x
lib/Control/Monad/State.idr view
@@ -2,17 +2,30 @@ import Control.Monad.Identity import Prelude.Monad+import Prelude.Functor %access public -class Monad m => MonadState s (m : Set -> Set) where+class Monad m => MonadState s (m : Type -> Type) where get : m s put : s -> m () -record StateT : Set -> (Set -> Set) -> Set -> Set where- ST : {m : Set -> Set} ->+record StateT : Type -> (Type -> Type) -> Type -> Type where+ ST : {m : Type -> Type} -> (runStateT : s -> m (a, s)) -> StateT s m a +instance Functor f => Functor (StateT s f) where+ fmap f (ST g) = ST (\st => fmap (mapFst f) (g st)) where+ mapFst : (a -> x) -> (a, b) -> (x, b)+ mapFst fn (a, b) = (fn a, b)++instance Monad f => Applicative (StateT s f) where+ pure x = ST (\st => pure (x, st))++ (ST f) <$> (ST a) = ST (\st => do (g, r) <- f st+ (b, t) <- a r+ return (g b, t))+ instance Monad m => Monad (StateT s m) where return x = ST (\st => return (x, st)) @@ -24,6 +37,6 @@ get = ST (\x => return (x, x)) put x = ST (\y => return ((), x)) -State : Set -> Set -> Set+State : Type -> Type -> Type State s a = StateT s Identity a
+ lib/Data/Bits.idr view
@@ -0,0 +1,25 @@+module Data.Bits++%access public+%default partial++infixl 5 .|.+infixl 7 .&.++class Num a => Bits a where+ (.|.) : a -> a -> a+ (.&.) : a -> a -> a++ xor : a -> a -> a+ complement : a -> a+ shiftL : a -> Int -> a+ shiftR : a -> Int -> a++instance Bits Int where+ (.|.) = prim__orInt+ (.&.) = prim__andInt++ xor = prim__xorInt+ complement = prim__complInt+ shiftL = prim__shLInt+ shiftR = prim__shRInt
+ lib/Data/Morphisms.idr view
@@ -0,0 +1,45 @@+module Data.Morphisms++import Builtins++%access public++data Homomorphism : Type -> Type -> Type where+ Homo : (a -> b) -> Homomorphism a b++data Endomorphism : Type -> Type where+ Endo : (a -> a) -> Endomorphism a++data Kleislimorphism : (Type -> Type) -> Type -> Type -> Type where+ Kleisli : Monad m => (a -> m b) -> Kleislimorphism m a b++applyKleisli : Monad m => (Kleislimorphism m a b) -> a -> m b+applyKleisli (Kleisli f) a = f a++applyHomo : Homomorphism a b -> a -> b+applyHomo (Homo f) a = f a++applyEndo : Endomorphism a -> a -> a+applyEndo (Endo f) a = f a++instance Functor (Homomorphism r) where+ fmap f (Homo a) = Homo (f . a)++instance Applicative (Homomorphism r) where+ pure a = Homo $ const a+ (Homo f) <$> (Homo a) = Homo $ \r => f r $ a r++instance Monad (Homomorphism r) where+ return a = Homo $ const a+ (Homo h) >>= f = Homo $ \r => applyHomo (f $ h r) r++instance Semigroup (Endomorphism a) where+ (Endo f) <+> (Endo g) = Endo $ g . f++instance Monoid (Endomorphism a) where+ neutral = Endo id++infixr 1 ~>++(~>) : Type -> Type -> Type+a ~> b = Homomorphism a b
+ lib/Data/Word.idr view
@@ -0,0 +1,19 @@+module Data.Word++%access public++instance Num Word8 where+ (+) = prim__addW8+ (-) = prim__subW8+ (*) = prim__mulW8++ abs x = x+ fromInteger = prim__intToWord8++instance Num Word16 where+ (+) = prim__addW16+ (-) = prim__subW16+ (*) = prim__mulW16++ abs x = x+ fromInteger = prim__intToWord16
+ lib/Debug/Trace.idr view
@@ -0,0 +1,8 @@+module Debug.Trace++import IO++trace : String -> a -> a+trace x val = unsafePerformIO (do putStrLn x; return val) ++
lib/IO.idr view
@@ -21,9 +21,9 @@ run__IO : IO () -> IO () run__IO v = io_bind v (\v' => io_return v') -data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Set | FUnit+data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Type | FUnit -interpFTy : FTy -> Set+interpFTy : FTy -> Type interpFTy FInt = Int interpFTy FFloat = Float interpFTy FChar = Char@@ -32,14 +32,14 @@ interpFTy (FAny t) = t interpFTy FUnit = () -ForeignTy : (xs:List FTy) -> (t:FTy) -> Set+ForeignTy : (xs:List FTy) -> (t:FTy) -> Type ForeignTy xs t = mkForeign' (reverse xs) (IO (interpFTy t)) where - mkForeign' : List FTy -> Set -> Set+ mkForeign' : List FTy -> Type -> Type mkForeign' Nil ty = ty mkForeign' (s :: ss) ty = mkForeign' ss (interpFTy s -> ty) -data Foreign : Set -> Set where+data Foreign : Type -> Type where FFun : String -> (xs:List FTy) -> (t:FTy) -> Foreign (ForeignTy xs t)
lib/Language/Reflection.idr view
@@ -1,11 +1,19 @@ module Language.Reflection -TTName : Set-TTName = String+TTName : Type+TTName = String -- needs to capture namespaces too... data TT = Var TTName | Lam TTName TT TT | Pi TTName TT TT | Let TTName TT TT TT | App TTName TT TT++data Tactic = Try Tactic Tactic+ | GoalType TTName Tactic -- only run if the goal has the right type+ | Refine TTName+ | Seq Tactic Tactic+ | Trivial+ | Solve+ | Exact TT -- not yet implemented
lib/Network/Cgi.idr view
@@ -3,10 +3,10 @@ import System public-Vars : Set+Vars : Type Vars = List (String, String) -record CGIInfo : Set where+record CGIInfo : Type where CGISt : (GET : Vars) -> (POST : Vars) -> (Cookies : Vars) ->@@ -21,11 +21,22 @@ add_Output str st = record { Output = Output st ++ str } st abstract-data CGI : Set -> Set where+data CGI : Type -> Type where MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a getAction : CGI a -> CGIInfo -> IO (a, CGIInfo) getAction (MkCGI act) = act++instance Functor CGI where+ fmap f (MkCGI c) = MkCGI (\s => do (a, i) <- c s+ return (f a, i))++instance Applicative CGI where+ pure v = MkCGI (\s => return (v, s))+ + (MkCGI a) <$> (MkCGI b) = MkCGI (\s => do (f, i) <- a s+ (c, j) <- b i+ return (f c, j)) instance Monad CGI where { (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s
lib/Prelude.idr view
@@ -10,6 +10,7 @@ import Prelude.Maybe import Prelude.Monad import Prelude.Applicative+import Prelude.Functor import Prelude.Either import Prelude.Vect import Prelude.Strings@@ -67,51 +68,82 @@ show Nothing = "Nothing" show (Just x) = "Just " ++ show x ----- Monad instances--instance Monad IO where - return t = io_return t- b >>= k = io_bind b k--instance Monad Maybe where - return t = Just t-- Nothing >>= k = Nothing- (Just x) >>= k = k x--instance MonadPlus Maybe where - mzero = Nothing-- mplus (Just x) _ = Just x- mplus Nothing (Just y) = Just y- mplus Nothing Nothing = Nothing--instance Monad List where - return x = [x]- m >>= f = concatMap f m--instance MonadPlus List where - mzero = []- mplus = (++)- ---- Functor instances +instance Functor IO where+ fmap f io = io_bind io (io_return . f)+ instance Functor Maybe where fmap f (Just x) = Just (f x) fmap f Nothing = Nothing +instance Functor (Either e) where+ fmap f (Left l) = Left l+ fmap f (Right r) = Right (f r)+ instance Functor List where fmap = map ---- Applicative instances +instance Applicative IO where+ pure = io_return+ + am <$> bm = io_bind am (\f => io_bind bm (io_return . f))+ instance Applicative Maybe where pure = Just (Just f) <$> (Just a) = Just (f a) _ <$> _ = Nothing +instance Applicative (Either e) where+ pure = Right + (Left a) <$> _ = Left a+ (Right f) <$> (Right r) = Right (f r)+ (Right _) <$> (Left l) = Left l++instance Applicative List where+ pure x = [x]++ fs <$> vs = concatMap (\f => map f vs) fs++---- Alternative instances++instance Alternative Maybe where+ empty = Nothing++ (Just x) <|> _ = Just x+ Nothing <|> v = v++instance Alternative List where+ empty = []+ + (<|>) = (++)++---- Monad instances++instance Monad IO where + return t = io_return t+ b >>= k = io_bind b k++instance Monad Maybe where + return t = Just t++ Nothing >>= k = Nothing+ (Just x) >>= k = k x++instance Monad (Either e) where+ return = Right++ (Left n) >>= _ = Left n+ (Right r) >>= f = f r++instance Monad List where + return x = [x]+ m >>= f = concatMap f m+ ---- some mathematical operations %include "math.h"@@ -158,7 +190,7 @@ ---- Ranges -partial+%assert_total count : (Ord a, Num a) => a -> a -> a -> List a count a inc b = if a <= b then a :: count (a + inc) inc b else []@@ -259,11 +291,19 @@ partial do_feof : Ptr -> IO Int-do_feof h = mkForeign (FFun "feof" [FPtr] FInt) h+do_feof h = mkForeign (FFun "fileEOF" [FPtr] FInt) h feof : File -> IO Bool feof (FHandle h) = do eof <- do_feof h- return (not (eof == 0)) + return (not (eof == 0))++partial+do_ferror : Ptr -> IO Int+do_ferror h = mkForeign (FFun "fileError" [FPtr] FInt) h++ferror : File -> IO Bool+ferror (FHandle h) = do err <- do_ferror h+ return (not (err == 0)) partial nullPtr : Ptr -> IO Bool
lib/Prelude/Applicative.idr view
@@ -1,13 +1,46 @@ module Prelude.Applicative import Builtins+import Prelude.Functor ---- Applicative functors/Idioms infixl 2 <$> -class Applicative (f : Set -> Set) where +class Functor f => Applicative (f : Type -> Type) where pure : a -> f a- (<$>) : f (a -> b) -> f a -> f b + (<$>) : f (a -> b) -> f a -> f b +infixl 2 <$+(<$) : Applicative f => f a -> f b -> f a+a <$ b = fmap const a <$> b +infixl 2 $>+($>) : Applicative f => f a -> f b -> f b+a $> b = fmap (const id) a <$> b++infixl 3 <|>+class Applicative f => Alternative (f : Type -> Type) where+ empty : f a+ (<|>) : f a -> f a -> f a++guard : Alternative f => Bool -> f ()+guard a = if a then pure () else empty++when : Applicative f => Bool -> f () -> f ()+when a f = if a then f else pure ()++sequence : Applicative f => List (f a) -> f (List a)+sequence [] = pure []+sequence (x :: xs) = fmap (::) x <$> sequence xs++sequence_ : Applicative f => List (f a) -> f ()+sequence_ [] = pure ()+sequence_ (x :: xs) = x $> sequence_ xs++traverse : Applicative f => (a -> f b) -> List a -> f (List b)+traverse f xs = sequence (map f xs)++traverse_ : Applicative f => (a -> f b) -> List a -> f ()+traverse_ f (x :: xs) = f x $> traverse_ f xs+traverse_ f [] = pure ()
lib/Prelude/Chars.idr view
@@ -22,6 +22,9 @@ x == '\n' || x == '\f' || x == '\v' || x == '\xa0' +isNL : Char -> Bool+isNL x = x == '\r' || x == '\n' + toUpper : Char -> Char toUpper x = if (isLower x) then (prim__intToChar (prim__charToInt x - 32))
lib/Prelude/Complex.idr view
@@ -1,5 +1,5 @@ {-- © 2012 Copyright Mekeor Melire+ (c) 2012 Copyright Mekeor Melire -}
lib/Prelude/Fin.idr view
@@ -1,8 +1,9 @@ module Prelude.Fin import Prelude.Nat+import Prelude.Either -data Fin : Nat -> Set where+data Fin : Nat -> Type where fO : Fin (S k) fS : Fin k -> Fin (S k) @@ -13,7 +14,17 @@ eq (fS k) (fS k') = eq k k' eq _ _ = False -wkn : Fin n -> Fin (S n)-wkn fO = fO-wkn (fS k) = fS (wkn k)+weaken : Fin n -> Fin (S n)+weaken fO = fO+weaken (fS k) = fS (weaken k) +strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)+strengthen {n = S k} fO = Right fO+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++last : Fin (S n)+last {n=O} = fO+last {n=S _} = fS last
+ lib/Prelude/Functor.idr view
@@ -0,0 +1,4 @@+module Prelude.Functor++class Functor (f : Type -> Type) where + fmap : (a -> b) -> f a -> f b
lib/Prelude/Heap.idr view
@@ -14,7 +14,7 @@ %access public -abstract data MaxiphobicHeap : Set -> Set where+abstract data MaxiphobicHeap : Type -> Type where Empty : MaxiphobicHeap a Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a @@ -66,6 +66,7 @@ largest : Nat largest = maximum (size left) $ maximum (size centre) (size right) +%assert_total -- relies on orderBySize doing the right thing merge : Ord a => MaxiphobicHeap a -> MaxiphobicHeap a -> MaxiphobicHeap a merge Empty right = right merge left Empty = left@@ -103,6 +104,7 @@ toList Empty = [] toList (Node s l e r) = toList' (Node s l e r) refl where+ %assert_total -- relies on deleteMinimum making heap smaller toList' : Ord a => (h : MaxiphobicHeap a) -> (isEmpty h = False) -> List a toList' heap p = findMinimum heap p :: (toList $ deleteMinimum heap p) @@ -142,7 +144,7 @@ total absurdBoolDischarge : False = True -> _|_ absurdBoolDischarge p = replace {P = disjointTy} p () where- total disjointTy : Bool -> Set+ total disjointTy : Bool -> Type disjointTy False = () disjointTy True = _|_
lib/Prelude/List.idr view
@@ -9,7 +9,7 @@ %access public %default total -infixr 7 :: +infixr 7 :: data List a = Nil@@ -266,7 +266,7 @@ intersperse sep [] = [] intersperse sep (x::xs) = x :: intersperse' sep xs where- intersperse' : a -> List a -> List a+-- intersperse' : a -> List a -> List a intersperse' sep [] = [] intersperse' sep (y::ys) = sep :: y :: intersperse' sep ys @@ -324,9 +324,9 @@ find p xs findIndex : (a -> Bool) -> List a -> Maybe Nat-findIndex = findIndex' 0+findIndex = findIndex' O where- findIndex' : Nat -> (a -> Bool) -> List a -> Maybe Nat+-- findIndex' : Nat -> (a -> Bool) -> List a -> Maybe Nat findIndex' cnt p [] = Nothing findIndex' cnt p (x::xs) = if p x then@@ -335,9 +335,9 @@ findIndex' (S cnt) p xs findIndices : (a -> Bool) -> List a -> List Nat-findIndices = findIndices' 0+findIndices = findIndices' O where- findIndices' : Nat -> (a -> Bool) -> List a -> List Nat+-- findIndices' : Nat -> (a -> Bool) -> List a -> List Nat findIndices' cnt p [] = [] findIndices' cnt p (x::xs) = if p x then@@ -448,6 +448,8 @@ Nil => True (y::ys) => x <= y && sorted (y::ys) +%assert_total -- can't work this out, because in the case which is lifted out+ -- y::ys and x::xs are bigger than the inputs... mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a mergeBy order [] right = right mergeBy order left [] = left
lib/Prelude/Maybe.idr view
@@ -1,7 +1,12 @@ module Prelude.Maybe import Builtins+import Prelude.Algebra+import Prelude.Cast +%access public+%default total+ data Maybe a = Nothing | Just a@@ -41,3 +46,24 @@ maybe_bind : Maybe a -> (a -> Maybe b) -> Maybe b maybe_bind Nothing k = Nothing maybe_bind (Just x) k = k x++-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to+-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup S may be+-- turned into a monoid simply by adjoining an element e not in S+-- and defining i+i = i and i+s = s = s+i for all s ∈ S.\"++instance (Semigroup a) => Semigroup (Maybe a) where+ Nothing <+> m = m+ m <+> Nothing = m+ (Just m1) <+> (Just m2) = Just (m1 <+> m2)++instance (Monoid a) => Monoid (Maybe a) where+ neutral = Nothing+++instance (Monoid a, Eq a) => Cast a (Maybe a) where+ cast x = if x == neutral then Nothing else Just x++instance (Monoid a) => Cast (Maybe a) a where+ cast Nothing = neutral+ cast (Just x) = x
lib/Prelude/Monad.idr view
@@ -4,42 +4,15 @@ import Builtins import Prelude.List+import Prelude.Applicative %access public infixl 5 >>= -class Monad (m : Set -> Set) where +class Applicative m => Monad (m : Type -> Type) where return : a -> m a (>>=) : m a -> (a -> m b) -> m b -class Functor (f : Set -> Set) where - fmap : (a -> b) -> f a -> f b--class Monad m => MonadPlus (m : Set -> Set) where - mplus : m a -> m a -> m a- mzero : m a--guard : MonadPlus m => Bool -> m ()-guard True = return ()-guard False = mzero--when : Monad m => Bool -> m () -> m ()-when True f = f-when False _ = return ()--sequence : Monad m => List (m a) -> m (List a)-sequence [] = return []-sequence (x :: xs) = [ x' :: xs' | x' <- x, xs' <- sequence xs ]--sequence_ : Monad m => List (m a) -> m ()-sequence_ [] = return ()-sequence_ (x :: xs) = do x; sequence_ xs--mapM : Monad m => (a -> m b) -> List a -> m (List b)-mapM f xs = sequence (map f xs)--mapM_ : Monad m => (a -> m b) -> List a -> m ()-mapM_ f xs = sequence_ (map f xs)--+flatten : Monad m => m (m a) -> m a+flatten a = a >>= id
− lib/Prelude/Morphisms.idr
@@ -1,7 +0,0 @@-module Prelude.Morphisms--data Morphism : Set -> Set -> Set where- Homo : (a -> b) -> Morphism a b--($) : Morphism a b -> a -> b-(Homo f) $ a = f a
lib/Prelude/Nat.idr view
@@ -57,17 +57,17 @@ -- Comparisons -------------------------------------------------------------------------------- -data LTE : Nat -> Nat -> Set where+data LTE : Nat -> Nat -> Type where lteZero : LTE O right lteSucc : LTE left right -> LTE (S left) (S right) -total GTE : Nat -> Nat -> Set+total GTE : Nat -> Nat -> Type GTE left right = LTE right left -total LT : Nat -> Nat -> Set+total LT : Nat -> Nat -> Type LT left right = LTE (S left) right -total GT : Nat -> Nat -> Set+total GT : Nat -> Nat -> Type GT left right = LT right left total lte : Nat -> Nat -> Bool@@ -135,10 +135,10 @@ else O -record Multiplicative : Set where+record Multiplicative : Type where getMultiplicative : Nat -> Multiplicative -record Additive : Set where+record Additive : Type where getAdditive : Nat -> Additive instance Semigroup Multiplicative where
lib/Prelude/Strings.idr view
@@ -4,10 +4,11 @@ import Prelude.List import Prelude.Chars import Prelude.Cast+import Prelude.Either -- Some more complex string operations -data StrM : String -> Set where+data StrM : String -> Type where StrNil : StrM "" StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs) @@ -27,21 +28,33 @@ strM x | (Left p) = believe_me $ StrCons (strHead' x p) (strTail' x p) strM x | (Right p) = believe_me StrNil +-- annoyingly, we need these assert_totals because StrCons doesn't have+-- a recursive argument, therefore the termination checker doesn't believe+-- the string is guaranteed smaller. It makes a good point.++%assert_total unpack : String -> List Char unpack s with (strM s) unpack "" | StrNil = []- unpack (strCons x xs) | (StrCons _ _) = x :: unpack xs+ unpack (strCons x xs) | (StrCons _ xs) = x :: unpack xs pack : List Char -> String pack [] = "" pack (x :: xs) = strCons x (pack xs) instance Cast String (List Char) where- cast = unpack+ cast = unpack instance Cast (List Char) String where- cast = pack+ cast = pack +instance Semigroup String where+ (<+>) = (++)++instance Monoid String where+ neutral = ""++%assert_total span : (Char -> Bool) -> String -> (String, String) span p xs with (strM xs) span p "" | StrNil = ("", "")@@ -56,6 +69,7 @@ split : (Char -> Bool) -> String -> List String split p xs = map pack (split p (unpack xs)) +%assert_total ltrim : String -> String ltrim xs with (strM xs) ltrim "" | StrNil = ""@@ -65,6 +79,7 @@ trim : String -> String trim xs = ltrim (reverse (ltrim (reverse xs))) +%assert_total words' : List Char -> List (List Char) words' s = case dropWhile isSpace s of [] => []@@ -74,19 +89,29 @@ words : String -> List String words s = map pack $ words' $ unpack s +%assert_total+lines' : List Char -> List (List Char)+lines' s = case dropWhile isNL s of+ [] => []+ s' => let (w, s'') = break isNL s'+ in w :: lines' s''++lines : String -> List String+lines s = map pack $ lines' $ unpack s+ partial-foldr1 : (a -> a -> a) -> List a -> a +foldr1 : (a -> a -> a) -> List a -> a foldr1 f [x] = x foldr1 f (x::xs) = f x (foldr1 f xs) %assert_total -- due to foldr1, but used safely unwords' : List (List Char) -> List Char-unwords' [] = [] +unwords' [] = [] unwords' ws = (foldr1 addSpace ws) where addSpace : List Char -> List Char -> List Char- addSpace w s = w ++ (' ' :: s) - + addSpace w s = w ++ (' ' :: s)+ unwords : List String -> String unwords = pack . unwords' . map unpack
lib/Prelude/Vect.idr view
@@ -9,7 +9,7 @@ infixr 7 :: -data Vect : Set -> Nat -> Set where+data Vect : Type -> Nat -> Type where Nil : Vect a O (::) : a -> Vect a n -> Vect a (S n) @@ -76,6 +76,19 @@ replicate (S k) x = x :: replicate k x --------------------------------------------------------------------------------+-- Zips and unzips+--------------------------------------------------------------------------------++zip : Vect a n -> Vect b n -> Vect (a, b) n+zip [] [] = []+zip (x :: xs) (y :: ys) = (x, y) :: (zip xs ys)++unzip : Vect (a, b) n -> (Vect a n, Vect b n)+unzip [] = ([], [])+unzip ((l, r)::xs) with (unzip xs)+ | (lefts, rights) = (l::lefts, r::rights)++-------------------------------------------------------------------------------- -- Maps -------------------------------------------------------------------------------- @@ -287,6 +300,14 @@ catMaybes (Nothing::xs) = catMaybes xs catMaybes ((Just j)::xs) with (catMaybes xs) | (_ ** tail) = (_ ** j::tail)++range : Vect (Fin n) n+range =+ reverse range_+ where+ range_ : Vect (Fin n) n+ range_ {n=O} = Nil+ range_ {n=(S _)} = last :: map weaken range_ -------------------------------------------------------------------------------- -- Proofs
+ lib/System/Concurrency/Process.idr view
@@ -0,0 +1,69 @@+-- WARNING: No guarantees that this works properly yet! ++module System.Concurrency.Process++import System.Concurrency.Raw++%access public++abstract +data ProcID msg = MkPID Ptr++-- Type safe message passing programs. Parameterised over the type of+-- message which can be send, and the return type.++data Process : (msgType : Type) -> Type -> Type where+ lift : IO a -> Process msg a++instance Functor (Process msg) where+ fmap f (lift a) = lift (fmap f a)++instance Applicative (Process msg) where+ pure = lift . return+ (lift f) <$> (lift a) = lift (f <$> a)++instance Monad (Process msg) where+ return = lift . return+ (lift io) >>= k = lift (do x <- io+ case k x of+ lift v => v)++run : Process msg x -> IO x+run (lift prog) = prog++-- Get current process ID++myID : Process msg (ProcID msg)+myID = lift (return (MkPID prim__vm))++-- Send a message to another process++send : ProcID msg -> msg -> Process msg ()+send (MkPID p) m = lift (sendToThread p (prim__vm, m))++-- Return whether a message is waiting in the queue++msgWaiting : Process msg Bool+msgWaiting = lift checkMsgs ++-- Receive a message - blocks if there is no message waiting++recv : Process msg msg+recv {msg} = do (senderid, m) <- lift get+ return m+ where get : IO (Ptr, msg)+ get = getMsg++-- receive a message, and return with the sender's process ID.++recvWithSender : Process msg (ProcID msg, msg)+recvWithSender {msg} + = do (senderid, m) <- lift get+ return (MkPID senderid, m)+ where get : IO (Ptr, msg)+ get = getMsg++create : |(thread : Process msg ()) -> Process msg (ProcID msg)+create (lift p) = do ptr <- lift (fork p)+ return (MkPID ptr)+
lib/System/Concurrency/Raw.idr view
@@ -1,3 +1,5 @@+-- WARNING: No guarantees that this works properly yet! + module System.Concurrency.Raw -- Raw (i.e. not type safe) message passing
lib/base.ipkg view
@@ -6,13 +6,16 @@ Prelude.Algebra, Prelude.Cast, Prelude.Nat, Prelude.Fin, Prelude.List, Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either, Prelude.Vect, Prelude.Strings, Prelude.Chars, - Prelude.Heap, Prelude.Complex, Prelude.Morphisms,+ Prelude.Heap, Prelude.Complex, Prelude.Functor, Network.Cgi,+ Debug.Trace, - System.Concurrency.Raw,+ System.Concurrency.Raw, System.Concurrency.Process, Language.Reflection,++ Data.Morphisms, Data.Bits, Data.Word, Control.Monad.Identity, Control.Monad.State, Control.Category, Control.Arrow
rts/Makefile view
@@ -2,7 +2,7 @@ OBJS = idris_rts.o idris_gc.o idris_gmp.o idris_stdfgn.o HDRS = idris_rts.h idris_gc.h idris_gmp.h idris_stdfgn.h-CFLAGS = -O2 -Wall -Werror+CFLAGS = -O2 -Wall ifneq ($(GMP_INCLUDE_DIR),) CFLAGS += -isystem $(GMP_INCLUDE_DIR) endif
rts/idris_gc.c view
@@ -3,36 +3,31 @@ #include <assert.h> VAL copy(VM* vm, VAL x) {- int i;- VAL* argptr;+ int i, ar; Closure* cl = NULL; if (x==NULL || ISINT(x)) { return x; } switch(GETTY(x)) { case CON:- cl = allocCon(vm, x->info.c.arity);- cl->info.c.tag = x->info.c.tag;- cl->info.c.arity = x->info.c.arity;-- argptr = (VAL*)(cl->info.c.args);- for(i = 0; i < x->info.c.arity; ++i) {+ ar = CARITY(x);+ allocCon(cl, vm, CTAG(x), ar, 1);+ for(i = 0; i < ar; ++i) { // *argptr = copy(vm, *((VAL*)(x->info.c.args)+i)); // recursive version- *argptr = *((VAL*)(x->info.c.args)+i);- argptr++;+ cl->info.c.args[i] = x->info.c.args[i]; } break; case FLOAT:- cl = MKFLOAT(vm, x->info.f);+ cl = MKFLOATc(vm, x->info.f); break; case STRING:- cl = MKSTR(vm, x->info.str);+ cl = MKSTRc(vm, x->info.str); break; case BIGINT:- cl = MKBIGM(vm, x->info.ptr);+ cl = MKBIGMc(vm, x->info.ptr); break; case PTR:- cl = MKPTR(vm, x->info.ptr);+ cl = MKPTRc(vm, x->info.ptr); break; case FWD: return x->info.ptr;@@ -45,8 +40,8 @@ } void cheney(VM *vm) {- VAL* argptr; int i;+ int ar; char* scan = vm->heap; while(scan < vm->heap_next) {@@ -55,13 +50,12 @@ // If it's a CON, copy its arguments switch(GETTY(heap_item)) { case CON:- argptr = (VAL*)(heap_item->info.c.args);- for(i = 0; i < heap_item->info.c.arity; ++i) {+ ar = ARITY(heap_item);+ for(i = 0; i < ar; ++i) { // printf("Copying %d %p\n", heap_item->info.c.tag, *argptr);- VAL newptr = copy(vm, *argptr);+ VAL newptr = copy(vm, heap_item->info.c.args[i]); // printf("Got %p\t\t%p %p\n", newptr, scan, vm->heap_next);- *argptr = newptr;- argptr++;+ heap_item->info.c.args[i] = newptr; } break; default: // Nothing to copy@@ -72,7 +66,7 @@ assert(scan == vm->heap_next); } -void gc(VM* vm) {+void idris_gc(VM* vm) { // printf("Collecting\n"); char* newheap = malloc(vm -> heap_size);@@ -108,16 +102,16 @@ vm->heap_size += vm->heap_growth; } vm->oldheap = oldheap;-+ // gcInfo(vm, 0); } -void gcInfo(VM* vm, int doGC) {+void idris_gcInfo(VM* vm, int doGC) { printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top); printf("Total allocations: %d\n", vm->allocations); printf("GCs: %d\n", vm->collections); printf("Final heap size %d\n", (int)(vm->heap_size)); printf("Final heap use %d\n", (int)(vm->heap_next - vm->heap));- if (doGC) { gc(vm); }+ if (doGC) { idris_gc(vm); } printf("Final heap use after GC %d\n", (int)(vm->heap_next - vm->heap)); }
rts/idris_gc.h view
@@ -3,7 +3,7 @@ #include "idris_rts.h" -void gc(VM* vm);-void gcInfo(VM* vm, int doGC);+void idris_gc(VM* vm);+void idris_gcInfo(VM* vm, int doGC); #endif
rts/idris_gmp.c view
@@ -9,9 +9,11 @@ VAL MKBIGC(VM* vm, char* val) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));-+ + VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));+ mpz_init(*bigint); mpz_set_str(*bigint, val, 10); @@ -23,8 +25,9 @@ VAL MKBIGM(VM* vm, void* big) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_init(*bigint); mpz_set(*bigint, *((mpz_t*)big));@@ -35,11 +38,26 @@ return cl; } +VAL MKBIGMc(VM* vm, void* big) {+ mpz_t* bigint;+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));++ mpz_init_set(*bigint, *((mpz_t*)big));++ SETTY(cl, BIGINT);+ cl -> info.ptr = (void*)bigint;++ return cl;+}+ VAL GETBIG(VM * vm, VAL x) { if (ISINT(x)) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_init(*bigint); mpz_set_si(*bigint, GETINT(x));@@ -55,8 +73,9 @@ VAL bigAdd(VM* vm, VAL x, VAL y) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_add(*bigint, GETMPZ(x), GETMPZ(y)); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint;@@ -65,8 +84,9 @@ VAL bigSub(VM* vm, VAL x, VAL y) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_sub(*bigint, GETMPZ(x), GETMPZ(y)); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint;@@ -75,8 +95,9 @@ VAL bigMul(VM* vm, VAL x, VAL y) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_mul(*bigint, GETMPZ(x), GETMPZ(y)); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint;@@ -85,14 +106,26 @@ VAL bigDiv(VM* vm, VAL x, VAL y) { mpz_t* bigint;- VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));- bigint = allocate(vm, sizeof(mpz_t));+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*)); mpz_div(*bigint, GETMPZ(x), GETMPZ(y)); SETTY(cl, BIGINT); cl -> info.ptr = (void*)bigint; return cl; } +VAL bigMod(VM* vm, VAL x, VAL y) {+ mpz_t* bigint;+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) + + sizeof(mpz_t), 0);+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));+ mpz_mod(*bigint, GETMPZ(x), GETMPZ(y));+ SETTY(cl, BIGINT);+ cl -> info.ptr = (void*)bigint;+ return cl;+}+ VAL idris_bigPlus(VM* vm, VAL x, VAL y) { if (ISINT(x) && ISINT(y)) { i_int vx = GETINT(x);@@ -155,6 +188,22 @@ return INTOP(/, x, y); } else { return bigDiv(vm, GETBIG(vm, x), GETBIG(vm, y));+ }+}++VAL idris_bigMod(VM* vm, VAL x, VAL y) {+ if (ISINT(x) && ISINT(y)) {+ return INTOP(%, x, y);+ } else {+ return bigMod(vm, GETBIG(vm, x), GETBIG(vm, y));+ }+}++int bigEqConst(VAL x, int c) {+ if (ISINT(x)) { return (GETINT(x) == c); }+ else { + int rv = mpz_cmp_si(GETMPZ(x), c); + return (rv == 0); } }
rts/idris_gmp.h view
@@ -4,11 +4,15 @@ VAL MKBIGI(int val); VAL MKBIGC(VM* vm, char* bigint); VAL MKBIGM(VM* vm, void* bigint);+VAL MKBIGMc(VM* vm, void* bigint); VAL idris_bigPlus(VM*, VAL x, VAL y); VAL idris_bigMinus(VM*, VAL x, VAL y); VAL idris_bigTimes(VM*, VAL x, VAL y); VAL idris_bigDivide(VM*, VAL x, VAL y);+VAL idris_bigMod(VM*, VAL x, VAL y);++int bigEqConst(VAL x, int c); VAL idris_bigEq(VM*, VAL x, VAL y); VAL idris_bigLt(VM*, VAL x, VAL y);
rts/idris_main.c view
@@ -1,9 +1,9 @@ int main(int argc, char* argv[]) {- VM* vm = init_vm(4096000, 2048000, 1, argc, argv); // 1024000);+ VM* vm = init_vm(4096000, 4096000, 1, argc, argv); // 1024000); _idris__123_runMain0_125_(vm, NULL); //_idris_main(vm, NULL); #ifdef IDRIS_TRACE- gcInfo(vm, 1);+ idris_gcInfo(vm, 1); #endif terminate(vm); }
rts/idris_rts.c view
@@ -37,15 +37,18 @@ vm->reg1 = NULL; vm->inbox = malloc(1024*sizeof(VAL));+ memset(vm->inbox, 0, 1024*sizeof(VAL)); vm->inbox_end = vm->inbox + 1024; vm->inbox_ptr = vm->inbox; vm->inbox_write = vm->inbox; pthread_mutex_init(&(vm->inbox_lock), NULL); pthread_mutex_init(&(vm->inbox_block), NULL);+ pthread_mutex_init(&(vm->alloc_lock), NULL); pthread_cond_init(&(vm->inbox_waiting), NULL); vm->max_threads = max_threads;+ vm->processes = 0; int i; // Assumption: there's enough space for this in the initial heap.@@ -73,40 +76,52 @@ free(vm); } -void* allocate(VM* vm, size_t size) {+void* allocate(VM* vm, size_t size, int outerlock) { // return malloc(size);+ int lock = vm->processes > 0 && !outerlock;++ if (lock) { // not message passing+ pthread_mutex_lock(&vm->alloc_lock); + }+ if ((size & 7)!=0) { size = 8 + ((size >> 3) << 3); }- vm->allocations += size + sizeof(size_t); if (vm -> heap_next + size < vm -> heap_end) {+ vm->allocations += size + sizeof(size_t); void* ptr = (void*)(vm->heap_next + sizeof(size_t)); *((size_t*)(vm->heap_next)) = size + sizeof(size_t); vm -> heap_next += size + sizeof(size_t); memset(ptr, 0, size);+ if (lock) { // not message passing+ pthread_mutex_unlock(&vm->alloc_lock); + } return ptr; } else {- gc(vm);- return allocate(vm, size);+ idris_gc(vm);+ if (lock) { // not message passing+ pthread_mutex_unlock(&vm->alloc_lock); + }+ return allocate(vm, size, 0); }+ } -void* allocCon(VM* vm, int arity) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity);+/* Now a macro+void* allocCon(VM* vm, int arity, int outer) {+ Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,+ outer); SETTY(cl, CON);- if (arity == 0) {- cl -> info.c.args = NULL;- } else {- cl -> info.c.args = (void*)((char*)cl + sizeof(Closure));- }+ cl -> info.c.arity = arity; // cl -> info.c.tag = 42424242; // printf("%p\n", cl); return (void*)cl; }+*/ VAL MKFLOAT(VM* vm, double val) {- Closure* cl = allocate(vm, sizeof(Closure));+ Closure* cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, FLOAT); cl -> info.f = val; return cl;@@ -114,7 +129,7 @@ VAL MKSTR(VM* vm, char* str) { Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) +- sizeof(char)*strlen(str)+1);+ sizeof(char)*strlen(str)+1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); @@ -123,39 +138,40 @@ } VAL MKPTR(VM* vm, void* ptr) {- Closure* cl = allocate(vm, sizeof(Closure));+ Closure* cl = allocate(vm, sizeof(Closure), 0); SETTY(cl, PTR); cl -> info.ptr = ptr; return cl; } -VAL MKCON(VM* vm, VAL cl, int tag, int arity, ...) {- int i;- va_list args;+VAL MKFLOATc(VM* vm, double val) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, FLOAT);+ cl -> info.f = val;+ return cl;+} - va_start(args, arity);+VAL MKSTRc(VM* vm, char* str) {+ Closure* cl = allocate(vm, sizeof(Closure) + // Type) + sizeof(char*) ++ sizeof(char)*strlen(str)+1, 1);+ SETTY(cl, STRING);+ cl -> info.str = (char*)cl + sizeof(Closure); -// Closure* cl = allocCon(vm, arity);- cl -> info.c.tag = tag;- cl -> info.c.arity = arity;- VAL* argptr = (VAL*)(cl -> info.c.args);- // printf("... %p %p\n", cl, argptr);+ strcpy(cl -> info.str, str);+ return cl;+} - for (i = 0; i < arity; ++i) {- VAL v = va_arg(args, VAL);- *argptr = v;- argptr++;- }- va_end(args);+VAL MKPTRc(VM* vm, void* ptr) {+ Closure* cl = allocate(vm, sizeof(Closure), 1);+ SETTY(cl, PTR);+ cl -> info.ptr = ptr; return cl; } void PROJECT(VM* vm, VAL r, int loc, int arity) { int i;- VAL* argptr = (VAL*)(r -> info.c.args);- for(i = 0; i < arity; ++i) {- LOC(i+loc) = *argptr++;+ LOC(i+loc) = r->info.c.args[i]; } } @@ -190,10 +206,9 @@ } switch(GETTY(v)) { case CON:- printf("%d[", v->info.c.tag);- for(i = 0; i < v->info.c.arity; ++i) {- VAL* args = (VAL*)v->info.c.args;- dumpVal(args[i]);+ printf("%d[", TAG(v));+ for(i = 0; i < ARITY(v); ++i) {+ dumpVal(v->info.c.args[i]); } printf("] "); break;@@ -211,7 +226,7 @@ } VAL idris_castIntStr(VM* vm, VAL i) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16);+ Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%d", (int)(GETINT(i)));@@ -228,7 +243,7 @@ } VAL idris_castFloatStr(VM* vm, VAL i) {- Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*32);+ Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*32, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); sprintf(cl -> info.str, "%g", GETFLOAT(i));@@ -244,7 +259,8 @@ char *ls = GETSTR(l); // dumpVal(l); // printf("\n");- Closure* cl = allocate(vm, sizeof(Closure) + strlen(ls) + strlen(rs) + 1);+ Closure* cl = allocate(vm, sizeof(Closure) + strlen(ls) + strlen(rs) + 1,+ 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); strcpy(cl -> info.str, ls);@@ -319,7 +335,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) { char *xstr = GETSTR(xs); Closure* cl = allocate(vm, sizeof(Closure) +- strlen(xstr) + 2);+ strlen(xstr) + 2, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); cl -> info.str[0] = (char)(GETINT(x));@@ -334,7 +350,7 @@ VAL idris_strRev(VM* vm, VAL str) { char *xstr = GETSTR(str); Closure* cl = allocate(vm, sizeof(Closure) +- strlen(xstr) + 1);+ strlen(xstr) + 1, 0); SETTY(cl, STRING); cl -> info.str = (char*)cl + sizeof(Closure); int y = 0;@@ -348,7 +364,8 @@ } typedef struct {- VM* vm;+ VM* vm; // thread's VM+ VM* callvm; // calling thread's VM func fn; VAL arg; } ThreadData;@@ -356,13 +373,16 @@ void* runThread(void* arg) { ThreadData* td = (ThreadData*)arg; VM* vm = td->vm;+ VM* callvm = td->callvm; TOP(0) = td->arg; BASETOP(0); ADDTOP(1); td->fn(vm, NULL);+ callvm->processes--; free(td);+ terminate(vm); return NULL; } @@ -370,6 +390,7 @@ VM* vm = init_vm(callvm->stack_max - callvm->valstack, callvm->heap_size, callvm->max_threads, 0, NULL);+ vm->processes=1; // since it can send and receive messages pthread_t t; pthread_attr_t attr; // size_t stacksize;@@ -380,19 +401,21 @@ ThreadData *td = malloc(sizeof(ThreadData)); td->vm = vm;+ td->callvm = callvm; td->fn = f; td->arg = copyTo(vm, arg);+ + callvm->processes++; pthread_create(&t, &attr, runThread, td); // usleep(100); return vm; } -// VM is assumed to be a different vm from the one x lives on (so we don't need-// to worry about gc moving things, as the VM x is on will not be allocating)+// VM is assumed to be a different vm from the one x lives on VAL copyTo(VM* vm, VAL x) {- int i;+ int i, ar; VAL* argptr; Closure* cl; if (x==NULL || ISINT(x)) {@@ -400,27 +423,26 @@ } switch(GETTY(x)) { case CON:- cl = allocCon(vm, x->info.c.arity);- cl->info.c.tag = x->info.c.tag;- cl->info.c.arity = x->info.c.arity;+ ar = CARITY(x);+ allocCon(cl, vm, CTAG(x), ar, 1); argptr = (VAL*)(cl->info.c.args);- for(i = 0; i < x->info.c.arity; ++i) {+ for(i = 0; i < ar; ++i) { *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version argptr++; } break; case FLOAT:- cl = MKFLOAT(vm, x->info.f);+ cl = MKFLOATc(vm, x->info.f); break; case STRING:- cl = MKSTR(vm, x->info.str);+ cl = MKSTRc(vm, x->info.str); break; case BIGINT:- cl = MKBIGM(vm, x->info.ptr);+ cl = MKBIGMc(vm, x->info.ptr); break; case PTR:- cl = MKPTR(vm, x->info.ptr);+ cl = MKPTRc(vm, x->info.ptr); break; default: assert(0); // We're in trouble if this happens...@@ -433,12 +455,26 @@ // 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 + // 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->collections;+ pthread_mutex_lock(&dest->alloc_lock); VAL dmsg = copyTo(dest, msg);+ pthread_mutex_unlock(&dest->alloc_lock); + if (dest->collections>gcs) {+ // a collection will have invalidated the copy+ pthread_mutex_lock(&dest->alloc_lock); + dmsg = copyTo(dest, msg); // try again now there's room...+ pthread_mutex_unlock(&dest->alloc_lock); + } -// printf("Sending [lock]...\n"); pthread_mutex_lock(&(dest->inbox_lock));- *(dest->inbox_write) = dmsg; dest->inbox_write++;
rts/idris_rts.h view
@@ -14,13 +14,14 @@ CON, INT, BIGINT, FLOAT, STRING, UNIT, PTR, FWD } ClosureType; +typedef struct Closure *VAL;+ typedef struct {- int tag;- int arity;- void* args;+ int tag_arity;+ VAL args[]; } con; -typedef struct {+typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in // Bottom 16 bits for closure type ClosureType ty;@@ -33,8 +34,6 @@ } info; } Closure; -typedef Closure* VAL;- typedef struct { VAL* valstack; int* intstack;@@ -51,6 +50,7 @@ pthread_mutex_t inbox_lock; pthread_mutex_t inbox_block;+ pthread_mutex_t alloc_lock; pthread_cond_t inbox_waiting; VAL* inbox; // Block of memory for storing messages@@ -59,6 +59,7 @@ VAL* inbox_ptr; // Next message to read VAL* inbox_write; // Location of next message to write + int processes; // Number of child processes int max_threads; // maximum number of threads to run in parallel int argc;@@ -88,6 +89,9 @@ #define RVAL (vm->ret) #define LOC(x) (*(vm->valstack_base + (x))) #define TOP(x) (*(vm->valstack_top + (x)))+// Doesn't work! Ordinary assign seems fine though...+#define UPDATE(x,y) if (!ISINT(x) && !ISINT(y)) \+ { (x)->ty = (y)->ty; (x)->info = (y)->info; } #define REG1 (vm->reg1) // Retrieving values@@ -96,8 +100,13 @@ #define GETPTR(x) (((VAL)(x))->info.ptr) #define GETFLOAT(x) (((VAL)(x))->info.f) -#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag : (-1)) )+#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) ) +// Already checked it's a CON+#define CTAG(x) (((x)->info.c.tag_arity) >> 8)+#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)+ // Use top 16 bits for saying which heap value is in // Bottom 16 bits for closure type @@ -126,12 +135,11 @@ #define INITFRAME VAL* myoldbase #define REBASE vm->valstack_base = oldbase #define RESERVE(x) if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \- else { bzero(vm->valstack_top, (x)*sizeof(VAL)); }+ else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); } #define ADDTOP(x) vm->valstack_top += (x) #define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x) #define BASETOP(x) vm->valstack_base = vm->valstack_top + (x) #define STOREOLD myoldbase = vm->valstack_base- #define CALL(f) f(vm, myoldbase); #define TAILCALL(f) f(vm, oldbase); @@ -140,17 +148,25 @@ VAL MKSTR(VM* vm, char* str); VAL MKPTR(VM* vm, void* ptr); -VAL MKCON(VM* vm, VAL cl, int tag, int arity, ...);+// following versions don't take a lock when allocating+VAL MKFLOATc(VM* vm, double val);+VAL MKSTRc(VM* vm, char* str);+VAL MKPTRc(VM* vm, void* ptr); -#define SETTAG(x, a) (x)->info.c.tag = (a)-#define SETARG(x, i, a) ((VAL*)((x)->info.c.args))[i] = ((VAL)(a))-#define GETARG(x, i) ((VAL*)((x)->info.c.args))[i]+// #define SETTAG(x, a) (x)->info.c.tag = (a)+#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 SLIDE(VM* vm, int args); -void* allocate(VM* vm, size_t size);-void* allocCon(VM* vm, int arity);+void* allocate(VM* vm, size_t size, int outerlock);+// void* allocCon(VM* vm, int arity, int outerlock);++#define allocCon(cl, vm, t, a, o) \+ cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*a, o); \+ SETTY(cl, CON); \+ cl->info.c.tag_arity = ((t) << 8) + (a); void* vmThread(VM* callvm, func f, VAL arg);
rts/idris_stdfgn.c view
@@ -15,6 +15,16 @@ fclose(f); } +int fileEOF(void* h) {+ FILE* f = (FILE*)h;+ return feof(f);+}++int fileError(void* h) {+ FILE* f = (FILE*)h;+ return ferror(f);+}+ void fputStr(void* h, char* str) { FILE* f = (FILE*)h; fputs(str, f);@@ -27,4 +37,3 @@ void* idris_stdin() { return (void*)stdin; }-
rts/libidris_rts.a view
binary file changed (26024 → 27896 bytes)
src/Core/CaseTree.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-} -module Core.CaseTree(CaseDef(..), SC(..), CaseAlt(..), Phase(..), CaseTree,+module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..), + Phase(..), CaseTree, simpleCase, small, namesUsed, findCalls, findUsedArgs) where import Core.TT@@ -13,25 +14,29 @@ data CaseDef = CaseDef [Name] SC [Term] deriving Show -data SC = Case Name [CaseAlt] -- invariant: lowest tags first- | ProjCase Term [CaseAlt] -- special case for projections- | STerm Term- | UnmatchedCase String -- error message- | ImpossibleCase -- already checked to be impossible- deriving (Eq, Ord)+data SC' t = Case Name [CaseAlt' t] -- invariant: lowest tags first+ | ProjCase t [CaseAlt' t] -- special case for projections+ | STerm t+ | UnmatchedCase String -- error message+ | ImpossibleCase -- already checked to be impossible+ deriving (Eq, Ord, Functor) {-! deriving instance Binary SC !-} -data CaseAlt = ConCase Name Int [Name] SC- | ConstCase Const SC- | DefaultCase SC- deriving (Show, Eq, Ord)+type SC = SC' Term++data CaseAlt' t = ConCase Name Int [Name] (SC' t)+ | ConstCase Const (SC' t)+ | DefaultCase (SC' t)+ deriving (Show, Eq, Ord, Functor) {-! deriving instance Binary CaseAlt !-} -instance Show SC where+type CaseAlt = CaseAlt' Term++instance Show t => Show (SC' t) where show sc = show' 1 sc where show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++ @@ -58,22 +63,29 @@ type CS = ([Term], Int) instance TermSize SC where- termsize (Case n as) = termsize as- termsize (STerm t) = termsize t- termsize _ = 1+ termsize n (Case n' as) = termsize n as+ termsize n (STerm t) = termsize n t+ termsize n _ = 1 instance TermSize CaseAlt where- termsize (ConCase _ _ _ s) = termsize s- termsize (ConstCase _ s) = termsize s- termsize (DefaultCase s) = termsize s+ termsize n (ConCase _ _ _ s) = termsize n s+ termsize n (ConstCase _ s) = termsize n s+ termsize n (DefaultCase s) = termsize n s -- simple terms can be inlined trivially - good for primitives in particular-small :: SC -> Bool-small t = False -- termsize t < 150+-- To avoid duplicating work, don't inline something which uses one+-- of its arguments in more than one place +small :: Name -> [Name] -> SC -> Bool+small n args t = let as = findAllUsedArgs t args in+ length as == length (nub as) && + termsize n t < 20 + namesUsed :: SC -> [Name] namesUsed sc = nub $ nu' [] sc where nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]+ nu' ps (ProjCase t alts) = nub $ (nut ps t ++ + (concatMap (nua ps) alts)) nu' ps (STerm t) = nub $ nut ps t nu' ps _ = [] @@ -84,6 +96,7 @@ nut ps (P _ n _) | n `elem` ps = [] | otherwise = [n] nut ps (App f a) = nut ps f ++ nut ps a+ nut ps (Proj t _) = nut ps t nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc nut ps (Bind n b sc) = nut (n:ps) sc nut ps _ = []@@ -95,6 +108,7 @@ findCalls :: SC -> [Name] -> [(Name, [[Name]])] findCalls sc topargs = nub $ nu' topargs sc where nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)+ nu' ps (ProjCase t alts) = nub (nut ps t ++ concatMap (nua ps) alts) nu' ps (STerm t) = nub $ nut ps t nu' ps _ = [] @@ -110,6 +124,7 @@ else [(n, map argNames args)] ++ concatMap (nut ps) args | otherwise = nut ps f ++ nut ps a nut ps (Bind n (Let t v) sc) = nut ps v ++ nut (n:ps) sc+ nut ps (Proj t _) = nut ps t nut ps (Bind n b sc) = nut (n:ps) sc nut ps _ = [] @@ -132,8 +147,11 @@ -- Find all directly used arguments (i.e. used but not in function calls) findUsedArgs :: SC -> [Name] -> [Name]-findUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nub $ nu' sc) where+findUsedArgs sc topargs = nub (findAllUsedArgs sc topargs)++findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where nu' (Case n alts) = n : concatMap nua alts+ nu' (ProjCase t alts) = directUse t ++ concatMap nua alts nu' (STerm t) = directUse t nu' _ = [] @@ -145,23 +163,25 @@ deriving (Show, Eq) -- Generate a simple case tree--- Work Left to Right at Compile Time +-- Work Right to Left -simpleCase :: Bool -> Bool -> Phase -> FC -> [([Name], Term, Term)] -> TC CaseDef+simpleCase :: Bool -> Bool -> Phase -> FC -> [([Name], Term, Term)] -> + TC CaseDef simpleCase tc cover phase fc [] = return $ CaseDef [] (UnmatchedCase "No pattern clauses") [] simpleCase tc cover phase fc cs = let proj = phase == RunTime pats = map (\ (avs, l, r) -> - (avs, rev phase (toPats tc l), (l, r))) cs+ (avs, toPats tc l, (l, r))) cs chkPats = mapM chkAccessible pats in case chkPats of OK pats -> let numargs = length (fst (head pats)) ns = take numargs args+ (ns', ps') = order ns pats (tree, st) = runState - (match (rev phase ns) pats (defaultCase cover)) ([], numargs)- t = CaseDef ns (prune proj (depatt ns tree)) (fst st) in+ (match ns' ps' (defaultCase cover)) ([], numargs)+ t = CaseDef ns (prune proj (depatt ns' tree)) (fst st) in if proj then return (stripLambdas t) else return t Error err -> Error (At fc err) where args = map (\i -> MN i "e") [0..]@@ -178,9 +198,6 @@ acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n acc (_ : xs) n = acc xs n -rev CompileTime = id-rev _ = reverse- data Pat = PCon Name Int [Pat] | PConst Const | PV Name@@ -210,6 +227,8 @@ toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 [] toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 [] toPat' (Constant BIType) [] | tc = return $ PCon (UN "Integer") 6 [] + toPat' (Constant W8Type) [] | tc = return $ PCon (UN "Word8") 7 []+ toPat' (Constant W16Type) [] | tc = return $ PCon (UN "Word16") 8 [] toPat' (P Bound n _) [] = do ns <- get if n `elem` ns @@ -217,7 +236,7 @@ else do put (n : ns) return (PV n) toPat' (App f a) args = toPat' f (a : args)- toPat' (Constant x@(I _)) [] = return $ PConst x + toPat' (Constant x) [] = return $ PConst x toPat' _ _ = return PAny @@ -242,6 +261,32 @@ Cons cons : partition rest partition xs = error $ "Partition " ++ show xs +-- reorder the patterns so that the one with most distinct names+-- comes next. Take rightmost first, otherwise (i.e. pick value rather+-- than dependency)++order :: [Name] -> [Clause] -> ([Name], [Clause])+order [] cs = ([], cs)+order ns [] = (ns, [])+order ns cs = let patnames = transpose (map (zip ns) (map fst cs))+ pats' = transpose (sortBy moreDistinct (reverse patnames)) in+ (getNOrder pats', zipWith rebuild pats' cs)+ where+ getNOrder [] = error $ "Failed order on " ++ show (ns, cs)+ getNOrder (c : _) = map fst c++ rebuild patnames clause = (map snd patnames, snd clause)++ moreDistinct xs ys = compare (numNames [] (map snd ys)) + (numNames [] (map snd xs))++ numNames xs (PCon n _ _ : ps) + | not (Left n `elem` xs) = numNames (Left n : xs) ps+ numNames xs (PConst c : ps)+ | not (Right c `elem` xs) = numNames (Right c : xs) ps+ numNames xs (_ : ps) = numNames xs ps+ numNames xs [] = length xs+ match :: [Name] -> [Clause] -> SC -- error case -> State CS SC match [] (([], ret) : xs) err @@ -251,8 +296,7 @@ Impossible -> return ImpossibleCase tm -> return $ STerm tm -- run out of arguments match vs cs err = do let ps = partition cs- cs <- mixture vs ps err- return cs+ mixture vs ps err mixture :: [Name] -> [Partition] -> SC -> State CS SC mixture vs [] err = return err@@ -344,7 +388,7 @@ repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res)) repVar v (PAny : ps , res) = (ps, res) --- fix: case e of S k -> f (S k) ==> case e of S k -. f e+-- fix: case e of S k -> f (S k) ==> case e of S k -> f e depatt :: [Name] -> SC -> SC depatt ns tm = dp [] tm where@@ -364,7 +408,8 @@ where applyMap [] nt cn pty args' = mkApp (P nt cn pty) args' applyMap ((x, (n, args)) : ms) nt cn pty args'- | and ((n == cn) : zipWith same args args') = P Ref x Erased+ | and ((length args == length args') :+ (n == cn) : zipWith same args args') = P Ref x Erased | otherwise = applyMap ms nt cn pty args' same n (P _ n' _) = n == n' same _ _ = False
src/Core/Constraints.hs view
@@ -1,61 +1,61 @@-module Core.Constraints(ucheck) where - -import Core.TT - -import Control.Applicative -import Control.Arrow -import Control.Monad.Error -import Control.Monad.RWS -import Control.Monad.State -import Data.List -import Data.Maybe -import qualified Data.Map as M - -import Debug.Trace - -ucheck :: [(UConstraint, FC)] -> TC () -ucheck cs = acyclic rels (map fst (M.toList rels)) - where lhs (ULT l _) = l - lhs (ULE l _) = l - rels = mkRels cs M.empty - -type Relations = M.Map UExp [(UConstraint, FC)] - -mkRels :: [(UConstraint, FC)] -> Relations -> Relations -mkRels [] acc = acc -mkRels ((c, f) : cs) acc - | not (ignore c) - = case M.lookup (lhs c) acc of - Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc) - Just rs -> mkRels cs (M.insert (lhs c) ((c,f):rs) acc) - | otherwise = mkRels cs acc - where lhs (ULT l _) = l - lhs (ULE l _) = l - ignore (ULE l r) = l == r - ignore _ = False - - -acyclic :: Relations -> [UExp] -> TC () -acyclic r cvs = checkCycle (FC "root" 0) r [] 0 cvs - where - checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC () - checkCycle fc r path inc [] = return () - checkCycle fc r path inc (c : cs) - = do check fc path inc c - -- Remove c from r since we know there's no cycles now - let r' = M.insert c [] r - checkCycle fc r' path inc cs - - check fc path inc (UVar x) | x < 0 = return () - check fc path inc cv - | inc > 0 && cv `elem` map fst path - = Error $ At fc UniverseError - -- FIXME: Make informative - -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path)) - | otherwise = case M.lookup cv r of - Nothing -> return () - Just cs -> mapM_ (next ((cv, fc):path) inc) cs - - next path inc (ULT l r, fc) = check fc path (inc + 1) r - next path inc (ULE l r, fc) = check fc path inc r - +module Core.Constraints(ucheck) where++import Core.TT++import Control.Applicative+import Control.Arrow+import Control.Monad.Error+import Control.Monad.RWS+import Control.Monad.State+import Data.List+import Data.Maybe+import qualified Data.Map as M++import Debug.Trace++ucheck :: [(UConstraint, FC)] -> TC ()+ucheck cs = acyclic rels (map fst (M.toList rels))+ where lhs (ULT l _) = l+ lhs (ULE l _) = l+ rels = mkRels cs M.empty++type Relations = M.Map UExp [(UConstraint, FC)]++mkRels :: [(UConstraint, FC)] -> Relations -> Relations+mkRels [] acc = acc+mkRels ((c, f) : cs) acc + | not (ignore c)+ = case M.lookup (lhs c) acc of+ Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc)+ Just rs -> mkRels cs (M.insert (lhs c) ((c,f):rs) acc)+ | otherwise = mkRels cs acc+ where lhs (ULT l _) = l+ lhs (ULE l _) = l+ ignore (ULE l r) = l == r+ ignore _ = False+++acyclic :: Relations -> [UExp] -> TC ()+acyclic r cvs = checkCycle (FC "root" 0) r [] 0 cvs + where+ checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC ()+ checkCycle fc r path inc [] = return ()+ checkCycle fc r path inc (c : cs)+ = do check fc path inc c+ -- Remove c from r since we know there's no cycles now+ let r' = M.insert c [] r+ checkCycle fc r' path inc cs++ check fc path inc (UVar x) | x < 0 = return ()+ check fc path inc cv+ | inc > 0 && cv `elem` map fst path + = Error $ At fc UniverseError+ -- FIXME: Make informative+ -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path))+ | otherwise = case M.lookup cv r of+ Nothing -> return ()+ Just cs -> mapM_ (next ((cv, fc):path) inc) cs+ + next path inc (ULT l r, fc) = check fc path (inc + 1) r+ next path inc (ULE l r, fc) = check fc path inc r+
src/Core/CoreParser.hs view
@@ -1,16 +1,22 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName, idrisDef,- maybeWithNS) where+module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName, + idrisLexer, maybeWithNS, pDocComment) where import Core.TT import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr import Text.ParserCombinators.Parsec.Language+import Text.ParserCombinators.Parsec.Prim+import Text.ParserCombinators.Parsec.Char+import Text.ParserCombinators.Parsec.Combinator import qualified Text.ParserCombinators.Parsec.Token as PTok import Control.Monad.State+import Control.Monad.Identity+import Data.Char+import Data.List import Debug.Trace type TokenParser a = PTok.TokenParser a@@ -22,23 +28,49 @@ reservedOpNames = [":", "..", "=", "\\", "|", "<-", "->", "=>", "**"], reservedNames - = ["let", "in", "data", "codata", "record", "Set", + = ["let", "in", "data", "codata", "record", "Type", "do", "dsl", "import", "impossible", "case", "of", "total", "partial", "mutual", "infix", "infixl", "infixr", "where", "with", "syntax", "proof", "postulate", "using", "namespace", "class", "instance", "public", "private", "abstract", - "Int", "Integer", "Float", "Char", "String", "Ptr"]+ "Int", "Integer", "Float", "Char", "String", "Ptr",+ "Word8", "Word16"] } iOpStart = oneOf ":!#$%&*+./<=>?@\\^|-~" iOpLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" -- <|> letter -lexer :: TokenParser a-lexer = PTok.makeTokenParser idrisDef+idrisLexer :: TokenParser a+idrisLexer = idrisMakeTokenParser idrisDef +lexer = idrisLexer++-- Taken from Parsec source code+lexWS = do i <- getInput+ skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+ where++ simpleSpace = skipMany1 (satisfy isSpace)+ oneLineComment = do try (do string ("--")+ satisfy (\x -> x /= '|' && x /= '^'))+ skipMany (satisfy (/= '\n'))+ return ()+ multiLineComment = do try (do string "{-"+ satisfy (\x -> x /= '|' && x /= '^'))+ inCommentMulti++ inCommentMulti+ = do{ try (string "-}") ; return () }+ <|> do{ multiLineComment ; inCommentMulti }+ <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti }+ <|> do{ oneOf startEnd ; inCommentMulti }+ <?> "end of comment"+ where+ startEnd = "-}{"+ whiteSpace= PTok.whiteSpace lexer lexeme = PTok.lexeme lexer symbol = PTok.symbol lexer@@ -50,6 +82,7 @@ reserved = PTok.reserved lexer operator = PTok.operator lexer reservedOp= PTok.reservedOp lexer+strlit = PTok.stringLiteral lexer lchar = lexeme.char type CParser a = GenParser Char a@@ -98,6 +131,30 @@ (x, "") -> [x] (x, '.':y) -> x : parseNS y +pDocComment :: Char -> CParser a String+pDocComment c + = try (do string ("--")+ char c+ skipMany simpleSpace+ i <- getInput+ let (doc, rest) = span (/='\n') i+ setInput rest+ whiteSpace+ return doc)+ <|> try (do string ("{-")+ char c+ skipMany simpleSpace+ i <- getInput+ -- read to '-}'+ let (doc, rest) = spanComment "" i+ setInput rest+ whiteSpace+ return doc)+ where spanComment acc ('-':'}':xs) = (reverse acc, xs)+ spanComment acc (x:xs) = spanComment (x : acc) xs+ spanComment acc [] = (acc, [])+ simpleSpace = skipMany1 (satisfy isSpace)+ pDef :: CParser a (Name, RDef) pDef = try (do x <- iName []; lchar ':'; ty <- pTerm lchar '='@@ -159,8 +216,8 @@ lchar '.'; sc <- pTerm return (RBind x (PVar ty) sc))- <|> try (do reserved "Set"- return RSet)+ <|> try (do reserved "Type"+ return RType) <|> try (do x <- iName [] return (Var x)) @@ -174,3 +231,340 @@ c <- iName []; lchar ':'; ty <- pTerm return (c, ty) +------ borrowed from Parsec +-- (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007++idrisMakeTokenParser languageDef+ = PTok.TokenParser{ + PTok.identifier = identifier+ , PTok.reserved = reserved+ , PTok.operator = operator+ , PTok.reservedOp = reservedOp++ , PTok.charLiteral = charLiteral+ , PTok.stringLiteral = stringLiteral+ , PTok.natural = natural+ , PTok.integer = integer+ , PTok.float = float+ , PTok.naturalOrFloat = naturalOrFloat+ , PTok.decimal = decimal+ , PTok.hexadecimal = hexadecimal+ , PTok.octal = octal++ , PTok.symbol = symbol+ , PTok.lexeme = lexeme+ , PTok.whiteSpace = lexWS++ , PTok.parens = parens+ , PTok.braces = braces+ , PTok.angles = angles+ , PTok.brackets = brackets+ , PTok.squares = brackets+ , PTok.semi = semi+ , PTok.comma = comma+ , PTok.colon = colon+ , PTok.dot = dot+ , PTok.semiSep = semiSep+ , PTok.semiSep1 = semiSep1+ , PTok.commaSep = commaSep+ , PTok.commaSep1 = commaSep1+ }+ where++ -----------------------------------------------------------+ -- Bracketing+ -----------------------------------------------------------+ parens p = between (symbol "(") (symbol ")") p+ braces p = between (symbol "{") (symbol "}") p+ angles p = between (symbol "<") (symbol ">") p+ brackets p = between (symbol "[") (symbol "]") p++ semi = symbol ";"+ comma = symbol ","+ dot = symbol "."+ colon = symbol ":"++ commaSep p = sepBy p comma+ semiSep p = sepBy p semi++ commaSep1 p = sepBy1 p comma+ semiSep1 p = sepBy1 p semi+++ -----------------------------------------------------------+ -- Chars & Strings+ -----------------------------------------------------------+ charLiteral = lexeme (between (char '\'')+ (char '\'' <?> "end of character")+ characterChar )+ <?> "character"++ characterChar = charLetter <|> charEscape+ <?> "literal character"++ charEscape = do{ char '\\'; escapeCode }+ charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++++ stringLiteral = lexeme (+ do{ str <- between (char '"')+ (char '"' <?> "end of string")+ (many stringChar)+ ; return (foldr (maybe id (:)) "" str)+ }+ <?> "literal string")++ stringChar = do{ c <- stringLetter; return (Just c) }+ <|> stringEscape+ <?> "string character"++ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++ stringEscape = do{ char '\\'+ ; do{ escapeGap ; return Nothing }+ <|> do{ escapeEmpty; return Nothing }+ <|> do{ esc <- escapeCode; return (Just esc) }+ }++ escapeEmpty = char '&'+ escapeGap = do{ many1 space+ ; char '\\' <?> "end of string gap"+ }++++ -- escape codes+ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl+ <?> "escape code"++ charControl = do{ char '^'+ ; code <- upper+ ; return (toEnum (fromEnum code - fromEnum 'A'))+ }++ charNum = do{ code <- decimal+ <|> do{ char 'o'; number 8 octDigit }+ <|> do{ char 'x'; number 16 hexDigit }+ ; return (toEnum (fromInteger code))+ }++ charEsc = choice (map parseEsc escMap)+ where+ parseEsc (c,code) = do{ char c; return code }++ charAscii = choice (map parseAscii asciiMap)+ where+ parseAscii (asc,code) = try (do{ string asc; return code })+++ -- escape code tables+ escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++ ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+ "FS","GS","RS","US","SP"]+ ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+ "CAN","SUB","ESC","DEL"]++ ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+ '\EM','\FS','\GS','\RS','\US','\SP']+ ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+ '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+ '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']+++ -----------------------------------------------------------+ -- Numbers+ -----------------------------------------------------------+ naturalOrFloat = lexeme (natFloat) <?> "number"++ float = lexeme floating <?> "float"+ integer = lexeme int <?> "integer"+ natural = lexeme nat <?> "natural"+++ -- floats+ floating = do{ n <- decimal+ ; fractExponent n+ }+++ natFloat = do{ char '0'+ ; zeroNumFloat+ }+ <|> decimalFloat++ zeroNumFloat = do{ n <- hexadecimal <|> octal+ ; return (Left n)+ }+ <|> decimalFloat+ <|> fractFloat 0+ <|> return (Left 0)++ decimalFloat = do{ n <- decimal+ ; option (Left n)+ (fractFloat n)+ }++ fractFloat n = do{ f <- fractExponent n+ ; return (Right f)+ }++ fractExponent n = do{ fract <- fraction+ ; expo <- option 1.0 exponent'+ ; return ((fromInteger n + fract)*expo)+ }+ <|>+ do{ expo <- exponent'+ ; return ((fromInteger n)*expo)+ }++ fraction = do{ char '.'+ ; digits <- many1 digit <?> "fraction"+ ; return (foldr op 0.0 digits)+ }+ <?> "fraction"+ where+ op d f = (f + fromIntegral (digitToInt d))/10.0++ exponent' = do{ oneOf "eE"+ ; f <- sign+ ; e <- decimal <?> "exponent"+ ; return (power (f e))+ }+ <?> "exponent"+ where+ power e | e < 0 = 1.0/power(-e)+ | otherwise = fromInteger (10^e)+++ -- integers and naturals+ int = do{ f <- lexeme sign+ ; n <- nat+ ; return (f n)+ }++ sign = (char '-' >> return negate)+ <|> (char '+' >> return id)+ <|> return id++ nat = zeroNumber <|> decimal++ zeroNumber = do{ char '0'+ ; hexadecimal <|> octal <|> decimal <|> return 0+ }+ <?> ""++ decimal = number 10 digit+ hexadecimal = do{ oneOf "xX"; number 16 hexDigit }+ octal = do{ oneOf "oO"; number 8 octDigit }++ number base baseDigit+ = do{ digits <- many1 baseDigit+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+ ; seq n (return n)+ }++ -----------------------------------------------------------+ -- Operators & reserved ops+ -----------------------------------------------------------+ reservedOp name =+ lexeme $ try $+ do{ string name+ ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+ }++ operator =+ lexeme $ try $+ do{ name <- oper+ ; if (isReservedOp name)+ then unexpected ("reserved operator " ++ show name)+ else return name+ }++ oper =+ do{ c <- (opStart languageDef)+ ; cs <- many (opLetter languageDef)+ ; return (c:cs)+ }+ <?> "operator"++ isReservedOp name =+ isReserved (sort (reservedOpNames languageDef)) name+++ -----------------------------------------------------------+ -- Identifiers & Reserved words+ -----------------------------------------------------------+ reserved name =+ lexeme $ try $+ do{ caseString name+ ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+ }++ caseString name+ | caseSensitive languageDef = string name+ | otherwise = do{ walk name; return name }+ where+ walk [] = return ()+ walk (c:cs) = do{ caseChar c <?> msg; walk cs }++ caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)+ | otherwise = char c++ msg = show name+++ identifier =+ lexeme $ try $+ do{ name <- ident+ ; if (isReservedName name)+ then unexpected ("reserved word " ++ show name)+ else return name+ }+++ ident+ = do{ c <- identStart languageDef+ ; cs <- many (identLetter languageDef)+ ; return (c:cs)+ }+ <?> "identifier"++ isReservedName name+ = isReserved theReservedNames caseName+ where+ caseName | caseSensitive languageDef = name+ | otherwise = map toLower name+++ isReserved names name+ = scan names+ where+ scan [] = False+ scan (r:rs) = case (compare r name) of+ LT -> scan rs+ EQ -> True+ GT -> False++ theReservedNames+ | caseSensitive languageDef = sortedNames+ | otherwise = map (map toLower) sortedNames+ where+ sortedNames = sort (reservedNames languageDef)++++ -----------------------------------------------------------+ -- White space & symbols+ -----------------------------------------------------------+ symbol name+ = lexeme (string name)++ lexeme p+ = do{ x <- p; whiteSpace; return x }++ --whiteSpace+ whiteSpace = lexWS
src/Core/Elaborate.hs view
@@ -91,11 +91,24 @@ get_context = do ES p _ _ <- get return (context (fst p)) +-- update the context+-- (should only be used for adding temporary definitions or all sorts of+-- stuff could go wrong)+set_context :: Context -> Elab' aux ()+set_context ctxt = do ES (p, a) logs prev <- get+ put (ES (p { context = ctxt }, a) logs prev)+ -- get the proof term get_term :: Elab' aux Term get_term = do ES p _ _ <- get return (pterm (fst p)) +-- get the proof term+update_term :: (Term -> Term) -> Elab' aux ()+update_term f = do ES (p,a) logs prev <- get+ let p' = p { pterm = f (pterm p) }+ put (ES (p', a) logs prev)+ -- get the local context at the currently in focus hole get_env :: Elab' aux Env get_env = do ES p _ _ <- get@@ -126,6 +139,12 @@ (val, ty) <- lift $ check ctxt env tm return (finalise ty) +get_type_val :: Raw -> Elab' aux (Term, Type)+get_type_val tm = do ctxt <- get_context+ env <- get_env+ (val, ty) <- lift $ check ctxt env tm+ return (finalise val, finalise ty)+ -- get holes we've deferred for later definition get_deferred :: Elab' aux [Name] get_deferred = do ES p _ _ <- get@@ -136,8 +155,16 @@ return (injective (fst p)) checkInjective :: (Term, Term, Term) -> Elab' aux ()-checkInjective (tm, l, r) = if isInjective tm then return ()+checkInjective (tm, l, r) = do ctxt <- get_context+ if isInj ctxt tm then return () else lift $ tfail (NotInjective tm l r) + where isInj ctxt (P _ n _) + | isConName Nothing n ctxt = True+ isInj ctxt (App f a) = isInj ctxt f+ isInj ctxt (Constant _) = True+ isInj ctxt (TType _) = True+ isInj ctxt (Bind _ (Pi _) sc) = True+ isInj ctxt _ = False -- get instance argument names get_instances :: Elab' aux [Name]@@ -145,11 +172,20 @@ return (instances (fst p)) -- given a desired hole name, return a unique hole name-unique_hole :: Name -> Elab' aux Name-unique_hole n = do ES p _ _ <- get- let bs = bound_in (pterm (fst p)) ++ bound_in (ptype (fst p))- n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) ++ bs ++ dontunify (fst p))- return n'+unique_hole = unique_hole' False++unique_hole' :: Bool -> Name -> Elab' aux Name+unique_hole' reusable n + = do ES p _ _ <- get+ let bs = bound_in (pterm (fst p)) ++ + bound_in (ptype (fst p))+ n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p) + ++ bs ++ dontunify (fst p) ++ usedns (fst p))+ ES (p, a) s u <- get+ -- Hmm: Do we need this level of uniqueness?+ let p' = p -- if reusable then p else p { usedns = n' : usedns p } + put (ES (p', a) s u)+ return n' where bound_in (Bind n b sc) = n : bi b ++ bound_in sc where@@ -208,6 +244,9 @@ compute :: Elab' aux () compute = processTactic' Compute +hnf_compute :: Elab' aux ()+hnf_compute = processTactic' HNF_Compute+ eval_in :: Raw -> Elab' aux () eval_in t = processTactic' (EvalIn t) @@ -251,6 +290,9 @@ defer n = do n' <- unique_hole n processTactic' (Defer n') +deferType :: Name -> Raw -> [Name] -> Elab' aux ()+deferType n ty ns = processTactic' (DeferType n ty ns)+ instanceArg :: Name -> Elab' aux () instanceArg n = processTactic' (Instance n) @@ -274,7 +316,8 @@ ctxt <- get_context env <- get_env -- let claims = getArgs ty imps- claims <- mkClaims (normalise ctxt env ty) imps []+ -- claims <- mkClaims (normalise ctxt env ty) imps []+ claims <- mkClaims (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)@@ -285,15 +328,17 @@ -- (h : _) -> reorder_claims h return claims where- mkClaims (Bind n' (Pi t) sc) (i : is) claims =- do n <- unique_hole (mkMN n')+ mkClaims (Bind n' (Pi t_in) sc) (i : is) claims hs =+ do let t = rebind hs t_in+ n <- unique_hole (mkMN n') -- when (null claims) (start_unify n) let sc' = instantiate (P Bound n t) sc+-- trace ("CLAIMING " ++ show (n, t) ++ " with " ++ show hs) $ claim n (forget t) when i (movelast n)- mkClaims sc' is (n : claims)- mkClaims t [] claims = return (reverse claims)- mkClaims _ _ _ + mkClaims sc' is (n : claims) hs+ mkClaims t [] claims _ = return (reverse claims)+ mkClaims _ _ _ _ | Var n <- fn = do ctxt <- get_context case lookupTy Nothing n ctxt of@@ -308,6 +353,13 @@ mkMN n@(UN x) = MN 1000 x mkMN (NS n xs) = NS (mkMN n) xs + rebind hs (Bind n t sc)+ | n `elem` hs = let n' = uniqueName n hs in+ Bind n' (fmap (rebind hs) t) (rebind (n':hs) sc)+ | otherwise = Bind n (fmap (rebind hs) t) (rebind (n:hs) sc)+ rebind hs (App f a) = App (rebind hs f) (rebind hs a)+ rebind hs t = t+ apply :: Raw -> [(Bool, Int)] -> Elab' aux [Name] apply fn imps = do args <- prepare_apply fn (map fst imps)@@ -325,9 +377,12 @@ map fst (filter (not.snd) (zip args (map fst imps))) let (n, hs) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $ unified p- let unify = dropGiven dont hs+ let unify = -- trace ("Not done " ++ show hs) $ + dropGiven dont hs put (ES (p { dontunify = dont, unified = (n, unify) }, a) s prev)+ ptm <- get_term end_unify+ ptm <- get_term return (map (updateUnify unify) args) where updateUnify hs n = case lookup n hs of Just (P _ t _) -> t@@ -355,7 +410,7 @@ do ty <- get_type (Var n) ctxt <- get_context env <- get_env- claims <- doClaims (normalise ctxt env ty) args []+ claims <- doClaims (hnf ctxt env ty) args [] prep_fill n (map fst claims) let eclaims = sortBy (\ (_, x) (_,y) -> priOrder x y) claims elabClaims [] False claims@@ -394,7 +449,7 @@ focus n; elaboration; elabClaims failed r xs mkMN n@(MN _ _) = n- mkMN n@(UN x) = MN 0 x+ mkMN n@(UN x) = MN 1000 x mkMN (NS n ns) = NS (mkMN n) ns simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux ()@@ -403,8 +458,8 @@ b <- unique_hole (MN 0 "b") f <- unique_hole (MN 0 "f") s <- unique_hole (MN 0 "s")- claim a RSet- claim b RSet+ claim a RType+ claim b RType claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b)) start_unify s claim s (Var a)@@ -428,19 +483,23 @@ -- which we'll fill with the argument type too. arg :: Name -> Name -> Elab' aux () arg n tyhole = do ty <- unique_hole tyhole- claim ty RSet+ claim ty RType forall n (Var ty) -- Try a tactic, if it fails, try another try :: Elab' aux a -> Elab' aux a -> Elab' aux a-try t1 t2 = do s <- get+try t1 t2 = try' t1 t2 False++try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a+try' t1 t2 proofSearch+ = do s <- get case runStateT t1 s of OK (v, s') -> do put s' return v- Error e1 -> if recoverableErr e1 then+ Error e1 -> if proofSearch || recoverableErr e1 then do case runStateT t2 s of OK (v, s') -> do put s'; return v- Error e2 -> if score e1 > score e2 + Error e2 -> if score e1 >= score e2 then lift (tfail e1) else lift (tfail e2) else lift (tfail e1)
src/Core/Evaluate.hs view
@@ -19,29 +19,14 @@ import Core.TT import Core.CaseTree -data EvalState = ES { limited :: [(Name, Int)],- steps :: Int -- number of applications/let reductions- }---- Evaluation fails if we hit a boredom threshold - in which case, just return--- the original (capture the failure in a Maybe)+data EvalState = ES { limited :: [(Name, Int)] } type Eval a = State EvalState a -data EvalOpt = Spec | HNF | Simplify | AtREPL+data EvalOpt = Spec | HNF | Simplify Bool | AtREPL deriving (Show, Eq) -initEval = ES [] 0--step :: Int -> Eval ()-step max = do e <- get- put (e { steps = steps e + 1 })- if steps e > max then fail "Threshold exceeded"- else return () --getSteps :: Eval Int-getSteps = do e <- get- return (steps e)+initEval = ES [] -- VALUES (as HOAS) --------------------------------------------------------- @@ -49,7 +34,7 @@ | VV Int | VBind Name (Binder Value) (Value -> Eval Value) | VApp Value Value- | VSet UExp+ | VType UExp | VErased | VConstant Const -- | VLazy Env [Value] Term@@ -59,7 +44,7 @@ | HV Int | HBind Name (Binder HNF) (HNF -> Eval HNF) | HApp HNF [HNF] [TT Name]- | HSet UExp+ | HType UExp | HConstant Const | HTmp Int deriving Show@@ -77,18 +62,15 @@ -- i.e. it's an intermediate environment that we have while type checking or -- while building a proof. -threshold = 1000 -- boredom threshold for evaluation, to prevent infinite typechecking- -- in fact it's a maximum recursion depth- -- Normalise fully type checked terms (so, assume all names/let bindings resolved) normaliseC :: Context -> Env -> TT Name -> TT Name normaliseC ctxt env t - = evalState (do val <- eval False ctxt threshold [] env t []+ = evalState (do val <- eval False ctxt [] env t [] quote 0 val) initEval normaliseAll :: Context -> Env -> TT Name -> TT Name normaliseAll ctxt env t - = evalState (do val <- eval False ctxt threshold [] env t [AtREPL]+ = evalState (do val <- eval False ctxt [] env t [AtREPL] quote 0 val) initEval normalise :: Context -> Env -> TT Name -> TT Name@@ -96,27 +78,31 @@ normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name normaliseTrace tr ctxt env t - = evalState (do val <- eval tr ctxt threshold [] (map finalEntry env) (finalise t) []+ = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) [] quote 0 val) initEval specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name specialise ctxt env limits t - = evalState (do val <- eval False ctxt threshold limits (map finalEntry env) (finalise t) []+ = evalState (do val <- eval False ctxt limits (map finalEntry env) (finalise t) [] quote 0 val) (initEval { limited = limits }) -- Like normalise, but we only reduce functions that are marked as okay to -- inline (and probably shouldn't reduce lets?) -simplify :: Context -> Env -> TT Name -> TT Name-simplify ctxt env t - = evalState (do val <- eval False ctxt threshold [(UN "lazy", 0),- (UN "par", 0)] - (map finalEntry env) (finalise t) [Simplify]+simplify :: Context -> Bool -> Env -> TT Name -> TT Name+simplify ctxt runtime env t + = evalState (do val <- eval False ctxt [(UN "lazy", 0),+ (UN "par", 0),+ (UN "fork", 0)] + (map finalEntry env) (finalise t) + [Simplify runtime] quote 0 val) initEval hnf :: Context -> Env -> TT Name -> TT Name hnf ctxt env t - = evalState (do val <- eval False ctxt threshold [] (map finalEntry env) (finalise t) [HNF]+ = evalState (do val <- eval False ctxt [] + (map finalEntry env) + (finalise t) [HNF] quote 0 val) initEval @@ -135,6 +121,8 @@ unbindEnv (_:bs) (Bind n b sc) = unbindEnv bs sc usable :: Bool -> Name -> [(Name, Int)] -> (Bool, [(Name, Int)])+usable _ _ ns@((MN 0 "STOP", _) : _) = (False, ns)+usable True (UN "io_bind") ns = (False, ns) usable s n [] = (True, []) usable s n ns = case lookup n ns of Just 0 -> (False, ns)@@ -142,34 +130,35 @@ _ -> if s then (True, (n, 0) : filter (\ (n', _) -> n/=n') ns) else (True, (n, 100) : filter (\ (n', _) -> n/=n') ns) -reduction :: Eval ()-reduction = do ES ns s <- get- put (ES ns (s+1))- -- Evaluate in a context of locally named things (i.e. not de Bruijn indexed, -- such as we might have during construction of a proof) -eval :: Bool -> Context -> Int -> [(Name, Int)] -> Env -> TT Name -> +eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name -> [EvalOpt] -> Eval Value-eval traceon ctxt maxred ntimes genv tm opts = ev ntimes [] True [] tm where+eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where spec = Spec `elem` opts- simpl = Simplify `elem` opts+ simpl = Simplify True `elem` opts atRepl = AtREPL `elem` opts+ hnf = HNF `elem` opts + canSimplify inl inr n stk + = (Simplify False `elem` opts && (not inl || elem n stk))+ || (Simplify True `elem` opts && (not inr || elem n stk))+ ev ntimes stk top env (P _ n ty)- | Just (Let t v) <- lookup n genv = do when (not atRepl) $ step maxred- ev ntimes stk top env v + | Just (Let t v) <- lookup n genv = ev ntimes stk top env v ev ntimes_in stk top env (P Ref n ty) + | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty) | (True, ntimes) <- usable simpl n ntimes_in = do let val = lookupDefAcc Nothing n atRepl ctxt - when (not atRepl) $ step maxred case val of [(Function _ tm, Public)] -> ev ntimes (n:stk) True env tm [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty return $ VP nt n vty- [(CaseOp inl _ _ _ [] tree _ _, Public)] -> -- unoptimised version- if simpl && (not inl || elem n stk) + [(CaseOp inl inr _ _ _ [] tree _ _, acc)] + | acc == Public || simpl -> -- unoptimised version+ if canSimplify inl inr n stk then liftM (VP Ref n) (ev ntimes stk top env ty) else do c <- evCase ntimes (n:stk) top env [] [] tree case c of@@ -180,60 +169,63 @@ ev ntimes stk top env (V i) | i < length env = return $ env !! i | otherwise = return $ VV i ev ntimes stk top env (Bind n (Let t v) sc)- | not simpl || vinstances 0 sc < 2+-- | not simpl || vinstances 0 sc < 2 = do v' <- ev ntimes stk top env v --(finalise v)- when (not atRepl) $ step maxred sc' <- ev ntimes stk top (v' : env) sc wknV (-1) sc'- | otherwise+{- | otherwise -- put this back when the Bind works properly = do t' <- ev ntimes stk top env t v' <- ev ntimes stk top env v --(finalise v)- when (not atRepl) $ step maxred+ -- use Tmp as a placeholder, then make it a variable reference+ -- again when evaluation finished sc' <- ev ntimes stk top (v' : env) sc- return $ VBind n (Let t' v') (\x -> return sc')+ return $ VBind n (Let t' v') (\x -> return sc') -} ev ntimes stk top env (Bind n (NLet t v) sc) = do t' <- ev ntimes stk top env (finalise t) v' <- ev ntimes stk top env (finalise v)- when (not atRepl) $ step maxred sc' <- ev ntimes stk top (v' : env) sc return $ VBind n (Let t' v') (\x -> return sc') ev ntimes stk top env (Bind n b sc) = do b' <- vbind env b- when (not atRepl) $ step maxred- return $ VBind n b' (\x -> ev ntimes stk top (x:env) sc)- where vbind env t = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t+ return $ VBind n b' (\x -> ev ntimes stk False (x:env) sc)+ where vbind env t + | simpl + = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes) + stk top env (finalise tm)) t + | otherwise + = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t -- ev ntimes stk top env (App (App (P _ laz _) _) a) -- | laz == UN "lazy" -- = trace (showEnvDbg genv a) $ ev ntimes stk top env a ev ntimes stk top env (App f a) - = do f' <- ev ntimes stk top env f+ = do f' <- ev ntimes stk False env f a' <- ev ntimes stk False env a- when (not atRepl) $ step maxred evApply ntimes stk top env [a'] f' ev ntimes stk top env (Constant c) = return $ VConstant c ev ntimes stk top env Erased = return VErased- ev ntimes stk top env (Set i) = return $ VSet i+ ev ntimes stk top env (TType i) = return $ VType i evApply ntimes stk top env args (VApp f a) = evApply ntimes stk top env (a:args) f- evApply ntimes stk top env args f = do when (not atRepl) $ step maxred- apply ntimes stk top env f args+ evApply ntimes stk top env args f = apply ntimes stk top env f args - apply ntimes stk top env f as - | length stk > threshold = return $ unload env f as apply ntimes stk top env (VBind n (Lam t) sc) (a:as) = do a' <- sc a app <- apply ntimes stk top env a' as wknV (-1) app -- apply ntimes stk False env f args -- | spec = specApply ntimes stk env f args - apply ntimes_in stk top env f@(VP Ref n ty) args+ apply ntimes_in stk top env f@(VP Ref n ty) args+ | not top && hnf = case args of+ [] -> return f+ _ -> return $ unload env f args | (True, ntimes) <- usable simpl n ntimes_in = traceWhen traceon (show stk) $ do let val = lookupDefAcc Nothing n atRepl ctxt case val of- [(CaseOp inl _ _ _ ns tree _ _, Public)] ->- if simpl && (not inl || elem n stk) + [(CaseOp inl inr _ _ _ ns tree _ _, acc)]+ | acc == Public || simpl -> -- unoptimised version+ if canSimplify inl inr n stk then return $ unload env (VP Ref n ty) args else do c <- evCase ntimes (n:stk) top env ns args tree case c of@@ -267,7 +259,8 @@ | length ns <= length args = do let args' = take (length ns) args let rest = drop (length ns) args- t <- evTree ntimes stk top env (zipWith (\n t -> (n, t)) ns args') tree+ t <- evTree ntimes stk top env + (zipWith (\n t -> (n, t)) ns args') tree return (t, rest) | otherwise = return (Nothing, args) @@ -276,7 +269,8 @@ evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing evTree ntimes stk top env amap (STerm tm) = do let etm = pToVs (map fst amap) tm- etm' <- ev ntimes stk top (map snd amap ++ env) etm+ etm' <- ev ntimes stk (not (conHeaded tm)) + (map snd amap ++ env) etm return $ Just etm' evTree ntimes stk top env amap (Case n alts) = case lookup n amap of@@ -289,6 +283,10 @@ _ -> return Nothing _ -> return Nothing + conHeaded tm@(App _ _) + | (P (DCon _ _) _ _, args) <- unApply tm = True+ conHeaded t = False+ chooseAlt' ntimes stk env _ (f, args) alts amap = do f' <- apply ntimes stk True env f args chooseAlt env f' (getValArgs f') alts amap@@ -332,6 +330,16 @@ getValArgs' (VApp f a) as = getValArgs' f (a:as) getValArgs' f as = (f, as) +tmpToV i (VTmp 0) = return $ VV i+tmpToV i (VP nt n v) = liftM (VP nt n) (tmpToV i v)+ +tmpToV i (VBind n b sc) = do b' <- fmapMB (tmpToV i) b+ let sc' = \x -> do x' <- sc x+ tmpToV (i + 1) x'+ return (VBind n b' sc')+tmpToV i (VApp f a) = liftM2 VApp (tmpToV i f) (tmpToV i a)+tmpToV i x = return x+ class Quote a where quote :: Int -> a -> Eval (TT Name) @@ -343,7 +351,7 @@ liftM (Bind n b') (quote (i+1) sc') where quoteB t = fmapMB (quote i) t quote i (VApp f a) = liftM2 App (quote i f) (quote i a)- quote i (VSet u) = return $ Set u+ quote i (VType u) = return $ TType u quote i VErased = return $ Erased quote i (VConstant c) = return $ Constant c quote i (VTmp x) = return $ V (i - x - 1)@@ -361,7 +369,7 @@ where iEnv [] a = return a iEnv (x:xs) a = do x' <- quote i x iEnv xs (weakenTm (-1) (instantiate x' a))- quote i (HSet u) = return $ Set u+ quote i (HType u) = return $ TType u quote i (HConstant c) = return $ Constant c quote i (HTmp x) = return $ V (i - x - 1) @@ -392,7 +400,7 @@ ev env (P Ref n ty) = case lookupDef Nothing n ctxt of [Function _ t] -> ev env t [TyDecl nt ty] -> return $ HP nt n ty- [CaseOp inl _ _ _ [] tree _ _] ->+ [CaseOp inl _ _ _ _ [] tree _ _] -> do c <- evCase env [] [] tree case c of (Nothing, _, _) -> return $ HP Ref n ty@@ -411,7 +419,7 @@ where hbind env t = fmapMB (\tm -> ev env (finalise tm)) t ev env (App f a) = evApply env [a] f ev env (Constant c) = return $ HConstant c- ev env (Set i) = return $ HSet i+ ev env (TType i) = return $ HType i evApply env args (App f a) = evApply env (a : args) f evApply env args f = do f' <- ev env f@@ -422,7 +430,7 @@ app <- apply env sc' as wknH (-1) app apply env (HP Ref n ty) args- | [CaseOp _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt+ | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt = do c <- evCase env ns args tree case c of (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args@@ -499,6 +507,8 @@ findConst ChType (ConCase n 3 [] v : xs) = Just v findConst StrType (ConCase n 4 [] v : xs) = Just v findConst PtrType (ConCase n 5 [] v : xs) = Just v + findConst W8Type (ConCase n 6 [] v : xs) = Just v+ findConst W16Type (ConCase n 7 [] v : xs) = Just v findConst c (_ : xs) = findConst c xs getValArgs (HApp t env args) = (t, env, args)@@ -510,7 +520,7 @@ convEq ctxt = ceq [] where ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool ceq ps (P xt x _) (P yt y _) - | (xt == yt && x ==y ) || (x, y) `elem` ps || (y,x) `elem` ps = return True+ | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True | otherwise = sameDefs ps x y ceq ps (V x) (V y) = return (x == y) ceq ps (Bind _ xb xs) (Bind _ yb ys) @@ -521,9 +531,9 @@ ceqB ps b b' = ceq ps (binderTy b) (binderTy b') ceq ps (App fx ax) (App fy ay) = liftM2 (&&) (ceq ps fx fy) (ceq ps ax ay) ceq ps (Constant x) (Constant y) = return (x == y)- ceq ps (Set x) (Set y) = do (v, cs) <- get- put (v, ULE x y : cs)- return True+ ceq ps (TType x) (TType y) = do (v, cs) <- get+ put (v, ULE x y : cs)+ return True ceq ps Erased _ = return True ceq ps _ Erased = return True ceq ps _ _ = return False@@ -549,8 +559,8 @@ sameDefs ps x y = case (lookupDef Nothing x ctxt, lookupDef Nothing y ctxt) of ([Function _ xdef], [Function _ ydef]) -> ceq ((x,y):ps) xdef ydef- ([CaseOp _ _ _ _ _ xdef _ _], - [CaseOp _ _ _ _ _ ydef _ _])+ ([CaseOp _ _ _ _ _ _ xdef _ _], + [CaseOp _ _ _ _ _ _ ydef _ _]) -> caseeq ((x,y):ps) xdef ydef _ -> return False @@ -572,7 +582,8 @@ data Def = Function Type Term | TyDecl NameType Type | Operator Type Int ([Value] -> Maybe Value)- | CaseOp Bool Type -- bool for inlinable+ | CaseOp Bool Bool -- compile-time/run-time inlinable+ Type [Either Term (Term, Term)] -- original definition [([Name], Term, Term)] -- simplified definition [Name] SC -- Compile time case definition@@ -585,10 +596,12 @@ show (Function ty tm) = "Function: " ++ show (ty, tm) show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty show (Operator ty _ _) = "Operator: " ++ show ty- show (CaseOp _ ty ps_in ps ns sc ns' sc') + show (CaseOp inlc inlr ty ps_in ps ns sc ns' sc') = "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++ show ns ++ " " ++ show sc ++ "\n" ++- show ns' ++ " " ++ show sc'+ show ns' ++ " " ++ show sc' ++ "\n" +++ if inlc then "Inlinable\n" else "Not inlinable\n"+ -- We need this for serialising Def. Fortunately, it never gets used because -- we'll never serialise a primitive operator @@ -611,7 +624,7 @@ deriving Eq data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name- | Mutual [Name] | NotProductive+ | BelieveMe | Mutual [Name] | NotProductive deriving (Show, Eq) instance Show Totality where@@ -622,6 +635,7 @@ show (Partial NotCovering) = "not total as there are missing cases" show (Partial NotPositive) = "not strictly positive" show (Partial NotProductive) = "not productive"+ show (Partial BelieveMe) = "not total due to use of believe_me in proof" show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns) show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++ showSep " --> " (map show ns)@@ -649,7 +663,7 @@ ctxtAlist :: Context -> [(Name, Def)] ctxtAlist ctxt = map (\(n, (d, a, t)) -> (n, d)) $ toAlist (definitions ctxt) -veval ctxt env t = evalState (eval False ctxt threshold [] env t []) initEval+veval ctxt env t = evalState (eval False ctxt [] env t []) initEval addToCtxt :: Name -> Term -> Type -> Context -> Context addToCtxt n tm ty uctxt @@ -694,12 +708,12 @@ addCons (tag+1) cons (addDef n (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt) -addCasedef :: Name -> Bool -> Bool -> Bool -> +addCasedef :: Name -> Bool -> Bool -> Bool -> Bool -> [Either Term (Term, Term)] -> [([Name], Term, Term)] -> [([Name], Term, Term)] -> Type -> Context -> Context-addCasedef n alwaysInline tcase covering ps_in ps psrt ty uctxt +addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt = let ctxt = definitions uctxt access = case lookupDefAcc Nothing n False uctxt of [(_, acc)] -> acc@@ -707,8 +721,11 @@ ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps, simpleCase tcase covering RunTime (FC "" 0) psrt) of (OK (CaseDef args sc _), OK (CaseDef args' sc' _)) -> - let inl = alwaysInline || small sc' in- addDef n (CaseOp inl ty ps_in ps args sc args' sc',+ let inl = alwaysInline + inlc = (inl || small n args sc') && (not asserted) + inlr = inl || small n args sc' in+ addDef n (CaseOp inlc inlr + ty ps_in ps args sc args' sc', access, Unchecked) ctxt in uctxt { definitions = ctxt' } @@ -716,15 +733,14 @@ simplifyCasedef n uctxt = let ctxt = definitions uctxt ctxt' = case lookupCtxt Nothing n ctxt of- [(CaseOp inl ty [] ps args sc args' sc', acc, tot)] ->+ [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] -> ctxt -- nothing to simplify (or already done...)- [(CaseOp inl ty ps_in ps args sc args' sc', acc, tot)] ->+ [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] -> let pdef = map debind $ map simpl ps_in in case simpleCase False True CompileTime (FC "" 0) pdef of OK (CaseDef args sc _) ->--- Erase the original patterns, since we won't use them again and it--- only clutters the .ibc- addDef n (CaseOp inl ty [] ps args sc args' sc',+ addDef n (CaseOp inl inr + ty ps_in ps args sc args' sc', acc, tot) ctxt _ -> ctxt in uctxt { definitions = ctxt' }@@ -737,7 +753,7 @@ (vs, x', y') debind (Left x) = let (vs, x') = depat [] x in (vs, x', Impossible)- simpl (Right (x, y)) = Right (x, simplify uctxt [] y)+ simpl (Right (x, y)) = Right (x, simplify uctxt False [] y) simpl t = t addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) -> @@ -761,7 +777,7 @@ (Function ty _) -> return ty (TyDecl _ ty) -> return ty (Operator ty _ _) -> return ty- (CaseOp _ ty _ _ _ _ _ _) -> return ty+ (CaseOp _ _ ty _ _ _ _ _ _) -> return ty isConName :: Maybe [String] -> Name -> Context -> Bool isConName root n ctxt @@ -777,7 +793,7 @@ case tfst def of (Function _ _) -> return True (Operator _ _ _) -> return True- (CaseOp _ _ _ _ _ _ _ _) -> return True+ (CaseOp _ _ _ _ _ _ _ _ _) -> return True _ -> return False lookupP :: Maybe [String] -> Name -> Context -> [Term]@@ -786,7 +802,7 @@ p <- case def of (Function ty tm, a, _) -> return (P Ref n ty, a) (TyDecl nt ty, a, _) -> return (P nt n ty, a)- (CaseOp _ ty _ _ _ _ _ _, a, _) -> return (P Ref n ty, a)+ (CaseOp _ _ ty _ _ _ _ _ _, a, _) -> return (P Ref n ty, a) (Operator ty _ _, a, _) -> return (P Ref n ty, a) case snd p of Hidden -> []
src/Core/ProofShell.hs view
@@ -26,7 +26,7 @@ processCommand (Theorem n ty) state = case check (ctxt state) [] ty of OK (gl, t) -> - case isSet (ctxt state) [] t of+ case isType (ctxt state) [] t of OK _ -> (state { prf = Just (newProof n (ctxt state) gl) }, "") _ -> (state, "Goal is not a type") err -> (state, show err)
src/Core/ProofState.hs view
@@ -21,6 +21,7 @@ data ProofState = PS { thname :: Name, holes :: [Name], -- holes still to be solved+ usedns :: [Name], -- used names, don't use again nextname :: Int, -- name supply pterm :: Term, -- current proof term ptype :: Type, -- original goal@@ -53,6 +54,7 @@ | StartUnify Name | EndUnify | Compute+ | HNF_Compute | EvalIn Raw | CheckIn Raw | Intro (Maybe Name)@@ -64,6 +66,7 @@ | PatBind Name | Focus Name | Defer Name+ | DeferType Name Raw [Name] | Instance Name | MoveLast Name | ProofState@@ -74,8 +77,8 @@ -- 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 _ _) + show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _) = let OK g = goal (Just h) tm wkenv = premises g in "Other goals: " ++ show hs ++ "\n" ++@@ -98,12 +101,12 @@ showG ps b = showEnv ps (binderTy b) instance Pretty ProofState where- pretty (PS nm [] _ trm _ _ _ _ _ _ _ _ _ _ _ _) =+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _) = if size nm > breakingSize then pretty nm <> colon $$ nest nestingSize (text " no more goals.") else pretty nm <> colon <+> text " no more goals."- pretty p@(PS nm (h:hs) _ tm _ _ _ _ _ _ i _ _ ctxt _ _) =+ pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _) = let OK g = goal (Just h) tm in let wkEnv = premises g in text "Other goals" <+> colon <+> pretty hs $$@@ -171,7 +174,8 @@ newProof :: Name -> Context -> Type -> ProofState newProof n ctxt ty = let h = holeName 0 ty' = vToP ty in- PS n [h] 1 (Bind h (Hole ty') (P Bound h ty')) ty [] (h, []) + PS n [h] [] 1 (Bind h (Hole ty') + (P Bound h ty')) ty [] (h, []) Nothing [] [] [] [] Nothing ctxt "" False@@ -233,7 +237,7 @@ claim :: Name -> Raw -> RunTactic claim n ty ctxt env t = do (tyv, tyt) <- lift $ check ctxt env ty- lift $ isSet ctxt env tyt+ lift $ isType ctxt env tyt action (\ps -> let (g:gs) = holes ps in ps { holes = g : n : gs } ) return $ Bind n (Hole tyv) t -- (weakenTm 1 t)@@ -296,6 +300,21 @@ getP (n, b) = P Bound n (binderTy b) +-- as defer, but build the type and application explicitly+deferType :: Name -> Raw -> [Name] -> RunTactic+deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' = + do (fty, _) <- lift $ check ctxt env fty_in+ action (\ps -> let hs = holes ps + ds = deferred ps in+ ps { holes = hs \\ [x],+ deferred = n : ds })+ return (Bind n (GHole fty) + (mkApp (P Ref n ty) (map getP args)))+ where+ getP n = case lookup n env of+ Just b -> P Bound n (binderTy b)+ Nothing -> error ("deferType can't find " ++ show n)+ regret :: RunTactic regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc = do action (\ps -> let hs = holes ps in@@ -356,7 +375,8 @@ -- dontunify = dontunify ps \\ [x], -- unified = (uh, uns ++ [(x, val)]), instances = instances ps \\ [x] })- return $ {- Bind x (Let ty val) sc -} instantiate val (pToV x sc)+ return $ {- Bind x (Let ty val) sc -} + instantiate val (pToV x sc) | otherwise = lift $ tfail $ IncompleteTerm val solve _ _ h = do ps <- get fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)@@ -366,7 +386,9 @@ do let n = case mn of Just name -> name Nothing -> x- let t' = normalise ctxt env t+ let t' = case t of+ 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@@ -384,18 +406,21 @@ do let n = case mn of Just name -> name Nothing -> x- let t' = normalise ctxt env t+ let t' = case t of+ x@(Bind y (Pi s) _) -> x+ _ -> hnf ctxt env t case t' of- Bind y (Pi s) t -> let t' = instantiate (P Bound n s) (pToV y t) in - return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))+ Bind y (Pi s) t -> -- trace ("in type " ++ show t') $+ let t' = instantiate (P Bound n s) (pToV y t) in + return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t')) _ -> fail "Nothing to introduce" 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' = do (tyv, tyt) <- lift $ check ctxt env ty- lift $ isSet ctxt env tyt- lift $ isSet ctxt env t+ lift $ isType ctxt env tyt+ lift $ isType ctxt env t return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t)) forall n ty ctxt env _ = fail "Can't pi bind here" @@ -409,7 +434,7 @@ letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do (tyv, tyt) <- lift $ check ctxt env ty (valv, valt) <- lift $ check ctxt env val- lift $ isSet ctxt env tyt+ lift $ isType ctxt env tyt return $ Bind n (Let tyv valv) (Bind x (Hole t) (P Bound x t)) letbind n ty val ctxt env _ = fail "Can't let bind here" @@ -422,7 +447,7 @@ do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t) let newt = mkP l r l t let sc = forget $ (Bind x (Hole newt) - (mkApp (P Ref (UN "replace") (Set (UVal 0)))+ (mkApp (P Ref (UN "replace") (TType (UVal 0))) [lt, l, r, p, tmv, xp])) (scv, sct) <- lift $ check ctxt env sc return scv@@ -451,7 +476,9 @@ patbind :: Name -> RunTactic patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =- do let t' = normalise ctxt env t+ do let t' = case t of+ x@(Bind y (PVTy s) t) -> x+ _ -> hnf ctxt env t case t' of Bind y (PVTy s) t -> let t' = instantiate (P Bound n s) (pToV y t) in return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))@@ -462,6 +489,12 @@ compute ctxt env (Bind x (Hole ty) sc) = do return $ Bind x (Hole (normalise ctxt env ty)) sc +hnf_compute :: RunTactic+hnf_compute ctxt env (Bind x (Hole ty) sc) = + do let ty' = hnf ctxt env ty in+-- trace ("HNF " ++ show (ty, ty')) $ + return $ Bind x (Hole ty') sc+ check_in :: Raw -> RunTactic check_in t ctxt env tm = do (val, valty) <- lift $ check ctxt env t@@ -505,14 +538,16 @@ -- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us dropGiven du (u : us) = u : dropGiven du us -updateSolved xs (Bind n (Hole ty) t)- | Just v <- lookup n xs = instantiate v (pToV n (updateSolved xs t))-updateSolved xs (Bind n b t) - | otherwise = Bind n (fmap (updateSolved xs) b) (updateSolved xs t)-updateSolved xs (App f a) = App (updateSolved xs f) (updateSolved xs a)-updateSolved xs (P _ n _)+updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $ + updateSolved' xs x+updateSolved' xs (Bind n (Hole ty) t)+ | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t))+updateSolved' xs (Bind n b t) + | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)+updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)+updateSolved' xs (P _ n _) | Just v <- lookup n xs = v-updateSolved xs t = t+updateSolved' xs t = t updateProblems ns [] = [] updateProblems ns ((x, y, env, err) : ps) =@@ -565,27 +600,29 @@ let (h, _) = unified ps tactic (Just h) solve_unified process t h = tactic (Just h) (mktac t)- where mktac Attack = attack- mktac (Claim n r) = claim n r- mktac (Exact r) = exact r- mktac (Fill r) = fill r- mktac (PrepFill n ns) = prep_fill n ns- mktac CompleteFill = complete_fill- mktac Regret = regret- mktac Solve = solve- mktac (StartUnify n) = start_unify n- mktac Compute = compute- mktac (Intro n) = intro n- mktac (IntroTy ty n) = introTy ty n- mktac (Forall n t) = forall n t- mktac (LetBind n t v) = letbind n t v- mktac (Rewrite t) = rewrite t- mktac (PatVar n) = patvar n- mktac (PatBind n) = patbind n- mktac (CheckIn r) = check_in r- mktac (EvalIn r) = eval_in r- mktac (Focus n) = focus n- mktac (Defer n) = defer n- mktac (Instance n) = instanceArg n- mktac (MoveLast n) = movelast n+ where mktac Attack = attack+ mktac (Claim n r) = claim n r+ mktac (Exact r) = exact r+ mktac (Fill r) = fill r+ mktac (PrepFill n ns) = prep_fill n ns+ mktac CompleteFill = complete_fill+ mktac Regret = regret+ mktac Solve = solve+ mktac (StartUnify n) = start_unify n+ mktac Compute = compute+ 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 (LetBind n t v) = letbind n t v+ mktac (Rewrite t) = rewrite t+ mktac (PatVar n) = patvar n+ mktac (PatBind n) = patbind n+ mktac (CheckIn r) = check_in r+ mktac (EvalIn r) = eval_in r+ mktac (Focus n) = focus n+ mktac (Defer n) = defer n+ mktac (DeferType n t a) = deferType n t a+ mktac (Instance n) = instanceArg n+ mktac (MoveLast n) = movelast n
src/Core/TT.hs view
@@ -14,7 +14,7 @@ {- The language has: * Full dependent types- * A hierarchy of universes, with cumulativity: Set : Set1, Set1 : Set2, ...+ * A hierarchy of universes, with cumulativity: Type : Type1, Type1 : Type2, ... * Pattern matching letrec binding * (primitive types defined externally) @@ -25,7 +25,7 @@ programs with implicit syntax into fully explicit terms. -} -data Option = SetInSet+data Option = TTypeInTType | CheckConv deriving Eq @@ -59,6 +59,8 @@ | UniverseError | ProgramLineComment | Inaccessible Name+ | NonCollapsiblePostulate Name+ | AlreadyDefined Name | At FC Err deriving Eq @@ -77,7 +79,7 @@ size UniverseError = 1 size ProgramLineComment = 1 size (At fc err) = size fc + size err- size (Inaccessible _) = 1+ size _ = 1 score :: Err -> Int score (CantUnify _ _ _ m _ s) = s + score m@@ -122,7 +124,7 @@ show (Error str) = "Error: " ++ show str -- at some point, this instance should also carry type checking options--- (e.g. Set:Set)+-- (e.g. Type:Type) instance Monad TC where return = OK @@ -256,7 +258,11 @@ addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt) data Const = I Int | BI Integer | Fl Double | Ch Char | Str String - | IType | BIType | FlType | ChType | StrType + | IType | BIType | FlType | ChType | StrType++ | W8 Word8 | W16 Word16+ | W8Type | W16Type + | PtrType | VoidType | Forgot deriving (Eq, Ord) {-! @@ -280,11 +286,13 @@ pretty PtrType = text "Ptr" pretty VoidType = text "Void" pretty Forgot = text "Forgot"+ pretty W8Type = text "Word8"+ pretty W16Type = text "Word16" data Raw = Var Name | RBind Name (Binder Raw) Raw | RApp Raw Raw- | RSet+ | RType | RForce Raw | RConstant Const deriving (Show, Eq)@@ -293,7 +301,7 @@ size (Var name) = 1 size (RBind name bind right) = 1 + size bind + size right size (RApp left right) = 1 + size left + size right- size RSet = 1+ size RType = 1 size (RForce raw) = 1 + size raw size (RConstant const) = size const @@ -427,25 +435,29 @@ | Proj (TT n) Int -- argument projection; runtime only | Erased | Impossible -- special case for totality checking- | Set UExp+ | TType UExp deriving (Ord, Functor) {-! deriving instance Binary TT !-} class TermSize a where- termsize :: a -> Int+ termsize :: Name -> a -> Int instance TermSize a => TermSize [a] where- termsize [] = 0- termsize (x : xs) = termsize x + termsize xs+ termsize n [] = 0+ termsize n (x : xs) = termsize n x + termsize n xs -instance TermSize (TT a) where- termsize (P _ _ _) = 1- termsize (V _) = 1- termsize (Bind n (Let t v) sc) = termsize v + termsize sc- termsize (App f a) = termsize f + termsize a- termsize _ = 1+instance TermSize (TT Name) where+ termsize n (P _ x _) + | x == n = 1000000 -- recursive => really big+ | otherwise = 1+ termsize n (V _) = 1+ termsize n (Bind n' (Let t v) sc) + = let rn = if n == n' then MN 0 "noname" else n in+ termsize rn v + termsize rn sc+ termsize n (App f a) = termsize n f + termsize n a+ termsize n _ = 1 instance Sized a => Sized (TT a) where size (P name n trm) = 1 + size name + size n + size trm@@ -454,7 +466,7 @@ size (App l r) = 1 + size l + size r size (Constant c) = size c size Erased = 1- size (Set u) = 1 + size u+ size (TType u) = 1 + size u instance Pretty a => Pretty (TT a) where pretty _ = text "test"@@ -472,7 +484,7 @@ (==) (V x) (V y) = x == y (==) (Bind _ xb xs) (Bind _ yb ys) = xb == yb && xs == ys (==) (App fx ax) (App fy ay) = fx == fy && ax == ay- (==) (Set _) (Set _) = True -- deal with constraints later+ (==) (TType _) (TType _) = True -- deal with constraints later (==) (Constant x) (Constant y) = x == y (==) (Proj x i) (Proj y j) = x == y && i == j (==) Erased _ = True@@ -485,7 +497,7 @@ isInjective (P (DCon _ _) _ _) = True isInjective (P (TCon _ _) _ _) = True isInjective (Constant _) = True-isInjective (Set x) = True+isInjective (TType x) = True isInjective (Bind _ (Pi _) sc) = True isInjective (App f a) = isInjective f isInjective _ = False@@ -507,12 +519,23 @@ subst i (Proj x idx) = Proj (subst i x) idx subst i t = t +explicitNames :: TT n -> TT n+explicitNames (Bind x b sc) = let b' = fmap explicitNames b in+ Bind x b'+ (explicitNames (instantiate + (P Bound x (binderTy b')) sc))+explicitNames (App f a) = App (explicitNames f) (explicitNames a)+explicitNames (Proj x idx) = Proj (explicitNames x) idx+explicitNames t = t+ pToV :: Eq n => n -> TT n -> TT n pToV n = pToV' n 0 pToV' n i (P _ x _) | n == x = V i pToV' n i (Bind x b sc)- | n == x = Bind x (fmap (pToV' n i) b) sc- | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc)+-- We can assume the inner scope has been pToVed already, so continue to+-- resolve names from the *outer* scope which may happen to have the same id.+-- | n == x = Bind x (fmap (pToV' n i) b) sc+ | otherwise = Bind x (fmap (pToV' n i) b) (pToV' n (i+1) sc) pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a) pToV' n i (Proj t idx) = Proj (pToV' n i t) idx pToV' n i t = t@@ -544,6 +567,13 @@ substNames [] t = t substNames ((n, tm) : xs) t = subst n tm (substNames xs t) +substTerm :: Eq n => TT n -> TT n -> TT n -> TT n+substTerm old new = st where+ st t | t == old = new+ st (App f a) = App (st f) (st a)+ st (Bind x b sc) = Bind x (fmap st b) (st sc)+ st t = t+ -- Returns true if V 0 and bound name n do not occur in the term noOccurrence :: Eq n => n -> TT n -> Bool@@ -597,7 +627,7 @@ fe env (App f a) = RApp (fe env f) (fe env a) fe env (Constant c) = RConstant c- fe env (Set i) = RSet+ fe env (TType i) = RType fe env Erased = RConstant Forgot bindAll :: [(n, Binder (TT n))] -> TT n -> TT n @@ -621,6 +651,14 @@ uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs | otherwise = n +uniqueBinders :: [Name] -> TT Name -> TT Name+uniqueBinders ns (Bind n b sc)+ = let n' = uniqueName n ns in+ Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)+uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)+uniqueBinders ns t = t+ + nextName (NS x s) = NS (nextName x) s nextName (MN i n) = MN (i+1) n nextName (UN x) = let (num', nm') = span isDigit (reverse x)@@ -651,12 +689,16 @@ show (Fl f) = show f show (Ch c) = show c show (Str s) = show s+ show (W8 x) = show x+ show (W16 x) = show x show IType = "Int" show BIType = "Integer" show FlType = "Float" show ChType = "Char" show StrType = "String" show PtrType = "Ptr"+ show W8Type = "Word8"+ show W16Type = "Word16" show VoidType = "Void" showEnv env t = showEnv' env t False@@ -694,7 +736,7 @@ prettySe 1 env x debug <+> text ("!" ++ show i) prettySe p env (Constant c) debug = pretty c prettySe p env Erased debug = text "[_]"- prettySe p env (Set i) debug = text "Set" <+> (text . show $ i)+ prettySe p env (TType i) debug = text "Type" <+> (text . show $ i) prettySb env n (Lam t) = prettyB env "λ" "=>" n t prettySb env n (Hole t) = prettyB env "?defer" "." n t@@ -726,7 +768,7 @@ se p env (Constant c) = show c se p env Erased = "[__]" se p env Impossible = "[impossible]"- se p env (Set i) = "Set " ++ show i+ se p env (TType i) = "Type " ++ show i sb env n (Lam t) = showb env "\\ " " => " n t sb env n (Hole t) = showb env "? " ". " n t@@ -782,8 +824,9 @@ orderPats :: Term -> Term orderPats tm = op [] tm where- op ps (Bind n (PVar t) sc) = op ((n, t) : ps) sc- op ps sc = bindAll (map (\ (n, t) -> (n, PVar t)) (sortP ps)) sc + 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 sc = bindAll (map (\ (n, t) -> (n, t)) (sortP ps)) sc sortP ps = pick [] (reverse ps) @@ -800,7 +843,8 @@ insert n t [] = [(n, t)] insert n t ((n',t') : ps)- | n `elem` (namesIn t' ++ concatMap namesIn (map snd ps))+ | n `elem` (namesIn (binderTy t') ++ + concatMap namesIn (map (binderTy . snd) ps)) = (n', t') : insert n t ps | otherwise = (n,t):(n',t'):ps
src/Core/Typecheck.hs view
@@ -16,27 +16,33 @@ convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC () convertsC ctxt env x y - = do c <- convEq ctxt (finalise (normalise ctxt env x))+ = do c1 <- convEq ctxt x y+ if c1 then return ()+ else + do c2 <- convEq ctxt (finalise (normalise ctxt env x)) (finalise (normalise ctxt env y))- if c then return ()- else lift $ tfail (CantConvert- (finalise (normalise ctxt env x))- (finalise (normalise ctxt env y)) (errEnv env))+ if c2 then return ()+ else lift $ tfail (CantConvert+ (finalise (normalise ctxt env x))+ (finalise (normalise ctxt env y)) (errEnv env)) converts :: Context -> Env -> Term -> Term -> TC ()-converts ctxt env x y = if (finalise (normalise ctxt env x) == - finalise (normalise ctxt env y))- then return ()- else tfail (CantConvert- (finalise (normalise ctxt env x))- (finalise (normalise ctxt env y)) (errEnv env))+converts ctxt env x y + = case convEq' ctxt x y of + OK _ -> return ()+ _ -> case convEq' ctxt (finalise (normalise ctxt env x)) + (finalise (normalise ctxt env y)) of+ OK _ -> return ()+ _ -> tfail (CantConvert+ (finalise (normalise ctxt env x))+ (finalise (normalise ctxt env y)) (errEnv env)) errEnv = map (\(x, b) -> (x, binderTy b)) -isSet :: Context -> Env -> Term -> TC ()-isSet ctxt env tm = isSet' (normalise ctxt env tm)- where isSet' (Set _) = return ()- isSet' tm = fail (showEnv env tm ++ " is not a Set")+isType :: Context -> Env -> Term -> TC ()+isType ctxt env tm = isType' (normalise ctxt env tm)+ where isType' (TType _) = return ()+ isType' tm = fail (showEnv env tm ++ " is not a TType") recheck :: Context -> Env -> Raw -> Term -> TC (Term, Type, UCs) recheck ctxt env tm orig@@ -59,26 +65,35 @@ chk env (RApp f a) = do (fv, fty) <- chk env f (av, aty) <- chk env a- let fty' = renameBinders 0 $ normalise ctxt env fty+ let fty' = case uniqueBinders (map fst env) (finalise fty) of+ ty@(Bind x (Pi s) t) -> ty+ _ -> uniqueBinders (map fst env) + $ hnf ctxt env fty case fty' of Bind x (Pi s) t ->+-- trace ("Converting " ++ show aty ++ " and " ++ show s +++-- " from " ++ show fv ++ " : " ++ show fty) $ do convertsC ctxt env aty s- let apty = normalise initContext env (Bind x (Let aty av) t)+ -- let apty = normalise initContext env + -- (Bind x (Let aty av) t)+ let apty = simplify initContext False env + (Bind x (Let aty av) t) return (App fv av, apty) t -> fail "Can't apply a non-function type" -- This rather unpleasant hack is needed because during incomplete -- proofs, variables are locally bound with an explicit name. If we just -- make sure bound names in function types are locally unique, machine -- generated names, we'll be fine.+ -- NOTE: now replaced with 'uniqueBinders' above where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s) (renameBinders (i+1) t) renameBinders i sc = sc- chk env RSet - | holes = return (Set (UVal 0), Set (UVal 0))+ chk env RType + | holes = return (TType (UVal 0), TType (UVal 0)) | otherwise = do (v, cs) <- get let c = ULT (UVar v) (UVar (v+1)) put (v+2, (c:cs))- return (Set (UVar v), Set (UVar (v+1)))+ return (TType (UVar v), TType (UVar (v+1))) chk env (RConstant Forgot) = return (Erased, Erased) chk env (RConstant c) = return (Constant c, constType c) where constType (I _) = Constant IType@@ -86,18 +101,21 @@ constType (Fl _) = Constant FlType constType (Ch _) = Constant ChType constType (Str _) = Constant StrType+ constType (W8 _) = Constant W8Type+ constType (W16 _) = Constant W16Type constType Forgot = Erased- constType _ = Set (UVal 0)+ constType _ = TType (UVal 0) chk env (RForce t) = do (_, ty) <- chk env t return (Erased, ty) chk env (RBind n (Pi s) t) = do (sv, st) <- chk env s (tv, tt) <- chk ((n, Pi sv) : env) t (v, cs) <- get- let Set su = normalise ctxt env st- let Set tu = normalise ctxt env tt+ let TType su = normalise ctxt env st+ let TType tu = normalise ctxt env tt when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs)- return (Bind n (Pi sv) (pToV n tv), Set (UVar v)) + return (Bind n (Pi (uniqueBinders (map fst env) sv)) + (pToV n tv), TType (UVar v)) chk env (RBind n b sc) = do b' <- checkBinder b (scv, sct) <- chk ((n, b'):env) sc@@ -106,13 +124,13 @@ = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (Lam tv) checkBinder (Pi t) = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (Pi tv) checkBinder (Let t v) = do (tv, tt) <- chk env t@@ -120,7 +138,7 @@ let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (Let tv vv) checkBinder (NLet t v) = do (tv, tt) <- chk env t@@ -128,7 +146,7 @@ let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (NLet tv vv) checkBinder (Hole t) | not holes = lift $ tfail (IncompleteTerm undefined)@@ -136,13 +154,13 @@ = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (Hole tv) checkBinder (GHole t) = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (GHole tv) checkBinder (Guess t v) | not holes = lift $ tfail (IncompleteTerm undefined)@@ -152,19 +170,19 @@ let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt convertsC ctxt env vt tv- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (Guess tv vv) checkBinder (PVar t) = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (PVar tv) checkBinder (PVTy t) = do (tv, tt) <- chk env t let tv' = normalise ctxt env tv let tt' = normalise ctxt env tt- lift $ isSet ctxt env tt'+ lift $ isType ctxt env tt' return (PVTy tv) discharge n (Lam t) scv sct@@ -204,17 +222,17 @@ checkProgram ctxt [] = return ctxt checkProgram ctxt ((n, RConst t) : xs) = do (t', tt') <- trace (show n) $ check ctxt [] t- isSet ctxt [] tt'+ isType ctxt [] tt' checkProgram (addTyDecl n t' ctxt) xs checkProgram ctxt ((n, RFunction (RawFun ty val)) : xs) = do (ty', tyt') <- trace (show n) $ check ctxt [] ty (val', valt') <- check ctxt [] val- isSet ctxt [] tyt'+ isType ctxt [] tyt' converts ctxt [] ty' valt' checkProgram (addToCtxt n val' ty' ctxt) xs checkProgram ctxt ((n, RData (RDatatype _ ty cons)) : xs) = do (ty', tyt') <- trace (show n) $ check ctxt [] ty- isSet ctxt [] tyt'+ isType ctxt [] tyt' -- add the tycon temporarily so we can check constructors let ctxt' = addDatatype (Data n 0 ty' []) ctxt cons' <- mapM (checkCon ctxt') cons
src/Core/Unify.hs view
@@ -21,26 +21,33 @@ type Fails = [(TT Name, TT Name, Env, Err)] data UInfo = UI Int Injs Fails+ deriving Show unify :: Context -> Env -> TT Name -> TT Name -> TC ([(Name, TT Name)], Injs, Fails)-unify ctxt env topx topy - = -- case runStateT (un' False [] topx topy) (UI 0 [] []) of- -- OK (v, UI _ inj []) -> return (filter notTrivial v, inj, [])- -- _ -> --- trace ("Unifying " ++ show (topx, topy)) $+unify ctxt env topx topy =+-- trace ("Unifying " ++ show (topx, topy)) $+ -- don't bother if topx and topy are different at the head+ case runStateT (un False [] topx topy) (UI 0 [] []) of+ OK (v, UI _ inj []) -> return (filter notTrivial v, inj, [])+-- Error e@(CantUnify False _ _ _ _ _) -> tfail e+ res -> let topxn = normalise ctxt env topx topyn = normalise ctxt env topy in--- trace ("Unifying " ++ show (topxn, topyn)) $- case runStateT (un' False [] topxn topyn)+-- 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- OK (v, UI _ inj fails) -> return (filter notTrivial v, inj, reverse fails)--- OK (_, UI s _ ((_,_,f):fs)) -> tfail $ CantUnify topx topy f s+ OK (v, UI _ inj fails) -> + return (filter notTrivial v, inj, reverse fails) Error e -> tfail e where notTrivial (x, P _ x' _) = x /= x' notTrivial _ = True + headDiff (P (DCon _ _) x _) (P (DCon _ _) y _) = x /= y+ headDiff (P (TCon _ _) x _) (P (TCon _ _) y _) = x /= y+ headDiff _ _ = False+ injective (P (DCon _ _) _ _) = True injective (P (TCon _ _) _ _) = True injective (App f a) = injective f@@ -59,6 +66,17 @@ then return r else do put (UI s i f); u2 + un :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->+ StateT UInfo + TC [(Name, TT Name)]+ un = un'+-- un fn names x y +-- = let (xf, _) = unApply x+-- (yf, _) = unApply y in+-- if headDiff xf yf then unifyFail x y else+-- uplus (un' fn names x y)+-- (un' fn names (hnf ctxt env x) (hnf ctxt env y))+ un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name -> StateT UInfo TC [(Name, TT Name)]@@ -75,12 +93,18 @@ | (x,y) `elem` bnames = do sc 1; return [] un' fn bnames (P Bound x _) tm | holeIn env x = do UI s i f <- get- when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f)+ -- injectivity check+ when (notP tm && fn) $ +-- trace (show (x, tm, normalise ctxt env tm)) $+ put (UI s ((tm, topx, topy) : i) f) sc 1 checkCycle (x, tm) un' fn bnames tm (P Bound y _) | holeIn env y = do UI s i f <- get- when (notP tm && fn) $ put (UI s ((tm, topx, topy) : i) f)+ -- injectivity check+ when (notP tm && fn) $ +-- trace (show (y, tm, normalise ctxt env tm)) $+ put (UI s ((tm, topx, topy) : i) f) sc 1 checkCycle (y, tm) un' fn bnames (V i) (P Bound x _)@@ -135,8 +159,9 @@ let r = recoverable x y let err = CantUnify r topx topy (CantUnify r x y (Msg "") [] s) (errEnv env) s- put (UI s i ((x, y, env, err) : f))- return [] -- lift $ tfail err+ if (not r) then lift $ tfail err+ else do put (UI s i ((x, y, env, err) : f))+ return [] -- lift $ tfail err -- shortcut failure, if we *know* nothing can fix it unifyFail x y = do UI s i f <- get@@ -192,12 +217,15 @@ recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) | x == y = True | otherwise = False--- recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False--- recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False- recoverable p@(P _ _ _) (App f a) = recoverable p f- recoverable (App f a) p@(P _ _ _) = recoverable f p+ recoverable (P (TCon _ _) x _) (P (TCon _ _) y _)+ | x == y = True+ | otherwise = False+ recoverable (P (DCon _ _) x _) (P (TCon _ _) y _) = False+ recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False+ 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')- = recoverable f f' && recoverable a a'+ = recoverable f f' -- && recoverable a a' recoverable _ _ = True errEnv = map (\(x, b) -> (x, binderTy b))
src/IRTS/Bytecode.hs view
@@ -27,8 +27,10 @@ data BC = ASSIGN Reg Reg | ASSIGNCONST Reg Const+ | UPDATE Reg Reg | MKCON Reg Int [Reg]- | CASE Reg [(Int, [BC])] (Maybe [BC])+ | CASE Bool -- definitely a constructor, no need to check, if true+ Reg [(Int, [BC])] (Maybe [BC]) | PROJECT Reg Int Int -- get all args from reg, put them from Int onwards | PROJECTINTO Reg Reg Int -- project argument from one reg into another | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])@@ -72,6 +74,8 @@ = FOREIGNCALL reg l t fname (map farg args) : clean r where farg (ty, Loc i) = (ty, L i) bc reg (SLet (Loc i) e sc) r = bc (L i) e False ++ bc reg sc r+bc reg (SUpdate (Loc i) sc) r = bc reg sc False ++ [ASSIGN (L i) reg]+ ++ clean r bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r where getL (Loc x) = L x bc reg (SProj (Loc l) i) r = PROJECTINTO reg (L l) i : clean r @@ -82,7 +86,9 @@ bc reg SNothing r = NULL reg : clean r bc reg (SCase (Loc l) alts) r | isConst alts = constCase reg (L l) alts r- | otherwise = conCase reg (L l) alts r+ | otherwise = conCase True reg (L l) alts r+bc reg (SChkCase (Loc l) alts) r + = conCase False reg (L l) alts r isConst [] = False isConst (SConstCase _ _ : xs) = True@@ -95,8 +101,8 @@ assign r1 r2 | r1 == r2 = [] | otherwise = [ASSIGN r1 r2] -conCase reg l xs r = [CASE l (mapMaybe (caseAlt l reg r) xs)- (defaultAlt reg xs r)]+conCase safe reg l xs r = [CASE safe l (mapMaybe (caseAlt l reg r) xs)+ (defaultAlt reg xs r)] constCase reg l xs r = [CONSTCASE l (mapMaybe (constAlt l reg r) xs) (defaultAlt reg xs r)]
src/IRTS/CodegenC.hs view
@@ -1,9 +1,10 @@-module IRTS.CodegenC where+module IRTS.CodegenC (codegenC) where import Idris.AbsSyntax import IRTS.Bytecode import IRTS.Lang import IRTS.Simplified+import IRTS.CodegenCommon import Core.TT import Paths_idris import Util.System@@ -13,49 +14,55 @@ import System.Exit import System.IO import System.Directory+import System.FilePath ((</>), (<.>)) import Control.Monad -data DbgLevel = NONE | DEBUG | TRACE--codegenC :: Maybe FilePath -> -- dump output- [(Name, SDecl)] ->+codegenC :: [(Name, SDecl)] -> String -> -- output file name- Bool -> -- generate executable if True, only .o if False + OutputType -> -- generate executable if True, only .o if False [FilePath] -> -- include files String -> -- extra object files String -> -- extra compiler flags DbgLevel -> IO ()-codegenC dump defs out exec incs objs libs dbg+codegenC defs out exec incs objs libs dbg = do -- print defs let bc = map toBC defs let h = concatMap toDecl (map fst bc) let cc = concatMap (uncurry toC) bc d <- getDataDir- mprog <- readFile (d ++ "/rts/idris_main.c")+ mprog <- readFile (d </> "rts" </> "idris_main" <.> "c") let cout = headers incs ++ debug dbg ++ h ++ cc ++ - (if exec then mprog else "")- (tmpn, tmph) <- tempfile- hPutStr tmph cout- hFlush tmph- hClose tmph- let useclang = False- comp <- getCC- let gcc = comp ++ " -I. " ++ objs ++ " -x c " ++ - (if exec then "" else " - c ") ++- gccDbg dbg ++- " " ++ tmpn ++- " `idris --link` `idris --include` " ++ libs ++- " -o " ++ out- case dump of- Just co -> do writeFile co cout- Nothing -> return ()- exit <- system gcc- when (exit /= ExitSuccess) $- putStrLn ("FAILURE: " ++ gcc)+ (if (exec == Executable) then mprog else "")+ case exec of+ Raw -> writeFile out cout+ _ -> do+ (tmpn, tmph) <- tempfile+ hPutStr tmph cout+ hFlush tmph+ hClose tmph+ let useclang = False+ comp <- getCC+ libFlags <- getLibFlags+ incFlags <- getIncFlags+ let gcc = comp ++ " " +++ gccDbg dbg +++ " -I. " ++ objs ++ " -x c " ++ + (if (exec == Executable) then "" else " -c ") +++ " " ++ tmpn +++ " " ++ libFlags +++ " " ++ incFlags +++ " " ++ libs +++ " -o " ++ out+-- putStrLn gcc+ exit <- system gcc+ when (exit /= ExitSuccess) $+ putStrLn ("FAILURE: " ++ gcc) -headers [] = "#include <idris_rts.h>\n#include <idris_stdfgn.h>\n#include <assert.h>\n"-headers (x : xs) = "#include <" ++ x ++ ">\n" ++ headers xs+headers xs =+ concatMap+ (\h -> "#include <" ++ h ++ ">\n")+ (xs ++ ["idris_rts.h", "idris_stdfgn.h", "gmp.h", "assert.h"]) debug TRACE = "#define IDRIS_TRACE\n\n" debug _ = ""@@ -69,7 +76,8 @@ where cchar x | isAlpha x || isDigit x = [x] | otherwise = "_" ++ show (fromEnum x) ++ "_" -indent i = take (i * 4) (repeat ' ')+indent :: Int -> String+indent n = replicate (n*4) ' ' creg RVal = "RVAL" creg (L i) = "LOC(" ++ show i ++ ")"@@ -98,9 +106,10 @@ mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")" mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")" mkConst _ = "MKINT(42424242)"+bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n" bcc i (MKCON l tag args)- = indent i ++ creg Tmp ++ " = allocCon(vm, " ++ show (length args) ++ - "); " ++ "SETTAG(" ++ creg Tmp ++ ", " ++ show tag ++ ");\n" +++ = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," +++ show (length args) ++ ", 0);\n" ++ indent i ++ setArgs 0 args ++ "\n" ++ indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n" @@ -115,33 +124,90 @@ ", " ++ show a ++ ");\n" bcc i (PROJECTINTO r t idx) = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n" -bcc i (CASE r code def) - = indent i ++ "switch(TAG(" ++ creg r ++ ")) {\n" +++bcc i (CASE True r code def) + | length code < 4 = showCase i def code+ where+ showCode :: Int -> [BC] -> String+ showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++ + indent i ++ "}\n"++ showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String+ showCase i Nothing [(t, c)] = showCode i c+ showCase i (Just def) [] = showCode i def+ showCase i def ((t, c) : cs)+ = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c+ ++ "else " ++ showCase i def cs++bcc i (CASE safe r code def) + = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++ concatMap (showCase i) code ++ showDef i def ++ indent i ++ "}\n" where+ ctag True = "CTAG"+ ctag False = "TAG"+ showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n" ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n" showDef i Nothing = "" showDef i (Just c) = indent i ++ "default:\n" ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n" bcc i (CONSTCASE r code def) - = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++- concatMap (showCase i) code ++- showDef i def ++- indent i ++ "}\n"+ | intConsts code+-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" +++-- concatMap (showCase i) code +++-- showDef i def +++-- indent i ++ "}\n"+ = concatMap (iCase (creg r)) code +++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+ | strConsts code+ = concatMap (strCase ("GETSTR(" ++ creg r ++ ")")) code +++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+ | bigintConsts code+ = concatMap (biCase (creg r)) code +++ indent i ++ "{\n" ++ showDefS i def ++ indent i ++ "}\n"+ | otherwise = error $ "Can't happen: Can't compile const case " ++ show code where+ intConsts ((I _, _ ) : _) = True+ intConsts ((Ch _, _ ) : _) = True+ intConsts _ = False++ bigintConsts ((BI _, _ ) : _) = True+ bigintConsts _ = False++ strConsts ((Str _, _ ) : _) = True+ strConsts _ = False++ strCase sv (s, bc) =+ indent i ++ "if (strcmp(" ++ sv ++ ", " ++ show s ++ ") == 0) {\n" +++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+ biCase bv (BI b, bc) =+ indent i ++ "if (bigEqConst(" ++ bv ++ ", " ++ show b ++ ")) {\n"+ ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+ iCase v (I b, bc) =+ indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"+ ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+ iCase v (Ch b, bc) =+ indent i ++ "if (GETINT(" ++ v ++ ") == " ++ show b ++ ") {\n"+ ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"+ showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"- ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"+ ++ concatMap (bcc (i+1)) bc ++ + indent (i + 1) ++ "break;\n" showDef i Nothing = "" showDef i (Just c) = indent i ++ "default:\n" - ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"+ ++ concatMap (bcc (i+1)) c ++ + indent (i + 1) ++ "break;\n"+ showDefS i Nothing = ""+ showDefS i (Just c) = concatMap (bcc (i+1)) c+ bcc i (CALL n) = indent i ++ "CALL(" ++ cname n ++ ");\n" bcc i (TAILCALL n) = indent i ++ "TAILCALL(" ++ cname n ++ ");\n" bcc i (SLIDE n) = indent i ++ "SLIDE(vm, " ++ show n ++ ");\n" bcc i REBASE = indent i ++ "REBASE;\n"+bcc i (RESERVE 0) = "" bcc i (RESERVE n) = indent i ++ "RESERVE(" ++ show n ++ ");\n"+bcc i (ADDTOP 0) = "" bcc i (ADDTOP n) = indent i ++ "ADDTOP(" ++ show n ++ ");\n" bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n" bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"@@ -176,6 +242,13 @@ doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LTimes [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")" doOp v LDiv [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LMod [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LAnd [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LOr [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LXOr [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LSHL [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LSHR [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LCompl [x] = v ++ "INTOP(~," ++ creg x ++ ")" doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")" doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"@@ -194,8 +267,10 @@ doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LBDec [l] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", MKINT(1))" doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"+doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")" doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"@@ -247,5 +322,7 @@ doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))" 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 LNoOp args = ""+doOp v LChInt args = v ++ creg (last args)+doOp v LIntCh args = v ++ creg (last args)+doOp v LNoOp args = v ++ creg (last args) doOp _ _ _ = "FAIL"
+ src/IRTS/CodegenCommon.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++module IRTS.CodegenCommon where++import Core.TT+import IRTS.Simplified++import Control.Exception+import System.Environment++data DbgLevel = NONE | DEBUG | TRACE deriving Eq+data OutputType = Raw | Object | Executable deriving (Eq, Show)++environment :: String -> IO (Maybe String)+environment x = Control.Exception.catch (do e <- getEnv x+ return (Just e))+#if MIN_VERSION_base(4,0,0)+ (\y-> do return (y::SomeException); return Nothing)+#endif+#if !MIN_VERSION_base(4,0,0)+ (\_-> return Nothing)+#endif
src/IRTS/CodegenJava.hs view
@@ -1,4 +1,4 @@-module IRTS.CodegenJava where+module IRTS.CodegenJava (codegenJava) where import IRTS.BCImp import IRTS.Lang@@ -6,6 +6,7 @@ import Core.TT import Paths_idris import Util.System+import IRTS.CodegenCommon import Data.Char import System.Process@@ -16,6 +17,7 @@ codegenJava :: [(Name, SDecl)] -> String -> -- output file name+ OutputType -> IO ()-codegenJava defs out = putStrLn "Not implemented yet"+codegenJava defs out exec = putStrLn "Not implemented yet"
+ src/IRTS/CodegenJavaScript.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE PatternGuards #-}++{-+ BigInteger Javascript code taken from:+ https://github.com/peterolson/BigInteger.js+-}++module IRTS.CodegenJavaScript (codegenJavaScript) where++import Idris.AbsSyntax+import IRTS.Bytecode+import IRTS.Lang+import IRTS.Simplified+import IRTS.CodegenCommon+import Core.TT+import Paths_idris+import Util.System++import Control.Arrow+import Data.Char+import Data.List+import System.IO++type NamespaceName = String++idrNamespace :: NamespaceName+idrNamespace = "__IDR__"++codegenJavaScript+ :: [(Name, SDecl)]+ -> FilePath+ -> OutputType+ -> IO ()+codegenJavaScript definitions filename outputType =+ writeFile filename output+ where+ def = map (first translateNamespace) definitions++ mainLoop :: String+ mainLoop = intercalate "\n" [ "\nfunction main() {"+ , createTailcall "__IDR__.runMain0()"+ , "}\n\nmain();\n"+ ]++ output :: String+ output = concat [ idrRuntime+ , concatMap (translateModule Nothing) def+ , mainLoop+ ]++idrRuntime :: String+idrRuntime =+ createModule Nothing idrNamespace $ concat+ [ "__IDR__.Type = function(type) { this.type = type; };"+ , "__IDR__.Int = new __IDR__.Type('Int');"+ , "__IDR__.Char = new __IDR__.Type('Char');"+ , "__IDR__.String = new __IDR__.Type('String');"+ , "__IDR__.Integer = new __IDR__.Type('Integer');"+ , "__IDR__.Float = new __IDR__.Type('Float');"+ , "__IDR__.Forgot = new __IDR__.Type('Forgot');" ++ , "__IDR__.bigInt=function(){var e=1e7,t=7,n={positive:!1,negative:!0},r=function(e,t){var n=e.value,r=t.value,i=n.length>r.length?n.length:r.length;for(var s=0;s<i;s++)n[s]=n[s]||0,r[s]=r[s]||0;for(var s=i-1;s>=0;s--){if(n[s]!==0||r[s]!==0)break;n.pop(),r.pop()}n.length||(n=[0],r=[0]),e.value=n,t.value=r},i=function(e,s){if(typeof e=='object')return e;e+='';var u=n.positive,a=[];e[0]==='-'&&(u=n.negative,e=e.slice(1));var e=e.split('e');if(e.length>2)throw new Error('Invalid integer');if(e[1]){var f=e[1];f[0]==='+'&&(f=f.slice(1)),f=i(f);if(f.lesser(0))throw new Error('Cannot include negative exponent part for integers');while(f.notEquals(0))e[0]+='0',f=f.prev()}e=e[0],e==='-0'&&(e='0');var l=/^([1-9][0-9]*)$|^0$/.test(e);if(!l)throw new Error('Invalid integer');while(e.length){var c=e.length>t?e.length-t:0;a.push(+e.slice(c)),e=e.slice(0,c)}var h=o(a,u);return s&&r(s,h),h},s=function(e,t){var e=o(e,n.positive),t=o(t,n.positive);if(e.equals(0))throw new Error('Cannot divide by 0');var r=0;do{var i=1,s=o(e.value,n.positive),u=s.times(10);while(u.lesser(t))s=u,i*=10,u=u.times(10);while(s.lesserOrEquals(t))t=t.minus(s),r+=i}while(e.lesserOrEquals(t));return{remainder:t.value,result:r}},o=function(f,l){var c={value:f,sign:l},h={value:f,sign:l,negate:function(e){var t=e||c;return o(t.value,!t.sign)},abs:function(e){var t=e||c;return o(t.value,n.positive)},add:function(t,s){var u,a=c,f;s?(a=i(t))&&(f=i(s)):f=i(t,a),u=a.sign;if(a.sign!==f.sign)return a=o(a.value,n.positive),f=o(f.value,n.positive),u===n.positive?h.subtract(a,f):h.subtract(f,a);r(a,f);var l=a.value,p=f.value,d=[],v=0;for(var m=0;m<l.length||v>0;m++){var g=l[m]+p[m]+v;v=g>e?1:0,g-=v*e,d.push(g)}return o(d,u)},plus:function(e,t){return h.add(e,t)},subtract:function(t,r){var s=c,u;r?(s=i(t))&&(u=i(r)):u=i(t,s);if(s.sign!==u.sign)return h.add(s,h.negate(u));if(s.sign===n.negative)return h.subtract(h.negate(u),h.negate(s));if(h.compare(s,u)===-1)return h.negate(h.subtract(u,s));var a=s.value,f=u.value,l=[],p=0;for(var d=0;d<a.length;d++){a[d]-=p,p=a[d]<f[d]?1:0;var v=p*e+a[d]-f[d];l.push(v)}return o(l,n.positive)},minus:function(e,t){return h.subtract(e,t)},multiply:function(t,n){var r,s=c,u;n?(s=i(t))&&(u=i(n)):u=i(t,s),r=s.sign!==u.sign;var a=s.value,f=u.value,l=[];for(var h=0;h<a.length;h++){l[h]=[];var p=h;while(p--)l[h].push(0)}var d=0;for(var h=0;h<a.length;h++){var v=a[h];for(var p=0;p<f.length||d>0;p++){var m=f[p],g=m?v*m+d:d;d=g>e?Math.floor(g/e):0,g-=d*e,l[h].push(g)}}var y=-1;for(var h=0;h<l.length;h++){var b=l[h].length;b>y&&(y=b)}var w=[],d=0;for(var h=0;h<y||d>0;h++){var E=d;for(var p=0;p<l.length;p++)E+=l[p][h]||0;d=E>e?Math.floor(E/e):0,E-=d*e,w.push(E)}return o(w,r)},times:function(e,t){return h.multiply(e,t)},divmod:function(e,t){var r,u=c,a;t?(u=i(e))&&(a=i(t)):a=i(e,u),r=u.sign!==a.sign;if(o(u.value,u.sign).equals(0))return{quotient:o([0],n.positive),remainder:o([0],n.positive)};if(a.equals(0))throw new Error('Cannot divide by zero');var f=u.value,l=a.value,h=[],p=[];for(var d=f.length-1;d>=0;d--){var e=[f[d]].concat(p),v=s(l,e);h.push(v.result),p=v.remainder}return h.reverse(),{quotient:o(h,r),remainder:o(p,u.sign)}},divide:function(e,t){return h.divmod(e,t).quotient},over:function(e,t){return h.divide(e,t)},mod:function(e,t){return h.divmod(e,t).remainder},pow:function(e,t){var n=c,r;t?(n=i(e))&&(r=i(t)):r=i(e,n);var s=n,f=r;if(f.lesser(0))return u;if(f.equals(0))return a;var l=o(s.value,s.sign);if(f.mod(2).equals(0)){var h=l.pow(f.over(2));return h.times(h)}return l.times(l.pow(f.minus(1)))},next:function(e){var t=e||c;return h.add(t,1)},prev:function(e){var t=e||c;return h.subtract(t,1)},compare:function(e,t){var s=c,o;t?(s=i(e))&&(o=i(t,s)):o=i(e,s),r(s,o);if(s.value.length===1&&o.value.length===1&&s.value[0]===0&&o.value[0]===0)return 0;if(o.sign!==s.sign)return s.sign===n.positive?1:-1;var u=s.sign===n.positive?1:-1,a=s.value,f=o.value;for(var l=a.length-1;l>=0;l--){if(a[l]>f[l])return 1*u;if(f[l]>a[l])return-1*u}return 0},compareAbs:function(e,t){var r=c,s;return t?(r=i(e))&&(s=i(t,r)):s=i(e,r),r.sign=s.sign=n.positive,h.compare(r,s)},equals:function(e,t){return h.compare(e,t)===0},notEquals:function(e,t){return!h.equals(e,t)},lesser:function(e,t){return h.compare(e,t)<0},greater:function(e,t){return h.compare(e,t)>0},greaterOrEquals:function(e,t){return h.compare(e,t)>=0},lesserOrEquals:function(e,t){return h.compare(e,t)<=0},isPositive:function(e){var t=e||c;return t.sign===n.positive},isNegative:function(e){var t=e||c;return t.sign===n.negative},isEven:function(e){var t=e||c;return t.value[0]%2===0},isOdd:function(e){var t=e||c;return t.value[0]%2===1},toString:function(r){var i=r||c,s='',o=i.value.length;while(o--)s+=(e.toString()+i.value[o]).slice(-t);while(s[0]==='0')s=s.slice(1);s.length||(s='0');var u=i.sign===n.positive?'':'-';return u+s},toJSNumber:function(e){return+h.toString(e)},valueOf:function(e){return h.toJSNumber(e)}};return h},u=o([0],n.positive),a=o([1],n.positive),f=o([1],n.negative),l=function(e){return typeof e=='undefined'?u:i(e)};return l.zero=u,l.one=a,l.minusOne=f,l}();typeof module!='undefined'&&(module.exports=__IDR__.bigInt);"++ , "__IDR__.Tailcall = function(f) { this.f = f };"++ , "__IDR__.Con = function(i,name,vars)"+ , "{this.i = i;this.name = name;this.vars = vars;};\n"++ , "__IDR__.tailcall = function(f){\n"+ ++ "var __f = f;\n"+ ++ "while (__f) {\n"+ ++ "var f = __f;\n"+ ++ "__f = null;\n"+ ++ "var ret = f();\n"+ ++ "if (ret instanceof __IDR__.Tailcall) {\n"+ ++ "__f = ret.f;"+ ++ "\n} else {\n"+ ++ "return ret;"+ ++ "\n}"+ ++ "\n}"+ ++ "\n};\n"++ , "var newline_regex =/(.*)\\n$/;\n"++ , "__IDR__.print = function(s){\n"+ ++ "var m = s.match(newline_regex);\n"+ ++ "console.log(m ? m[1] : s);"+ ++ "\n};\n"+ ]++createModule :: Maybe String -> NamespaceName -> String -> String+createModule toplevel modname body =+ concat [header modname, body, footer modname]+ where+ header :: NamespaceName -> String+ header modname =+ concatMap (++ "\n")+ [ "\nvar " ++ modname ++ ";"+ , "(function(" ++ modname ++ "){"+ ]++ footer :: NamespaceName -> String+ footer modname =+ let m = maybe "" (++ ".") toplevel ++ modname in+ "\n})("+ ++ m+ ++ " || ("+ ++ m+ ++ " = {})"+ ++ ");\n"++translateModule :: Maybe String -> ([String], SDecl) -> String+translateModule toplevel ([modname], decl) =+ let body = translateDeclaration modname decl in+ createModule toplevel modname body+translateModule toplevel (n:ns, decl) =+ createModule toplevel n $ translateModule (Just n) (ns, decl)++translateIdentifier :: String -> String+translateIdentifier =+ concatMap replaceBadChars+ where replaceBadChars :: Char -> String+ replaceBadChars ' ' = "_"+ replaceBadChars '_' = "__"+ replaceBadChars '@' = "_at"+ replaceBadChars '[' = "_OSB"+ replaceBadChars ']' = "_CSB"+ replaceBadChars '(' = "_OP"+ replaceBadChars ')' = "_CP"+ replaceBadChars '{' = "_OB"+ replaceBadChars '}' = "_CB"+ replaceBadChars '!' = "_bang"+ replaceBadChars '#' = "_hash"+ replaceBadChars '.' = "_dot"+ replaceBadChars ',' = "_comma"+ replaceBadChars ':' = "_colon"+ replaceBadChars '+' = "_plus"+ replaceBadChars '-' = "_minus"+ replaceBadChars '*' = "_times"+ replaceBadChars '<' = "_lt"+ replaceBadChars '>' = "_gt"+ replaceBadChars '=' = "_eq"+ replaceBadChars '|' = "_pipe"+ replaceBadChars '&' = "_amp"+ replaceBadChars '/' = "_SL"+ replaceBadChars '\\' = "_BSL"+ replaceBadChars '%' = "_per"+ replaceBadChars '?' = "_que"+ replaceBadChars '~' = "_til"+ replaceBadChars '\'' = "_apo"+ replaceBadChars c+ | isDigit c = "_" ++ [c] ++ "_"+ | otherwise = [c]++translateNamespace :: Name -> [String]+translateNamespace (UN _) = [idrNamespace]+translateNamespace (NS _ ns) = idrNamespace : map translateIdentifier ns+translateNamespace (MN _ _) = [idrNamespace]++translateName :: Name -> String+translateName (UN name) = translateIdentifier name+translateName (NS name _) = translateName name+translateName (MN i name) = translateIdentifier name ++ show i++translateQualifiedName :: Name -> String+translateQualifiedName name =+ intercalate "." (translateNamespace name) ++ "." ++ translateName name++translateConstant :: Const -> String+translateConstant (I i) = show i+translateConstant (BI i) = "__IDR__.bigInt('" ++ show i ++ "')"+translateConstant (Fl f) = show f+translateConstant (Ch c) = show c+translateConstant (Str s) = show s+translateConstant IType = "__IDR__.Int"+translateConstant ChType = "__IDR__.Char"+translateConstant StrType = "__IDR__.String"+translateConstant BIType = "__IDR__.Integer"+translateConstant FlType = "__IDR__.Float"+translateConstant Forgot = "__IDR__.Forgot"+translateConstant c =+ "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"++translateParameterlist =+ map translateParameter+ where translateParameter (MN i name) = name ++ show i+ translateParameter (UN name) = name++translateDeclaration :: NamespaceName -> SDecl -> String+translateDeclaration modname (SFun name params stackSize body) =+ modname+ ++ "."+ ++ translateName name+ ++ " = function("+ ++ intercalate "," p+ ++ "){\n"+ ++ concatMap assignVar (zip [0..] p)+ ++ concatMap allocVar [numP..(numP+stackSize-1)]+ ++ "return "+ ++ translateExpression modname body+ ++ ";\n};\n"+ where + numP :: Int+ numP = length params++ allocVar :: Int -> String+ allocVar n = "var __var_" ++ show n ++ ";\n"++ assignVar :: (Int, String) -> String+ assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"++ p :: [String]+ p = translateParameterlist params++translateVariableName :: LVar -> String+translateVariableName (Loc i) =+ "__var_" ++ show i++translateExpression :: NamespaceName -> SExp -> String+translateExpression modname (SLet name value body) =+ "(function("+ ++ translateVariableName name+ ++ "){\nreturn "+ ++ translateExpression modname body+ ++ ";\n})("+ ++ translateExpression modname value+ ++ ")"++translateExpression _ (SConst cst) =+ translateConstant cst++translateExpression _ (SV var) =+ translateVariableName var++translateExpression modname (SApp False name vars) =+ createTailcall $ translateFunctionCall name vars++translateExpression modname (SApp True name vars) =+ "new __IDR__.Tailcall("+ ++ "function(){\n"+ ++ "return " ++ translateFunctionCall name vars+ ++ ";\n});"++translateExpression _ (SOp op vars)+ | LPlus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+ | LMinus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs+ | LTimes <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs+ | LDiv <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs+ | LMod <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs+ | LEq <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs+ | LLt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs+ | LLe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs+ | LGt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs+ | LGe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs+ | LAnd <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs+ | LOr <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs+ | LXOr <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs+ | LSHL <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs+ | LSHR <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs+ | LCompl <- op+ , (arg:_) <- vars = '~' : translateVariableName arg++ | LBPlus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"+ | LBMinus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"+ | LBTimes <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"+ | LBDiv <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"+ | LBMod <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"+ | LBEq <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"+ | LBLt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"+ | LBLe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"+ | LBGt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"+ | LBGe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"++ | LFPlus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+ | LFMinus <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs+ | LFTimes <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs+ | LFDiv <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs+ | LFEq <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs+ | LFLt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs+ | LFLe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs+ | LFGt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs+ | LFGe <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs++ | LStrConcat <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+ | LStrEq <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs+ | LStrLt <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs+ | LStrLen <- op+ , (arg:_) <- vars = translateVariableName arg ++ ".length"++ | LStrInt <- op+ , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"+ | LIntStr <- op+ , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"+ | LIntBig <- op+ , (arg:_) <- vars = "__IDR__.bigint(" ++ translateVariableName arg ++ ")"+ | LBigInt <- op+ , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"+ | LBigStr <- op+ , (arg:_) <- vars = translateVariableName arg ++ ".toString()"+ | LStrBig <- op+ , (arg:_) <- vars = "__IDR__.bigint(" ++ translateVariableName arg ++ ")"+ | LFloatStr <- op+ , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"+ | LStrFloat <- op+ , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"+ | LIntFloat <- op+ , (arg:_) <- vars = translateVariableName arg+ | LFloatInt <- op+ , (arg:_) <- vars = translateVariableName arg+ | LChInt <- op+ , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"+ | LIntCh <- op+ , (arg:_) <- vars =+ "String.fromCharCode(" ++ translateVariableName arg ++ ")"++ | LFExp <- op+ , (arg:_) <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"+ | LFLog <- op+ , (arg:_) <- vars = "Math.log(" ++ translateVariableName arg ++ ")"+ | LFSin <- op+ , (arg:_) <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"+ | LFCos <- op+ , (arg:_) <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"+ | LFTan <- op+ , (arg:_) <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"+ | LFASin <- op+ , (arg:_) <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"+ | LFACos <- op+ , (arg:_) <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"+ | LFATan <- op+ , (arg:_) <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"+ | LFSqrt <- op+ , (arg:_) <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"+ | LFFloor <- op+ , (arg:_) <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"+ | LFCeil <- op+ , (arg:_) <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"++ | LStrCons <- op+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs+ | LStrHead <- op+ , (arg:_) <- vars = translateVariableName arg ++ "[0]"+ | LStrRev <- op+ , (arg:_) <- vars = let v = translateVariableName arg in+ v ++ "split('').reverse().join('')"+ | LStrIndex <- op+ , (lhs:rhs:_) <- vars = let l = translateVariableName lhs+ r = translateVariableName rhs in+ l ++ "[" ++ r ++ "]"+ | LStrTail <- op+ , (arg:_) <- vars = let v = translateVariableName arg in+ v ++ ".substr(1," ++ v ++ ".length-1)"+ where+ translateBinaryOp :: String -> LVar -> LVar -> String+ translateBinaryOp f lhs rhs =+ translateVariableName lhs+ ++ f+ ++ translateVariableName rhs++translateExpression _ (SError msg) =+ "(function(){throw \'" ++ msg ++ "\';})();"++translateExpression _ (SForeign _ _ "putStr" [(FString, var)]) =+ "__IDR__.print(" ++ translateVariableName var ++ ");"++translateExpression _ (SForeign _ _ fun args) =+ fun+ ++ "("+ ++ intercalate "," (map (translateVariableName . snd) args)+ ++ ");"++translateExpression modname (SChkCase var cases) =+ "(function(e){\n"+ ++ intercalate " else " (map (translateCase modname "e") cases)+ ++ "\n})("+ ++ translateVariableName var+ ++ ")"++translateExpression modname (SCase var cases) = + "(function(e){\n"+ ++ intercalate " else " (map (translateCase modname "e") cases)+ ++ "\n})("+ ++ translateVariableName var+ ++ ")"++translateExpression _ (SCon i name vars) =+ concat [ "new __IDR__.Con("+ , show i+ , ","+ , '\'' : translateQualifiedName name ++ "\',["+ , intercalate "," $ map translateVariableName vars+ , "])"+ ]++translateExpression modname (SUpdate var e) =+ translateVariableName var ++ " = " ++ translateExpression modname e++translateExpression modname (SProj var i) =+ translateVariableName var ++ ".vars[" ++ show i ++"]"++translateExpression _ SNothing = "null"++translateExpression _ e =+ "(function(){throw 'Not yet implemented: "+ ++ filter (/= '\'') (show e)+ ++ "';})()"++translateCase :: String -> String -> SAlt -> String+translateCase modname _ (SDefaultCase e) =+ createIfBlock "true" (translateExpression modname e)++translateCase modname var (SConstCase ty e)+ | ChType <- ty = matchHelper "Char"+ | StrType <- ty = matchHelper "String"+ | IType <- ty = matchHelper "Int"+ | BIType <- ty = matchHelper "Integer"+ | FlType <- ty = matchHelper "Float"+ | Forgot <- ty = matchHelper "Forgot"+ where+ matchHelper tyName = translateTypeMatch modname var tyName e++translateCase modname var (SConstCase cst@(BI _) e) =+ let cond = var ++ ".equals(" ++ translateConstant cst ++ ")" in+ createIfBlock cond (translateExpression modname e)++translateCase modname var (SConstCase cst e) =+ let cond = var ++ " == " ++ translateConstant cst in+ createIfBlock cond (translateExpression modname e)++translateCase modname var (SConCase a i name vars e) =+ let isCon = var ++ " instanceof __IDR__.Con"+ isI = show i ++ " == " ++ var ++ ".i"+ params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]+ args = ".apply(this," ++ var ++ ".vars)"+ f b =+ "(function("+ ++ params + ++ "){\nreturn " ++ b ++ "\n})" ++ args+ cond = intercalate " && " [isCon, isI] in+ createIfBlock cond $ f (translateExpression modname e)++translateTypeMatch :: String -> String -> String -> SExp -> String+translateTypeMatch modname var ty exp =+ let e = translateExpression modname exp in+ createIfBlock (var+ ++ " instanceof __IDR__.Type && "+ ++ var ++ ".type == '"++ ty ++"'") e+++createIfBlock cond e =+ "if (" ++ cond ++") {\n"+ ++ "return " ++ e+ ++ ";\n}"++createTailcall call =+ "__IDR__.tailcall(function(){return " ++ call ++ "})"++translateFunctionCall name vars =+ concat (intersperse "." $ translateNamespace name)+ ++ "."+ ++ translateName name+ ++ "("+ ++ intercalate "," (map translateVariableName vars)+ ++ ")"
src/IRTS/Compiler.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, TypeSynonymInstances #-} module IRTS.Compiler where import IRTS.Lang import IRTS.Defunctionalise import IRTS.Simplified+import IRTS.CodegenCommon import IRTS.CodegenC import IRTS.CodegenJava+import IRTS.DumpBC+import IRTS.CodegenJavaScript import IRTS.Inliner import Idris.AbsSyntax@@ -22,6 +25,7 @@ import System.IO import System.Directory import System.Environment+import System.FilePath ((</>), addTrailingPathSeparator) import Paths_idris @@ -29,7 +33,8 @@ compile target f tm = do checkMVs let tmnames = namesUsed (STerm tm)- used <- mapM (allNames []) tmnames+ usedIn <- mapM (allNames []) tmnames+ let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn defsIn <- mkDecls tm (concat used) findUnusedArgs (concat used) maindef <- irMain tm@@ -49,7 +54,7 @@ iLOG "Resolving variables for CG" -- iputStrLn $ showSep "\n" (map show (toAlist defuns)) let checked = checkDefs defuns (toAlist defuns)- dumpC <- getDumpC+ outty <- outputTy dumpCases <- getDumpCases dumpDefun <- getDumpDefun case dumpCases of@@ -61,16 +66,18 @@ iLOG "Building output" case checked of OK c -> case target of- ViaC -> liftIO $ codegenC dumpC c f True hdrs + ViaC -> liftIO $ codegenC c f outty hdrs (concatMap mkObj objs) (concatMap mkLib libs) NONE- ViaJava -> liftIO $ codegenJava c f + ViaJava -> liftIO $ codegenJava c f outty+ Bytecode -> liftIO $ dumpBC c f+ ToJavaScript -> liftIO $ codegenJavaScript c f outty Error e -> fail $ show e where checkMVs = do i <- get case idris_metavars i \\ primDefs of [] -> return () ms -> fail $ "There are undefined metavariables: " ++ show ms- inDir d h = do let f = d ++ "/" ++ h+ inDir d h = do let f = d </> h ex <- doesFileExist f if ex then return f else return h mkObj f = f ++ " "@@ -80,7 +87,7 @@ irMain :: TT Name -> Idris LDecl irMain tm = do i <- ir tm- return $ LFun (MN 0 "runMain") [] (LForce i)+ return $ LFun [] (MN 0 "runMain") [] (LForce i) allNames :: [Name] -> Name -> Idris [Name] allNames ns n | n `elem` ns = return []@@ -101,7 +108,7 @@ showCaseTrees :: [(Name, LDecl)] -> String showCaseTrees ds = showSep "\n\n" (map showCT ds) where- showCT (n, LFun f args lexp) + showCT (n, LFun _ f args lexp) = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t " ++ show lexp showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a @@ -118,22 +125,30 @@ case lookup n (idris_scprims i) of Just (ar, op) -> let args = map (\x -> MN x "op") [0..] in- return (n, (LFun n (take ar args) + return (n, (LFun [] n (take ar args) (LOp op (map (LV . Glob) (take ar args))))) _ -> do def <- mkLDecl n d logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def return (n, def) -declArgs args n (LLam xs x) = declArgs (args ++ xs) n x-declArgs args n x = LFun n args x +getPrim :: IState -> Name -> [LExp] -> Maybe LExp+getPrim i n args = case lookup n (idris_scprims i) of+ Just (ar, op) -> + if (ar == length args) + then return (LOp op args)+ else Nothing+ _ -> Nothing +declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x+declArgs args inl n x = LFun (if inl then [Inline] else []) n args x + mkLDecl n (Function tm _) = do e <- ir tm- return (declArgs [] n e)-mkLDecl n (CaseOp _ _ _ pats _ _ args sc) = do e <- ir (args, sc)- return (declArgs [] n e)+ return (declArgs [] True n e)+mkLDecl n (CaseOp _ inl _ _ pats _ _ args sc) = do e <- ir (args, sc)+ return (declArgs [] inl n e) mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a-mkLDecl n _ = return (LFun n [] (LError ("Impossible declaration " ++ show n)))+mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n))) instance ToIR (TT Name) where ir tm = ir' [] tm where@@ -142,6 +157,9 @@ = doForeign env args | (P _ (UN "unsafePerformIO") _, [_, arg]) <- unApply tm = ir' env arg+ -- TMP HACK - until we get inlining. + | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm+ = ir' env arg | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = do arg' <- ir' env arg return $ LLazyExp arg'@@ -154,6 +172,10 @@ | (P _ (UN "prim__IO") _, [v]) <- unApply tm = do v' <- ir' env v return v'+ | (P _ (UN "io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm+ = do v' <- ir' env v + sc' <- ir' (n:env) sc+ return (LLet n (LForce v') sc') | (P _ (UN "io_bind") _, [_,_,v,k]) <- unApply tm = do v' <- ir' env v k' <- ir' env k@@ -165,19 +187,31 @@ | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm = do t' <- ir' env t return t' -- TODO+-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm+-- = do k' <- ir' env k+-- return (LOp LBPlus [k', LConst (BI 1)]) | (P (DCon t a) n _, args) <- unApply tm = irCon env t a n args | (P _ n _, args) <- unApply tm = do i <- get- let collapse = case lookupCtxt Nothing n (idris_optimisation i) of- [oi] -> collapsible oi- _ -> False- let unused = case lookupCtxt Nothing n (idris_callgraph i) of- [CGInfo _ _ _ _ unusedpos] -> unusedpos- _ -> [] args' <- mapM (ir' env) args- if collapse then return LNothing- else return (LApp False (LV (Glob n)) + case getPrim i n args' of+ Just tm -> return tm+ _ -> do+ let collapse + = case lookupCtxt Nothing n + (idris_optimisation i) of+ [oi] -> collapsible oi+ _ -> False+ let unused + = case lookupCtxt Nothing n + (idris_callgraph i) of+ [CGInfo _ _ _ _ unusedpos] -> + unusedpos+ _ -> []+ if collapse + then return LNothing+ else return (LApp False (LV (Glob n)) (mkUnused unused 0 args')) | (f, args) <- unApply tm = do f' <- ir' env f@@ -186,6 +220,8 @@ where mkUnused u i [] = [] mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs | otherwise = x : mkUnused u (i + 1) xs+-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)+-- = return $ LConst (BI 0) ir' env (P _ n _) = return $ LV (Glob n) ir' env (V i) | i < length env = return $ LV (Glob (env!!i)) | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm@@ -201,7 +237,7 @@ ir' env (Proj t i) = do t' <- ir' env t return $ LProj t' i ir' env (Constant c) = return $ LConst c- ir' env (Set _) = return $ LNothing+ ir' env (TType _) = return $ LNothing ir' env Erased = return $ LNothing ir' env Impossible = return $ LNothing -- ir' env _ = return $ LError "Impossible"@@ -227,7 +263,7 @@ do args' <- mapM (ir' env) args -- wrap it in a prim__IO -- return $ con_ 0 @@ impossible @@ - return $ LLazyExp $+ return $ -- LLazyExp $ LForeign LANG_C rty fgnName (zip tys args') | otherwise = fail "Badly formed foreign function call" @@ -248,6 +284,9 @@ mkIty "FPtr" = FPtr mkIty "FUnit" = FUnit +zname = NS (UN "O") ["Nat","Prelude"] +sname = NS (UN "S") ["Nat","Prelude"] + instance ToIR ([Name], SC) where ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree tree' <- ir tree@@ -258,25 +297,52 @@ ir' (STerm t) = ir t ir' (UnmatchedCase str) = return $ LError str- ir' (ProjCase tm alts) = do alts' <- mapM mkIRAlt alts+ ir' (ProjCase tm alts) = do alts' <- mapM (mkIRAlt tm) alts tm' <- ir tm return $ LCase tm' alts'- ir' (Case n alts) = do alts' <- mapM mkIRAlt alts+ ir' (Case n alts) = do alts' <- mapM (mkIRAlt (P Bound n Erased)) alts return $ LCase (LV (Glob n)) alts' ir' ImpossibleCase = return LNothing - mkIRAlt (ConCase n t args rhs) + -- special cases for O and S+ -- Needs rethink: projections make this fail+-- mkIRAlt n (ConCase z _ [] rhs) | z == zname+-- = mkIRAlt n (ConstCase (BI 0) rhs)+-- mkIRAlt n (ConCase s _ [arg] rhs) | s == sname+-- = do n' <- ir n+-- rhs' <- ir rhs+-- return $ LDefaultCase+-- (LLet arg (LOp LBMinus [n', LConst (BI 1)]) +-- rhs')+ mkIRAlt _ (ConCase n t args rhs) = do rhs' <- ir rhs return $ LConCase (-1) n args rhs'- mkIRAlt (ConstCase (I i) rhs) + mkIRAlt _ (ConstCase x rhs)+ | matchable x = do rhs' <- ir rhs- return $ LConstCase (I i) rhs'- mkIRAlt (ConstCase IType rhs) + return $ LConstCase x rhs'+ | matchableTy x = do rhs' <- ir rhs return $ LDefaultCase rhs'- mkIRAlt (ConstCase c rhs) - = fail $ "Can only pattern match on integer constants (" ++ show c ++ ")"- mkIRAlt (DefaultCase rhs)+ mkIRAlt _ (ConstCase c rhs) + = fail $ "Can't match on (" ++ show c ++ ")"+ mkIRAlt _ (DefaultCase rhs) = do rhs' <- ir rhs return $ LDefaultCase rhs'++ matchable (I _) = True+ matchable (BI _) = True+ matchable (Ch _) = True+ matchable (Str _) = True+ matchable _ = False++ matchableTy IType = True+ matchableTy BIType = True+ matchableTy ChType = True+ matchableTy StrType = True++ matchableTy W8Type = True+ matchableTy W16Type = True++ matchableTy _ = False
src/IRTS/Defunctionalise.hs view
@@ -7,13 +7,17 @@ import Debug.Trace import Data.Maybe import Data.List+import Control.Monad+import Control.Monad.State data DExp = DV LVar | DApp Bool Name [DExp] -- True = tail call | DLet Name DExp DExp -- name just for pretty printing+ | DUpdate Name DExp -- eval expression, then update var with it | DProj DExp Int | DC Int Name [DExp] | DCase DExp [DAlt]+ | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY) | DConst Const | DForeign FLang FType String [(FType, DExp)] | DOp PrimFn [DExp]@@ -37,16 +41,17 @@ defunctionalise nexttag defs = let all = toAlist defs -- sort newcons so that EVAL and APPLY cons get sequential tags- newcons = sortBy conord $ concatMap toCons (getFn all)+ (allD, enames) = runState (mapM (addApps defs) all) []+ newcons = sortBy conord $ concatMap (toCons enames) (getFn all) eval = mkEval newcons app = mkApply newcons condecls = declare nexttag newcons in- addAlist (eval : app : condecls ++ (map (addApps defs) all)) emptyContext+ addAlist (eval : app : condecls ++ allD) emptyContext where conord (n, _, _) (n', _, _) = compare n n' getFn :: [(Name, LDecl)] -> [(Name, Int)] getFn xs = mapMaybe fnData xs- where fnData (n, LFun _ args _) = Just (n, length args) + where fnData (n, LFun _ _ args _) = Just (n, length args) fnData _ = Nothing -- To defunctionalise:@@ -62,91 +67,147 @@ -- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY -- 8 Add explicit EVAL to case, primitives, and foreign calls -addApps :: LDefs -> (Name, LDecl) -> (Name, DDecl)-addApps defs o@(n, LConstructor _ t a) = (n, DConstructor n t a) -addApps defs (n, LFun _ args e) = (n, DFun n args (aa args e))+addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)+addApps defs o@(n, LConstructor _ t a) + = return (n, DConstructor n t a) +addApps defs (n, LFun _ _ args e) + = do e' <- aa args e+ return (n, DFun n args e') where- aa :: [Name] -> LExp -> DExp- aa env (LV (Glob n)) | n `elem` env = DV (Glob n)+ aa :: [Name] -> LExp -> State [Name] DExp+ aa env (LV (Glob n)) | n `elem` env = return $ DV (Glob n) | otherwise = aa env (LApp False (LV (Glob n)) []) -- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e aa env (LApp tc (LV (Glob n)) args)- = let args' = map (aa env) args in- case lookupCtxt Nothing n defs of- [LConstructor _ i ar] -> DApp tc n args'- [LFun _ as _] -> let arity = length as in- fixApply tc n args' arity- [] -> chainAPPLY (DV (Glob n)) args'+ = do args' <- mapM (aa env) args + case lookupCtxt Nothing n defs of+ [LConstructor _ i ar] -> return $ DApp tc n args'+ [LFun _ _ as _] -> let arity = length as in+ fixApply tc n args' arity+ [] -> return $ chainAPPLY (DV (Glob n)) args' aa env (LLazyApp n args)- = let args' = map (aa env) args in- case lookupCtxt Nothing n defs of- [LConstructor _ i ar] -> DApp False n args'- [LFun _ as _] -> let arity = length as in- fixLazyApply n args' arity- [] -> chainAPPLY (DV (Glob n)) args'- aa env (LForce e) = eEVAL (aa env e)- aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)- aa env (LCon i n args) = DC i n (map (aa env) args)- aa env (LProj t i) = DProj (eEVAL (aa env t)) i- aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)- aa env (LConst c) = DConst c- aa env (LForeign l t n args) = DForeign l t n (map (aaF env) args)- aa env (LOp LFork args) = DOp LFork (map (aa env) args)- aa env (LOp f args) = DOp f (map (eEVAL . (aa env)) args)- aa env LNothing = DNothing- aa env (LError e) = DError e+ = do args' <- mapM (aa env) args+ case lookupCtxt Nothing n defs of+ [LConstructor _ i ar] -> return $ DApp False n args'+ [LFun _ _ as _] -> let arity = length as in+ fixLazyApply n args' arity+ [] -> return $ chainAPPLY (DV (Glob n)) args'+ aa env (LForce (LLazyApp n args)) = aa env (LApp False (LV (Glob n)) args)+ aa env (LForce e) = liftM eEVAL (aa env e)+ aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)+ aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args)+ aa env (LProj t@(LV (Glob n)) i) + = do t' <- aa env t+ return $ DProj (DUpdate n (eEVAL t')) i+ aa env (LProj t i) = do t' <- aa env t+ return $ DProj (eEVAL t') i+ aa env (LCase e alts) = do e' <- aa env e+ alts' <- mapM (aaAlt env) alts+ return $ DCase (eEVAL e') alts'+ aa env (LConst c) = return $ DConst c+ aa env (LForeign l t n args) = liftM (DForeign l t n) (mapM (aaF env) args)+ aa env (LOp LFork args) = liftM (DOp LFork) (mapM (aa env) args)+ aa env (LOp f args) = do args' <- mapM (aa env) args+ return $ DOp f (map eEVAL args')+ aa env LNothing = return DNothing+ aa env (LError e) = return $ DError e - aaF env (t, e) = (t, eEVAL (aa env e))+ aaF env (t, e) = do e' <- aa env e+ return (t, eEVAL e') - aaAlt env (LConCase i n args e) = DConCase i n args (aa (args ++ env) e)- aaAlt env (LConstCase c e) = DConstCase c (aa env e)- aaAlt env (LDefaultCase e) = DDefaultCase (aa env e)+ aaAlt env (LConCase i n args e) + = liftM (DConCase i n args) (aa (args ++ env) e)+ aaAlt env (LConstCase c e) = liftM (DConstCase c) (aa env e)+ aaAlt env (LDefaultCase e) = liftM DDefaultCase (aa env e) fixApply tc n args ar - | length args == ar = DApp tc n args- | length args < ar = DApp tc (mkUnderCon n (ar - length args)) args- | length args > ar = chainAPPLY (DApp tc n (take ar args)) (drop ar args)+ | length args == ar + = return $ DApp tc n args+ | length args < ar + = do ns <- get+ put $ nub (n : ns)+ return $ DApp tc (mkUnderCon n (ar - length args)) args+ | length args > ar + = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args) fixLazyApply n args ar - | length args == ar = DApp False (mkFnCon n) args- | length args < ar = DApp False (mkUnderCon n (ar - length args)) args- | length args > ar = chainAPPLY (DApp False n (take ar args)) (drop ar args)+ | length args == ar + = do ns <- get+ put $ nub (n : ns)+ return $ DApp False (mkFnCon n) args+ | length args < ar + = do ns <- get+ put $ nub (n : ns)+ return $ DApp False (mkUnderCon n (ar - length args)) args+ | length args > ar + = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args) chainAPPLY f [] = f chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as + -- if anything in the DExp is projected from, we'll need to evaluate it,+ -- but we only want to do it once, rather than every time we project.++ preEval [] t = t+ preEval (x : xs) t + | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t)+ | otherwise = preEval xs t++ needsEval x (DApp _ _ args) = or (map (needsEval x) args)+ needsEval x (DC _ _ args) = or (map (needsEval x) args)+ needsEval x (DCase e alts) = needsEval x e || or (map nec alts)+ where nec (DConCase _ _ _ e) = needsEval x e+ nec (DConstCase _ e) = needsEval x e+ nec (DDefaultCase e) = needsEval x e+ needsEval x (DChkCase e alts) = needsEval x e || or (map nec alts)+ where nec (DConCase _ _ _ e) = needsEval x e+ nec (DConstCase _ e) = needsEval x e+ nec (DDefaultCase e) = needsEval x e+ needsEval x (DLet n v e) + | x == n = needsEval x v+ | otherwise = needsEval x v || needsEval x e+ needsEval x (DForeign _ _ _ args) = or (map (needsEval x) (map snd args))+ needsEval x (DOp op args) = or (map (needsEval x) args)+ needsEval x (DProj (DV (Glob x')) _) = x == x'+ needsEval x _ = False+ eEVAL x = DApp False (MN 0 "EVAL") [x] -data EvalApply a = EvalCase a+data EvalApply a = EvalCase (Name -> a) | ApplyCase a- deriving Show+-- deriving Show -- For a function name, generate a list of -- data constuctors, and whether to handle them in EVAL or APPLY -toCons :: (Name, Int) -> [(Name, Int, EvalApply DAlt)]-toCons (n, i) - = (mkFnCon n, i, - EvalCase (DConCase (-1) (mkFnCon n) (take i (genArgs 0))- (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))- : mkApplyCase n 0 i+toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]+toCons ns (n, i) + | n `elem` ns+ = (mkFnCon n, i, + EvalCase (\tlarg ->+ (DConCase (-1) (mkFnCon n) (take i (genArgs 0))+ (dupdate tlarg+ (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))))+ : mkApplyCase n 0 i+ | otherwise = []+ where dupdate tlarg x = x mkApplyCase fname n ar | n == ar = [] mkApplyCase fname n ar = let nm = mkUnderCon fname (ar - n) in (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))- (DApp False (mkUnderCon fname (ar - (n + 1))) - (map (DV . Glob) (take n (genArgs 0) ++ - [MN 0 "arg"])))))+ (DApp False (mkUnderCon fname (ar - (n + 1))) + (map (DV . Glob) (take n (genArgs 0) ++ + [MN 0 "arg"]))))) : mkApplyCase fname (n + 1) ar mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl) mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]- (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))- (mapMaybe evalCase xs ++- [DDefaultCase (DV (Glob (MN 0 "arg")))])))+ (mkBigCase (MN 0 "EVAL") 256 (DV (Glob (MN 0 "arg")))+ (mapMaybe evalCase xs +++ [DDefaultCase (DV (Glob (MN 0 "arg")))]))) where- evalCase (n, t, EvalCase x) = Just x+ evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg")) evalCase _ = Nothing mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)@@ -180,10 +241,13 @@ showSep ", " (map (show' env) args) ++")" show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++ show' (env ++ [show n]) e+ show' env (DUpdate n e) = "!update " ++ show n ++ "(" ++ show' env e ++ ")" show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")" show' env (DProj t i) = show t ++ "!" ++ show i show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++ showSep "\n\t| " (map (showAlt env) alts)+ show' env (DChkCase e alts) = "case' " ++ show' env e ++ " of {\n\t" +++ showSep "\n\t| " (map (showAlt env) alts) show' env (DConst c) = show c show' env (DForeign lang ty n args) = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"@@ -201,8 +265,8 @@ -- 'max' branches mkBigCase cn max arg branches - | length branches <= max = DCase arg branches- | otherwise = -- DCase arg branches -- until I think of something...+ | length branches <= max = DChkCase arg branches+ | otherwise = -- DChkCase arg branches -- until I think of something... -- divide the branches into groups of at most max (by tag), -- generate a new case and shrink, recursively let bs = sortBy tagOrd branches@@ -211,9 +275,9 @@ _ -> (all, Nothing) bss = groupsOf max all cs = map mkCase bss in- DCase arg branches+ DChkCase arg branches - where mkCase bs = DCase arg bs + where mkCase bs = DChkCase arg bs tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t' tagOrd (DConstCase c _) (DConstCase c' _) = compare c c'
+ src/IRTS/DumpBC.hs view
@@ -0,0 +1,76 @@+module IRTS.DumpBC where++import IRTS.Lang+import IRTS.Simplified+import Core.TT++import IRTS.Bytecode+import Data.List++interMap :: [a] -> [b] -> (a -> [b]) -> [b]+interMap xs y f = concat (intersperse y (map f xs))++indent :: Int -> String+indent n = replicate (n*4) ' '++serializeReg :: Reg -> String+serializeReg (L n) = "L" ++ show n+serializeReg (T n) = "T" ++ show n+serializeReg r = show r++serializeCase :: Show a => Int -> (a, [BC]) -> String+serializeCase n (x, bcs) =+ indent n ++ show x ++ ":\n" ++ interMap bcs "\n" (serializeBC (n + 1))++serializeDefault :: Int -> [BC] -> String+serializeDefault n bcs =+ indent n ++ "default:\n" ++ interMap bcs "\n" (serializeBC (n + 1))++serializeBC :: Int -> BC -> String+serializeBC n bc = indent n +++ case bc of+ ASSIGN a b ->+ "ASSIGN " ++ serializeReg a ++ " " ++ serializeReg b+ ASSIGNCONST a b ->+ "ASSIGNCONST " ++ serializeReg a ++ " " ++ show b+ UPDATE a b ->+ "UPDATE " ++ serializeReg a ++ " " ++ serializeReg b+ MKCON a b xs ->+ "MKCON " ++ serializeReg a ++ " " ++ show b ++ " [" ++ (interMap xs ", " serializeReg) ++ "]"+ CASE safe r cases def ->+ "CASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) +++ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def+ PROJECT a b c ->+ "PROJECT " ++ serializeReg a ++ " " ++ show b ++ " " ++ show c+ PROJECTINTO a b c ->+ "PROJECTINTO " ++ serializeReg a ++ " " ++ serializeReg b ++ " " ++ show c+ CONSTCASE r cases def ->+ "CONSTCASE " ++ serializeReg r ++ ":\n" ++ interMap cases "\n" (serializeCase (n + 1)) +++ maybe "" (\def' -> "\n" ++ serializeDefault (n + 1) def') def+ CALL x -> "CALL " ++ show x+ TAILCALL x -> "TAILCALL " ++ show x+ FOREIGNCALL r _ ret name args ->+ "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++ + " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]"+ SLIDE n -> "SLIDE " ++ show n+ REBASE -> "REBASE"+ RESERVE n -> "RESERVE " ++ show n+ ADDTOP n -> "ADDTOP " ++ show n+ TOPBASE n -> "TOPBASE " ++ show n+ BASETOP n -> "BASETOP " ++ show n+ STOREOLD -> "STOREOLD"+ OP a b c ->+ "OP " ++ serializeReg a ++ " " ++ show b ++ " [" ++ interMap c ", " serializeReg ++ "]"+ NULL r -> "NULL " ++ serializeReg r+ ERROR s -> "ERROR \"" ++ s ++ "\"" -- FIXME: s may contain quotes++serialize :: [(Name, [BC])] -> String+serialize decls =+ interMap decls "\n\n" serializeDecl+ where+ serializeDecl :: (Name, [BC]) -> String+ serializeDecl (name, bcs) =+ show name ++ ":\n" ++ interMap bcs "\n" (serializeBC 1)++dumpBC :: [(Name, SDecl)] -> String -> IO ()+dumpBC c output = writeFile output $ serialize $ map toBC c
src/IRTS/LParser.hs view
@@ -1,11 +1,15 @@ module IRTS.LParser where +import Idris.AbsSyntaxTree import Core.CoreParser import Core.TT import IRTS.Lang import IRTS.Simplified import IRTS.Bytecode+import IRTS.CodegenCommon import IRTS.CodegenC+import IRTS.CodegenJava+import IRTS.CodegenJavaScript import IRTS.Defunctionalise import Paths_idris @@ -26,7 +30,7 @@ type LParser = GenParser Char () lexer :: TokenParser ()-lexer = PTok.makeTokenParser idrisDef+lexer = idrisLexer whiteSpace= PTok.whiteSpace lexer lexeme = PTok.lexeme lexer@@ -45,17 +49,20 @@ chlit = PTok.charLiteral lexer lchar = lexeme.char -fovm :: FilePath -> IO ()-fovm f = do defs <- parseFOVM f- let (nexttag, tagged) = addTags 0 (liftAll defs)- let ctxtIn = addAlist tagged emptyContext- let defuns = defunctionalise nexttag ctxtIn- putStrLn $ showSep "\n" (map show (toAlist defuns))- let checked = checkDefs defuns (toAlist defuns)--- print checked- case checked of- OK c -> codegenC Nothing c "a.out" True ["math.h"] "" "" TRACE- Error e -> fail $ show e +fovm :: Target -> OutputType -> FilePath -> IO ()+fovm tgt outty f+ = do defs <- parseFOVM f+ let (nexttag, tagged) = addTags 0 (liftAll defs)+ ctxtIn = addAlist tagged emptyContext+ defuns = defunctionalise nexttag ctxtIn+ putStrLn $ showSep "\n" (map show (toAlist defuns))+ let checked = checkDefs defuns (toAlist defuns)+-- print checked+ case checked of+ OK c -> case tgt of+ ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE+ ViaJava -> codegenJava c "a.out" outty+ Error e -> fail $ show e parseFOVM :: FilePath -> IO [(Name, LDecl)] parseFOVM fname = do -- putStrLn $ "Reading " ++ fname@@ -81,7 +88,7 @@ lchar ')' lchar '=' def <- pLExp- return (n, LFun n args def)+ return (n, LFun [] n args def) pLExp = buildExpressionParser optable pLExp'
src/IRTS/Lang.hs view
@@ -28,14 +28,23 @@ -- Primitive operators. Backends are not *required* to implement all -- of these, but should report an error if they are unable -data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe- | LFPlus | LFMinus | LFTimes | LFDiv | LFEq | LFLt | LFLe | LFGt | LFGe- | LBPlus | LBMinus | LBTimes | LBDiv | LBEq | LBLt | LBLe | LBGt | LBGe+data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod + | LAnd | LOr | LXOr | LCompl | LSHL| LSHR+ | LEq | LLt | LLe | LGt | LGe+ | LFPlus | LFMinus | LFTimes | LFDiv + | LFEq | LFLt | LFLe | LFGt | LFGe+ | LBPlus | LBMinus | LBDec | LBTimes | LBDiv | LBMod + | LBEq | LBLt | LBLe | LBGt | LBGe | LStrConcat | LStrLt | LStrEq | LStrLen | LIntFloat | LFloatInt | LIntStr | LStrInt | LFloatStr | LStrFloat- | LIntBig | LBigInt | LStrBig | LBigStr+ | LIntBig | LBigInt | LStrBig | LBigStr | LChInt | LIntCh | LPrintNum | LPrintStr | LReadStr + | LW8 | LW16+ + | LW8Plus | LW8Minus | LW8Times+ | LW16Plus | LW16Minus | LW16Times+ | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan | LFSqrt | LFFloor | LFCeil @@ -62,12 +71,15 @@ | LDefaultCase LExp deriving (Show, Eq) -data LDecl = LFun Name [Name] LExp -- name, arg names, definition, inlinable+data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def | LConstructor Name Int Int -- constructor name, tag, arity deriving (Show, Eq) type LDefs = Ctxt LDecl +data LOpt = Inline | NoInline+ deriving (Show, Eq)+ addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)]) addTags i ds = tag i ds [] where tag i ((n, LConstructor n' (-1) a) : as) acc@@ -87,9 +99,9 @@ liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs lambdaLift :: Name -> LDecl -> [(Name, LDecl)]-lambdaLift n (LFun _ args e) +lambdaLift n (LFun _ _ args e) = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in- (n, LFun n args e') : decls+ (n, LFun [] n args e') : decls lambdaLift n x = [(n, x)] getNextName :: State LiftState Name@@ -107,16 +119,18 @@ return (LApp tc (LV (Glob n)) args') lift env (LApp tc f args) = do f' <- lift env f fn <- getNextName- addFn fn (LFun fn env f')+ addFn fn (LFun [Inline] fn env f') args' <- mapM (lift env) args return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args')) lift env (LLazyApp n args) = do args' <- mapM (lift env) args return (LLazyApp n args') lift env (LLazyExp (LConst c)) = return (LConst c)+-- lift env (LLazyExp (LApp tc (LV (Glob f)) args)) +-- = lift env (LLazyApp f args) lift env (LLazyExp e) = do e' <- lift env e let usedArgs = nub $ usedIn env e' fn <- getNextName- addFn fn (LFun fn usedArgs e')+ addFn fn (LFun [NoInline] fn usedArgs e') return (LLazyApp fn (map (LV . Glob) usedArgs)) lift env (LForce e) = do e' <- lift env e return (LForce e') @@ -126,7 +140,7 @@ lift env (LLam args e) = do e' <- lift (env ++ args) e let usedArgs = nub $ usedIn env e' fn <- getNextName- addFn fn (LFun fn (usedArgs ++ args) e')+ addFn fn (LFun [Inline] fn (usedArgs ++ args) e') return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs)) lift env (LProj t i) = do t' <- lift env t return (LProj t' i)
src/IRTS/Simplified.hs view
@@ -13,8 +13,10 @@ data SExp = SV LVar | SApp Bool Name [LVar] | SLet LVar SExp SExp+ | SUpdate LVar SExp | SCon Int Name [LVar] | SCase LVar [SAlt]+ | SChkCase LVar [SAlt] | SProj LVar Int | SConst Const | SForeign FLang FType String [(FType, LVar)]@@ -56,6 +58,8 @@ simplify tl (DLet n v e) = do v' <- simplify False v e' <- simplify tl e return (SLet (Glob n) v' e')+simplify tl (DUpdate n e) = do e' <- simplify False e+ return (SUpdate (Glob n) e') simplify tl (DC i n args) = do args' <- mapM sVar args mkapp (SCon i n) args' simplify tl (DProj t i) = do v <- sVar t@@ -69,6 +73,13 @@ (x, Nothing) -> return (SCase x alts') (Glob x, Just e) -> return (SLet (Glob x) e (SCase (Glob x) alts'))+simplify tl (DChkCase e alts) + = do v <- sVar e+ alts' <- mapM (sAlt tl) alts+ case v of + (x, Nothing) -> return (SChkCase x alts')+ (Glob x, Just e) -> + return (SLet (Glob x) e (SChkCase (Glob x) alts')) simplify tl (DConst c) = return (SConst c) simplify tl (DOp p args) = do args' <- mapM sVar args mkapp (SOp p) args'@@ -163,12 +174,21 @@ = do e' <- scVar env e alts' <- mapM (scalt env) alts return (SCase e' alts')+ sc env (SChkCase e alts)+ = do e' <- scVar env e+ alts' <- mapM (scalt env) alts+ return (SChkCase e' alts') sc env (SLet (Glob n) v e) = do let env' = env ++ [(n, length env)] v' <- sc env v n' <- scVar env' (Glob n) e' <- sc env' e return (SLet n' v' e')+ sc env (SUpdate (Glob n) e)+ = do -- n already in env+ e' <- sc env e+ n' <- scVar env (Glob n)+ return (SUpdate n' e') sc env (SOp prim args) = do args' <- mapM (scVar env) args return (SOp prim args')
src/Idris/AbsSyntax.hs view
@@ -8,6 +8,7 @@ import Core.Elaborate hiding (Tactic(..)) import Core.Typecheck import Idris.AbsSyntaxTree+import IRTS.CodegenCommon import Paths_idris @@ -68,9 +69,15 @@ _ -> return (Total []) addToCG :: Name -> CGInfo -> Idris ()-addToCG n cg = do i <- get- put (i { idris_callgraph = addDef n cg (idris_callgraph i) })+addToCG n cg + = do i <- get+ put (i { idris_callgraph = addDef n cg (idris_callgraph i) }) +addDocStr :: Name -> String -> Idris ()+addDocStr n doc + = do i <- get+ put (i { idris_docstrings = addDef n doc (idris_docstrings i) })+ addToCalledG :: Name -> [Name] -> Idris () addToCalledG n ns = return () -- TODO @@ -215,13 +222,6 @@ let iopts = idris_options i put (i { idris_options = iopts { opt_cmdline = opts } }) -getDumpC :: Idris (Maybe FilePath)-getDumpC = do i <- get- return $ findC (opt_cmdline (idris_options i))- where findC [] = Nothing- findC (DumpC x : _) = Just x- findC (_ : xs) = findC xs- getDumpDefun :: Idris (Maybe FilePath) getDumpDefun = do i <- get return $ findC (opt_cmdline (idris_options i))@@ -260,6 +260,26 @@ let opt' = opts { opt_repl = t } put (i { idris_options = opt' }) +setTarget :: Target -> Idris ()+setTarget t = do i <- get+ let opts = idris_options i+ let opt' = opts { opt_target = t }+ put (i { idris_options = opt' })++target :: Idris Target+target = do i <- get+ return (opt_target (idris_options i))++setOutputTy :: OutputType -> Idris ()+setOutputTy t = do i <- get+ let opts = idris_options i+ let opt' = opts { opt_outputTy = t }+ put (i { idris_options = opt' })++outputTy :: Idris OutputType+outputTy = do i <- get+ return $ opt_outputTy $ idris_options i+ verbose :: Idris Bool verbose = do i <- get return (opt_verbose (idris_options i))@@ -332,9 +352,9 @@ $ do liftIO (putStrLn str) put (i { idris_log = idris_log i ++ str ++ "\n" } ) -cmdOptSet :: Opt -> Idris Bool-cmdOptSet x = do i <- get- return $ x `elem` opt_cmdline (idris_options i)+cmdOptType :: Opt -> Idris Bool+cmdOptType x = do i <- get+ return $ x `elem` opt_cmdline (idris_options i) iLOG :: String -> Idris () iLOG = logLvl 1@@ -359,18 +379,18 @@ inferTy = MN 0 "__Infer" inferCon = MN 0 "__infer" inferDecl = PDatadecl inferTy - PSet- [(inferCon, PPi impl (MN 0 "A") PSet (+ PType+ [("", inferCon, PPi impl (MN 0 "A") PType ( PPi expl (MN 0 "a") (PRef bi (MN 0 "A")) (PRef bi inferTy)), bi)] infTerm t = PApp bi (PRef bi inferCon) [pimp (MN 0 "A") Placeholder, pexp t]-infP = P (TCon 6 0) inferTy (Set (UVal 0))+infP = P (TCon 6 0) inferTy (TType (UVal 0)) getInferTerm, getInferType :: Term -> Term getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc getInferTerm (App (App _ _) tm) = tm-getInferTerm tm = error ("getInferTerm " ++ show tm)+getInferTerm tm = tm -- error ("getInferTerm " ++ show tm) getInferType (Bind n b sc) = Bind n b $ getInferType sc getInferType (App (App _ ty) _) = ty@@ -383,17 +403,17 @@ unitTy = MN 0 "__Unit" unitCon = MN 0 "__II"-unitDecl = PDatadecl unitTy PSet- [(unitCon, PRef bi unitTy, bi)]+unitDecl = PDatadecl unitTy PType+ [("", unitCon, PRef bi unitTy, bi)] falseTy = MN 0 "__False"-falseDecl = PDatadecl falseTy PSet []+falseDecl = PDatadecl falseTy PType [] pairTy = MN 0 "__Pair" pairCon = MN 0 "__MkPair"-pairDecl = PDatadecl pairTy (piBind [(n "A", PSet), (n "B", PSet)] PSet)- [(pairCon, PPi impl (n "A") PSet (- PPi impl (n "B") PSet (+pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)+ [("", pairCon, PPi impl (n "A") PType (+ PPi impl (n "B") PType ( PPi expl (n "a") (PRef bi (n "A")) ( PPi expl (n "b") (PRef bi (n "B")) (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),@@ -402,10 +422,10 @@ eqTy = UN "=" eqCon = UN "refl"-eqDecl = PDatadecl eqTy (piBind [(n "a", PSet), (n "b", PSet),+eqDecl = PDatadecl eqTy (piBind [(n "a", PType), (n "b", PType), (n "x", PRef bi (n "a")), (n "y", PRef bi (n "b"))]- PSet)- [(eqCon, PPi impl (n "a") PSet (+ PType)+ [("", eqCon, PPi impl (n "a") PType ( PPi impl (n "x") (PRef bi (n "a")) (PApp bi (PRef bi eqTy) [pimp (n "a") Placeholder, pimp (n "b") Placeholder,@@ -426,8 +446,11 @@ -- Dealing with parameters -expandParams :: (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PTerm -> PTerm-expandParams dec ps ns tm = en tm+expandParams :: (Name -> Name) -> [(Name, PTerm)] -> + [Name] -> -- all names+ [Name] -> -- names with no declaration+ PTerm -> PTerm+expandParams dec ps ns infs tm = en tm where -- if we shadow a name (say in a lambda binding) that is used in a call to -- a lifted function, we need access to both names - once in the scope of the@@ -466,12 +489,22 @@ en (PQuote (Var n)) | n `nselem` ns = PQuote (Var (dec n))+ en (PApp fc (PInferRef fc' n) as)+ | n `nselem` ns = PApp fc (PInferRef fc' (dec n)) + (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) en (PApp fc (PRef fc' n) as)+ | n `elem` infs = PApp fc (PInferRef fc' (dec n)) + (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) | n `nselem` ns = PApp fc (PRef fc' (dec n)) (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as)) en (PRef fc n)+ | n `elem` infs = PApp fc (PInferRef fc (dec n)) + (map (pexp . (PRef fc)) (map fst ps)) | n `nselem` ns = PApp fc (PRef fc (dec n)) (map (pexp . (PRef fc)) (map fst ps))+ en (PInferRef fc n)+ | n `nselem` ns = PApp fc (PInferRef fc (dec n)) + (map (pexp . (PRef fc)) (map fst ps)) en (PApp fc f as) = PApp fc (en f) (map (fmap en) as) en (PCase fc c os) = PCase fc (en c) (map (pmap en) os) en t = t@@ -482,63 +515,81 @@ nseq x y = nsroot x == nsroot y -expandParamsD :: IState -> +expandParamsD :: Bool -> -- True = RHS only+ IState -> (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl-expandParamsD ist dec ps ns (PTy syn fc o n ty) - = if n `elem` ns- then PTy syn fc o (dec n) (piBind ps (expandParams dec ps ns ty))- else PTy syn fc o n (expandParams dec ps ns ty)-expandParamsD ist dec ps ns (PClauses fc opts n cs)+expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty) + = if n `elem` ns && (not rhsonly)+ then -- trace (show (n, expandParams dec ps ns ty)) $+ PTy doc syn fc o (dec n) (piBind ps (expandParams dec ps ns [] ty))+ else --trace (show (n, expandParams dec ps ns ty)) $ + PTy doc syn fc o n (expandParams dec ps ns [] ty)+expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty) + = if n `elem` ns && (not rhsonly)+ then -- trace (show (n, expandParams dec ps ns ty)) $+ PPostulate doc syn fc o (dec n) (piBind ps + (expandParams dec ps ns [] ty))+ else --trace (show (n, expandParams dec ps ns ty)) $ + PPostulate doc syn fc o n (expandParams dec ps ns [] ty)+expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs) = let n' = if n `elem` ns then dec n else n in PClauses fc opts n' (map expandParamsC cs) where expandParamsC (PClause fc n lhs ws rhs ds) = let -- ps' = updateps True (namesIn ist rhs) (zip ps [0..]) ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])+ lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs) n' = if n `elem` ns then dec n else n in- PClause fc n' (expandParams dec ps'' ns lhs)- (map (expandParams dec ps'' ns) ws)- (expandParams dec ps'' ns rhs)- (map (expandParamsD ist dec ps'' ns) ds)+ PClause fc n' lhs'+ (map (expandParams dec ps'' ns []) ws)+ (expandParams dec ps'' ns [] rhs)+ (map (expandParamsD True ist dec ps'' ns) ds) expandParamsC (PWith fc n lhs ws wval ds) = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..]) ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])+ lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs) n' = if n `elem` ns then dec n else n in- PWith fc n' (expandParams dec ps'' ns lhs)- (map (expandParams dec ps'' ns) ws)- (expandParams dec ps'' ns wval)- (map (expandParamsD ist dec ps'' ns) ds)+ PWith fc n' lhs'+ (map (expandParams dec ps'' ns []) ws)+ (expandParams dec ps'' ns [] wval)+ (map (expandParamsD rhsonly ist dec ps'' ns) ds) updateps yn nm [] = [] updateps yn nm (((a, t), i):as) | (a `elem` nm) == yn = (a, t) : updateps yn nm as | otherwise = (MN i (show n ++ "_u"), t) : updateps yn nm as-expandParamsD ist dec ps ns (PData syn fc co pd) = PData syn fc co (expandPData pd)+expandParamsD rhs ist dec ps ns (PData doc syn fc co pd) + = PData doc syn fc co (expandPData pd) where -- just do the type decl, leave constructors alone (parameters will be -- added implicitly) expandPData (PDatadecl n ty cons) = if n `elem` ns- then PDatadecl (dec n) (piBind ps (expandParams dec ps ns ty)) (map econ cons)- else PDatadecl n (expandParams dec ps ns ty) (map econ cons)- econ (n, t, fc) = (dec n, piBindp expl ps (expandParams dec ps ns t), fc)-expandParamsD ist dec ps ns (PParams f params pds)- = PParams f (map (mapsnd (expandParams dec ps ns)) params) - (map (expandParamsD ist dec ps ns) pds) -expandParamsD ist dec ps ns (PClass info f cs n params decls)- = PClass info f - (map (expandParams dec ps ns) cs)+ then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty)) + (map econ cons)+ else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)+ econ (doc, n, t, fc) + = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc)+expandParamsD rhs ist dec ps ns (PParams f params pds)+ = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params) + (map (expandParamsD True ist dec ps ns) pds)+-- (map (expandParamsD ist dec ps ns) pds) +expandParamsD rhs ist dec ps ns (PMutual f pds)+ = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)+expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls)+ = PClass doc info f + (map (expandParams dec ps ns []) cs) n- (map (mapsnd (expandParams dec ps ns)) params)- (map (expandParamsD ist dec ps ns) decls)-expandParamsD ist dec ps ns (PInstance info f cs n params ty cn decls)+ (map (mapsnd (expandParams dec ps ns [])) params)+ (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 (expandParams dec ps ns []) cs) n- (map (expandParams dec ps ns) params)- (expandParams dec ps ns ty)+ (map (expandParams dec ps ns []) params)+ (expandParams dec ps ns [] ty) cn- (map (expandParamsD ist dec ps ns) decls)-expandParamsD ist dec ps ns d = d+ (map (expandParamsD rhs ist dec ps ns) decls)+expandParamsD rhs ist dec ps ns d = d mapsnd f (x, t) = (x, f t) @@ -549,13 +600,13 @@ -- * finally, everything else (3) getPriority :: IState -> PTerm -> Int-getPriority i tm = pri tm +getPriority i tm = 1 -- pri tm where pri (PRef _ n) = case lookupP Nothing n (tt_ctxt i) of ((P (DCon _ _) _ _):_) -> 1 ((P (TCon _ _) _ _):_) -> 1- ((P Ref _ _):_) -> 4+ ((P Ref _ _):_) -> 1 [] -> 0 -- must be locally bound, if it's not an error... pri (PPi _ _ x y) = max 5 (max (pri x) (pri y)) pri (PTrue _) = 0@@ -638,34 +689,34 @@ = 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 _ doc) n ty sc) = do let isn = nub (namesIn uvars ist ty) `dropAll` [n] (decls , ns) <- get- put (PImp (getPriority ist ty) l n ty : decls, + put (PImp (getPriority ist ty) l n ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc- imps top env (PPi (Exp l _) n ty sc) + imps top env (PPi (Exp l _ doc) n ty sc) = do let isn = nub (namesIn uvars ist ty ++ case sc of (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types- put (PExp (getPriority ist ty) l ty : decls, + put (PExp (getPriority ist ty) l ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc- imps top env (PPi (Constraint l _) n ty sc)+ imps top env (PPi (Constraint l _ doc) n ty sc) = do let isn = nub (namesIn uvars ist ty ++ case sc of (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types- put (PConstraint 10 l ty : decls, + put (PConstraint 10 l ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc- imps top env (PPi (TacImp l _ scr) n ty sc)+ imps top env (PPi (TacImp l _ scr doc) n ty sc) = do let isn = nub (namesIn uvars ist ty ++ case sc of (PRef _ x) -> namesIn uvars ist sc `dropAll` [n] _ -> []) (decls, ns) <- get -- ignore decls in HO types- put (PTacImplicit 10 l n scr ty : decls, + put (PTacImplicit 10 l n scr ty doc : decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls))))) imps True (n:env) sc imps top env (PEq _ l r)@@ -700,32 +751,34 @@ pibind using [] sc = sc pibind using (n:ns) sc = case lookup n using of- Just ty -> PPi (Imp False Dynamic) n ty (pibind using ns sc)- Nothing -> if (implicitable n)- then PPi (Imp False Dynamic) n Placeholder + Just ty -> PPi (Imp False Dynamic "") n ty (pibind using ns sc)+ Nothing -> PPi (Imp False Dynamic "") n Placeholder (pibind using ns sc)- else pibind using ns sc -- Add implicit arguments in function calls addImplPat :: IState -> PTerm -> PTerm-addImplPat = addImpl' True []+addImplPat = addImpl' True [] [] addImplBound :: IState -> [Name] -> PTerm -> PTerm-addImplBound ist ns = addImpl' False ns ist+addImplBound ist ns = addImpl' False ns [] ist +addImplBoundInf :: IState -> [Name] -> [Name] -> PTerm -> PTerm+addImplBoundInf ist ns inf = addImpl' False ns inf ist+ addImpl :: IState -> PTerm -> PTerm-addImpl = addImpl' False []+addImpl = addImpl' False [] [] -- TODO: in patterns, don't add implicits to function names guarded by constructors -- and *not* inside a PHidden -addImpl' :: Bool -> [Name] -> IState -> PTerm -> PTerm-addImpl' inpat env ist ptm = ai env ptm+addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm+addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm where ai env (PRef fc f) - | not (f `elem` env) = handleErr $ aiFn inpat inpat ist fc f []+ | f `elem` infns = PInferRef fc f+ | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f [] ai env (PHidden (PRef fc f))- | not (f `elem` env) = handleErr $ aiFn inpat False ist fc f []+ | not (f `elem` map fst env) = handleErr $ aiFn inpat False ist fc f [] ai env (PEq fc l r) = let l' = ai env l r' = ai env r in PEq fc l' r'@@ -741,10 +794,18 @@ PDPair fc l' t' r' ai env (PAlternative a as) = let as' = map (ai env) as in PAlternative a as'- ai env (PApp fc (PRef _ f) as) - | not (f `elem` env)+ ai env (PApp fc (PInferRef _ f) as) + = let as' = map (fmap (ai env)) as in+ PApp fc (PInferRef fc f) as' + ai env (PApp fc ftm@(PRef _ f) as) + | f `elem` infns = ai env (PApp fc (PInferRef fc f) as)+ | not (f `elem` map fst env) = let as' = map (fmap (ai env)) as in handleErr $ aiFn inpat False ist fc f as'+ | Just (Just ty) <- lookup f env+ = let as' = map (fmap (ai env)) as + arity = getPArity ty in+ mkPApp fc arity ftm as' ai env (PApp fc f as) = let f' = ai env f as' = map (fmap (ai env)) as in mkPApp fc 1 f' as'@@ -752,15 +813,15 @@ os' = map (pmap (ai env)) os in PCase fc c' os' ai env (PLam n ty sc) = let ty' = ai env ty- sc' = ai (n:env) sc in+ sc' = ai ((n, Just ty):env) sc in PLam n ty' sc' ai env (PLet n ty val sc) = let ty' = ai env ty val' = ai env val- sc' = ai (n:env) sc in+ sc' = ai ((n, Just ty):env) sc in PLet n ty' val' sc' ai env (PPi p n ty sc) = let ty' = ai env ty- sc' = ai (n:env) sc in+ sc' = ai ((n, Just ty):env) sc in PPi p n ty' sc' ai env (PHidden tm) = PHidden (ai env tm) ai env (PProof ts) = PProof (map (fmap (ai env)) ts)@@ -783,7 +844,7 @@ || any constructor alts || any allImp ialts) then aiFn inpat False ist fc f [] -- use it as a constructor else Right $ PPatvar fc f- where imp (PExp _ _ _) = False+ where imp (PExp _ _ _ _) = False imp _ = True allImp [] = False allImp xs = all imp xs@@ -808,29 +869,29 @@ (insertImpl ns as)) alts where insertImpl :: [PArg] -> [PArg] -> [PArg]- insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) =- PExp p l tm : insertImpl ps given- insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) =- PConstraint p l tm : insertImpl ps given- insertImpl (PConstraint p l ty : ps) given =- PConstraint p l (PResolveTC fc) : insertImpl ps given- insertImpl (PImp p l n ty : ps) given =+ insertImpl (PExp p l ty _ : ps) (PExp _ _ tm d : given) =+ PExp p l tm d : insertImpl ps given+ insertImpl (PConstraint p l ty _ : ps) (PConstraint _ _ tm d : given) =+ PConstraint p l tm d : insertImpl ps given+ insertImpl (PConstraint p l ty d : ps) given =+ PConstraint p l (PResolveTC fc) d : insertImpl ps given+ insertImpl (PImp p l n ty d : ps) given = case find n given [] of- Just (tm, given') -> PImp p l n tm : insertImpl ps given'- Nothing -> PImp p l n Placeholder : insertImpl ps given- insertImpl (PTacImplicit p l n sc ty : ps) given =+ Just (tm, given') -> PImp p l n tm "" : insertImpl ps given'+ Nothing -> PImp p l n Placeholder "" : insertImpl ps given+ insertImpl (PTacImplicit p l n sc ty d : ps) given = case find n given [] of- Just (tm, given') -> PTacImplicit p l n sc tm : insertImpl ps given'+ Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given' Nothing -> if inpat - then PTacImplicit p l n sc Placeholder : insertImpl ps given- else PTacImplicit p l n sc sc : insertImpl ps given+ then PTacImplicit p l n sc Placeholder "" : insertImpl ps given+ else PTacImplicit p l n sc sc "" : insertImpl ps given insertImpl expected [] = [] insertImpl _ given = given find n [] acc = Nothing- find n (PImp _ _ n' t : gs) acc + find n (PImp _ _ n' t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs)- find n (PTacImplicit _ _ n' _ t : gs) acc + find n (PTacImplicit _ _ n' _ t _ : gs) acc | n == n' = Just (t, reverse acc ++ gs) find n (g : gs) acc = find n gs (g : acc) @@ -878,13 +939,13 @@ dumpDecls (d:ds) = dumpDecl d ++ "\n" ++ dumpDecls ds dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops -dumpDecl (PTy _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp True t+dumpDecl (PTy _ _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp True t dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs)-dumpDecl (PData _ _ _ d) = showDImp True d+dumpDecl (PData _ _ _ _ d) = showDImp True d dumpDecl (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ dumpDecls ps ++ "}\n" dumpDecl (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ dumpDecls ps ++ "}\n" dumpDecl (PSyntax _ syn) = "syntax " ++ show syn-dumpDecl (PClass _ _ cs n ps ds) +dumpDecl (PClass _ _ _ cs n ps ds) = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ dumpDecls ds dumpDecl (PInstance _ _ cs n _ t _ ds) = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ dumpDecls ds@@ -932,7 +993,11 @@ -- | otherwise = Nothing match (PRef f n) (PApp _ x []) = match (PRef f n) x match (PApp _ x []) (PRef f n) = match x (PRef f n)- match (PRef _ n) (PRef _ n') | n == n' = return []+ match (PRef _ n) tm@(PRef _ n')+ | n == n' && not names && + (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)+ = return [(n, tm)]+ | n == n' = return [] match (PRef _ n) tm | not names && (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder) = return [(n, tm)]@@ -961,6 +1026,7 @@ _ -> LeftErr (a, b) match (PCase _ _ _) _ = return [] -- lifted out match (PMetavar _) _ = return [] -- modified+ match (PInferRef _ _) _ = return [] -- modified match (PQuote _) _ = return [] match (PProof _) _ = return [] match (PTactics _) _ = return []@@ -996,24 +1062,36 @@ checkRpts (LeftErr x) = Left x substMatches :: [(Name, PTerm)] -> PTerm -> PTerm-substMatches [] t = t-substMatches ((n,tm):ns) t = substMatch n tm (substMatches ns t)+substMatches ms = substMatchesShadow ms [] +substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm+substMatchesShadow [] shs t = t+substMatchesShadow ((n,tm):ns) shs t + = substMatchShadow n shs tm (substMatchesShadow ns shs t)+ substMatch :: Name -> PTerm -> PTerm -> PTerm-substMatch n tm t = sm t where- sm (PRef _ n') | n == n' = tm- sm (PLam x t sc) = PLam x (sm t) (sm sc)- sm (PPi p x t sc) = PPi p x (sm t) (sm sc)- sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)- sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)- sm (PEq f x y) = PEq f (sm x) (sm y)- sm (PTyped x y) = PTyped (sm x) (sm y)- sm (PPair f x y) = PPair f (sm x) (sm y)- sm (PDPair f x t y) = PDPair f (sm x) (sm t) (sm y)- sm (PAlternative a as) = PAlternative a (map sm as)- sm (PHidden x) = PHidden (sm x)- sm x = x+substMatch n = substMatchShadow n [] +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 (PPi p x t sc) + | x `elem` xs + = let x' = nextName x in+ PPi p x' (sm (x':xs) (substMatch x (PRef (FC "" 0) x') t)) + (sm (x':xs) (substMatch x (PRef (FC "" 0) x') sc))+ | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)+ sm xs (PApp f x as) = PApp f (sm xs x) (map (fmap (sm xs)) as)+ sm xs (PCase f x as) = PCase f (sm xs x) (map (pmap (sm xs)) as)+ sm xs (PEq f x y) = PEq f (sm xs x) (sm xs y)+ sm xs (PTyped x y) = PTyped (sm xs x) (sm xs y)+ sm xs (PPair f x y) = PPair f (sm xs x) (sm xs y)+ sm xs (PDPair f x t y) = PDPair f (sm xs x) (sm xs t) (sm xs y)+ sm xs (PAlternative a as) = PAlternative a (map (sm xs) as)+ sm xs (PHidden x) = PHidden (sm xs x)+ sm xs x = x+ shadow :: Name -> Name -> PTerm -> PTerm shadow n n' t = sm t where sm (PRef fc x) | n == x = PRef fc n'@@ -1028,4 +1106,5 @@ sm (PAlternative a as) = PAlternative a (map sm as) sm (PHidden x) = PHidden (sm x) sm x = x+
src/Idris/AbsSyntaxTree.hs view
@@ -8,6 +8,7 @@ import Core.Elaborate hiding (Tactic(..)) import Core.Typecheck import IRTS.Lang+import IRTS.CodegenCommon import Util.Pretty import Paths_idris@@ -30,13 +31,15 @@ opt_errContext :: Bool, opt_repl :: Bool, opt_verbose :: Bool,+ opt_target :: Target,+ opt_outputTy :: OutputType, opt_ibcsubdir :: FilePath, opt_importdirs :: [FilePath], opt_cmdline :: [Opt] -- remember whole command line } deriving (Show, Eq) -defaultOpts = IOption 0 False False True False False True True "" [] []+defaultOpts = IOption 0 False False True False False True True ViaC Executable "" [] [] -- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e -- without typechecking).@@ -57,6 +60,7 @@ idris_flags :: Ctxt [FnOpt], idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos idris_calledgraph :: Ctxt [Name],+ idris_docstrings :: Ctxt String, idris_totcheck :: [(FC, Name)], idris_log :: String, idris_options :: IOption,@@ -120,12 +124,13 @@ | IBCTotal Name Totality | IBCFlags Name [FnOpt] | IBCCG Name+ | IBCDoc Name | IBCDef Name -- i.e. main context deriving Show idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext emptyContext - emptyContext emptyContext emptyContext+ emptyContext emptyContext emptyContext emptyContext [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] Nothing Nothing [] [] [] Hidden False [] Nothing @@ -135,12 +140,14 @@ -- Commands in the REPL -data Target = ViaC | ViaJava+data Target = ViaC | ViaJava | Bytecode | ToJavaScript+ deriving (Show, Eq) data Command = Quit | Help | Eval PTerm | Check PTerm+ | DocStr Name | TotCheck Name | Reload | Load FilePath @@ -199,13 +206,13 @@ | WarnOnly | Pkg String | BCAsm String- | DumpC String | DumpDefun String | DumpCases String | FOVM String+ | UseTarget Target+ | OutputTy OutputType deriving (Show, Eq) - -- Parsed declarations data Fixity = Infixl { prec :: Int } @@ -224,7 +231,11 @@ show (PrefixN i) = "prefix " ++ show i data FixDecl = Fix Fixity String - deriving (Show, Eq)+ deriving Eq++instance Show FixDecl where+ show (Fix f s) = show f ++ " " ++ s+ {-! deriving instance Binary FixDecl !-}@@ -241,24 +252,28 @@ -- Mark bindings with their explicitness, and laziness data Plicity = Imp { plazy :: Bool,- pstatic :: Static }+ pstatic :: Static,+ pdocstr :: String } | Exp { plazy :: Bool,- pstatic :: Static }+ pstatic :: Static,+ pdocstr :: String } | Constraint { plazy :: Bool,- pstatic :: Static }+ pstatic :: Static,+ pdocstr :: String } | TacImp { plazy :: Bool, pstatic :: Static,- pscript :: PTerm }+ pscript :: PTerm,+ pdocstr :: String } deriving (Show, Eq) {-! deriving instance Binary Plicity !-} -impl = Imp False Dynamic-expl = Exp False Dynamic-constraint = Constraint False Dynamic-tacimpl = TacImp False Dynamic+impl = Imp False Dynamic ""+expl = Exp False Dynamic ""+constraint = Constraint False Dynamic ""+tacimpl t = TacImp False Dynamic t "" data FnOpt = Inlinable | TotalFn | PartialFn | Coinductive | AssertTotal | TCGen@@ -274,31 +289,33 @@ inlinable :: FnOpts -> Bool inlinable = elem Inlinable -data PDecl' t = PFix FC Fixity [String] -- fixity declaration- | PTy SyntaxInfo FC FnOpts Name t -- type declaration- | PClauses FC FnOpts Name [PClause' t] -- pattern clause- | PCAF FC Name t -- top level constant- | PData SyntaxInfo FC Bool -- codata- (PData' t) -- data declaration- | PParams FC [(Name, t)] [PDecl' t] -- params block- | PNamespace String [PDecl' t] -- new namespace- | PRecord SyntaxInfo FC Name t Name t -- record declaration- | PClass SyntaxInfo FC - [t] -- constraints- Name- [(Name, t)] -- parameters- [PDecl' t] -- declarations- | PInstance SyntaxInfo FC [t] -- constraints- Name -- class- [t] -- parameters- t -- full instance type- (Maybe Name) -- explicit name- [PDecl' t]- | PDSL Name (DSL' t)- | PSyntax FC Syntax- | PMutual FC [PDecl' t]- | PDirective (Idris ())- deriving Functor+data PDecl' t + = PFix FC Fixity [String] -- fixity declaration+ | PTy String SyntaxInfo FC FnOpts Name t -- type declaration+ | PPostulate String SyntaxInfo FC FnOpts Name t+ | PClauses FC FnOpts Name [PClause' t] -- pattern clause+ | PCAF FC Name t -- top level constant+ | PData String SyntaxInfo FC Bool -- codata+ (PData' t) -- data declaration+ | PParams FC [(Name, t)] [PDecl' t] -- params block+ | PNamespace String [PDecl' t] -- new namespace+ | PRecord String SyntaxInfo FC Name t String Name t -- record declaration+ | PClass String SyntaxInfo FC + [t] -- constraints+ Name+ [(Name, t)] -- parameters+ [PDecl' t] -- declarations+ | PInstance SyntaxInfo FC [t] -- constraints+ Name -- class+ [t] -- parameters+ t -- full instance type+ (Maybe Name) -- explicit name+ [PDecl' t]+ | PDSL Name (DSL' t)+ | PSyntax FC Syntax+ | PMutual FC [PDecl' t]+ | PDirective (Idris ())+ deriving Functor {-! deriving instance Binary PDecl' !-}@@ -314,7 +331,7 @@ data PData' t = PDatadecl { d_name :: Name, d_tcon :: t,- d_cons :: [(Name, t, FC)] }+ d_cons :: [(String, Name, t, FC)] } | PLaterdecl { d_name :: Name, d_tcon :: t } deriving Functor {-!@@ -332,21 +349,40 @@ declared :: PDecl -> [Name] declared (PFix _ _ _) = []-declared (PTy _ _ _ n t) = [n]+declared (PTy _ _ _ _ n t) = [n]+declared (PPostulate _ _ _ _ n t) = [n] declared (PClauses _ _ n _) = [] -- not a declaration-declared (PData _ _ _ (PDatadecl n _ ts)) = n : map fstt ts- where fstt (a, _, _) = a+declared (PRecord _ _ _ n _ _ c _) = [n, c]+declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+ where fstt (_, a, _, _) = a declared (PParams _ _ ds) = concatMap declared ds+declared (PMutual _ ds) = concatMap declared ds declared (PNamespace _ ds) = concatMap declared ds++-- get the names declared, not counting nested parameter blocks+tldeclared :: PDecl -> [Name]+tldeclared (PFix _ _ _) = []+tldeclared (PTy _ _ _ _ n t) = [n]+tldeclared (PPostulate _ _ _ _ n t) = [n]+tldeclared (PClauses _ _ n _) = [] -- not a declaration+tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]+tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+ where fstt (_, a, _, _) = a+tldeclared (PParams _ _ ds) = [] +tldeclared (PMutual _ ds) = concatMap tldeclared ds+tldeclared (PNamespace _ ds) = concatMap tldeclared ds -- declared (PImport _) = [] defined :: PDecl -> [Name] defined (PFix _ _ _) = []-defined (PTy _ _ _ n t) = []+defined (PTy _ _ _ _ n t) = []+defined (PPostulate _ _ _ _ n t) = [] defined (PClauses _ _ n _) = [n] -- not a declaration-defined (PData _ _ _ (PDatadecl n _ ts)) = n : map fstt ts- where fstt (a, _, _) = a+defined (PRecord _ _ _ n _ _ c _) = [n, c]+defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts+ where fstt (_, a, _, _) = a defined (PParams _ _ ds) = concatMap defined ds+defined (PMutual _ ds) = concatMap defined ds defined (PNamespace _ ds) = concatMap defined ds -- declared (PImport _) = [] @@ -375,6 +411,7 @@ data PTerm = PQuote Raw | PRef FC Name+ | PInferRef FC Name -- a name to be defined later | PPatvar FC Name | PLam Name PTerm PTerm | PPi Plicity Name PTerm PTerm@@ -391,7 +428,7 @@ | PDPair FC PTerm PTerm PTerm | PAlternative Bool [PTerm] -- True if only one may work | PHidden PTerm -- irrelevant or hidden pattern- | PSet+ | PType | PConstant Const | Placeholder | PDoBlock [PDo]@@ -427,13 +464,16 @@ data PTactic' t = Intro [Name] | Intros | Focus Name- | Refine Name [Bool] | Rewrite t | LetTac Name t+ | Refine Name [Bool] | Rewrite t + | LetTac Name t | LetTacTy Name t t | Exact t | Compute | Trivial | Solve | Attack | ProofState | ProofTerm | Undo | Try (PTactic' t) (PTactic' t) | TSeq (PTactic' t) (PTactic' t)+ | ReflectTac t -- see Language.Reflection module+ | GoalType String (PTactic' t) | Qed | Abandon deriving (Show, Eq, Functor) {-! @@ -486,31 +526,35 @@ -- variables, e.g. a before (interpTy a). data PArg' t = PImp { priority :: Int, - lazyarg :: Bool, pname :: Name, getTm :: t }+ lazyarg :: Bool, pname :: Name, getTm :: t,+ pargdoc :: String } | PExp { priority :: Int,- lazyarg :: Bool, getTm :: t }+ lazyarg :: Bool, getTm :: t,+ pargdoc :: String } | PConstraint { priority :: Int,- lazyarg :: Bool, getTm :: t }+ lazyarg :: Bool, getTm :: t,+ pargdoc :: String } | PTacImplicit { priority :: Int, lazyarg :: Bool, pname :: Name, getScript :: t,- getTm :: t }+ getTm :: t, + pargdoc :: String } deriving (Show, Eq, Functor) instance Sized a => Sized (PArg' a) where- size (PImp p l nm trm) = 1 + size nm + size trm- size (PExp p l trm) = 1 + size trm- size (PConstraint p l trm) = 1 + size trm- size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm+ size (PImp p l nm trm _) = 1 + size nm + size trm+ size (PExp p l trm _) = 1 + size trm+ size (PConstraint p l trm _) = 1 + size trm+ size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm {-! deriving instance Binary PArg' !-} -pimp = PImp 0 True-pexp = PExp 0 False-pconst = PConstraint 0 False-ptacimp = PTacImplicit 0 True+pimp n t = PImp 0 True n t ""+pexp t = PExp 0 False t ""+pconst t = PConstraint 0 False t ""+ptacimp n s t = PTacImplicit 0 True n s t "" type PArg = PArg' PTerm @@ -633,9 +677,10 @@ show d = showDImp False d showDeclImp _ (PFix _ f ops) = show f ++ " " ++ showSep ", " ops-showDeclImp t (PTy _ _ _ n ty) = show n ++ " : " ++ showImp t ty+showDeclImp t (PTy _ _ _ _ n ty) = show n ++ " : " ++ showImp t ty+showDeclImp t (PPostulate _ _ _ _ n ty) = show n ++ " : " ++ showImp t ty showDeclImp _ (PClauses _ _ n c) = showSep "\n" (map show c)-showDeclImp _ (PData _ _ _ d) = show d+showDeclImp _ (PData _ _ _ _ d) = show d showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++ showSep "\n" (map show ps) @@ -659,21 +704,21 @@ showDImp impl (PDatadecl n ty cons) = "data " ++ show n ++ " : " ++ showImp impl ty ++ " where\n\t" ++ showSep "\n\t| " - (map (\ (n, t, _) -> show n ++ " : " ++ showImp impl t) cons)+ (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp impl t) cons) getImps :: [PArg] -> [(Name, PTerm)] getImps [] = []-getImps (PImp _ _ n tm : xs) = (n, tm) : getImps xs+getImps (PImp _ _ n tm _ : xs) = (n, tm) : getImps xs getImps (_ : xs) = getImps xs getExps :: [PArg] -> [PTerm] getExps [] = []-getExps (PExp _ _ tm : xs) = tm : getExps xs+getExps (PExp _ _ tm _ : xs) = tm : getExps xs getExps (_ : xs) = getExps xs getConsts :: [PArg] -> [PTerm] getConsts [] = []-getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs+getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs getConsts (_ : xs) = getConsts xs getAll :: [PArg] -> [PTerm]@@ -711,7 +756,7 @@ else text "let" <+> pretty n <+> text "=" <+> prettySe 10 v <+> text "in" <+> prettySe 10 sc- prettySe p (PPi (Exp l s) n ty sc)+ prettySe p (PPi (Exp l s _) n ty sc) | n `elem` allNamesIn sc || impl = let open = if l then text "|" <> lparen else lparen in bracket p 2 $@@ -732,7 +777,7 @@ case s of Static -> text "[static]" _ -> empty- prettySe p (PPi (Imp l s) n ty sc)+ prettySe p (PPi (Imp l s _) n ty sc) | impl = let open = if l then text "|" <> lbrace else lbrace in bracket p 2 $@@ -748,13 +793,13 @@ case s of Static -> text $ "[static]" _ -> empty- prettySe p (PPi (Constraint _ _) n ty sc) =+ prettySe p (PPi (Constraint _ _ _) n ty sc) = bracket p 2 $ if size sc > breakingSize then prettySe 10 ty <+> text "=>" <+> prettySe 10 sc else prettySe 10 ty <+> text "=>" $+$ prettySe 10 sc- prettySe p (PPi (TacImp _ _ s) n ty sc) =+ prettySe p (PPi (TacImp _ _ s _) n ty sc) = bracket p 2 $ if size sc > breakingSize then lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 ty <>@@ -830,7 +875,7 @@ where prettyAs = foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10) as- prettySe p PSet = text "Set"+ prettySe p PType = text "Type" prettySe p (PConstant c) = pretty c -- XXX: add pretty for tactics prettySe p (PProof ts) =@@ -846,10 +891,10 @@ prettySe p _ = text "test" - prettyArgS (PImp _ _ n tm) = prettyArgSi (n, tm)- prettyArgS (PExp _ _ tm) = prettyArgSe tm- prettyArgS (PConstraint _ _ tm) = prettyArgSc tm- prettyArgS (PTacImplicit _ _ n _ tm) = prettyArgSti (n, tm)+ prettyArgS (PImp _ _ n tm _) = prettyArgSi (n, tm)+ prettyArgS (PExp _ _ tm _) = prettyArgSe tm+ prettyArgS (PConstraint _ _ tm _) = prettyArgSc tm+ prettyArgS (PTacImplicit _ _ n _ tm _) = prettyArgSti (n, tm) prettyArgSe arg = prettySe 0 arg prettyArgSi (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 val <> rbrace@@ -864,6 +909,7 @@ showImp impl tm = se 10 tm where se p (PQuote r) = "![" ++ show r ++ "]" se p (PPatvar fc n) = show n+ se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]" se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]" else showbasic n where showbasic n@(UN _) = show n@@ -874,10 +920,10 @@ ++ se 10 sc se p (PLet n ty v sc) = bracket p 2 $ "let " ++ show n ++ " = " ++ se 10 v ++ " in " ++ se 10 sc - se p (PPi (Exp l s) n ty sc)+ se p (PPi (Exp l s _) n ty sc) | n `elem` allNamesIn sc || impl = bracket p 2 $- if l then "|(" else "(" ++ + (if l then "|(" else "(") ++ show n ++ " : " ++ se 10 ty ++ ") " ++ st ++ "-> " ++ se 10 sc@@ -885,17 +931,17 @@ where st = case s of Static -> "[static] " _ -> ""- se p (PPi (Imp l s) n ty sc)- | impl = bracket p 2 $ if l then "|{" else "{" ++ + se p (PPi (Imp l s _) n ty sc)+ | impl = bracket p 2 $ (if l then "|{" else "{") ++ show n ++ " : " ++ se 10 ty ++ "} " ++ st ++ "-> " ++ se 10 sc | otherwise = se 10 sc where st = case s of Static -> "[static] " _ -> ""- se p (PPi (Constraint _ _) n ty sc)+ se p (PPi (Constraint _ _ _) n ty sc) = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc- se p (PPi (TacImp _ _ s) n ty sc)+ se p (PPi (TacImp _ _ s _) n ty sc) = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc se p (PApp _ (PRef _ f) []) | not impl = show f@@ -921,7 +967,7 @@ se p (PPair _ l r) = "(" ++ se 10 l ++ ", " ++ se 10 r ++ ")" se p (PDPair _ l t r) = "(" ++ se 10 l ++ " ** " ++ se 10 r ++ ")" se p (PAlternative a as) = "(|" ++ showSep " , " (map (se 10) as) ++ "|)"- se p PSet = "Set"+ se p PType = "Type" se p (PConstant c) = show c se p (PProof ts) = "proof { " ++ show ts ++ "}" se p (PTactics ts) = "tactics { " ++ show ts ++ "}"@@ -933,10 +979,10 @@ se p (PElabError s) = show s -- se p x = "Not implemented" - sArg (PImp _ _ n tm) = siArg (n, tm)- sArg (PExp _ _ tm) = seArg tm- sArg (PConstraint _ _ tm) = scArg tm- sArg (PTacImplicit _ _ n _ tm) = stiArg (n, tm)+ sArg (PImp _ _ n tm _) = siArg (n, tm)+ sArg (PExp _ _ tm _) = seArg tm+ sArg (PConstraint _ _ tm _) = scArg tm+ sArg (PTacImplicit _ _ n _ tm _) = stiArg (n, tm) seArg arg = " " ++ se 0 arg siArg (n, val) = " {" ++ show n ++ " = " ++ se 10 val ++ "}"@@ -965,7 +1011,7 @@ size (PDPair fs left ty right) = 1 + size left + size ty + size right size (PAlternative a alts) = 1 + size alts size (PHidden hidden) = size hidden- size PSet = 1+ size PType = 1 size (PConstant const) = 1 + size const size Placeholder = 1 size (PDoBlock dos) = 1 + size dos@@ -976,6 +1022,12 @@ size (PElabError err) = size err size PImpossible = 1 +getPArity :: PTerm -> Int+getPArity (PPi _ _ _ sc) = 1 + getPArity sc+getPArity _ = 0++-- Return all names, free or globally bound, in the given term.+ allNamesIn :: PTerm -> [Name] allNamesIn tm = nub $ ni [] tm where@@ -994,6 +1046,8 @@ ni env (PAlternative a ls) = concatMap (ni env) ls ni env _ = [] +-- Return names which are free in the given term.+ namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name] namesIn uvars ist tm = nub $ ni [] tm where@@ -1002,6 +1056,29 @@ = case lookupTy Nothing n (tt_ctxt ist) of [] -> [n] _ -> if n `elem` (map fst uvars) then [n] else []+ ni env (PApp _ 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 (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc+ ni env (PEq _ l r) = ni env l ++ ni env r+ ni env (PTyped l r) = ni env l ++ ni env r+ ni env (PPair _ l r) = ni env l ++ ni env r+ ni env (PDPair _ (PRef _ n) t r) = ni env t ++ ni (n:env) r+ ni env (PDPair _ l t r) = ni env l ++ ni env t ++ ni env r+ ni env (PAlternative a as) = concatMap (ni env) as+ ni env (PHidden tm) = ni env tm+ ni env _ = []++-- Return which of the given names are used in the given term.++usedNamesIn :: [Name] -> IState -> PTerm -> [Name]+usedNamesIn vars ist tm = nub $ ni [] tm + where+ ni env (PRef _ n) + | n `elem` vars && not (n `elem` env) + = case lookupTy Nothing n (tt_ctxt ist) of+ [] -> [n]+ _ -> [] ni env (PApp _ 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
src/Idris/Compiler.hs view
@@ -147,7 +147,7 @@ return (f' @@ a') epic' env (Constant c) = epic c epic' env Erased = return impossible- epic' env (Set _) = return impossible+ epic' env (TType _) = return impossible epicCon env t arity n args | length args == arity = buildApp env (con_ t) args
src/Idris/Coverage.hs view
@@ -34,7 +34,7 @@ mkPatTm :: PTerm -> Idris Term mkPatTm t = do i <- get- let timp = addImpl' True [] i t+ let timp = addImpl' True [] [] i t evalStateT (toTT timp) 0 where toTT (PRef _ n) = do i <- lift $ get@@ -338,7 +338,7 @@ t' <- case t of Unchecked -> case lookupDef Nothing n ctxt of- [CaseOp _ _ _ pats _ _ _ _] -> + [CaseOp _ _ _ _ pats _ _ _ _] -> do t' <- if AssertTotal `elem` opts then return $ Total [] else calcTotality path fc n pats@@ -360,7 +360,7 @@ case t' of Total _ -> return t' Productive -> return t'- e -> do w <- cmdOptSet WarnPartial+ e -> do w <- cmdOptType WarnPartial if TotalFn `elem` opts then totalityError t' else do when (w && not (PartialFn `elem` opts)) $ @@ -382,7 +382,8 @@ checkDeclTotality :: (FC, Name) -> Idris Totality checkDeclTotality (fc, n) = do logLvl 2 $ "Checking " ++ show n ++ " for totality"- buildSCG (fc, n)+-- buildSCG (fc, n)+-- logLvl 2 $ "Built SCG" checkTotality [] fc n -- Calculate the size change graph for this definition@@ -401,16 +402,19 @@ ist <- get case lookupCtxt Nothing n (idris_callgraph ist) of [cg] -> case lookupDef Nothing n (tt_ctxt ist) of- [CaseOp _ _ _ _ args sc _ _] -> + [CaseOp _ _ _ _ _ args sc _ _] -> do logLvl 5 $ "Building SCG for " ++ show n ++ " from\n" ++ show sc let newscg = buildSCG' ist sc args logLvl 5 $ show newscg addToCG n ( cg { scg = newscg } )+ [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"+ x -> error $ "buildSCG: " ++ show (n, x) buildSCG' :: IState -> SC -> [Name] -> [SCGEntry] -buildSCG' ist sc args = nub $ scg sc (zip args args) - (zip args (zip args (repeat Same)))+buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $+ nub $ scg sc (zip args args) + (zip args (zip args (repeat Same))) where scg :: SC -> [(Name, Name)] -> -- local var, originating top level var [(Name, (Name, SizeChange))] -> -- orig to new, and relationship@@ -437,7 +441,7 @@ map (getRel nty) (map (fst . unApply . getRetTy) args) where getRel ty (P _ n' _) | n' == ty = (n, Smaller)- getRel ty _ = (n, Unknown)+ getRel ty t = (n, Unknown) scgAlt x vars szs (ConCase n _ args sc) -- all args smaller than top variable of x in sc@@ -446,7 +450,7 @@ = let arel = argRels n szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel ++ szs- vars' = zip args (repeat tvar) ++ vars in+ vars' = nub (zip args (repeat tvar) ++ vars) in scg sc vars' szs' | otherwise = scg sc vars szs scgAlt x vars szs (ConstCase _ sc) = scg sc vars szs@@ -459,13 +463,13 @@ = let rest = concatMap (\x -> scgTerm x vars szs) args in case lookup fn vars of Just _ -> rest- Nothing -> (fn, map (mkChange szs) args) : rest + Nothing -> nub $ (fn, map (mkChange szs) args) : rest scgTerm (App f a) vars szs = scgTerm f vars szs ++ scgTerm a vars szs scgTerm (Bind n (Let t v) e) vars szs = scgTerm v vars szs ++ scgTerm e vars szs scgTerm (Bind n _ e) vars szs- = scgTerm e ((n, n) : vars) szs+ = scgTerm e (nub ((n, n) : vars)) szs scgTerm (P _ fn _) vars szs = case lookup fn vars of Just _ -> []@@ -505,6 +509,8 @@ let tot = map (checkMP ist (length (argsdef cg))) ms logLvl 3 $ "Paths for " ++ show n ++ " yield " ++ (show tot) return (noPartial tot)+ [] -> do logLvl 5 $ "No paths for " ++ show n+ return Unchecked type MultiPath = [SCGEntry] @@ -529,63 +535,76 @@ -- If any route along the multipath leads to infinite descent, we're fine. -- Try a route beginning with every argument. -- If we reach a point we've been to before, but with a smaller value,--- that means there is an infinitely descending path.+-- that means there is an infinitely descending path from that argument. checkMP :: IState -> Int -> MultiPath -> Totality checkMP ist i mp = if i > 0 then collapse (map (tryPath 0 [] mp) [0..i-1]) else tryPath 0 [] mp 0 where+ tryPath' d path mp arg + = let res = tryPath d path mp arg in+ trace (show mp ++ "\n" ++ show arg ++ " " ++ show res) res+ tryPath :: Int -> [(SCGEntry, Int)] -> MultiPath -> Int -> Totality tryPath desc path [] _ = Total []+-- tryPath desc path ((UN "believe_me", _) : _) arg+-- = Partial BelieveMe -- if we get to a constructor, it's fine as long as it's strictly positive tryPath desc path ((f, _) :es) arg | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist) = case lookupTotal f (tt_ctxt ist) of- [Total _] -> Total []+ [Total _] -> Unchecked -- okay so far [Partial _] -> Partial (Other [f]) x -> error (show x) | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist) = Total []--- tryPath desc path (e@(f, []) : es) arg--- | [Unchecked] <- lookupTotal f (tt_ctxt ist) =--- tryPath (-10000) ((e, desc) : path) es 0+ tryPath desc path (e@(f, []) : es) arg+ | e `elem` es = Partial (Mutual [f]) tryPath desc path (e@(f, nextargs) : es) arg | Just d <- lookup e path- = if (desc - d) > 0 - then Total []+ = if desc > 0 + then -- trace ("Descent " ++ show (desc - d) ++ " "+ -- ++ show (path, e)) $+ Total [] else Partial (Mutual (map (fst . fst) path ++ [f])) | [Unchecked] <- lookupTotal f (tt_ctxt ist) = let argspos = zip nextargs [0..] in- collapse' (Partial (Mutual (map (fst . fst) path ++ [f]))) $ - do (arg, pos) <- argspos- case arg of- Nothing -> -- don't know, but it's okay if the+ collapse' Unchecked $ + do (a, pos) <- argspos+ case a of+ Nothing -> -- don't know, but if the -- rest definitely terminates without- -- any cycles with route so far- map (tryPath (-10000) ((e, desc):path) es)- [0..length nextargs - 1]+ -- any cycles with route so far,+ -- then we might yet be total+ case collapse (map (tryPath (-10000) ((e, desc):path) es)+ [0..length nextargs - 1]) of+ Total _ -> return Unchecked+ x -> return x Just (nextarg, sc) ->- case sc of- Same -> return $ tryPath desc ((e, desc):path) - es- nextarg- Smaller -> return $ tryPath (desc+1) - ((e, desc):path) - es- nextarg- _ -> trace ("Shouldn't happen " ++ show e) $ - return (Partial Itself)- | [Total _] <- lookupTotal f (tt_ctxt ist) = Total []+ if nextarg == arg then+ case sc of+ Same -> return $ tryPath desc ((e, desc) : path)+ es pos+ Smaller -> return $ tryPath (desc+1) + ((e, desc):path) + es+ pos+ _ -> trace ("Shouldn't happen " ++ show e) $ + return (Partial Itself)+ else return Unchecked+ | [Total _] <- lookupTotal f (tt_ctxt ist) = Unchecked | [Partial _] <- lookupTotal f (tt_ctxt ist) = Partial (Other [f])- | otherwise = Total []+ | otherwise = Unchecked noPartial (Partial p : xs) = Partial p noPartial (_ : xs) = noPartial xs noPartial [] = Total [] -collapse xs = collapse' (Partial Itself) xs-collapse' def (Total r : xs) = Total r+collapse xs = collapse' Unchecked xs+collapse' def (Total r : xs) = Total r+collapse' def (Unchecked : xs) = collapse' def xs collapse' def (d : xs) = collapse' d xs+-- collapse' Unchecked [] = Total [] collapse' def [] = def
src/Idris/Delaborate.hs view
@@ -38,7 +38,7 @@ de env (Constant i) = PConstant i de env Erased = Placeholder de env Impossible = Placeholder- de env (Set i) = PSet + de env (TType i) = PType dens x | fullname = x dens ns@(NS n _) = case lookupCtxt Nothing n (idris_implicits ist) of@@ -66,10 +66,10 @@ = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args) | otherwise = PApp un (PRef un n) (map pexp args) - imp (PImp p l n _) arg = PImp p l n arg- imp (PExp p l _) arg = PExp p l arg- imp (PConstraint p l _) arg = PConstraint p l arg- imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg+ imp (PImp p l n _ d) arg = PImp p l n arg d+ imp (PExp p l _ d) arg = PExp p l arg d+ imp (PConstraint p l _ d) arg = PConstraint p l arg d+ imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d pshow :: IState -> Err -> String pshow i (Msg s) = s@@ -77,15 +77,18 @@ "\nThis is probably a bug, or a missing error message.\n" ++ "Please consider reporting at " ++ bugaddr pshow i (CantUnify _ x y e sc s) - = "Can't unify " ++ show (delab i x)- ++ " with " ++ show (delab i y) +++ = let imps = opt_showimp (idris_options i) in+ "Can't unify " ++ showImp imps (delab i x)+ ++ " with " ++ showImp imps (delab i y) ++ -- " (" ++ show x ++ " and " ++ show y ++ ") " ++ case e of Msg "" -> "" _ -> "\n\nSpecifically:\n\t" ++ pshow i e ++ if (opt_errContext (idris_options i)) then showSc i sc else "" pshow i (CantConvert x y env) - = "Can't unify " ++ show (delab i x) ++ " with " ++ show (delab i y) +++ = let imps = opt_showimp (idris_options i) in+ "Can't convert " ++ showImp imps (delab i x) ++ " with " + ++ showImp imps (delab i y) ++ if (opt_errContext (idris_options i)) then showSc i env else "" pshow i (InfiniteUnify x tm env) = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++ @@ -102,6 +105,9 @@ pshow i UniverseError = "Universe inconsistency" pshow i ProgramLineComment = "Program line next to comment" pshow i (Inaccessible n) = show n ++ " is not an accessible pattern variable"+pshow i (NonCollapsiblePostulate n) + = "The return type of postulate " ++ show n ++ " is not collapsible"+pshow i (AlreadyDefined n) = show n ++ " is already defined" pshow i (At f e) = show f ++ ":" ++ pshow i e showSc i [] = ""
+ src/Idris/Docs.hs view
@@ -0,0 +1,113 @@+module Idris.Docs where++import Idris.AbsSyntax+import Idris.AbsSyntaxTree+import Idris.Delaborate+import Core.TT+import Core.Evaluate++import Data.Maybe+import Data.List++-- TODO: Only include names with public/abstract accessibility++data FunDoc = Doc Name String + [(Name, PArg)] -- args+ PTerm -- function type+ (Maybe Fixity)++data Doc = FunDoc FunDoc+ | DataDoc FunDoc -- type constructor docs+ [FunDoc] -- data constructor docs+ | ClassDoc Name String -- class docs+ [FunDoc] -- method docs++showDoc "" = ""+showDoc x = " -- " ++ x ++instance Show FunDoc where+ show (Doc n doc args ty f)+ = show n ++ " : " ++ show ty ++ "\n" ++ showDoc doc ++ "\n" +++ maybe "" (\f -> show f ++ "\n\n") f +++ let argshow = mapMaybe showArg args in+ if not (null argshow)+ then "Arguments:\n\t" ++ showSep "\t" argshow+ else ""++ where showArg (n, arg@(PExp _ _ _ _))+ = Just $ showName n ++ show (getTm arg) ++ + showDoc (pargdoc arg) ++ "\n"+ showArg (n, arg@(PConstraint _ _ _ _))+ = Just $ "Class constraint " +++ show (getTm arg) ++ showDoc (pargdoc arg)+ ++ "\n"+ showArg (n, arg@(PImp _ _ _ _ doc))+ | not (null doc)+ = Just $ "(implicit) " +++ show n ++ " : " ++ show (getTm arg) + ++ showDoc (pargdoc arg) ++ "\n"+ showArg (n, _) = Nothing++ showName (MN _ _) = ""+ showName x = show x ++ " : "++instance Show Doc where++ show (FunDoc d) = show d+ show (DataDoc t args) = "Data type " ++ show t +++ "\nConstructors:\n\n" +++ showSep "\n" (map show args)+ show (ClassDoc n doc meths) + = "Type class " ++ show n ++ -- parameters?+ "\nMethods:\n\n" +++ showSep "\n" (map show meths)++getDocs :: Name -> Idris Doc+getDocs n + = do i <- getIState+ case lookupCtxt Nothing n (idris_classes i) of+ [ci] -> docClass n ci+ _ -> case lookupCtxt Nothing n (idris_datatypes i) of+ [ti] -> docData n ti+ _ -> do fd <- docFun n+ return (FunDoc fd)++docData :: Name -> TypeInfo -> Idris Doc+docData n ti + = do tdoc <- docFun n+ cdocs <- mapM docFun (con_names ti)+ return (DataDoc tdoc cdocs)++docClass :: Name -> ClassInfo -> Idris Doc+docClass n ci+ = do i <- getIState+ let docstr = case lookupCtxt Nothing n (idris_docstrings i) of+ [str] -> str+ _ -> ""+ mdocs <- mapM docFun (map fst (class_methods ci))+ return (ClassDoc n docstr mdocs)++docFun :: Name -> Idris FunDoc+docFun n+ = do i <- getIState+ let docstr = case lookupCtxt Nothing n (idris_docstrings i) of+ [str] -> str+ _ -> ""+ let ty = case lookupTy Nothing n (tt_ctxt i) of+ (t : _) -> t+ let argnames = map fst (getArgTys ty)+ let args = case lookupCtxt Nothing n (idris_implicits i) of+ [args] -> zip argnames args+ _ -> []+ let infixes = idris_infixes i+ let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes+ let f = case fixdecls of+ [] -> Nothing+ (Fix x _:_) -> Just x ++ return (Doc n docstr args (delab i ty) f)+ where funName :: Name -> String+ funName (UN n) = n+ funName (NS n _) = funName n++
src/Idris/ElabDecls.hs view
@@ -38,25 +38,29 @@ mapM (\(n, t) -> do (t', _) <- recheckC fc [] t return (n, t')) ns -elabType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm -> Idris ()-elabType info syn fc opts n ty' = {- let ty' = piBind (params info) ty_in +elabType :: ElabInfo -> SyntaxInfo -> String ->+ FC -> FnOpts -> Name -> PTerm -> Idris ()+elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in n = liftname info n_in in -} do checkUndefined fc n ctxt <- getContext i <- get+ logLvl 3 $ show n ++ " pre-type " ++ showImp True ty' ty' <- implicit syn n ty' let ty = addImpl i ty'- logLvl 3 $ show n ++ " pre-type " ++ showImp True ty' logLvl 2 $ show n ++ " type " ++ showImp True ty- ((tyT, defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) []+ ((tyT, defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n ty)) ds <- checkDef fc defer addDeferred ds mapM_ (elabCaseBlock info) is ctxt <- getContext+ logLvl 5 $ "Rechecking"+ logLvl 6 $ show tyT (cty, _) <- recheckC fc [] tyT addStatics n cty ty'- logLvl 2 $ "---> " ++ show cty+ logLvl 6 $ "Elaborated to " ++ showEnvDbg [] tyT+ logLvl 2 $ "Rechecked to " ++ show cty let nty = cty -- normalise ctxt [] cty -- if the return type is something coinductive, freeze the definition let nty' = normalise ctxt [] nty@@ -71,19 +75,45 @@ addIBC (IBCDef n) addDeferred ds setFlags n opts'+ addDocStr n doc+ addIBC (IBCDoc n) addIBC (IBCFlags n opts') when corec $ do setAccessibility n Frozen addIBC (IBCAccess n Frozen) -elabData :: ElabInfo -> SyntaxInfo -> FC -> Bool -> PData -> Idris ()-elabData info syn fc codata (PLaterdecl n t_in)- = do iLOG (show fc)+elabPostulate :: ElabInfo -> SyntaxInfo -> String ->+ FC -> FnOpts -> Name -> PTerm -> Idris ()+elabPostulate info syn doc fc opts n ty+ = do elabType info syn doc fc opts n ty+ -- make sure it's collapsible, so it is never needed at run time+ -- start by getting the elaborated type+ ctxt <- getContext+ fty <- case lookupTy Nothing n ctxt of+ [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!+ [ty] -> return ty+ ist <- get+ let (ap, _) = unApply (getRetTy fty)+ logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)+ let postOK = case ap of+ P _ tn _ -> case lookupCtxt Nothing tn+ (idris_optimisation ist) of+ [oi] -> collapsible oi+ _ -> False+ _ -> False+ when (not postOK)+ $ tclift $ tfail (At fc (NonCollapsiblePostulate n))+ -- remove it from the deferred definitions list+ solveDeferred n++elabData :: ElabInfo -> SyntaxInfo -> String -> FC -> Bool -> PData -> Idris ()+elabData info syn doc fc codata (PLaterdecl n t_in)+ = do iLOG (show (fc, doc)) checkUndefined fc n ctxt <- getContext i <- get t_in <- implicit syn n t_in let t = addImpl i t_in- ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) []+ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) def' <- checkDef fc defer addDeferred def'@@ -92,14 +122,14 @@ logLvl 2 $ "---> " ++ show cty updateContext (addTyDecl n cty) -- temporary, to check cons -elabData info syn fc codata (PDatadecl n t_in dcons)+elabData info syn doc fc codata (PDatadecl n t_in dcons) = do iLOG (show fc) undef <- isUndefined fc n ctxt <- getContext i <- get t_in <- implicit syn n t_in let t = addImpl i t_in- ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) []+ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) def' <- checkDef fc defer addDeferred def'@@ -115,14 +145,16 @@ (idris_datatypes i) }) addIBC (IBCDef n) addIBC (IBCData n)+ addDocStr n doc+ addIBC (IBCDoc n) collapseCons n cons updateContext (addDatatype (Data n ttag cty cons)) mapM_ (checkPositive n) cons -elabRecord :: ElabInfo -> SyntaxInfo -> FC -> Name -> - PTerm -> Name -> PTerm -> Idris ()-elabRecord info syn fc tyn ty cn cty- = do elabData info syn fc False (PDatadecl tyn ty [(cn, cty, fc)]) +elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name -> + PTerm -> String -> Name -> PTerm -> Idris ()+elabRecord info syn doc fc tyn ty cdoc cn cty+ = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)]) cty' <- implicit syn cn cty i <- get cty <- case lookupTy Nothing cn (tt_ctxt i) of@@ -145,7 +177,7 @@ where -- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in } - isNonImp (PExp _ _ _, a) = Just a+ isNonImp (PExp _ _ _ _, a) = Just a isNonImp _ = Nothing tryElabDecl info (fn, ty, val)@@ -157,15 +189,15 @@ show fn ++ " (" ++ show ty ++ ")" put i) - getImplB k (PPi (Imp l s) n Placeholder sc)+ getImplB k (PPi (Imp l s _) n Placeholder sc) = getImplB k sc- getImplB k (PPi (Imp l s) n ty sc)- = getImplB (\x -> k (PPi (Imp l s) n ty x)) sc+ getImplB k (PPi (Imp l s d) n ty sc)+ = getImplB (\x -> k (PPi (Imp l s d) n ty x)) sc getImplB k (PPi _ n ty sc) = getImplB k sc getImplB k _ = k - renameBs (PImp _ _ _ _ : ps) (PPi p n ty s)+ renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s) = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s)) renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s) renameBs _ t = t@@ -186,13 +218,13 @@ mkImp (MN i n) = MN i ("implicit_" ++ n) mkImp (NS n s) = NS (mkImp n) s - mkSet (UN n) = UN ("set_" ++ n)- mkSet (MN i n) = MN i ("set_" ++ n)- mkSet (NS n s) = NS (mkSet n) s+ mkType (UN n) = UN ("set_" ++ n)+ mkType (MN i n) = MN i ("set_" ++ n)+ mkType (NS n s) = NS (mkType n) s mkProj recty substs cimp ((pn_in, pty), pos) = do let pn = expandNS syn pn_in- let pfnTy = PTy defaultSyntax fc [] pn+ let pfnTy = PTy "" defaultSyntax fc [] pn (PPi expl rec recty (substMatches substs pty)) let pls = repeat Placeholder@@ -209,11 +241,11 @@ implicitise (pa, t) = pa { getTm = t } mkUpdate recty k num ((pn, pty), pos)- = do let setname = expandNS syn $ mkSet pn+ = do let setname = expandNS syn $ mkType pn let valname = MN 0 "updateval" let pt = k (PPi expl pn pty (PPi expl rec recty recty))- let pfnTy = PTy defaultSyntax fc [] setname pt+ let pfnTy = PTy "" defaultSyntax fc [] setname pt let pls = map (\x -> PRef fc (MN x "field")) [0..num-1] let lhsArgs = pls let rhsArgs = take pos pls ++ (PRef fc valname) :@@ -228,15 +260,16 @@ (map pexp rhsArgs)) [] return (pn, pfnTy, PClauses fc [] setname [pclause]) -elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> (Name, PTerm, FC) -> Idris (Name, Type)-elabCon info syn tn codata (n, t_in, fc)+elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool -> + (String, Name, PTerm, FC) -> Idris (Name, Type)+elabCon info syn tn codata (doc, n, t_in, fc) = do checkUndefined fc n ctxt <- getContext i <- get t_in <- implicit syn n (if codata then mkLazy t_in else t_in) let t = addImpl i t_in logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp True t- ((t', defer, is), log) <- tclift $ elaborate ctxt n (Set (UVal 0)) []+ ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) [] (erun fc (build i info False n t)) logLvl 2 $ "Rechecking " ++ show t' def' <- checkDef fc defer@@ -248,6 +281,8 @@ tyIs cty' logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty' addIBC (IBCDef n)+ addDocStr n doc+ addIBC (IBCDoc n) forceArgs n cty' return (n, cty') where@@ -263,119 +298,135 @@ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris () elabClauses info fc opts n_in cs = let n = liftname info n_in in do ctxt <- getContext- -- Check n actually exists- fty <- case lookupTy Nothing n ctxt of- [] -> -- TODO: turn into a CAF if there's no arguments- -- question: CAFs in where blocks?- tclift $ tfail $ (At fc (NoTypeDecl n))- [ty] -> return ty- pats_in <- mapM (elabClause info (TCGen `elem` opts)) cs- -- if the return type of 'ty' is collapsible, the optimised version should- -- just do nothing- ist <- get- let (ap, _) = unApply (getRetTy fty)- logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)- -- FIXME: Really ought to only do this for total functions!- let doNothing = case ap of- P _ tn _ -> case lookupCtxt Nothing tn- (idris_optimisation ist) of- [oi] -> collapsible oi- _ -> False- _ -> False- solveDeferred n- ist <- get- when doNothing $ - case lookupCtxt Nothing n (idris_optimisation ist) of- [oi] -> do let opts = addDef n (oi { collapsible = True }) - (idris_optimisation ist)- put (ist { idris_optimisation = opts })- _ -> do let opts = addDef n (Optimise True [] [])- (idris_optimisation ist)- put (ist { idris_optimisation = opts })- addIBC (IBCOpt n)- ist <- get- let pats = pats_in--- logLvl 3 (showSep "\n" (map (\ (l,r) -> --- show l ++ " = " ++ --- show r) pats))- let tcase = opt_typecase (idris_options ist)- let pdef = map debind $ map (simpl (tt_ctxt ist)) pats- - numArgs <- tclift $ sameLength pdef+ -- Check n actually exists, with no definition yet+ let tys = lookupTy Nothing n ctxt+ checkUndefined n ctxt+ unless (length tys > 1) $ do+ fty <- case tys of+ [] -> -- TODO: turn into a CAF if there's no arguments+ -- question: CAFs in where blocks?+ tclift $ tfail $ At fc (NoTypeDecl n)+ [ty] -> return ty+ pats_in <- mapM (elabClause info (TCGen `elem` opts)) + (zip [0..] cs)+ -- if the return type of 'ty' is collapsible, the optimised version should+ -- just do nothing+ ist <- get+ let (ap, _) = unApply (getRetTy fty)+ logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)+ -- FIXME: Really ought to only do this for total functions!+ let doNothing = case ap of+ P _ tn _ -> case lookupCtxt Nothing tn+ (idris_optimisation ist) of+ [oi] -> collapsible oi+ _ -> False+ _ -> False+ solveDeferred n+ ist <- get+ when doNothing $ + case lookupCtxt Nothing n (idris_optimisation ist) of+ [oi] -> do let opts = addDef n (oi { collapsible = True }) + (idris_optimisation ist)+ put (ist { idris_optimisation = opts })+ _ -> do let opts = addDef n (Optimise True [] [])+ (idris_optimisation ist)+ put (ist { idris_optimisation = opts })+ addIBC (IBCOpt n)+ ist <- get+ let pats = pats_in+ -- logLvl 3 (showSep "\n" (map (\ (l,r) -> + -- show l ++ " = " ++ + -- show r) pats))+ let tcase = opt_typecase (idris_options ist)+ let pdef = map debind $ map (simpl False (tt_ctxt ist)) pats+ + numArgs <- tclift $ sameLength pdef - optpats <- if doNothing - then return $ [Right (mkApp (P Bound n Erased)- (take numArgs (repeat Erased)), Erased)]- else stripCollapsed pats+ optpats <- if doNothing + then return $ [Right (mkApp (P Bound n Erased)+ (take numArgs (repeat Erased)), Erased)]+ else stripCollapsed pats - logLvl 5 $ "Patterns:\n" ++ show pats- logLvl 5 $ "Optimised patterns:\n" ++ show optpats+ logLvl 5 $ "Patterns:\n" ++ show pats - let optpdef = map debind $ map (simpl (tt_ctxt ist)) optpats- tree@(CaseDef scargs sc _) <- tclift $ - simpleCase tcase False CompileTime fc pdef- cov <- coverage- pmissing <-- if cov - then do missing <- genClauses fc n (map getLHS pdef) cs- -- missing <- genMissing n scargs sc - missing' <- filterM (checkPossible info fc True n) missing- logLvl 3 $ "Must be unreachable:\n" ++ - showSep "\n" (map (showImp True) missing') ++- "\nAgainst: " ++- showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))- return missing'- else return []- let pcover = null pmissing- pdef' <- applyOpts optpdef - ist <- get--- let wf = wellFounded ist n sc- let tot = if pcover || AssertTotal `elem` opts- then Unchecked -- finish checking later- else Partial NotCovering -- already know it's not total--- case lookupCtxt (namespace info) n (idris_flags ist) of --- [fs] -> if TotalFn `elem` fs --- then case tot of--- Total _ -> return ()--- t -> tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t)))--- else return ()--- _ -> return ()- case tree of- CaseDef _ _ [] -> return ()- CaseDef _ _ xs -> mapM_ (\x ->- iputStrLn $ show fc ++- ":warning - Unreachable case: " ++ - show (delab ist x)) xs- tree' <- tclift $ simpleCase tcase pcover RunTime fc pdef'- logLvl 3 (show tree)- logLvl 3 $ "Optimised: " ++ show tree'- ctxt <- getContext- ist <- get- put (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })- case lookupTy (namespace info) n ctxt of- [ty] -> do updateContext (addCasedef n (inlinable opts)- tcase pcover pats- pdef pdef' ty)- addIBC (IBCDef n)- setTotality n tot- totcheck (fc, n)- when (tot /= Unchecked) $ addIBC (IBCTotal n tot)- i <- get- case lookupDef Nothing n (tt_ctxt i) of- (CaseOp _ _ _ _ scargs sc scargs' sc' : _) ->- do let calls = findCalls sc' scargs'- let used = findUsedArgs sc' scargs'- -- let scg = buildSCG i sc scargs- -- add SCG later, when checking totality- let cg = CGInfo scargs' calls [] used []- logLvl 2 $ "Called names: " ++ show cg- addToCG n cg- addToCalledG n (nub (map fst calls)) -- plus names in type!- addIBC (IBCCG n)- _ -> return ()--- addIBC (IBCTotal n tot)- [] -> return ()+ let optpdef = map debind $ map (simpl True (tt_ctxt ist)) optpats+ tree@(CaseDef scargs sc _) <- tclift $ + simpleCase tcase False CompileTime fc pdef+ cov <- coverage+ pmissing <-+ if cov + then do missing <- genClauses fc n (map getLHS pdef) cs+ -- missing <- genMissing n scargs sc + missing' <- filterM (checkPossible info fc True n) missing+ logLvl 2 $ "Must be unreachable:\n" ++ + showSep "\n" (map (showImp True) missing') +++ "\nAgainst: " +++ showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))+ return missing'+ else return []+ let pcover = null pmissing+ logLvl 2 $ "Optimising patterns"+ pdef' <- applyOpts optpdef + logLvl 2 $ "Optimised patterns"+ logLvl 5 $ show pdef'+ ist <- get+ -- let wf = wellFounded ist n sc+ let tot = if pcover || AssertTotal `elem` opts+ then Unchecked -- finish checking later+ else Partial NotCovering -- already know it's not total+ -- case lookupCtxt (namespace info) n (idris_flags ist) of + -- [fs] -> if TotalFn `elem` fs + -- then case tot of+ -- Total _ -> return ()+ -- t -> tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t)))+ -- else return ()+ -- _ -> return ()+ case tree of+ CaseDef _ _ [] -> return ()+ CaseDef _ _ xs -> mapM_ (\x ->+ iputStrLn $ show fc +++ ":warning - Unreachable case: " ++ + show (delab ist x)) xs+ let knowncovering = (pcover && cov) || AssertTotal `elem` opts++ tree' <- tclift $ simpleCase tcase knowncovering RunTime fc pdef'+ logLvl 3 (show tree)+ logLvl 3 $ "Optimised: " ++ show tree'+ ctxt <- getContext+ ist <- get+ put (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })+ case lookupTy (namespace info) n ctxt of+ [ty] -> do updateContext (addCasedef n (inlinable opts)+ tcase knowncovering + (AssertTotal `elem` opts)+ pats+ pdef pdef' ty)+ addIBC (IBCDef n)+ setTotality n tot+ totcheck (fc, n)+ when (tot /= Unchecked) $ addIBC (IBCTotal n tot)+ i <- get+ case lookupDef Nothing n (tt_ctxt i) of+ (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->+ do let calls = findCalls sc' scargs'+ let used = findUsedArgs sc' scargs'+ -- let scg = buildSCG i sc scargs+ -- add SCG later, when checking totality+ let cg = CGInfo scargs' calls [] used []+ logLvl 2 $ "Called names: " ++ show cg+ addToCG n cg+ addToCalledG n (nub (map fst calls)) -- plus names in type!+ addIBC (IBCCG n)+ _ -> return ()+ -- addIBC (IBCTotal n tot)+ [] -> return ()+ return () where+ checkUndefined n ctxt = case lookupDef Nothing n ctxt of+ [] -> return ()+ [TyDecl _ _] -> return ()+ _ -> tclift $ tfail (At fc (AlreadyDefined n))+ debind (Right (x, y)) = let (vs, x') = depat [] x (_, y') = depat [] y in (vs, x', y')@@ -387,8 +438,10 @@ getLHS (_, l, _) = l - simpl ctxt (Right (x, y)) = Right (x, simplify ctxt [] y)- simpl ctxt t = t+ simpl rt ctxt (Right (x, y)) = Right (normalise ctxt [] x,+ simplify ctxt rt [] y)+-- simpl rt ctxt (Right (x, y)) = Right (x, y)+ simpl rt ctxt t = t sameLength ((_, x, _) : xs) = do l <- sameLength xs@@ -403,9 +456,18 @@ i <- get let tm = addImpl i tm_in logLvl 10 (showImp True tm)- ((tm', defer, is), _) <- tclift $ elaborate ctxt (MN 0 "val") infP []- (build i info aspat (MN 0 "val") (infTerm tm))+ -- try:+ -- * ordinary elaboration+ -- * elaboration as a Type+ -- * elaboration as a function a -> b+ + ((tm', defer, is), _) <- +-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) [] +-- (build i info aspat (MN 0 "val") tm))+ tclift (elaborate ctxt (MN 0 "val") infP []+ (build i info aspat (MN 0 "val") (infTerm tm))) logLvl 3 ("Value: " ++ show tm')+ recheckC (FC "(input)" 0) [] tm' let vtm = getInferTerm tm' logLvl 2 (show vtm) recheckC (FC "(input)" 0) [] vtm@@ -431,14 +493,15 @@ -- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b) Error _ -> return False -elabClause :: ElabInfo -> Bool -> PClause -> Idris (Either Term (Term, Term))-elabClause info tcgen (PClause fc fname lhs_in [] PImpossible [])+elabClause :: ElabInfo -> Bool -> (Int, PClause) -> + Idris (Either Term (Term, Term))+elabClause info tcgen (_, PClause fc fname lhs_in [] PImpossible []) = do b <- checkPossible info fc tcgen fname lhs_in case b of True -> fail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case" False -> do ptm <- mkPatTm lhs_in return (Left ptm)-elabClause info tcgen (PClause fc fname lhs_in withs rhs_in whereblock) +elabClause info tcgen (cnum, PClause fc fname lhs_in withs rhs_in whereblock) = do ctxt <- getContext -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings@@ -457,16 +520,23 @@ ist <- getIState windex <- getName let winfo = pinfo (pvars ist lhs_tm) whereblock windex- let decls = concatMap declared whereblock+ let decls = nub (concatMap declared whereblock)+ let defs = nub (decls ++ concatMap defined whereblock) let newargs = pvars ist lhs_tm- let wb = map (expandParamsD ist decorate newargs decls) whereblock- logLvl 5 $ "Where block: " ++ show wb- mapM_ (elabDecl' EAll info) wb+ let wb = map (expandParamsD False ist decorate newargs defs) whereblock+ + -- Split the where block into declarations with a type, and those+ -- without+ -- Elaborate those with a type *before* RHS, those without *after*+ let (wbefore, wafter) = sepBlocks wb++ logLvl 5 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter+ mapM_ (elabDecl' EAll info) wbefore -- Now build the RHS, using the type of the LHS as the goal. i <- get -- new implicits from where block- logLvl 5 (showImp True (expandParams decorate newargs decls rhs_in))- let rhs = addImplBound i (map fst newargs) - (expandParams decorate newargs decls rhs_in)+ logLvl 5 (showImp True (expandParams decorate newargs defs (defs \\ decls) rhs_in))+ let rhs = addImplBoundInf i (map fst newargs) (defs \\ decls)+ (expandParams decorate newargs defs (defs \\ decls) rhs_in) logLvl 2 $ "RHS: " ++ showImp True rhs ctxt <- getContext -- new context with where block added logLvl 5 "STARTING CHECK"@@ -483,19 +553,38 @@ when (not (null defer)) $ iLOG $ "DEFERRED " ++ show defer def' <- checkDef fc defer addDeferred def'++ -- Now the remaining deferred (i.e. no type declarations) clauses+ -- from the where block++ mapM_ (elabDecl' EAll info) wafter mapM_ (elabCaseBlock info) is+ ctxt <- getContext logLvl 5 $ "Rechecking" (crhs, crhsty) <- recheckC fc [] rhs' logLvl 6 $ " ==> " ++ show crhsty ++ " against " ++ show clhsty case converts ctxt [] clhsty crhsty of OK _ -> return ()- Error _ -> ierror (At fc (CantUnify False clhsty crhsty (Msg "") [] 0))+ Error e -> ierror (At fc (CantUnify False clhsty crhsty e [] 0)) i <- get checkInferred fc (delab' i crhs True) rhs return $ Right (clhs, crhs) where- decorate x = UN (show x ++ "#" ++ show fname)+ decorate (NS x ns) = NS (UN ('#':show x)) (ns ++ [show cnum, show fname])+ decorate x = NS (UN ('#':show x)) [show cnum, show fname]++ sepBlocks bs = sepBlocks' [] bs where+ sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)+ = let (bf, af) = sepBlocks' (n : ns) bs in+ (d : bf, af)+ sepBlocks' ns (d@(PClauses _ _ n _) : bs) + | not (n `elem` ns) = let (bf, af) = sepBlocks' ns bs in+ (bf, d : af)+ sepBlocks' ns (b : bs) = let (bf, af) = sepBlocks' ns bs in+ (b : bf, af)+ sepBlocks' ns [] = ([], [])+ pinfo ns ps i = let ds = concatMap declared ps newps = params info ++ ns@@ -509,15 +598,16 @@ -- _ -> MN i (show n)) . l } -elabClause info tcgen (PWith fc fname lhs_in withs wval_in withblock) +elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock) = do ctxt <- getContext -- Build the LHS as an "Infer", and pull out its type and -- pattern bindings i <- get let lhs = addImpl i lhs_in logLvl 5 ("LHS: " ++ showImp True lhs)- ((lhs', dlhs, []), _) <- tclift $ elaborate ctxt (MN 0 "patLHS") infP []- (erun fc (buildTC i info True tcgen fname (infTerm lhs)))+ ((lhs', dlhs, []), _) <- + tclift $ elaborate ctxt (MN 0 "patLHS") infP []+ (erun fc (buildTC i info True tcgen fname (infTerm lhs))) let lhs_tm = orderPats (getInferTerm lhs') let lhs_ty = getInferType lhs' let ret_ty = getRetTy lhs_ty@@ -541,11 +631,27 @@ addDeferred def' mapM_ (elabCaseBlock info) is (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')- logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)+ let cwvaltyN = explicitNames cwvalty+ let cwvalN = explicitNames cwval+ logLvl 5 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)+ let pvars = map fst (getPBtys cwvalty)+ -- we need the unelaborated term to get the names it depends on+ -- rather than a de Bruijn index.+ let pdeps = usedNamesIn pvars i (delab i cwvalty)+ let (bargs_pre, bargs_post) = split pdeps bargs []+ logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++ + " depends on " ++ show pdeps ++ " from " ++ show pvars)+ logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post) windex <- getName -- build a type declaration for the new function:- -- (ps : Xs) -> (withval : cwvalty) -> ret_ty - let wtype = bindTyArgs Pi (bargs ++ [(MN 0 "warg", getRetTy cwvalty)]) ret_ty+ -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty + let wargval = getRetTy cwvalN+ let wargtype = getRetTy cwvaltyN+ logLvl 5 ("Abstract over " ++ show wargval)+ let wtype = bindTyArgs Pi (bargs_pre ++ + (MN 0 "warg", wargtype) : + map (abstract (MN 0 "warg") wargval wargtype) bargs_post) + (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty) logLvl 3 ("New function type " ++ show wtype) let wname = MN windex (show fname) let imps = getImps wtype -- add to implicits context@@ -557,14 +663,17 @@ -- in the subdecls, lhs becomes: -- fname pats | wpat [rest] -- ==> fname' ps wpat [rest], match pats against toplevel for ps- wb <- mapM (mkAuxC wname lhs (map fst bargs)) withblock- logLvl 5 ("with block " ++ show wb)+ wb <- mapM (mkAuxC wname lhs (map fst bargs_pre) (map fst bargs_post))+ withblock+ logLvl 3 ("with block " ++ show wb) mapM_ (elabDecl EAll info) wb -- rhs becomes: fname' ps wval- let rhs = PApp fc (PRef fc wname) (map (pexp . (PRef fc) . fst) bargs ++ - [pexp wval])- logLvl 3 ("New RHS " ++ show rhs)+ let rhs = PApp fc (PRef fc wname) + (map (pexp . (PRef fc) . fst) bargs_pre ++ + pexp wval :+ (map (pexp . (PRef fc) . fst) bargs_post))+ logLvl 1 ("New RHS " ++ show rhs) ctxt <- getContext -- New context with block added i <- get ((rhs', defer, is), _) <-@@ -583,49 +692,68 @@ getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t getImps _ = [] - mkAuxC wname lhs ns (PClauses fc o n cs)- | True = do cs' <- mapM (mkAux wname lhs ns) cs+ mkAuxC wname lhs ns ns' (PClauses fc o n cs)+ | True = do cs' <- mapM (mkAux wname lhs ns ns') cs return $ PClauses fc o wname cs' | otherwise = fail $ show fc ++ "with clause uses wrong function name " ++ show n- mkAuxC wname lhs ns d = return $ d+ mkAuxC wname lhs ns ns' d = return $ d - mkAux wname toplhs ns (PClause fc n tm_in (w:ws) rhs wheres)+ mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres) = do i <- get let tm = addImpl i tm_in logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ showImp True toplhs) case matchClause i toplhs tm of Left _ -> fail $ show fc ++ "with clause does not match top level"- Right mvars -> do logLvl 3 ("Match vars : " ++ show mvars)- lhs <- updateLHS n wname mvars ns (fullApp tm) w- return $ PClause fc wname lhs ws rhs wheres- mkAux wname toplhs ns (PWith fc n tm_in (w:ws) wval withs)+ Right mvars -> + do logLvl 3 ("Match vars : " ++ show mvars)+ lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w+ return $ PClause fc wname lhs ws rhs wheres+ mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs) = do i <- get let tm = addImpl i tm_in logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++ showImp True toplhs)- withs' <- mapM (mkAuxC wname toplhs ns) withs+ withs' <- mapM (mkAuxC wname toplhs ns ns') withs case matchClause i toplhs tm of Left _ -> fail $ show fc ++ "with clause does not match top level"- Right mvars -> do lhs <- updateLHS n wname mvars ns (fullApp tm) w- return $ PWith fc wname lhs ws wval withs'- - updateLHS n wname mvars ns (PApp fc (PRef fc' n') args) w- = return $ substMatches mvars $ - PApp fc (PRef fc' wname) (map (pexp . (PRef fc')) ns ++ [pexp w])- updateLHS n wname mvars ns tm w = fail $ "Not implemented match " ++ show tm + Right mvars -> + do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w+ return $ PWith fc wname lhs ws wval withs'+ mkAux wname toplhs ns ns' c+ = fail $ show fc ++ "badly formed with clause" + updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w+ = let ns = map (keepMvar (map fst mvars) fc') ns_in+ ns' = map (keepMvar (map fst mvars) fc') ns_in' in+ return $ substMatches mvars $ + PApp fc (PRef fc' wname) + (map pexp ns ++ pexp w : (map pexp ns'))+ updateLHS n wname mvars ns ns' tm w + = fail $ "Not implemented match " ++ show tm ++ keepMvar mvs fc v | v `elem` mvs = PRef fc v+ | otherwise = Placeholder+ fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs)) fullApp x = x + split [] rest pre = (reverse pre, rest)+ split deps ((n, ty) : rest) pre+ | n `elem` deps = split (deps \\ [n]) rest ((n, ty) : pre)+ | otherwise = split deps rest ((n, ty) : pre)+ split deps [] pre = (reverse pre, []) ++ abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty)+ data MArgTy = IA | EA | CA deriving Show -elabClass :: ElabInfo -> SyntaxInfo -> +elabClass :: ElabInfo -> SyntaxInfo -> String -> FC -> [PTerm] -> Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()-elabClass info syn fc constraints tn ps ds +elabClass info syn doc fc constraints tn ps ds = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)- let tty = pibind ps PSet+ let tty = pibind ps PType let constraint = PApp fc (PRef fc tn) (map (pexp . PRef fc) (map fst ps)) -- build data declaration@@ -635,12 +763,18 @@ ims <- mapM (tdecl mnames) mdecls defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint) (filter clause ds)- let (methods, imethods) = unzip (map (\ (x,y,z) -> (x, y)) ims)- let cty = impbind ps $ conbind constraints $ pibind methods constraint- let cons = [(cn, cty, fc)]+ let (methods, imethods) + = unzip (map (\ ( x,y,z) -> (x, y)) ims)+ -- build instance constructor type+ -- decorate names of functions to ensure they can't be referred+ -- to elsewhere in the class declaration+ let cty = impbind ps $ conbind constraints + $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods) + constraint+ let cons = [("", cn, cty, fc)] let ddecl = PDatadecl tn tty cons logLvl 5 $ "Class data " ++ showDImp True ddecl- elabData info (syn { no_imp = no_imp syn ++ mnames }) fc False ddecl+ elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl -- for each constraint, build a top level function to chase it logLvl 5 $ "Building functions" let usyn = syn { using = ps ++ using syn }@@ -653,22 +787,28 @@ mapM_ (elabDecl EAll info) (concat (map (snd.snd) defs)) i <- get let defaults = map (\ (x, (y, z)) -> (x,y)) defs- addClass tn (CI cn imethods defaults (map fst ps) []) + addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) []) addIBC (IBCClass tn) where+ nodoc (n, (_, o, t)) = (n, (o, t)) pibind [] x = x pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x) ++ mdec (UN n) = UN ('!':n)+ mdec (NS x n) = NS (mdec x) n+ mdec x = x+ impbind [] x = x impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x) conbind (ty : ns) x = PPi constraint (MN 0 "c") ty (conbind ns x) conbind [] x = x - getMName (PTy _ _ _ n _) = nsroot n- tdecl allmeths (PTy syn _ o n t) + getMName (PTy _ _ _ _ n _) = nsroot n+ tdecl allmeths (PTy doc syn _ o n t) = do t' <- implicit' syn allmeths n t logLvl 5 $ "Method " ++ show n ++ " : " ++ showImp True t' return ( (n, (toExp (map fst ps) Exp t')),- (n, (o, (toExp (map fst ps) Imp t'))),+ (n, (doc, o, (toExp (map fst ps) Imp t'))), (n, (syn, o, t) ) ) tdecl _ _ = fail "Not allowed in a class declaration" @@ -677,7 +817,7 @@ case lookup n mtys of Just (syn, o, ty) -> do let ty' = insertConstraint c ty let ds = map (decorateid defaultdec)- [PTy syn fc [] n ty', + [PTy "" syn fc [] n ty', PClauses fc (TCGen:o ++ opts) n cs] iLOG (show ds) return (n, ((defaultdec n, ds!!1), ds))@@ -687,7 +827,7 @@ defaultdec (UN n) = UN ("default#" ++ n) defaultdec (NS n ns) = NS (defaultdec n) ns - tydecl (PTy _ _ _ _ _) = True+ tydecl (PTy _ _ _ _ _ _) = True tydecl _ = False clause (PClauses _ _ _ _) = True clause _ = False@@ -711,10 +851,10 @@ addInstance False conn' cfn addIBC (IBCInstance False conn' cfn) -- iputStrLn ("Added " ++ show (conn, cfn, ty))- return [PTy syn fc [] cfn ty,+ return [PTy "" syn fc [] cfn ty, PClauses fc [Inlinable,TCGen] cfn [PClause fc cfn lhs [] rhs []]] - tfun cn c syn all (m, (o, ty)) + tfun cn c syn all (m, (doc, o, ty)) = do let ty' = insertConstraint c ty let mnames = take (length all) $ map (\x -> MN x "meth") [0..] let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)@@ -725,12 +865,12 @@ iLOG (showImp True ty) iLOG (show (m, ty', capp, margs)) iLOG (showImp True lhs ++ " = " ++ showImp True rhs)- return [PTy syn fc o m ty',+ return [PTy doc syn fc o m ty', PClauses fc [Inlinable,TCGen] m [PClause fc m lhs [] rhs []]] - getMArgs (PPi (Imp _ _) n ty sc) = IA : getMArgs sc- getMArgs (PPi (Exp _ _) n ty sc) = EA : getMArgs sc- getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc+ getMArgs (PPi (Imp _ _ _) n ty sc) = IA : getMArgs sc+ getMArgs (PPi (Exp _ _ _) n ty sc) = EA : getMArgs sc+ getMArgs (PPi (Constraint _ _ _) n ty sc) = CA : getMArgs sc getMArgs _ = [] getMeth (m:ms) (a:as) x | x == a = PRef fc m@@ -746,14 +886,14 @@ rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns rhsArgs [] _ = [] - insertConstraint c (PPi p@(Imp _ _) n ty sc)+ insertConstraint c (PPi p@(Imp _ _ _) n ty sc) = PPi p n ty (insertConstraint c sc) insertConstraint c sc = PPi constraint (MN 0 "c") c sc -- make arguments explicit and don't bind class parameters- toExp ns e (PPi (Imp l s) n ty sc)+ toExp ns e (PPi (Imp l s _) n ty sc) | n `elem` ns = toExp ns e sc- | otherwise = PPi (e l s) n ty (toExp ns e sc)+ | otherwise = PPi (e l s "") n ty (toExp ns e sc) toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc) toExp ns e sc = sc @@ -778,15 +918,21 @@ Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci) addInstance intInst n iname Just _ -> addInstance intInst n iname - elabType info syn fc [] iname t+ elabType info syn "" fc [] iname t let ips = zip (class_params ci) ps let ns = case n of NS n ns' -> ns' _ -> []+ -- get the implicit parameters that need passing through to the + -- where block+ wparams <- mapM (\p -> case p of+ PApp _ _ args -> getWParams args+ _ -> return []) ps+ let pnames = map pname (concat (nub wparams)) let mtys = map (\ (n, (op, t)) -> - let t' = substMatches ips t in- (decorate ns iname n, - op, coninsert cs t', t'))+ let t' = substMatchesShadow ips pnames t in+ (decorate ns iname n, + op, coninsert cs t', t')) (class_methods ci) logLvl 3 (show (mtys, ips)) let ds' = insertDefaults i iname (class_defaults ci) ns ds@@ -797,11 +943,6 @@ let wbVals = map (decorateid (decorate ns iname)) ds' let wb = wbTys ++ wbVals logLvl 3 $ "Method types " ++ showSep "\n" (map (showDeclImp True . mkTyDecl) mtys)- -- get the implicit parameters that need passing through to the - -- where block- wparams <- mapM (\p -> case p of- PApp _ _ args -> getWParams args- _ -> return []) ps logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++ show (concat (nub wparams)) let lhs = case concat (nub wparams) of@@ -836,17 +977,19 @@ getRetType (PPi _ _ _ sc) = getRetType sc getRetType t = t - mkMethApp (n, _, _, ty) = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))- lamBind i (PPi (Constraint _ _) _ _ sc) sc' - = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')- lamBind i (PPi _ n ty sc) sc' = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')+ mkMethApp (n, _, _, ty) + = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))+ lamBind i (PPi (Constraint _ _ _) _ _ sc) sc' + = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')+ lamBind i (PPi _ n ty sc) sc' + = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc') lamBind i _ sc = sc- methArgs i (PPi (Imp _ _) n ty sc) - = PImp 0 False n (PRef fc (MN i "meth")) : methArgs (i+1) sc- methArgs i (PPi (Exp _ _) n ty sc) - = PExp 0 False (PRef fc (MN i "meth")) : methArgs (i+1) sc- methArgs i (PPi (Constraint _ _) n ty sc) - = PConstraint 0 False (PResolveTC fc) : methArgs (i+1) sc+ methArgs i (PPi (Imp _ _ _) n ty sc) + = PImp 0 False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc+ methArgs i (PPi (Exp _ _ _) n ty sc) + = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc+ methArgs i (PPi (Constraint _ _ _) n ty sc) + = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc methArgs i _ = [] papp fc f [] = f@@ -865,12 +1008,12 @@ decorate ns iname (UN n) = NS (UN ('!':n)) ns decorate ns iname (NS (UN n) s) = NS (UN ('!':n)) ns - mkTyDecl (n, op, t, _) = PTy syn fc op n t+ mkTyDecl (n, op, t, _) = PTy "" syn fc op n t conbind (ty : ns) x = PPi constraint (MN 0 "c") ty (conbind ns x) conbind [] x = x - coninsert cs (PPi p@(Imp _ _) n t sc) = PPi p n t (coninsert cs sc)+ coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc) coninsert cs sc = conbind cs sc insertDefaults :: IState -> Name ->@@ -882,7 +1025,7 @@ insertDef i meth def clauses ns iname decls | null $ filter (clauseFor meth iname ns) decls- = let newd = expandParamsD i (\n -> meth) [] [def] clauses in+ = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in -- trace (show newd) $ decls ++ [newd] | otherwise = decls@@ -903,7 +1046,7 @@ = decorate ns iname m == decorate ns iname m' clauseFor m iname ns _ = False -decorateid decorate (PTy s f o n t) = PTy s f o (decorate n) t+decorateid decorate (PTy doc s f o n t) = PTy doc s f o (decorate n) t decorateid decorate (PClauses f o n cs) = PClauses f o (decorate n) (map dc cs) where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds@@ -921,6 +1064,7 @@ pbty _ tm = tm getPBtys (Bind n (PVar t) sc) = (n, t) : getPBtys sc+getPBtys (Bind n (PVTy t) sc) = (n, t) : getPBtys sc getPBtys _ = [] psolve (Bind n (PVar t) sc) = do solve; psolve sc@@ -947,17 +1091,21 @@ = return () -- nothing to elaborate elabDecl' _ info (PSyntax _ p) = return () -- nothing to elaborate-elabDecl' what info (PTy s f o n ty) +elabDecl' what info (PTy doc s f o n ty) | what /= EDefns = do iLOG $ "Elaborating type decl " ++ show n ++ show o- elabType info s f o n ty-elabDecl' what info (PData s f co d) + elabType info s doc f o n ty+elabDecl' what info (PPostulate doc s f o n ty) + | what /= EDefns+ = do iLOG $ "Elaborating postulate " ++ show n ++ show o+ elabPostulate info s doc f o n ty+elabDecl' what info (PData doc s f co d) | what /= ETypes = do iLOG $ "Elaborating " ++ show (d_name d)- elabData info s f co d+ elabData info s doc f co d | otherwise = do iLOG $ "Elaborating [type of] " ++ show (d_name d)- elabData info s f co (PLaterdecl (d_name d) (d_tcon d))+ elabData info s doc f co (PLaterdecl (d_name d) (d_tcon d)) elabDecl' what info d@(PClauses f o n ps) | what /= ETypes = do iLOG $ "Elaborating clause " ++ show n@@ -971,35 +1119,37 @@ mapM_ (elabDecl EDefns info) ps elabDecl' what info (PParams f ns ps) = do i <- get- iLOG $ "Expanding params block with " ++ show (concatMap declared ps)+ iLOG $ "Expanding params block with " ++ show ns ++ " decls " +++ show (concatMap tldeclared ps) let nblock = pblock i mapM_ (elabDecl' what info) nblock where- pinfo = let ds = concatMap declared ps+ pinfo = let ds = concatMap tldeclared ps newps = params info ++ ns dsParams = map (\n -> (n, map fst newps)) ds newb = addAlist dsParams (inblock info) in info { params = newps, inblock = newb }- pblock i = map (expandParamsD i id ns (concatMap declared ps)) ps+ pblock i = map (expandParamsD False i id ns + (concatMap tldeclared ps)) ps elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps where ninfo = case namespace info of Nothing -> info { namespace = Just [n] } Just ns -> info { namespace = Just (n:ns) } -elabDecl' what info (PClass s f cs n ps ds) +elabDecl' what info (PClass doc s f cs n ps ds) | what /= EDefns = do iLOG $ "Elaborating class " ++ show n- elabClass info s f cs n ps ds+ elabClass info s doc f cs n ps ds elabDecl' what info (PInstance s f cs n ps t expn ds) | what /= ETypes = do iLOG $ "Elaborating instance " ++ show n elabInstance info s f cs n ps t expn ds-elabDecl' what info (PRecord s f tyn ty cn cty)+elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty) | what /= EDefns = do iLOG $ "Elaborating record " ++ show tyn- elabRecord info s f tyn ty cn cty+ elabRecord info s doc f tyn ty cdoc cn cty elabDecl' _ info (PDSL n dsl) = do i <- get put (i { idris_dsls = addDef n dsl (idris_dsls i) })
src/Idris/ElabTerm.hs view
@@ -69,7 +69,9 @@ elab ist info pattern tcgen fn tm = do elabE (False, False) tm -- (in argument, guarded) when pattern -- convert remaining holes to pattern vars- mkPat+ (do update_term orderPats+-- tm <- get_term+ mkPat) inj <- get_inj mapM_ checkInjective inj where@@ -86,6 +88,7 @@ v -> Just (elabE ina v) mkPat = do hs <- get_holes+ tm <- get_term case hs of (h: hs) -> do patvar h; mkPat [] -> return ()@@ -98,7 +101,7 @@ local f = do e <- get_env return (f `elem` map fst e) - elab' ina PSet = do apply RSet []; solve+ elab' ina PType = do apply RType []; solve elab' ina (PConstant c) = do apply (RConstant c) []; solve elab' ina (PQuote r) = do fill r; solve elab' ina (PTrue fc) = try (elab' ina (PRef fc unitCon))@@ -109,7 +112,8 @@ elab' ina (PResolveTC fc) | pattern = do c <- unique_hole (MN 0 "c") instanceArg c- | otherwise = try (resolveTC 2 fn ist)+ | otherwise = do g <- goal+ try (resolveTC 2 fn ist) (do c <- unique_hole (MN 0 "c") instanceArg c) elab' ina (PRefl fc t) = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder,@@ -144,15 +148,16 @@ ctxt <- get_context let (tc, _) = unApply ty let as' = pruneByType tc ctxt as- let as'' = as' -- pruneAlt as'- try (tryAll (zip (map (elab' ina) as'') (map showHd as'')))- (tryAll (zip (map (elab' ina) as') (map showHd as')))+ tryAll (zip (map (elab' ina) as') (map showHd as')) where showHd (PApp _ h _) = show h showHd x = show x elab' ina (PAlternative False as) = trySeq as- where trySeq [] = fail "All alternatives fail to elaborate"- trySeq (x : xs) = try (elab' ina x) (trySeq xs)+ where -- if none work, take the error from the first+ trySeq (x : xs) = let e1 = elab' ina x in+ try e1 (trySeq' e1 xs)+ trySeq' deferr [] = deferr+ trySeq' deferr (x : xs) = try (elab' ina x) (trySeq' deferr xs) elab' ina (PPatvar fc n) | pattern = patvar n elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n) = do ctxt <- get_context@@ -170,18 +175,22 @@ where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of [] -> False _ -> True+ 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) (PLam n Placeholder sc) = do -- n' <- unique_hole n -- let sc' = mapPT (repN n n') sc- attack; intro (Just n); elabE (True, a) sc; solve+ ptm <- get_term+ attack; intro (Just n); + -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm) + elabE (True, a) sc; solve where repN n n' (PRef fc x) | x == n' = PRef fc n' repN _ _ t = t elab' ina@(_, a) (PLam n ty sc) = do hsin <- get_holes ptmin <- get_term tyn <- unique_hole (MN 0 "lamty")- claim tyn RSet+ claim tyn RType attack ptm <- get_term hs <- get_holes@@ -199,7 +208,7 @@ = do attack; arg n (MN 0 "ty"); elabE (True, a) sc; solve elab' ina@(_,a) (PPi _ n ty sc) = do attack; tyn <- unique_hole (MN 0 "ty")- claim tyn RSet+ claim tyn RType n' <- case n of MN _ _ -> unique_hole n _ -> return n@@ -211,7 +220,7 @@ elab' ina@(_,a) (PLet n ty val sc) = do attack; tyn <- unique_hole (MN 0 "letty")- claim tyn RSet+ claim tyn RType valn <- unique_hole (MN 0 "letval") claim valn (Var tyn) letbind n (Var tyn) (Var valn)@@ -223,6 +232,51 @@ elabE (True, a) val elabE (True, a) sc solve+ elab' ina tm@(PApp fc (PInferRef _ f) args) = do+ rty <- goal+ ds <- get_deferred+ ctxt <- get_context+ -- make a function type a -> b -> c -> ... -> rty for the+ -- new function name+ env <- get_env+ argTys <- claimArgTys env args+ fn <- unique_hole (MN 0 "inf_fn")+ let fty = fnTy argTys rty+-- trace (show (ptm, map fst argTys)) $ focus fn+ -- build and defer the function application+ attack; deferType (mkN f) fty (map fst argTys); solve+ -- elaborate the arguments, to unify their types. They all have to+ -- be explicit.+ mapM_ elabIArg (zip argTys args)+ where claimArgTys env [] = return []+ claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg)+ = do nty <- get_type (Var n) + ans <- claimArgTys env xs+ return ((n, (False, forget nty)) : ans)+ claimArgTys env (_ : xs) + = do an <- unique_hole (MN 0 "inf_argTy")+ aval <- unique_hole (MN 0 "inf_arg")+ claim an RType+ claim aval (Var an)+ ans <- claimArgTys env xs+ return ((aval, (True, (Var an))) : ans)+ fnTy [] ret = forget ret+ fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt) (fnTy xs ret)++ localVar env (PRef _ x) + = case lookup x env of+ Just _ -> Just x+ _ -> Nothing+ localVar env _ = Nothing++ elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def) + elabIArg _ = return () -- already done, just a name+ + mkN n@(NS _ _) = n+ mkN n = case namespace info of+ Just xs@(_:_) -> NS n xs+ _ -> n+ elab' (ina, g) tm@(PApp fc (PRef _ f) args') = do let args = {- case lookupCtxt f (inblock info) of Just ps -> (map (pexp . (PRef fc)) ps ++ args')@@ -237,16 +291,17 @@ -- when True tryWhen True (do ns <- apply (Var f) (map isph args)- let (ns', eargs) - = unzip $- sortBy (\(_,x) (_,y) -> compare (priority x) (priority y))+ ptm <- get_term+ let (ns', eargs) = unzip $ + sortBy (\(_,x) (_,y) -> + compare (priority x) (priority y)) (zip ns args)- try - (elabArgs (ina || not isinf, guarded)- [] False ns' (map (\x -> (lazyarg x, getTm x)) eargs))- (elabArgs (ina || not isinf, guarded)- [] False (reverse ns') - (map (\x -> (lazyarg x, getTm x)) (reverse eargs)))+ tryWhen True + (elabArgs (ina || not isinf, guarded)+ [] False ns' (map (\x -> (lazyarg x, getTm x)) eargs))+ (elabArgs (ina || not isinf, guarded)+ [] False (reverse ns') + (map (\x -> (lazyarg x, getTm x)) (reverse eargs))) mkSpecialised ist fc f (map getTm args') tm solve) (do apply_elab f (map (toElab (ina || not isinf, guarded)) args)@@ -259,12 +314,17 @@ mapM_ (\n -> do focus n -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist)) resolveTC 7 fn ist) (ivs' \\ ivs) - where tcArg (n, PConstraint _ _ Placeholder) = True+ where tcArg (n, PConstraint _ _ Placeholder _) = True tcArg _ = False + tacTm (PTactics _) = True+ tacTm (PProof _) = True+ tacTm _ = False+ elab' ina@(_, a) (PApp fc f [arg]) = erun fc $ - do simple_app (elabE ina f) (elabE (True, a) (getTm arg))+ do ptm <- get_term+ simple_app (elabE ina f) (elabE (True, a) (getTm arg)) solve elab' ina Placeholder = do (h : hs) <- get_holes movelast h@@ -274,7 +334,7 @@ mkN n = case namespace info of Just xs@(_:_) -> NS n xs _ -> n- elab' ina (PProof ts) = do mapM_ (runTac True ist) ts+ elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts elab' ina (PTactics ts) | not pattern = do mapM_ (runTac False ist) ts | otherwise = elab' ina Placeholder@@ -282,7 +342,7 @@ elab' ina@(_, a) c@(PCase fc scr opts) = do attack tyn <- unique_hole (MN 0 "scty")- claim tyn RSet+ claim tyn RType valn <- unique_hole (MN 0 "scval") scvn <- unique_hole (MN 0 "scvar") claim valn (Var tyn)@@ -290,10 +350,11 @@ focus valn elabE (True, a) scr args <- get_env- cname <- unique_hole (mkCaseName fn)- elab' ina (PMetavar cname)+ cname <- unique_hole' True (mkCaseName fn) let cname' = mkN cname- let newdef = PClauses fc [] cname' (caseBlock fc cname' (reverse args) opts)+ elab' ina (PMetavar cname')+ let newdef = PClauses fc [] cname' + (caseBlock fc cname' (reverse args) opts) -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args -- elaborate case updateAux (newdef : )@@ -307,16 +368,24 @@ _ -> n elab' ina x = fail $ "Something's gone wrong. Did you miss a semi-colon somewhere?" - caseBlock :: FC -> Name -> [(Name, Binder Term)] -> [(PTerm, PTerm)] -> [PClause]+ caseBlock :: FC -> Name -> [(Name, Binder Term)] -> + [(PTerm, PTerm)] -> [PClause] caseBlock fc n env opts = let args = map mkarg (map fst (init env)) in map (mkClause args) opts where -- mkarg (MN _ _) = Placeholder mkarg n = PRef fc n+ -- may be shadowed names in the new pattern - so replace the+ -- old ones with an _ mkClause args (l, r) - = PClause fc n (PApp fc (PRef fc n)- (map pexp args ++ [pexp l])) [] r []+ = let args' = map (shadowed (allNamesIn l)) args+ lhs = PApp fc (PRef fc n)+ (map pexp args' ++ [pexp l]) in+ PClause fc n lhs [] r [] + shadowed new (PRef _ n) | n `elem` new = Placeholder+ shadowed new t = t+ elabArgs ina failed retry [] _ -- | retry = let (ns, ts) = unzip (reverse failed) in -- elabArgs ina [] False ns ts@@ -335,10 +404,10 @@ failed' <- -- trace (show (n, t, hs, tm)) $ case n `elem` hs of True ->- if r- then try (do focus n; elabE ina t; return failed)- (return ((n,(lazy, t)):failed))- else do focus n; elabE ina t; return failed+-- if r+-- then try (do focus n; elabE ina t; return failed)+-- (return ((n,(lazy, t)):failed))+ do focus n; elabE ina t; return failed False -> return failed elabArgs ina failed r ns args @@ -389,17 +458,17 @@ pruneByType t _ as = as trivial :: IState -> ElabD ()-trivial ist = try (do elab ist toplevel False False (MN 0 "tac") +trivial ist = try' (do elab ist toplevel False False (MN 0 "tac") (PRefl (FC "prf" 0) Placeholder)- return ())- (do env <- get_env- tryAll (map fst env)- return ())+ return ())+ (do env <- get_env+ tryAll (map fst env)+ return ()) True where tryAll [] = fail "No trivial solution"- tryAll (x:xs) = try (elab ist toplevel False False+ tryAll (x:xs) = try' (elab ist toplevel False False (MN 0 "tac") (PRef (FC "prf" 0) x))- (tryAll xs)+ (tryAll xs) True findInstances :: IState -> Term -> [Name] findInstances ist t @@ -411,18 +480,19 @@ resolveTC :: Int -> Name -> IState -> ElabD () resolveTC 0 fn ist = fail $ "Can't resolve type class"-resolveTC 1 fn ist = try (trivial ist) (resolveTC 0 fn ist)+resolveTC 1 fn ist = try' (trivial ist) (resolveTC 0 fn ist) True resolveTC depth fn ist - = try (trivial ist)- (do t <- goal- let insts = findInstances ist t- let (tc, ttypes) = unApply t- scopeOnly <- needsDefault t tc ttypes- tm <- get_term+ = do hnf_compute+ try' (trivial ist)+ (do t <- goal+ let insts = findInstances ist t+ let (tc, ttypes) = unApply t+ scopeOnly <- needsDefault t tc ttypes+ tm <- get_term -- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $ -- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))- let depth' = if scopeOnly then 2 else depth- blunderbuss t depth' insts)+ let depth' = if scopeOnly then 2 else depth+ blunderbuss t depth' insts) True where elabTC n | n /= fn && tcname n = (resolve n depth, show n) | otherwise = (fail "Can't resolve", show n)@@ -441,8 +511,8 @@ blunderbuss t d [] = lift $ tfail $ CantResolve t blunderbuss t d (n:ns) - | n /= fn && tcname n = try (resolve n d)- (blunderbuss t d ns)+ | n /= fn && tcname n = try' (resolve n d)+ (blunderbuss t d ns) True | otherwise = blunderbuss t d ns resolve n depth@@ -466,14 +536,14 @@ (filter (\ (x, y) -> not x) (zip (map fst imps) args)) -- if there's any arguments left, we've failed to resolve solve- where isImp (PImp p _ _ _) = (True, p)+ where isImp (PImp p _ _ _ _) = (True, p) isImp arg = (False, priority arg) collectDeferred :: Term -> State [(Name, Type)] Term collectDeferred (Bind n (GHole t) app) = do ds <- get- put ((n, t) : ds)- return app+ when (not (n `elem` map fst ds)) $ put ((n, t) : ds)+ collectDeferred app collectDeferred (Bind n b t) = do b' <- cdb b t' <- collectDeferred t return (Bind n b' t')@@ -488,7 +558,9 @@ -- Running tactics directly runTac :: Bool -> IState -> PTactic -> ElabD ()-runTac autoSolve ist tac = runT (fmap (addImpl ist) tac) where+runTac autoSolve ist tac = do env <- get_env+ runT (fmap (addImplBound ist (map fst env)) tac) + where runT (Intro []) = do g <- goal attack; intro (bname g) where@@ -497,8 +569,8 @@ runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs runT Intros = do g <- goal attack; intro (bname g)- try (runT Intros)- (return ())+ try' (runT Intros)+ (return ()) True where bname (Bind n _ _) = Just n bname _ = Nothing@@ -512,7 +584,7 @@ [(n, args)] -> return $ (n, map isImp args) ns <- apply (Var fn') (map (\x -> (x, 0)) imps) when autoSolve solveAll- where isImp (PImp _ _ _ _) = True+ where isImp (PImp _ _ _ _ _) = True isImp _ = False envArgs n = do e <- get_env case lookup n e of@@ -525,7 +597,7 @@ = do attack; -- (h:_) <- get_holes tyn <- unique_hole (MN 0 "rty") -- start_unify h- claim tyn RSet+ claim tyn RType valn <- unique_hole (MN 0 "rval") claim valn (Var tyn) letn <- unique_hole (MN 0 "rewrite_rule")@@ -537,7 +609,7 @@ runT (LetTac n tm) = do attack tyn <- unique_hole (MN 0 "letty")- claim tyn RSet+ claim tyn RType valn <- unique_hole (MN 0 "letval") claim valn (Var tyn) letn <- unique_hole n@@ -545,13 +617,68 @@ focus valn elab ist toplevel False False (MN 0 "tac") tm when autoSolve solveAll+ runT (LetTacTy n ty tm)+ = do attack+ tyn <- unique_hole (MN 0 "letty")+ claim tyn RType+ valn <- unique_hole (MN 0 "letval")+ claim valn (Var tyn)+ letn <- unique_hole n+ letbind letn (Var tyn) (Var valn)+ focus tyn+ elab ist toplevel False False (MN 0 "tac") ty+ focus valn+ elab ist toplevel False False (MN 0 "tac") tm+ when autoSolve solveAll runT Compute = compute runT Trivial = do trivial ist; when autoSolve solveAll runT (Focus n) = focus n runT Solve = solve- runT (Try l r) = do try (runT l) (runT r)+ runT (Try l r) = do try' (runT l) (runT r) True runT (TSeq l r) = do runT l; runT r+ runT (ReflectTac tm) = do attack -- let x : Tactic = tm in ...+ valn <- unique_hole (MN 0 "tacval")+ claim valn (Var tacticTy)+ tacn <- unique_hole (MN 0 "tacn")+ letbind tacn (Var tacticTy) (Var valn)+ focus valn+ elab ist toplevel False False (MN 0 "tac") tm+ (tm', ty') <- get_type_val (Var tacn)+ ctxt <- get_context+ env <- get_env+ let tactic = normalise ctxt env tm'+ runReflected tactic+-- p <- get_term+-- trace (show p ++ "\n\n") $ + return ()+ where tacticTy = tacm "Tactic"+ runT (GoalType n tac) = do g <- goal+ case unApply g of+ (P _ n' _, _) -> + if nsroot n' == UN n+ then runT tac+ else fail "Wrong goal type"+ _ -> fail "Wrong goal type" runT x = fail $ "Not implemented " ++ show x++ runReflected t = do t' <- reify t+ runTac autoSolve ist t'+ tacm n = NS (UN n) ["Reflection", "Language"]++ reify :: Term -> ElabD PTactic+ reify (P _ n _) | n == tacm "Trivial" = return Trivial+ reify (P _ n _) | n == tacm "Solve" = return Solve+ reify f@(App _ _) + | (P _ f _, args) <- unApply f = reifyAp f args+ reify t = fail ("Unknown tactic " ++ show t)++ reifyAp t [l, r] | t == tacm "Try" = liftM2 Try (reify l) (reify r)+ reifyAp t [Constant (Str x)] + | t == tacm "Refine" = return $ Refine (UN x) []+ reifyAp t [l, r] | t == tacm "Seq" = liftM2 TSeq (reify l) (reify r)+ reifyAp t [Constant (Str n), x] + | t == tacm "GoalType" = liftM (GoalType n) (reify x)+ reifyAp f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen solveAll = try (do solve; solveAll) (return ())
src/Idris/Error.hs view
@@ -58,6 +58,12 @@ _ -> return () throwIO (IErr $ pshow i err) +tctry :: TC a -> TC a -> Idris a+tctry tc1 tc2 + = case tc1 of+ OK v -> return v+ Error err -> tclift tc2+ getErrLine str = case span (/=':') str of (_, ':':rest) -> case span isDigit rest of
src/Idris/IBC.hs view
@@ -21,7 +21,7 @@ import Paths_idris ibcVersion :: Word8-ibcVersion = 22+ibcVersion = 24 data IBCFile = IBCFile { ver :: Word8, sourcefile :: FilePath,@@ -43,13 +43,15 @@ ibc_total :: [(Name, Totality)], ibc_flags :: [(Name, [FnOpt])], ibc_cg :: [(Name, CGInfo)],- ibc_defs :: [(Name, Def)] }+ ibc_defs :: [(Name, Def)],+ ibc_docstrings :: [(Name, String)]+ } {-! deriving instance Binary IBCFile !-} initIBC :: IBCFile-initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] loadIBC :: FilePath -> Idris () loadIBC fp = do iLOG $ "Loading ibc " ++ fp@@ -111,6 +113,9 @@ ibc i (IBCDef n) f = case lookupDef Nothing n (tt_ctxt i) of [v] -> return f { ibc_defs = (n,v) : ibc_defs f } _ -> fail "IBC write failed"+ibc i (IBCDoc n) f = case lookupCtxt Nothing n (idris_docstrings i) of+ [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }+ _ -> fail "IBC write failed" ibc i (IBCCG n) f = case lookupCtxt Nothing n (idris_callgraph i) of [v] -> return f { ibc_cg = (n,v) : ibc_cg f } _ -> fail "IBC write failed"@@ -145,6 +150,7 @@ pAccess (ibc_access i) pTotal (ibc_total i) pCG (ibc_cg i)+ pDocs (ibc_docstrings i) timestampOlder :: FilePath -> FilePath -> IO () timestampOlder src ibc = do srct <- getModificationTime src@@ -243,6 +249,9 @@ putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) })) ds +pDocs :: [(Name, String)] -> Idris ()+pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds+ pAccess :: [(Name, Accessibility)] -> Idris () pAccess ds = mapM_ (\ (n, a) -> do i <- getIState@@ -351,6 +360,9 @@ StrType -> putWord8 9 PtrType -> putWord8 10 Forgot -> putWord8 11++ W8Type -> putWord8 12+ W16Type -> putWord8 13 get = do i <- getWord8 case i of@@ -371,6 +383,10 @@ 9 -> return StrType 10 -> return PtrType 11 -> return Forgot++ 12 -> return W8Type+ 13 -> return W16Type+ _ -> error "Corrupted binary data for Const" @@ -386,7 +402,7 @@ RApp x1 x2 -> do putWord8 2 put x1 put x2- RSet -> putWord8 3+ RType -> putWord8 3 RConstant x1 -> do putWord8 4 put x1 RForce x1 -> do putWord8 5@@ -403,7 +419,7 @@ 2 -> do x1 <- get x2 <- get return (RApp x1 x2)- 3 -> return RSet+ 3 -> return RType 4 -> do x1 <- get return (RConstant x1) 5 -> do x1 <- get@@ -509,8 +525,8 @@ put x1 put x2 Erased -> putWord8 6- Set x1 -> do putWord8 7- put x1+ TType x1 -> do putWord8 7+ put x1 Impossible -> putWord8 8 get = do i <- getWord8@@ -535,7 +551,7 @@ return (Proj x1 x2) 6 -> return Erased 7 -> do x1 <- get- return (Set x1)+ return (TType x1) 8 -> return Impossible _ -> error "Corrupted binary data for TT" @@ -612,11 +628,12 @@ put x1 put x2 put x3- CaseOp x1 x2 x3 x4 x5 x6 x7 x8 -> + CaseOp x1 x2 x3 x3a x4 x5 x6 x7 x8 -> do putWord8 3 put x1 put x2 put x3+ -- no x3a put x4 put x5 put x6@@ -638,12 +655,13 @@ 3 -> do x1 <- get x2 <- get x3 <- get+ -- x3 <- get always [] x4 <- get x5 <- get x6 <- get x7 <- get x8 <- get- return (CaseOp x1 x2 x3 x4 x5 x6 x7 x8)+ return (CaseOp x1 x2 x3 [] x4 x5 x6 x7 x8) _ -> error "Corrupted binary data for Def" instance Binary Accessibility where@@ -671,6 +689,7 @@ Mutual x1 -> do putWord8 4 put x1 NotProductive -> putWord8 5+ BelieveMe -> putWord8 6 get = do i <- getWord8 case i of@@ -682,6 +701,7 @@ 4 -> do x1 <- get return (Mutual x1) 5 -> return NotProductive+ 6 -> return BelieveMe _ -> error "Corrupted binary data for PReason" instance Binary Totality where@@ -705,7 +725,7 @@ _ -> error "Corrupted binary data for Totality" instance Binary IBCFile where- put (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21)+ put (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22) = do put x1 put x2 put x3@@ -727,6 +747,7 @@ put x19 put x20 put x21+ put x22 get = do x1 <- get if x1 == ibcVersion then @@ -750,7 +771,8 @@ x19 <- get x20 <- get x21 <- get- return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21)+ x22 <- get+ return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22) else return (initIBC { ver = x1 }) instance Binary FnOpt where@@ -828,35 +850,47 @@ instance Binary Plicity where put x = case x of- Imp x1 x2 -> do putWord8 0+ Imp x1 x2 x3 -> + do putWord8 0 put x1 put x2- Exp x1 x2 -> do putWord8 1+ put x3+ Exp x1 x2 x3 -> + do putWord8 1 put x1 put x2- Constraint x1 x2 -> do putWord8 2+ put x3+ Constraint x1 x2 x3 -> + do putWord8 2 put x1 put x2- TacImp x1 x2 x3 -> do putWord8 3+ put x3+ TacImp x1 x2 x3 x4 -> + do putWord8 3 put x1 put x2 put x3+ put x4 get = do i <- getWord8 case i of 0 -> do x1 <- get x2 <- get- return (Imp x1 x2)+ x3 <- get+ return (Imp x1 x2 x3) 1 -> do x1 <- get x2 <- get- return (Exp x1 x2)+ x3 <- get+ return (Exp x1 x2 x3) 2 -> do x1 <- get x2 <- get- return (Constraint x1 x2)+ x3 <- get+ return (Constraint x1 x2 x3) 3 -> do x1 <- get x2 <- get x3 <- get- return (TacImp x1 x2 x3)+ x4 <- get+ return (TacImp x1 x2 x3 x4) _ -> error "Corrupted binary data for Plicity" @@ -867,22 +901,26 @@ put x1 put x2 put x3- PTy x1 x2 x3 x4 x5 -> do putWord8 1+ PTy x1 x2 x3 x4 x5 x6+ -> do putWord8 1 put x1 put x2 put x3 put x4 put x5+ put x6 PClauses x1 x2 x3 x4 -> do putWord8 2 put x1 put x2 put x3 put x4- PData x1 x2 x3 x4 -> do putWord8 3+ PData x1 x2 x3 x4 x5 -> + do putWord8 3 put x1 put x2 put x3 put x4+ put x5 PParams x1 x2 x3 -> do putWord8 4 put x1 put x2@@ -890,20 +928,25 @@ PNamespace x1 x2 -> do putWord8 5 put x1 put x2- PRecord x1 x2 x3 x4 x5 x6 -> do putWord8 6+ PRecord x1 x2 x3 x4 x5 x6 x7 x8 -> + do putWord8 6 put x1 put x2 put x3 put x4 put x5 put x6- PClass x1 x2 x3 x4 x5 x6 -> do putWord8 7+ put x7+ put x8+ PClass x1 x2 x3 x4 x5 x6 x7+ -> do putWord8 7 put x1 put x2 put x3 put x4 put x5 put x6+ put x7 PInstance x1 x2 x3 x4 x5 x6 x7 x8 -> do putWord8 8 put x1 put x2@@ -923,6 +966,14 @@ PMutual x1 x2 -> do putWord8 11 put x1 put x2+ PPostulate x1 x2 x3 x4 x5 x6+ -> do putWord8 12+ put x1+ put x2+ put x3+ put x4+ put x5+ put x6 get = do i <- getWord8 case i of@@ -935,7 +986,8 @@ x3 <- get x4 <- get x5 <- get- return (PTy x1 x2 x3 x4 x5)+ x6 <- get+ return (PTy x1 x2 x3 x4 x5 x6) 2 -> do x1 <- get x2 <- get x3 <- get@@ -945,7 +997,8 @@ x2 <- get x3 <- get x4 <- get- return (PData x1 x2 x3 x4)+ x5 <- get+ return (PData x1 x2 x3 x4 x5) 4 -> do x1 <- get x2 <- get x3 <- get@@ -959,14 +1012,17 @@ x4 <- get x5 <- get x6 <- get- return (PRecord x1 x2 x3 x4 x5 x6)+ x7 <- get+ x8 <- get+ return (PRecord x1 x2 x3 x4 x5 x6 x7 x8) 7 -> do x1 <- get x2 <- get x3 <- get x4 <- get x5 <- get x6 <- get- return (PClass x1 x2 x3 x4 x5 x6)+ x7 <- get+ return (PClass x1 x2 x3 x4 x5 x6 x7) 8 -> do x1 <- get x2 <- get x3 <- get@@ -986,6 +1042,13 @@ 11 -> do x1 <- get x2 <- get return (PMutual x1 x2)+ 12 -> do x1 <- get+ x2 <- get+ x3 <- get+ x4 <- get+ x5 <- get+ x6 <- get+ return (PPostulate x1 x2 x3 x4 x5 x6) _ -> error "Corrupted binary data for PDecl'" instance Binary SyntaxInfo where@@ -1147,7 +1210,7 @@ put x2 PHidden x1 -> do putWord8 16 put x1- PSet -> putWord8 17+ PType -> putWord8 17 PConstant x1 -> do putWord8 18 put x1 Placeholder -> putWord8 19@@ -1168,6 +1231,9 @@ PPatvar x1 x2 -> do putWord8 28 put x1 put x2+ PInferRef x1 x2 -> do putWord8 29+ put x1+ put x2 get = do i <- getWord8 case i of@@ -1228,7 +1294,7 @@ return (PAlternative x1 x2) 16 -> do x1 <- get return (PHidden x1)- 17 -> return PSet+ 17 -> return PType 18 -> do x1 <- get return (PConstant x1) 19 -> return Placeholder@@ -1249,6 +1315,9 @@ 28 -> do x1 <- get x2 <- get return (PPatvar x1 x2)+ 29 -> do x1 <- get+ x2 <- get+ return (PInferRef x1 x2) _ -> error "Corrupted binary data for PTerm" instance (Binary t) => Binary (PTactic' t) where@@ -1282,6 +1351,8 @@ put x1 put x2 Qed -> putWord8 15+ ReflectTac x1 -> do putWord8 16+ put x1 get = do i <- getWord8 case i of@@ -1313,6 +1384,8 @@ x2 <- get return (TSeq x1 x2) 15 -> return Qed+ 16 -> do x1 <- get+ return (ReflectTac x1) _ -> error "Corrupted binary data for PTactic'" @@ -1368,25 +1441,33 @@ instance (Binary t) => Binary (PArg' t) where put x = case x of- PImp x1 x2 x3 x4 -> do putWord8 0+ PImp x1 x2 x3 x4 x5 -> + do putWord8 0 put x1 put x2 put x3 put x4- PExp x1 x2 x3 -> do putWord8 1+ put x5+ PExp x1 x2 x3 x4 -> + do putWord8 1 put x1 put x2 put x3- PConstraint x1 x2 x3 -> do putWord8 2+ put x4+ PConstraint x1 x2 x3 x4 -> + do putWord8 2 put x1 put x2 put x3- PTacImplicit x1 x2 x3 x4 x5 -> do putWord8 3+ put x4+ PTacImplicit x1 x2 x3 x4 x5 x6 -> + do putWord8 3 put x1 put x2 put x3 put x4 put x5+ put x6 get = do i <- getWord8 case i of@@ -1394,21 +1475,25 @@ x2 <- get x3 <- get x4 <- get- return (PImp x1 x2 x3 x4)+ x5 <- get+ return (PImp x1 x2 x3 x4 x5) 1 -> do x1 <- get x2 <- get x3 <- get- return (PExp x1 x2 x3)+ x4 <- get+ return (PExp x1 x2 x3 x4) 2 -> do x1 <- get x2 <- get x3 <- get- return (PConstraint x1 x2 x3)+ x4 <- get+ return (PConstraint x1 x2 x3 x4) 3 -> do x1 <- get x2 <- get x3 <- get x4 <- get x5 <- get- return (PTacImplicit x1 x2 x3 x4 x5)+ x6 <- get+ return (PTacImplicit x1 x2 x3 x4 x5 x6) _ -> error "Corrupted binary data for PArg'"
src/Idris/Imports.hs view
@@ -29,9 +29,9 @@ ibcPath ibcsd use_ibcsd fp = let (d_fp, n_fp) = splitFileName fp d = if (not use_ibcsd) || ibcsd == "" then d_fp- else d_fp ++ ibcsd ++ "/"+ else d_fp </> ibcsd n = dropExtension n_fp- in d ++ n ++ ".ibc"+ in d </> n <.> "ibc" ibcPathWithFallback :: FilePath -> FilePath -> IO FilePath ibcPathWithFallback ibcsd fp = do let ibcp = ibcPath ibcsd True fp@@ -45,7 +45,7 @@ findImport :: [FilePath] -> FilePath -> FilePath -> IO IFileType findImport [] ibcsd fp = fail $ "Can't find import " ++ fp-findImport (d:ds) ibcsd fp = do let fp_full = d ++ "/" ++ fp+findImport (d:ds) ibcsd fp = do let fp_full = d </> fp ibcp <- ibcPathWithFallback ibcsd fp_full let idrp = srcPath fp_full let lidrp = lsrcPath fp_full@@ -68,7 +68,7 @@ findInPath :: [FilePath] -> FilePath -> IO FilePath findInPath [] fp = fail $ "Can't find file " ++ fp-findInPath (d:ds) fp = do let p = d ++ "/" ++ fp+findInPath (d:ds) fp = do let p = d </> fp e <- doesFileExist p if e then return p else findInPath ds p
src/Idris/Parser.hs view
@@ -25,6 +25,7 @@ import qualified Text.Parsec.Token as PTok import Data.List+import Data.List.Split(splitOn) import Control.Monad.State import Debug.Trace import Data.Maybe@@ -35,7 +36,7 @@ type IParser = GenParser Char IState lexer :: TokenParser IState-lexer = PTok.makeTokenParser idrisDef+lexer = idrisLexer whiteSpace = PTok.whiteSpace lexer lexeme = PTok.lexeme lexer@@ -54,6 +55,9 @@ chlit = PTok.charLiteral lexer lchar = lexeme.char +fixErrorMsg :: String -> [String] -> String+fixErrorMsg msg fixes = msg ++ ", possible fixes:\n" ++ (concat $ intersperse "\n\nor\n\n" fixes)+ -- Loading modules loadModule :: FilePath -> Idris String@@ -96,40 +100,42 @@ mapM_ (addIBC . IBCImport) modules ds' <- parseProg (defaultSyntax {syn_namespace = reverse mname }) f rest pos- let ds = namespaces mname ds'- logLvl 3 (dumpDecls ds)- i <- getIState- logLvl 10 (show (toAlist (idris_implicits i)))- logLvl 3 (show (idris_infixes i))- -- Now add all the declarations to the context- v <- verbose- when v $ iputStrLn $ "Type checking " ++ f- elabDecls toplevel ds- i <- get- -- simplify every definition do give the totality checker- -- a better chance- mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n- updateContext (simplifyCasedef n))- (map snd (idris_totcheck i))- -- build size change graph from simplified definitions- iLOG "Totality checking"- i <- get--- mapM_ buildSCG (idris_totcheck i)- mapM_ checkDeclTotality (idris_totcheck i)- iLOG ("Finished " ++ f)- ibcsd <- valIBCSubDir i- let ibc = ibcPathNoFallback ibcsd f- iLOG "Universe checking"- iucheck- i <- getIState- addHides (hide_list i)- ok <- noErrors- when ok $- idrisCatch (do writeIBC f ibc; clearIBC)- (\c -> return ()) -- failure is harmless- i <- getIState- putIState (i { default_total = def_total,- hide_list = [] })+ unless (null ds') $ do+ let ds = namespaces mname ds'+ logLvl 3 (dumpDecls ds)+ i <- getIState+ logLvl 10 (show (toAlist (idris_implicits i)))+ logLvl 3 (show (idris_infixes i))+ -- Now add all the declarations to the context+ v <- verbose+ when v $ iputStrLn $ "Type checking " ++ f+ elabDecls toplevel ds+ i <- get+ -- simplify every definition do give the totality checker+ -- a better chance+ mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n+ updateContext (simplifyCasedef n))+ (map snd (idris_totcheck i))+ -- build size change graph from simplified definitions+ iLOG "Totality checking"+ i <- get+ mapM_ buildSCG (idris_totcheck i)+ mapM_ checkDeclTotality (idris_totcheck i)+ iLOG ("Finished " ++ f)+ ibcsd <- valIBCSubDir i+ let ibc = ibcPathNoFallback ibcsd f+ iLOG "Universe checking"+ iucheck+ i <- getIState+ addHides (hide_list i)+ ok <- noErrors+ when ok $+ idrisCatch (do writeIBC f ibc; clearIBC)+ (\c -> return ()) -- failure is harmless+ i <- getIState+ putIState (i { default_total = def_total,+ hide_list = [] })+ return () return () where namespaces [] ds = ds@@ -154,12 +160,6 @@ eof return t) i "(proof)" -iShowError fname err = let ln = sourceLine (errorPos err)- clm = sourceColumn (errorPos err)- msg = map messageString (errorMessages err) in- fname ++ ":" ++ show ln ++ ":parse error"- ++ " at column " ++ show clm -- ++ " with error:\n\t" ++ show msg- parseImports :: FilePath -> String -> Idris ([String], [String], String, SourcePos) parseImports fname input = do i <- get@@ -169,7 +169,7 @@ rest <- getInput pos <- getPosition return ((mname, ps, rest, pos), i)) i fname input of- Left err -> fail (iShowError fname err)+ Left err -> fail (show err) Right (x, i) -> do put i return x @@ -212,14 +212,13 @@ closeBlock :: IParser () closeBlock = do ist <- getState bs <- case brace_stack ist of- Nothing : xs -> do lchar '}'- return xs- Just lvl : xs -> do i <- indent- inp <- getInput+ Nothing : xs -> (lchar '}' >> return xs) <|> (eof >> return [])+ Just lvl : xs -> (do i <- indent+ inp <- getInput -- trace (show (take 10 inp, i, lvl)) $- if i >= lvl && take 1 inp /= ")" - then fail "Not end of block"- else return xs+ if i >= lvl && take 1 inp /= ")" + then fail "Not end of block"+ else return xs) <|> (eof >> return []) setState (ist { brace_stack = bs }) pTerminator = do lchar ';'; popIndent@@ -262,18 +261,19 @@ pfc :: IParser FC pfc = do s <- getPosition let (dir, file) = splitFileName (sourceName s)- let f = case dir of- "./" -> file- _ -> sourceName s+ let f = if dir == addTrailingPathSeparator "." then file else sourceName s return $ FC f (sourceLine s) pImport :: IParser String pImport = do reserved "import"; f <- identifier; option ';' (lchar ';')- return (map dot f)- where dot '.' = '/'- dot c = c+ return (toPath f)+ where toPath n = foldl1 (</>) $ splitOn "." n -parseProg :: SyntaxInfo -> FilePath -> String -> SourcePos -> Idris [PDecl]+-- a program is a list of declarations, possibly with associated+-- documentation strings++parseProg :: SyntaxInfo -> FilePath -> String -> SourcePos -> + Idris [PDecl] parseProg syn fname input pos = do i <- get case runParser (do setPosition pos@@ -282,7 +282,8 @@ eof i' <- getState return (concat ps, i')) i fname input of- Left err -> fail (iShowError fname err)+ Left err -> do iputStrLn (show err)+ return [] Right (x, i) -> do put i return (collect x) @@ -308,7 +309,8 @@ collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds-collect (PClass f s cs n ps ds : ds') = PClass f s cs n ps (collect ds) : collect ds'+collect (PClass doc f s cs n ps ds : ds') + = PClass doc f s cs n ps (collect ds) : collect ds' collect (PInstance f s cs n ps t en ds : ds') = PInstance f s cs n ps t en (collect ds) : collect ds' collect (d : ds) = d : collect ds@@ -352,10 +354,10 @@ pDecl' :: SyntaxInfo -> IParser PDecl pDecl' syn = try pFixity- <|> pFunDecl' syn+ <|> try (pFunDecl' syn) <|> try (pData syn) <|> try (pRecord syn)- <|> pSyntaxDecl syn+ <|> try (pSyntaxDecl syn) pSyntaxDecl :: SyntaxInfo -> IParser PDecl pSyntaxDecl syn@@ -388,7 +390,7 @@ when (length ns /= length (nub ns)) $ fail "Repeated variable in syntax rule" lchar '='- tm <- pExpr (impOK syn)+ tm <- pTExpr (impOK syn) pTerminator return (Rule (mkSimple syms) tm sty) where@@ -418,7 +420,8 @@ return (Symbol sym) pFunDecl' :: SyntaxInfo -> IParser PDecl-pFunDecl' syn = try (do pushIndent+pFunDecl' syn = try (do doc <- option "" (pDocComment '|')+ pushIndent ist <- getState let initOpts = if default_total ist then [TotalFn]@@ -433,10 +436,31 @@ pTerminator -- ty' <- implicit syn n ty addAcc n acc- return (PTy syn fc opts' n ty))+ return (PTy doc syn fc opts' n ty))+ <|> try (pPostulate syn) <|> try (pPattern syn) <|> try (pCAF syn) +pPostulate :: SyntaxInfo -> IParser PDecl+pPostulate syn = do doc <- option "" (pDocComment '|')+ pushIndent+ reserved "postulate"+ ist <- getState+ let initOpts = if default_total ist+ then [TotalFn]+ else []+ opts <- pFnOpts initOpts+ acc <- pAccessibility+ opts' <- pFnOpts opts+ n_in <- pfName+ let n = expandNS syn n_in+ ty <- pTSig (impOK syn)+ fc <- pfc+ pTerminator + addAcc n acc+ return (PPostulate doc syn fc opts' n ty)++ pUsing :: SyntaxInfo -> IParser [PDecl] pUsing syn = do reserved "using"; lchar '('; ns <- tyDeclList syn; lchar ')'@@ -482,13 +506,27 @@ pTerminator let prec = fromInteger i istate <- getState- let fs = map (Fix (f prec)) ops- setState (istate { - idris_infixes = nub $ sort (fs ++ idris_infixes istate),- ibc_write = map IBCFix fs ++ ibc_write istate })- fc <- pfc- return (PFix fc (f prec) ops)+ let infixes = idris_infixes istate+ let fs = map (Fix (f prec)) ops+ let redecls = map (alreadyDeclared infixes) fs+ let ill = filter (not . checkValidity) redecls+ if null ill+ then do setState (istate { idris_infixes = nub $ sort (fs ++ infixes)+ , ibc_write = map IBCFix fs ++ ibc_write istate+ })+ fc <- pfc+ return (PFix fc (f prec) ops)+ else fail $ concatMap (\(f, (x:xs)) -> "Illegal redeclaration of fixity:\n\t\""+ ++ show f ++ "\" overrides \"" ++ show x ++ "\"") ill+ where alreadyDeclared :: [FixDecl] -> FixDecl -> (FixDecl, [FixDecl])+ alreadyDeclared fs f = (f, filter ((extractName f ==) . extractName) fs) + checkValidity :: (FixDecl, [FixDecl]) -> Bool+ checkValidity (f, fs) = all (== f) fs++ extractName :: FixDecl -> String+ extractName (Fix _ n) = n+ fixity :: IParser (Int -> Fixity) fixity = try (do reserved "infixl"; return Infixl) <|> try (do reserved "infixr"; return Infixr)@@ -498,7 +536,8 @@ --------- Type classes --------- pClass :: SyntaxInfo -> IParser [PDecl]-pClass syn = do acc <- pAccessibility+pClass syn = do doc <- option "" (pDocComment '|')+ acc <- pAccessibility reserved "class"; fc <- pfc; cons <- pConstList syn; n_in <- pName let n = expandNS syn n_in cs <- many1 carg@@ -507,12 +546,12 @@ closeBlock let allDs = concat ds accData acc n (concatMap declared allDs)- return [PClass syn fc cons n cs allDs]+ return [PClass doc syn fc cons n cs allDs] where carg = do lchar '('; i <- pName; lchar ':'; ty <- pExpr syn; lchar ')' return (i, ty) <|> do i <- pName;- return (i, PSet)+ return (i, PType) pInstance :: SyntaxInfo -> IParser [PDecl] pInstance syn = do reserved "instance"; fc <- pfc@@ -560,7 +599,7 @@ pNoExtExpr syn = try (pApp syn) - <|> pRecordSet syn+ <|> pRecordType syn <|> try (pSimpleExpr syn) <|> pLambda syn <|> pLet syn@@ -699,6 +738,7 @@ pSimpleExpr syn = try (do symbol "!["; t <- pTerm; lchar ']'; return $ PQuote t) <|> do lchar '?'; x <- pName; return (PMetavar x)+ <|> do lchar '%'; fc <- pfc; reserved "instance"; return (PResolveTC fc) <|> do reserved "refl"; fc <- pfc; tm <- option Placeholder (do lchar '{'; t <- pExpr syn; lchar '}'; return t)@@ -710,6 +750,9 @@ <|> try (do x <- pfName fc <- pfc return (PRef fc x))+ <|> try (do lchar '!'; x <- pfName+ fc <- pfc+ return (PInferRef fc x)) <|> try (pList syn) <|> try (pAlt syn) <|> try (pIdiom syn)@@ -718,7 +761,7 @@ <|> try (do c <- pConstant fc <- pfc return (modifyConst syn fc (PConstant c)))- <|> do reserved "Set"; return PSet+ <|> do reserved "Type"; return PType <|> try (do symbol "()" fc <- pfc return (PTrue fc))@@ -744,14 +787,18 @@ pexp (PRef fc (MN 1000 "ARG"))])) pCaseOpt :: SyntaxInfo -> IParser (PTerm, PTerm)-pCaseOpt syn = do lhs <- pExpr syn; symbol "=>"; rhs <- pExpr syn+pCaseOpt syn = do lhs <- pExpr (syn { inPattern = True }) + symbol "=>"; rhs <- pExpr syn return (lhs, rhs) modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm modifyConst syn fc (PConstant (I x)) | not (inPattern syn)- = PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))]- | otherwise = PConstant (I x)+ = PAlternative False+ [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))],+ PConstant (I x), PConstant (BI (toEnum x))]+ | otherwise = PAlternative False+ [PConstant (I x), PConstant (BI (toEnum x))] modifyConst syn fc x = x pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']'@@ -834,10 +881,10 @@ symbol "}" return (pconst e) -pRecordSet syn +pRecordType syn = do reserved "record" lchar '{'- fields <- sepBy1 pFieldSet (lchar ',')+ fields <- sepBy1 pFieldType (lchar ',') lchar '}' fc <- pfc rec <- option Nothing (do e <- pSimpleExpr syn@@ -847,26 +894,27 @@ return (PLam (MN 0 "fldx") Placeholder (applyAll fc fields (PRef fc (MN 0 "fldx")))) Just v -> return (applyAll fc fields v)- where pFieldSet = do n <- pfName- lchar '='- e <- pExpr syn- return (n, e)+ where pFieldType = do n <- pfName+ lchar '='+ e <- pExpr syn+ return (n, e) applyAll fc [] x = x applyAll fc ((n, e) : es) x- = applyAll fc es (PApp fc (PRef fc (mkSet n)) [pexp e, pexp x])+ = applyAll fc es (PApp fc (PRef fc (mkType n)) [pexp e, pexp x]) -mkSet (UN n) = UN ("set_" ++ n)-mkSet (MN 0 n) = MN 0 ("set_" ++ n)-mkSet (NS n s) = NS (mkSet n) s+mkType (UN n) = UN ("set_" ++ n)+mkType (MN 0 n) = MN 0 ("set_" ++ n)+mkType (NS n s) = NS (mkType n) s noImp syn = syn { implicitAllowed = False } impOK syn = syn { implicitAllowed = True } -pTSig syn = do lchar ':'- cs <- if implicitAllowed syn then pConstList syn else return []- sc <- pExpr syn - return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc)+pTSig syn = do lchar ':'; pTExpr syn +pTExpr syn = do cs <- if implicitAllowed syn then pConstList syn else return []+ sc <- pExpr syn + return (bindList (PPi constraint) (map (\x -> (MN 0 "c", x)) cs) sc)+ pLambda syn = do lchar '\\' try (do xt <- tyOptDeclList syn symbol "=>"@@ -899,9 +947,10 @@ try (do lazy <- option False (do lchar '|'; return True) st <- pStatic lchar '('; xt <- tyDeclList syn; lchar ')'+ doc <- option "" (pDocComment '^') symbol "->" sc <- pExpr syn- return (bindList (PPi (Exp lazy st)) xt sc))+ return (bindList (PPi (Exp lazy st doc)) xt sc)) <|> try (if implicitAllowed syn then do lazy <- option False (do lchar '|' return True)@@ -911,7 +960,7 @@ lchar '}' symbol "->" sc <- pExpr syn- return (bindList (PPi (Imp lazy st)) xt sc)+ return (bindList (PPi (Imp lazy st "")) xt sc) else fail "No implicit arguments allowed here") <|> try (do lchar '{' reserved "auto"@@ -919,7 +968,8 @@ lchar '}' symbol "->" sc <- pExpr syn- return (bindList (PPi (TacImp False Dynamic (PTactics [Trivial]))) xt sc))+ return (bindList (PPi + (TacImp False Dynamic (PTactics [Trivial]) "")) xt sc)) <|> try (do lchar '{' reserved "default" script <- pSimpleExpr syn @@ -927,7 +977,7 @@ lchar '}' symbol "->" sc <- pExpr syn- return (bindList (PPi (TacImp False Dynamic script)) xt sc))+ return (bindList (PPi (TacImp False Dynamic script "")) xt sc)) <|> do --lazy <- option False (do lchar '|'; return True) lchar '{' reserved "static"@@ -935,7 +985,7 @@ t <- pExpr' syn symbol "->" sc <- pExpr syn- return (PPi (Exp False Static) (MN 42 "__pi_arg") t sc)+ return (PPi (Exp False Static "") (MN 42 "__pi_arg") t sc) pConstList :: SyntaxInfo -> IParser [PTerm] pConstList syn = try (do lchar '(' @@ -1034,6 +1084,8 @@ <|> do reserved "Float"; return FlType <|> do reserved "String"; return StrType <|> do reserved "Ptr"; return PtrType+ <|> do reserved "Word8"; return W8Type+ <|> do reserved "Word16"; return W16Type <|> try (do f <- float; return $ Fl f) -- <|> try (do i <- natural; lchar 'L'; return $ BI i) <|> try (do i <- natural; return $ I (fromInteger i))@@ -1067,6 +1119,7 @@ binary name f = Infix (do reservedOp name fc <- pfc; + doc <- option "" (pDocComment '^') return (f fc)) prefix name f = Prefix (do reservedOp name fc <- pfc;@@ -1086,7 +1139,8 @@ mapM_ (`addAcc` a) ns pRecord :: SyntaxInfo -> IParser PDecl-pRecord syn = do acc <- pAccessibility+pRecord syn = do doc <- option "" (pDocComment '|')+ acc <- pAccessibility reserved "record" fc <- pfc tyn_in <- pfName@@ -1095,7 +1149,7 @@ reserved "where" openBlock pushIndent- (cn, cty, _) <- pConstructor syn+ (cdoc, cn, cty, _) <- pConstructor syn pKeepTerminator popIndent closeBlock@@ -1103,10 +1157,10 @@ let rsyn = syn { syn_namespace = show (nsroot tyn) : syn_namespace syn } let fns = getRecNames rsyn cty- mapM_ (\n -> addAcc n (toFreeze acc)) fns- return $ PRecord rsyn fc tyn ty cn cty+ mapM_ (\n -> addAcc n acc) fns+ return $ PRecord doc rsyn fc tyn ty cdoc cn cty where- getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkSet n)]+ getRecNames syn (PPi _ n _ sc) = [expandNS syn n, expandNS syn (mkType n)] ++ getRecNames syn sc getRecNames _ _ = [] @@ -1117,13 +1171,14 @@ <|> do reserved "codata"; return True pData :: SyntaxInfo -> IParser PDecl-pData syn = try (do acc <- pAccessibility+pData syn = try (do doc <- option "" (pDocComment '|')+ acc <- pAccessibility co <- pDataI fc <- pfc tyn_in <- pfName ty <- pTSig (impOK syn) let tyn = expandNS syn tyn_in- option (PData syn fc co (PLaterdecl tyn ty)) (do+ option (PData doc syn fc co (PLaterdecl tyn ty)) (do reserved "where" openBlock pushIndent@@ -1133,26 +1188,38 @@ return c) -- (lchar '|') popIndent closeBlock - accData acc tyn (map (\ (n, _, _) -> n) cons)- return $ PData syn fc co (PDatadecl tyn ty cons)))- <|> try (do pushIndent+ accData acc tyn (map (\ (_, n, _, _) -> n) cons)+ return $ PData doc syn fc co (PDatadecl tyn ty cons)))+ <|> try (do doc <- option "" (pDocComment '|')+ pushIndent acc <- pAccessibility co <- pDataI fc <- pfc tyn_in <- pfName args <- many pName- let ty = bindArgs (map (const PSet) args) PSet+ let ty = bindArgs (map (const PType) args) PType let tyn = expandNS syn tyn_in- option (PData syn fc co (PLaterdecl tyn ty)) (do- lchar '='+ option (PData doc syn fc co (PLaterdecl tyn ty)) (do+ try (lchar '=') <|> do reserved "where"+ let kw = (if co then "co" else "") ++ "data "+ let n = show tyn_in ++ " "+ let s = kw ++ n + let as = concat (intersperse " " $ map show args) ++ " "+ let ns = concat (intersperse " -> " $ map ((\x -> "(" ++ x ++ " : Type)") . show) args)+ let ss = concat (intersperse " -> " $ map (const "Type") args)+ let fix1 = s ++ as ++ " = ..."+ let fix2 = s ++ ": " ++ ns ++ " -> Type where\n ..."+ let fix3 = s ++ ": " ++ ss ++ " -> Type where\n ..."+ fail $ fixErrorMsg "unexpected \"where\"" [fix1, fix2, fix3]+ cons <- sepBy1 (pSimpleCon syn) (lchar '|') pTerminator let conty = mkPApp fc (PRef fc tyn) (map (PRef fc) args)- cons' <- mapM (\ (x, cargs, cfc) -> + cons' <- mapM (\ (doc, x, cargs, cfc) -> do let cty = bindArgs cargs conty- return (x, cty, cfc)) cons- accData acc tyn (map (\ (n, _, _) -> n) cons')- return $ PData syn fc co (PDatadecl tyn ty cons')))+ return (doc, x, cty, cfc)) cons+ accData acc tyn (map (\ (_, n, _, _) -> n) cons')+ return $ PData doc syn fc co (PDatadecl tyn ty cons'))) where mkPApp fc t [] = t mkPApp fc t xs = PApp fc t (map pexp xs)@@ -1160,23 +1227,25 @@ bindArgs :: [PTerm] -> PTerm -> PTerm bindArgs xs t = foldr (PPi expl (MN 0 "t")) t xs -pConstructor :: SyntaxInfo -> IParser (Name, PTerm, FC)+pConstructor :: SyntaxInfo -> IParser (String, Name, PTerm, FC) pConstructor syn - = do cn_in <- pfName; fc <- pfc+ = do doc <- option "" (pDocComment '|')+ cn_in <- pfName; fc <- pfc let cn = expandNS syn cn_in ty <- pTSig (impOK syn) -- ty' <- implicit syn cn ty- return (cn, ty, fc)+ return (doc, cn, ty, fc) -pSimpleCon :: SyntaxInfo -> IParser (Name, [PTerm], FC)+pSimpleCon :: SyntaxInfo -> IParser (String, Name, [PTerm], FC) pSimpleCon syn = do cn_in <- pfName let cn = expandNS syn cn_in fc <- pfc args <- many (do notEndApp pSimpleExpr syn)- return (cn, args, fc)+ doc <- option "" (pDocComment '^')+ return (doc, cn, args, fc) --------- DSL syntax overloading --------- @@ -1258,7 +1327,7 @@ = try (do pushIndent n_in <- pfName; let n = expandNS syn n_in cargs <- many (pConstraintArg syn)- iargs <- many (pImplicitArg syn)+ iargs <- many (pImplicitArg (syn { inPattern = True } )) fc <- pfc args <- many (pArgExpr syn) wargs <- many (pWExpr syn)@@ -1296,7 +1365,7 @@ <|> try (do pushIndent n_in <- pfName; let n = expandNS syn n_in cargs <- many (pConstraintArg syn)- iargs <- many (pImplicitArg syn)+ iargs <- many (pImplicitArg (syn { inPattern = True } )) fc <- pfc args <- many (pArgExpr syn) wargs <- many (pWExpr syn)@@ -1423,15 +1492,22 @@ <|> do reserved "rewrite"; t <- pExpr syn; i <- getState return $ Rewrite (desugar syn i t)- <|> do reserved "let"; n <- pName; lchar '=';- t <- pExpr syn;- i <- getState- return $ LetTac n (desugar syn i t)+ <|> try (do reserved "let"; n <- pName; lchar ':'; + ty <- pExpr' syn; lchar '='; t <- pExpr syn;+ i <- getState+ return $ LetTacTy n (desugar syn i ty) (desugar syn i t))+ <|> try (do reserved "let"; n <- pName; lchar '=';+ t <- pExpr syn;+ i <- getState+ return $ LetTac n (desugar syn i t)) <|> do reserved "focus"; n <- pName return $ Focus n <|> do reserved "exact"; t <- pExpr syn; i <- getState return $ Exact (desugar syn i t)+ <|> do reserved "reflect"; t <- pExpr syn;+ i <- getState+ return $ ReflectTac (desugar syn i t) <|> do reserved "try"; t <- pTactic syn; lchar '|'; t1 <- pTactic syn
src/Idris/Primitives.hs view
@@ -10,6 +10,7 @@ import Core.TT import Core.Evaluate+import Data.Bits data Prim = Prim { p_name :: Name, p_type :: Type,@@ -22,8 +23,8 @@ ty [] x = Constant x ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x) -believeTy = Bind (UN "a") (Pi (Set (UVar (-2))))- (Bind (UN "b") (Pi (Set (UVar (-2))))+believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))+ (Bind (UN "b") (Pi (TType (UVar (-2)))) (Bind (UN "x") (Pi (V 1)) (V 1))) total = Total []@@ -37,8 +38,22 @@ (2, LMinus) total, Prim (UN "prim__mulInt") (ty [IType, IType] IType) 2 (iBin (*)) (2, LTimes) total,- Prim (UN "prim__divInt") (ty [IType, IType] IType) 2 (iBin (div))+ Prim (UN "prim__divInt") (ty [IType, IType] IType) 2 (iBin div) (2, LDiv) partial,+ Prim (UN "prim__modInt") (ty [IType, IType] IType) 2 (iBin mod)+ (2, LMod) partial,+ Prim (UN "prim__andInt") (ty [IType, IType] IType) 2 (iBin (.&.))+ (2, LAnd) partial,+ Prim (UN "prim__orInt") (ty [IType, IType] IType) 2 (iBin (.|.))+ (2, LOr) partial,+ Prim (UN "prim__xorInt") (ty [IType, IType] IType) 2 (iBin xor)+ (2, LXOr) partial,+ Prim (UN "prim__shLInt") (ty [IType, IType] IType) 2 (iBin shiftL)+ (2, LSHL) partial,+ Prim (UN "prim__shRInt") (ty [IType, IType] IType) 2 (iBin shiftR)+ (2, LSHR) partial,+ Prim (UN "prim__complInt") (ty [IType] IType) 1 (iUn complement)+ (1, LCompl) partial, Prim (UN "prim__eqInt") (ty [IType, IType] IType) 2 (biBin (==)) (2, LEq) total, Prim (UN "prim__ltInt") (ty [IType, IType] IType) 2 (biBin (<))@@ -59,15 +74,36 @@ (2, LGt) total, Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=)) (2, LGe) total,++ Prim (UN "prim__addW8") (ty [W8Type, W8Type] W8Type) 2 (w8Bin (+))+ (2, LW8Plus) total,+ Prim (UN "prim__subW8") (ty [W8Type, W8Type] W8Type) 2 (w8Bin (-))+ (2, LW8Minus) total,+ Prim (UN "prim__mulW8") (ty [W8Type, W8Type] W8Type) 2 (w8Bin (*))+ (2, LW8Times) total,++ Prim (UN "prim__addW16") (ty [W16Type, W16Type] W16Type) 2 (w16Bin (+))+ (2, LW16Plus) total,+ Prim (UN "prim__subW16") (ty [W16Type, W16Type] W16Type) 2 (w16Bin (-))+ (2, LW16Minus) total,+ Prim (UN "prim__mulW16") (ty [W16Type, W16Type] W16Type) 2 (w16Bin (*))+ (2, LW16Times) total,++ Prim (UN "prim__intToWord8") (ty [IType] W8Type) 1 intToWord8+ (1, LW8) total,+ Prim (UN "prim__intToWord16") (ty [IType] W16Type) 1 intToWord16+ (1, LW16) total,+ Prim (UN "prim__addBigInt") (ty [BIType, BIType] BIType) 2 (bBin (+))- (2, LBPlus) total, Prim (UN "prim__subBigInt") (ty [BIType, BIType] BIType) 2 (bBin (-)) (2, LBMinus) total, Prim (UN "prim__mulBigInt") (ty [BIType, BIType] BIType) 2 (bBin (*)) (2, LBTimes) total,- Prim (UN "prim__divBigInt") (ty [BIType, BIType] BIType) 2 (bBin (div))+ Prim (UN "prim__divBigInt") (ty [BIType, BIType] BIType) 2 (bBin div) (2, LBDiv) partial,+ Prim (UN "prim__modBigInt") (ty [BIType, BIType] BIType) 2 (bBin mod)+ (2, LBMod) partial, Prim (UN "prim__eqBigInt") (ty [BIType, BIType] IType) 2 (bbBin (==)) (2, LBEq) total, Prim (UN "prim__ltBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<))@@ -108,9 +144,9 @@ Prim (UN "prim__intToStr") (ty [IType] StrType) 1 (c_intToStr) (1, LIntStr) total, Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)- (1, LNoOp) total,+ (1, LChInt) total, Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)- (1, LNoOp) total,+ (1, LIntCh) total, Prim (UN "prim__intToBigInt") (ty [IType] BIType) 1 (c_intToBigInt) (1, LIntBig) total, Prim (UN "prim__bigIntToInt") (ty [BIType] IType) 1 (c_bigIntToInt)@@ -169,12 +205,15 @@ Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce) (0, LStdIn) partial, Prim (UN "prim__believe_me") believeTy 3 (p_believeMe)- (3, LNoOp) total -- ahem+ (3, LNoOp) partial -- ahem ] p_believeMe [_,_,x] = Just x p_believeMe _ = Nothing +iUn op [VConstant (I x)] = Just $ VConstant (I (op x))+iUn _ _ = Nothing+ iBin op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y)) iBin _ _ = Nothing @@ -206,6 +245,20 @@ sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y)) sBin _ _ = Nothing +w8Bin op [VConstant (W8 x), VConstant (W8 y)] = Just $ VConstant (W8 (op x y))+w8Bin _ _ = Nothing++w16Bin op [VConstant (W16 x), VConstant (W16 y)] = Just $ VConstant (W16 (op x y))+w16Bin _ _ = Nothing++-- w32Bin op [VConstant (W32 x), VConstant (W32 y)] = Just $ VConstant (W32 (op x y))+-- w32Bin _ _ = Nothing++intToWord8 [VConstant (I x)] = Just $ VConstant (W8 $ fromIntegral x)+intToWord8 _ = Nothing+intToWord16 [VConstant (I x)] = Just $ VConstant (W16 $ fromIntegral x)+intToWord16 _ = Nothing+ c_intToStr [VConstant (I x)] = Just $ VConstant (Str (show x)) c_intToStr _ = Nothing c_strToInt [VConstant (Str x)] = case reads x of@@ -281,7 +334,7 @@ elabPrims :: Idris () elabPrims = do mapM_ (elabDecl EAll toplevel) - (map (PData defaultSyntax (FC "builtin" 0) False)+ (map (PData "" defaultSyntax (FC "builtin" 0) False) [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]) mapM_ elabPrim primitives
src/Idris/Prover.hs view
@@ -32,7 +32,7 @@ showProof :: Bool -> Name -> [String] -> String showProof lit n ps = bird ++ show n ++ " = proof {" ++ break ++- showSep break (map (\x -> " " ++ x ++ ";") ps) +++ showSep break (map (\x -> " " ++ x ++ ";") ps) ++ break ++ "}\n" where bird = if lit then "> " else "" break = "\n" ++ bird@@ -50,7 +50,7 @@ logLvl 3 (show tree) (ptm, pty) <- recheckC (FC "proof" 0) [] tm ptm' <- applyOpts ptm- updateContext (addCasedef n True False True + updateContext (addCasedef n True False True False [Right (P Ref n ty, ptm)] [([], P Ref n ty, ptm)] [([], P Ref n ty, ptm')] ty)@@ -62,9 +62,9 @@ fail (pshow i a) dumpState :: IState -> ProofState -> IO ()-dumpState ist (PS nm [] _ tm _ _ _ _ _ _ _ _ _ _ _ _) =+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) = putStrLn . render $ pretty nm <> colon <+> text "No more goals."-dumpState ist ps@(PS nm (h:hs) _ tm _ _ _ _ _ problems i _ _ ctxy _ _) = do+dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ problems i _ _ ctxy _ _) = do let OK ty = goalAtFocus ps let OK env = envAtFocus ps putStrLn . render $
src/Idris/REPL.hs view
@@ -15,6 +15,7 @@ import Idris.Primitives import Idris.Coverage import Idris.UnusedArgs+import Idris.Docs import Paths_idris import Util.System@@ -26,6 +27,7 @@ import IRTS.Compiler import IRTS.LParser+import IRTS.CodegenCommon -- import RTS.SC -- import RTS.Bytecode@@ -177,7 +179,8 @@ -- [pexp t]) (tmpn, tmph) <- liftIO tempfile liftIO $ hClose tmph- compile ViaC tmpn tm+ t <- target+ compile t tmpn tm liftIO $ system tmpn return () where fc = FC "(input)" 0 @@ -196,6 +199,14 @@ let ty' = normaliseC ctxt [] ty iputStrLn (showImp imp (delab ist tm) ++ " : " ++ showImp imp (delab ist ty))++process fn (DocStr n) = do i <- get+ case lookupCtxtName Nothing n (idris_docstrings i) of+ [] -> iputStrLn $ "No documentation for " ++ show n+ ns -> mapM_ showDoc ns + where showDoc (n, d) + = do doc <- getDocs n+ iputStrLn $ show doc process fn Universes = do i <- get let cs = idris_constraints i -- iputStrLn $ showSep "\n" (map show cs)@@ -248,7 +259,7 @@ process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- get- let tm' = simplify ctxt [] {- (idris_statics ist) -} tm+ let tm' = simplify ctxt True [] {- (idris_statics ist) -} tm iputStrLn (show (delab ist tm')) process fn (RmProof n')@@ -312,7 +323,7 @@ process fn (HNF t) = do (tm, ty) <- elabVal toplevel False t ctxt <- getContext ist <- get- let tm' = simplify ctxt [] tm+ let tm' = hnf ctxt [] tm iputStrLn (show (delab ist tm')) process fn TTShell = do ist <- get let shst = initState (tt_ctxt ist)@@ -325,7 +336,8 @@ -- (PRef (FC "main" 0) (NS (UN "main") ["main"])) (tmpn, tmph) <- liftIO tempfile liftIO $ hClose tmph- compile ViaC tmpn m+ t <- target+ compile t tmpn m liftIO $ system tmpn return () where fc = FC "main" 0 @@ -349,7 +361,7 @@ process fn (Missing n) = do i <- get case lookupDef Nothing n (tt_ctxt i) of- [CaseOp _ _ _ _ args t _ _]+ [CaseOp _ _ _ _ _ args t _ _] -> do tms <- genMissing n args t iputStrLn (showSep "\n" (map (showImp True) tms)) [] -> iputStrLn $ show n ++ " undefined"@@ -404,6 +416,13 @@ l ++ take (c1 - length l) (repeat ' ') ++ m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n" +parseTarget :: String -> Target+parseTarget "C" = ViaC+parseTarget "Java" = ViaJava+parseTarget "bytecode" = Bytecode+parseTarget "javascript" = ToJavaScript+parseTarget _ = error "unknown target" -- FIXME: partial function+ parseArgs :: [String] -> [Opt] parseArgs [] = [] parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)@@ -434,9 +453,11 @@ parseArgs ("--clean":n:ns) = PkgClean n : (parseArgs ns) parseArgs ("--bytecode":n:ns) = NoREPL : BCAsm n : (parseArgs ns) parseArgs ("--fovm":n:ns) = NoREPL : FOVM n : (parseArgs ns)-parseArgs ("--dumpc":n:ns) = DumpC n : (parseArgs ns)+parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)+parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns) parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns) parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns)+parseArgs ("--target":n:ns) = UseTarget (parseTarget n) : (parseArgs ns) parseArgs (n:ns) = Filename n : (parseArgs ns) help =@@ -458,6 +479,7 @@ ([":showproof"], "<name>", "Show proof"), ([":proofs"], "", "Show available proofs"), ([":c",":compile"], "<filename>", "Compile to an executable <filename>"),+ ([":js", ":javascript"], "<filename>", "Compile to JavaScript <filename>"), ([":exec",":execute"], "", "Compile to an executable and run"), ([":?",":h",":help"], "", "Display this help text"), ([":set"], "<option>", "Set an option (errorcontext, showimplicits)"),@@ -480,21 +502,29 @@ let bcs = opt getBC opts let vm = opt getFOVM opts let pkgdirs = opt getPkgDir opts+ let outty = case opt getOutputTy opts of+ [] -> Executable+ xs -> last xs+ let tgt = case opt getTarget opts of+ [] -> ViaC+ xs -> last xs when (DefaultTotal `elem` opts) $ do i <- get put (i { default_total = True }) setREPL runrepl setVerbose runrepl setCmdLine opts+ setOutputTy outty+ setTarget tgt when (Verbose `elem` opts) $ setVerbose True mapM_ makeOption opts -- if we have the --fovm flag, drop into the first order VM testing case vm of- [] -> return ()- xs -> liftIO $ mapM_ fovm xs + [] -> return ()+ xs -> liftIO $ mapM_ (fovm tgt outty) xs -- if we have the --bytecode flag, drop into the bytecode assembler case bcs of- [] -> return ()- xs -> return () -- liftIO $ mapM_ bcAsm xs + [] -> return ()+ xs -> return () -- liftIO $ mapM_ bcAsm xs case ibcsubdir of [] -> setIBCSubDir "" (d:_) -> setIBCSubDir d@@ -510,7 +540,7 @@ ok <- noErrors when ok $ case output of [] -> return ()- (o:_) -> process "" (Compile ViaC o) + (o:_) -> process "" (Compile tgt o) when ok $ case newoutput of [] -> return () (o:_) -> process "" (NewCompile o) @@ -527,7 +557,7 @@ addPkgDir :: String -> Idris () addPkgDir p = do ddir <- liftIO $ getDataDir - addImportDir (ddir ++ "/" ++ p)+ addImportDir (ddir </> p) getFile :: Opt -> Maybe String getFile (Filename str) = Just str@@ -569,6 +599,14 @@ getPkgClean :: Opt -> Maybe String getPkgClean (PkgClean str) = Just str getPkgClean _ = Nothing++getTarget :: Opt -> Maybe Target+getTarget (UseTarget x) = Just x+getTarget _ = Nothing++getOutputTy :: Opt -> Maybe OutputType+getOutputTy (OutputTy t) = Just t+getOutputTy _ = Nothing opt :: (Opt -> Maybe a) -> [Opt] -> [a] opt = mapMaybe
src/Idris/REPLParser.hs view
@@ -1,5 +1,7 @@ module Idris.REPLParser(parseCmd) where +import System.FilePath ((</>))+ import Idris.Parser import Idris.AbsSyntax import Core.TT@@ -11,6 +13,7 @@ import Debug.Trace import Data.List+import Data.List.Split(splitOn) parseCmd i = runParser pCmd i "(input)" @@ -24,12 +27,13 @@ <|> try (do cmd ["h", "?", "help"]; eof; return Help) <|> try (do cmd ["r", "reload"]; eof; return Reload) <|> try (do cmd ["m", "module"]; f <- identifier; eof;- return (ModImport (map dot f)))+ return (ModImport (toPath f))) <|> try (do cmd ["e", "edit"]; eof; return Edit) <|> try (do cmd ["exec", "execute"]; eof; return Execute) <|> try (do cmd ["ttshell"]; eof; return TTShell) <|> try (do cmd ["c", "compile"]; f <- identifier; eof; return (Compile ViaC f)) <|> try (do cmd ["jc", "newcompile"]; f <- identifier; eof; return (Compile ViaJava f))+ <|> try (do cmd ["js", "javascript"]; f <- identifier; eof; return (Compile ToJavaScript f)) <|> try (do cmd ["nc", "newcompile"]; f <- identifier; eof; return (NewCompile f)) <|> try (do cmd ["m", "metavars"]; eof; return Metavars) <|> try (do cmd ["proofs"]; eof; return Proofs)@@ -43,6 +47,7 @@ <|> try (do cmd ["l", "load"]; f <- getInput; return (Load f)) <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t)) <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t))+ <|> try (do cmd ["doc"]; n <- pfName; eof; return (DocStr n)) <|> try (do cmd ["d", "def"]; n <- pfName; eof; return (Defn n)) <|> try (do cmd ["total"]; do n <- pfName; eof; return (TotCheck n)) <|> try (do cmd ["t", "type"]; do t <- pFullExpr defaultSyntax; return (Check t))@@ -58,8 +63,7 @@ <|> do t <- pFullExpr defaultSyntax; return (Eval t) <|> do eof; return NOP - where dot '.' = '/'- dot c = c+ where toPath n = foldl1 (</>) $ splitOn "." n pOption :: IParser Opt pOption = do discard (symbol "errorcontext"); return ErrContext
src/Idris/Unlit.hs view
@@ -13,7 +13,8 @@ ulLine ('>':' ':xs) = (Prog, xs) ulLine ('>':xs) = (Prog, xs) ulLine xs | all isSpace xs = (Blank, "")- | otherwise = (Comm, '-':'-':xs)+-- make sure it's not a doc comment+ | otherwise = (Comm, '-':'-':' ':'>':xs) check f l (a:b:cs) = do chkAdj f l (fst a) (fst b) check f (l+1) (b:cs)
src/Main.hs view
@@ -4,6 +4,7 @@ import System.IO import System.Environment import System.Exit+import System.FilePath ((</>), addTrailingPathSeparator) import Data.Maybe import Data.Version@@ -27,6 +28,8 @@ import Idris.Imports import Idris.Error +import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )+ import Pkg.Package import Paths_idris@@ -59,16 +62,16 @@ showver = do putStrLn $ "Idris version " ++ ver exitWith ExitSuccess -showLibs = do dir <- getDataDir- putStrLn $ "-L" ++ dir ++ "/rts -lidris_rts -lgmp -lpthread"+showLibs = do libFlags <- getLibFlags+ putStrLn libFlags exitWith ExitSuccess -showLibdir = do dir <- getDataDir- putStrLn $ dir ++ "/"+showLibdir = do dir <- getIdrisLibDir+ putStrLn dir exitWith ExitSuccess -showIncs = do dir <- getDataDir- putStrLn $ "-I" ++ dir ++ "/rts"+showIncs = do incFlags <- getIncFlags+ putStrLn incFlags exitWith ExitSuccess usagemsg = "Idris version " ++ ver ++ "\n" ++@@ -76,16 +79,17 @@ "Usage: idris [input file] [options]\n" ++ "Options:\n" ++ "\t--check Type check only\n" ++- "\t-o [file] Generate executable\n" +++ "\t-o [file] Specify output filename\n" ++ "\t-i [dir] Add directory to the list of import paths\n" ++ "\t--ibcsubdir [dir] Write IBC files into sub directory\n" ++ "\t--noprelude Don't import the prelude\n" ++ "\t--total Require functions to be total by default\n" ++ "\t--warnpartial Warn about undeclared partial functions\n" ++ "\t--typeintype Disable universe checking\n" ++- "\t--log [level] Set debugging log level\n" ++- "\t--dumpc [file] Dump generated C code\n" ++- "\t--libdir Show library install directory and exit\n" ++- "\t--link Show C library directories and exit (for C linking)\n" ++- "\t--include Show C include directories and exit (for C linking)\n"-+ "\t--log [level] Type debugging log level\n" +++ "\t-S Do no further compilation of code generator output\n" +++ "\t-c Compile to object files rather than an executable\n" +++ "\t--libdir Show library install directory and exit\n" +++ "\t--link Show C library directories and exit (for C linking)\n" +++ "\t--include Show C include directories and exit (for C linking)\n" +++ "\t--target [target] Type the target: C, Java, bytecode, javascript\n"
src/Pkg/PParser.hs view
@@ -18,7 +18,7 @@ type PParser = GenParser Char PkgDesc lexer :: TokenParser PkgDesc-lexer = PTok.makeTokenParser idrisDef+lexer = idrisLexer whiteSpace= PTok.whiteSpace lexer lexeme = PTok.lexeme lexer
src/Pkg/Package.hs view
@@ -1,14 +1,18 @@+{-# LANGUAGE CPP #-} module Pkg.Package where import System.Process import System.Directory import System.Exit import System.IO+import System.FilePath ((</>), addTrailingPathSeparator, takeFileName)+import System.Directory (createDirectoryIfMissing, copyFile) import Util.System import Control.Monad import Data.List+import Data.List.Split(splitOn) import Core.TT import Idris.REPL@@ -32,14 +36,14 @@ when (and ok) $ do make (makefile pkgdesc) dir <- getCurrentDirectory- setCurrentDirectory $ dir ++ "/" ++ sourcedir pkgdesc+ setCurrentDirectory $ dir </> sourcedir pkgdesc case (execout pkgdesc) of Nothing -> buildMods (NoREPL : Verbose : idris_opts pkgdesc) (modules pkgdesc)- Just o -> do let exec = dir ++ "/" ++ o- buildMod + Just o -> do let exec = dir </> o+ buildMods (NoREPL : Verbose : Output exec : idris_opts pkgdesc) - (idris_main pkgdesc)+ [idris_main pkgdesc] setCurrentDirectory dir when install $ installPkg pkgdesc @@ -48,37 +52,26 @@ = do pkgdesc <- parseDesc fp clean (makefile pkgdesc) dir <- getCurrentDirectory- setCurrentDirectory $ dir ++ "/" ++ sourcedir pkgdesc+ setCurrentDirectory $ dir </> sourcedir pkgdesc mapM_ rmIBC (modules pkgdesc) case execout pkgdesc of Nothing -> return ()- Just s -> do let exec = dir ++ "/" ++ s- putStrLn $ "Removing " ++ exec- system $ "rm -f " ++ exec - return ()+ Just s -> rmFile $ dir </> s installPkg :: PkgDesc -> IO () installPkg pkgdesc = do dir <- getCurrentDirectory- setCurrentDirectory $ dir ++ "/" ++ sourcedir pkgdesc+ setCurrentDirectory $ dir </> sourcedir pkgdesc case (execout pkgdesc) of Nothing -> mapM_ (installIBC (pkgname pkgdesc)) (modules pkgdesc) Just o -> return () -- do nothing, keep executable locally, for noe mapM_ (installObj (pkgname pkgdesc)) (objs pkgdesc) -buildMod :: [Opt] -> Name -> IO ()-buildMod opts n = do let f = map slash $ show n- idris (Filename f : opts) - return ()- where slash '.' = '/'- slash x = x- buildMods :: [Opt] -> [Name] -> IO ()-buildMods opts ns = do let f = map ((map slash) . show) ns+buildMods opts ns = do let f = map (toPath . show) ns idris (map Filename f ++ opts) return ()- where slash '.' = '/'- slash x = x+ where toPath n = foldl1 (</>) $ splitOn "." n testLib :: Bool -> String -> String -> IO Bool testLib warn p f @@ -86,7 +79,8 @@ gcc <- getCC (tmpf, tmph) <- tempfile hClose tmph- e <- system $ gcc ++ " " ++ d ++ "/rts/libtest.c -l" ++ f ++ " -o " ++ tmpf+ let libtest = d </> "rts" </> "libtest.c"+ e <- system $ gcc ++ " " ++ libtest ++ " -l" ++ f ++ " -o " ++ tmpf case e of ExitSuccess -> return True _ -> do if warn @@ -96,33 +90,37 @@ else fail $ "Missing library " ++ f rmIBC :: Name -> IO ()-rmIBC m = do let f = toIBCFile m - putStrLn $ "Removing " ++ f- system $ "rm -f " ++ f- return ()+rmIBC m = rmFile $ toIBCFile m toIBCFile (UN n) = n ++ ".ibc"-toIBCFile (NS n ns) = concat (intersperse "/" (reverse ns)) ++ "/" ++ toIBCFile n +toIBCFile (NS n ns) = foldl1 (</>) (reverse (toIBCFile n : ns)) installIBC :: String -> Name -> IO () installIBC p m = do let f = toIBCFile m- d <- getDataDir- let destdir = d ++ "/" ++ p ++ "/" ++ getDest m+ target <- environment "TARGET"+ d <- maybe getDataDir return target+ let destdir = d </> p </> getDest m putStrLn $ "Installing " ++ f ++ " to " ++ destdir- system $ "mkdir -p " ++ destdir - system $ "install " ++ f ++ " " ++ destdir+ createDirectoryIfMissing True destdir+ copyFile f (destdir </> takeFileName f) return () where getDest (UN n) = ""- getDest (NS n ns) = concat (intersperse "/" (reverse ns)) ++ "/" ++ getDest n + getDest (NS n ns) = foldl1 (</>) (reverse (getDest n : ns)) installObj :: String -> String -> IO () installObj p o = do d <- getDataDir- let destdir = d ++ "/" ++ p ++ "/"+ let destdir = addTrailingPathSeparator (d </> p) putStrLn $ "Installing " ++ o ++ " to " ++ destdir- system $ "mkdir -p " ++ destdir - system $ "install " ++ o ++ " " ++ destdir+ createDirectoryIfMissing True destdir+ copyFile o (destdir </> takeFileName o) return () +#ifdef mingw32_HOST_OS+mkDirCmd = "mkdir "+#else+mkDirCmd = "mkdir -p "+#endif+ make :: Maybe String -> IO () make Nothing = return () make (Just s) = do system $ "make -f " ++ s@@ -132,6 +130,3 @@ clean Nothing = return () clean (Just s) = do system $ "make -f " ++ s ++ " clean" return ()---
src/Util/System.hs view
@@ -1,14 +1,19 @@ {-# LANGUAGE CPP #-}-module Util.System(tempfile,environment,getCC) where+module Util.System(tempfile,environment,getCC,+ getLibFlags,getIdrisLibDir,getIncFlags,rmFile) where -- System helper functions. +import System.Directory (getTemporaryDirectory, removeFile)+import System.FilePath ((</>), addTrailingPathSeparator, normalise) import System.Environment import System.IO #if MIN_VERSION_base(4,0,0) import Control.Exception as CE #endif +import Paths_idris+ #if MIN_VERSION_base(4,0,0) catchIO :: IO a -> (IOError -> IO a) -> IO a catchIO = CE.catch@@ -23,13 +28,26 @@ Just cc -> return cc tempfile :: IO (FilePath, Handle)-tempfile = do env <- environment "TMPDIR"- let dir = case env of- Nothing -> "/tmp"- (Just d) -> d- openTempFile dir "idris"+tempfile = do dir <- getTemporaryDirectory+ openTempFile (normalise dir) "idris" environment :: String -> IO (Maybe String) environment x = catchIO (do e <- getEnv x return (Just e)) (\_ -> return Nothing)++rmFile :: FilePath -> IO ()+rmFile f = do putStrLn $ "Removing " ++ f+ catchIO (removeFile f)+ (\ioerr -> putStrLn $ "WARNING: Cannot remove file " + ++ f ++ ", Error msg:" ++ show ioerr)++ +getLibFlags = do dir <- getDataDir+ return $ "-L" ++ (dir </> "rts") ++ " -lidris_rts -lgmp -lpthread"+ +getIdrisLibDir = do dir <- getDataDir+ return $ addTrailingPathSeparator dir++getIncFlags = do dir <- getDataDir+ return $ "-I" ++ dir </> "rts"
tutorial/examples/binary.idr view
@@ -1,6 +1,6 @@ module Main -data Binary : Nat -> Set where+data Binary : Nat -> Type where bEnd : Binary O bO : Binary n -> Binary (n + n) bI : Binary n -> Binary (S (n + n))@@ -12,7 +12,7 @@ show' (bI x) = show x ++ "1" show' bEnd = "" -data Parity : Nat -> Set where+data Parity : Nat -> Type where even : Parity (n + n) odd : Parity (S (n + n))
tutorial/examples/idiom.idr view
@@ -4,7 +4,7 @@ | Val Int | Add Expr Expr -data Eval : Set -> Set where+data Eval : Type -> Type where MkEval : (List (String, Int) -> Maybe a) -> Eval a fetch : String -> Eval Int
tutorial/examples/interp.idr view
@@ -2,18 +2,18 @@ data Ty = TyInt | TyBool| TyFun Ty Ty -interpTy : Ty -> Set+interpTy : Ty -> Type interpTy TyInt = Int interpTy TyBool = Bool interpTy (TyFun s t) = interpTy s -> interpTy t using (G : Vect Ty n) - data Env : Vect Ty n -> Set where+ data Env : Vect Ty n -> Type where Nil : Env Nil (::) : interpTy a -> Env G -> Env (a :: G) - data HasType : (i : Fin n) -> Vect Ty n -> Ty -> Set where+ data HasType : (i : Fin n) -> Vect Ty n -> Ty -> Type where stop : HasType fO (t :: G) t pop : HasType k G t -> HasType (fS k) (u :: G) t @@ -21,7 +21,7 @@ lookup stop (x :: xs) = x lookup (pop k) (x :: xs) = lookup k xs - data Expr : Vect Ty n -> Ty -> Set where+ data Expr : Vect Ty n -> Ty -> Type where Var : HasType i G t -> Expr G t Val : (x : Int) -> Expr G TyInt Lam : Expr (a :: G) t -> Expr G (TyFun a t)
tutorial/examples/theorems.idr view
@@ -8,7 +8,7 @@ total disjoint : (n : Nat) -> O = S n -> _|_ disjoint n p = replace {P = disjointTy} p () where- disjointTy : Nat -> Set+ disjointTy : Nat -> Type disjointTy O = () disjointTy (S k) = _|_
tutorial/examples/universe.idr view
@@ -1,7 +1,7 @@-myid : (a : Set) -> a -> a+myid : (a : Type) -> a -> a myid _ x = x -idid : (a : Set) -> a -> a+idid : (a : Type) -> a -> a idid = myid _ myid
tutorial/examples/views.idr view
@@ -1,6 +1,6 @@ module views -data Parity : Nat -> Set where+data Parity : Nat -> Type where even : Parity (n + n) odd : Parity (S (n + n))