├── BUGS ├── INSTALL ├── IOvor ├── IOPrims.lhs ├── Main.lhs └── iobasics.tt ├── Ivor ├── BasicTactics.lhs ├── Bytecode-old.lhs ├── Constant.lhs ├── Construction.lhs ├── CtxtTT.lhs ├── Datatype.lhs ├── Display.lhs ├── Equality.lhs ├── Errors.lhs ├── EvalTT.lhs ├── Evaluator.lhs ├── Gadgets.lhs ├── MakeData.lhs ├── Makefile ├── Nobby.lhs ├── Overloading.lhs ├── PMComp.lhs ├── PatternDefs.lhs ├── Plugin.lhs ├── Primitives.lhs ├── Scopecheck.lhs ├── Shell.lhs ├── ShellParser.lhs ├── ShellState.lhs ├── Specialise.lhs ├── State.lhs ├── TT.lhs ├── TTCore.lhs ├── TTold.lhs ├── Tactics.lhs ├── TermParser.lhs ├── Typecheck.lhs ├── Unify.lhs ├── Values.lhs ├── ViewTerm.lhs ├── rts │ ├── Makefile │ ├── closure.c │ ├── closure.h │ ├── nat.c │ ├── newtest.c │ ├── oldtest.c │ ├── test.c │ ├── testdrive │ ├── testdrive.c │ └── testdrive2.c └── test.c ├── Jones └── Main.lhs ├── LICENSE ├── Makefile ├── Setup.lhs ├── TODO ├── docs ├── HCAR.tex ├── Makefile ├── combinators.tex ├── conclusion.tex ├── dtp.bib ├── hcar.sty ├── humett.tex ├── interface.tex ├── intro.tex ├── library.ltx ├── local.ltx ├── macros.ltx ├── shell.tex ├── tactics.tex └── tt.tex ├── emacs └── ivor-mode.el ├── examplett ├── Nat.hs ├── Test.hs ├── ack.tt ├── eq.tt ├── fin.tt ├── general.tt ├── interp.tt ├── jmeq.tt ├── logic.tt ├── lt.tt ├── nat.tt ├── natsimpl.tt ├── partial.tt ├── plus.tt ├── staged.tt ├── stageplus.tt ├── test.c ├── test.tt ├── vec.tt └── vect.tt ├── ivor.cabal ├── lib ├── basics.tt ├── eq.tt ├── fin.tt ├── list.tt ├── logic.tt ├── lt.tt ├── nat.tt └── vect.tt ├── papers ├── bib │ └── literature.bib ├── ivor │ ├── Makefile │ ├── alink.bib │ ├── code.tex │ ├── conclusions.tex │ ├── corett.tex │ ├── dtp.bib │ ├── embounded.bib │ ├── examples.tex │ ├── intro.tex │ ├── ivor.tex │ ├── library.ltx │ ├── llncs.cls │ ├── macros.ltx │ └── tactics.tex └── tutorial │ ├── Makefile │ ├── hslibrary.tex │ ├── introduction.tex │ ├── library.ltx │ ├── macros.ltx │ ├── programming.tex │ ├── theoremproving.tex │ └── tutorial.tex ├── release └── Release.lhs └── tests ├── Makefile ├── Test.lhs ├── ack.tt ├── partial.tt └── patt.tt /BUGS: -------------------------------------------------------------------------------- 1 | * Pattern matching RHS doesn't deal with bindings properly (if there 2 | are names bound on the RHS, anything could happen...) 3 | * Higher order recursive datatypes do not have induction hypothesis 4 | generated for the higher order arguments. 5 | * Non-termination if trying to parse an expression with no closing bracket. 6 | * Tactics should know what level they operate at; currently we need to 7 | allow escapes at the top level in the typechecker as a hack, and 8 | trust people to get it right. 9 | * intro should check that the name it is introducing is not the name of 10 | another goal, or we get confused. 11 | * Resuming an incomplete proof (e.g. created by suspend or axiomatise) 12 | resumes it in the current global context, not the context at the 13 | point when it was suspended. So if you're sneaky, you can make a 14 | non-terminating definition this way. 15 | Workaround: Please don't do that. 16 | * Refine tactic adds as many claims as possible, rather than adding 17 | claims for one argument at a time then attempting to unify. 18 | Workaround: Use intros before refining. You might then need to solve 19 | some of the arguments explicitly. 20 | * No check for strict positivity. 21 | Workaround: Don't use non positive types :). 22 | 23 | Recently fixed: 24 | 25 | * If a datatype has a placeholder in its indices, the value should 26 | be inferred (i.e. it should be checked) otherwise we can't make a pattern 27 | properly (and we'll certainly need this for optimisation). 28 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | Requirements: 2 | GHC version >= 6.4, 3 | happy 4 | 5 | To build and install: 6 | 7 | 1. Edit the DB and PREFIX variables in the Makefile; DB should be 8 | --user to install for a single user, or --global to install for all 9 | users. PREFIX should point to the installation directory. 10 | 2. Enter the following: 11 | make 12 | make install 13 | 3. [optional] To build and install the driver/shell, enter the following: 14 | make jones_install 15 | -------------------------------------------------------------------------------- /IOvor/IOPrims.lhs: -------------------------------------------------------------------------------- 1 | > module IOPrims where 2 | 3 | > import System.IO 4 | > import System.IO.Unsafe 5 | > import Data.Typeable 6 | > import Debug.Trace 7 | 8 | > import Ivor.Primitives 9 | > import Ivor.TT 10 | 11 | IO primitives; adds 'RealWorld' and 'Handle' 12 | 13 | RealWorld is a dummy type representing the world state, Handle (from 14 | System.IO) gives file handles. 15 | 16 | > data RealWorld = RW () 17 | > deriving Eq 18 | 19 | > instance Show RealWorld where 20 | > show _ = "<>" 21 | 22 | > rwName = name "RealWorld" 23 | 24 | > instance Typeable RealWorld where 25 | > typeOf (RW ()) = mkTyConApp (mkTyCon "RW") [] 26 | 27 | > instance ViewConst RealWorld where 28 | > typeof x = rwName 29 | 30 | > instance ViewConst Handle where 31 | > typeof x = (name "Handle") 32 | 33 | > addIOPrimTypes :: Monad m => Context -> m Context 34 | > addIOPrimTypes c = do c <- addPrimitives c 35 | > c <- addPrimitive c rwName 36 | > c <- addPrimitive c (name "Handle") 37 | > c <- addExternalFn c (name "initWorld") 1 initWorld 38 | > "True -> RealWorld" 39 | > return c 40 | 41 | > addIOPrimFns :: Monad m => Context -> m Context 42 | > addIOPrimFns c = do c <- addBinFn c (name "putStr") doPutStr 43 | > "String -> (IO True)" 44 | > c <- addPrimFn c (name "getLine") doGetLine 45 | > "(IO String)" 46 | > return c 47 | 48 | Make an instance of IOResult from the result of an IO action and a 49 | value 50 | 51 | > mkIO :: () -> ViewTerm -> ViewTerm 52 | > mkIO t v = case (t,v) of -- make sure they get evaluated 53 | > (tr,val) -> apply (Name DataCon (name "ioResult")) 54 | > [Placeholder, Constant (RW tr), val] 55 | 56 | > trueVal = Name DataCon (name "II") 57 | 58 | > {-# NOINLINE doPutStr #-} 59 | > doPutStr :: String -> RealWorld -> ViewTerm 60 | > doPutStr str w = mkIO () trueVal -- (unsafePerformIO (putStr str)) trueVal 61 | 62 | > {-# NOINLINE doGetLine #-} 63 | > doGetLine :: RealWorld -> ViewTerm 64 | > doGetLine w = mkIO () (Constant "foo") -- (unsafePerformIO getLine)) 65 | 66 | Needs a dummy argument so that evaluator doesn't loop 67 | 68 | > initWorld :: [ViewTerm] -> ViewTerm 69 | > initWorld [_] = Constant (RW ()) 70 | -------------------------------------------------------------------------------- /IOvor/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | Jones the Steam, with IO primitives. 4 | Simple program for starting up an interactive shell with Ivor library. 5 | 6 | > import Ivor.TT 7 | > import Ivor.Shell 8 | > import Ivor.Primitives 9 | 10 | > import IOPrims 11 | 12 | > main :: IO () 13 | > main = do let shell = addModulePath (newShell emptyContext) 14 | > (prefix ++ "/lib/ivor") 15 | > shell <- importFile "basics.tt" shell 16 | > primCtxt <- addIOPrimTypes (getContext shell) 17 | > let shell' = addModulePath (newShell primCtxt) 18 | > (prefix ++ "/lib/ivor") 19 | > shell' <- importFile "iobasics.tt" shell' 20 | > primFnCtxt <- addIOPrimFns (getContext shell') 21 | > -- It is horrible to have to do this every time. Fix the API! 22 | > let shell'' = addModulePath (newShell primFnCtxt) 23 | > (prefix ++ "/lib/ivor") 24 | > ctxt <- runShell "> " (extendParser shell'' parsePrimitives) 25 | > putStrLn "Finished" 26 | -------------------------------------------------------------------------------- /IOvor/iobasics.tt: -------------------------------------------------------------------------------- 1 | Data IOResult (A:*) :* where 2 | ioResult : (world:RealWorld)(a:A)(IOResult A); 3 | 4 | IO = [A:*](RealWorld -> (IOResult A)); 5 | 6 | world = initWorld II; 7 | -------------------------------------------------------------------------------- /Ivor/BasicTactics.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.BasicTactics where 4 | 5 | > import Ivor.TTCore as TTCore 6 | > import Ivor.State 7 | > import qualified Ivor.Tactics 8 | > import Ivor.Nobby 9 | > import Ivor.Typecheck 10 | > import Ivor.ViewTerm as VTerm 11 | 12 | > import Debug.Trace 13 | 14 | -------------------------------------------------------------------------------- /Ivor/Bytecode-old.lhs: -------------------------------------------------------------------------------- 1 | > module Bytecode where 2 | 3 | > import SC 4 | > import TT 5 | 6 | > type Arity = Int 7 | > type Tag = Int 8 | > type TmpVar = Int 9 | 10 | > type Bytecode = [ByteOp] 11 | 12 | > data ByteOp 13 | > = STARTFN SCName Arity -- Needed? 14 | > | DECLARE Int 15 | > | RETURN TmpVar 16 | > | CALL TmpVar SCName [TmpVar] 17 | > | CON TmpVar Tag [TmpVar] 18 | > | CLOSURE TmpVar SCName [TmpVar] 19 | > | VAR TmpVar Int 20 | > | GETARG TmpVar Int TmpVar 21 | > | CLOSUREADD TmpVar TmpVar [TmpVar] 22 | > | EVAL Int 23 | > | TYPE TmpVar 24 | > | TAILCALL SCName [TmpVar] 25 | > | ALET Int TmpVar 26 | > | CASE Int [Bytecode] 27 | > deriving Show 28 | 29 | > data FunInfo 30 | > = FI { 31 | > bytecode :: Bytecode, 32 | > cname :: String, 33 | > ctag :: String, 34 | > farity :: Int, 35 | > ctagid :: Int 36 | > } 37 | > deriving Show 38 | 39 | > type ByteDef = [(SCName,FunInfo)] 40 | 41 | I wonder how generally useful this is... 42 | 43 | > mapInc :: (a->Int->b) -> [a] -> Int -> [b] 44 | > mapInc f [] i = [] 45 | > mapInc f (x:xs) i = (f x i):(mapInc f xs (i+1)) 46 | 47 | > compileAll :: SCs -> SCs -> ByteDef 48 | > compileAll ctxt group = mapInc scomp group ((length ctxt)-(length group)) 49 | > where scomp (n,(a,sc)) i = (n,FI (scompile n ctxt sc) 50 | > (mkcname n) 51 | > (mkctag n) 52 | > a 53 | > i) 54 | > mkcname (N n) = "_EVM_"++show n 55 | > mkcname (SN n i) = "_EVMSC_"++show i++"_"++show n 56 | > mkctag (N n) = "FTAG_EVM_"++show n 57 | > mkctag (SN n i) = "FTAG_EVMSC_"++show i++"_"++show n 58 | 59 | > scompile :: SCName -> SCs -> SC -> Bytecode 60 | > scompile name scs (SLam args body) = 61 | > (STARTFN name (length args)):(bcomp (length args) 0 body) 62 | > where 63 | > getarity n = case lookup n scs of 64 | > (Just (a,d)) -> a 65 | > Nothing -> error "Can't happen (scompile)" 66 | > bcomp v t (SCase scr alts) = 67 | > (EVAL scr): 68 | > [CASE scr (map (acomp v t) alts)] 69 | > bcomp v t (SApp (SP n) as) 70 | > | getarity n == length as = 71 | > concat (mapInc (ecomp v) as (t+1)) 72 | > ++ [TAILCALL n (mktargs (length as) (t+1))] 73 | > bcomp v t x = (ecomp v t x):[RETURN t] 74 | 75 | > mktargs 0 s = [s] 76 | > mktargs n s = s:(mktargs (n-1) (s+1)) 77 | 78 | > acomp v t x = bcomp v t x -- Hmm. Well, maybe alts will get more complex 79 | 80 | > ecomp v t (SP n) | getarity n == 0 = CALL t n [] 81 | > | otherwise = CLOSURE t n [] 82 | > -- ecomp v (SElim n) | getarity n == 0 = CALL n [] 83 | > -- | otherwise = CLOSURE n [] 84 | > ecomp v t (SV i) = VAR t i 85 | > ecomp v t (SCon tag n as) 86 | > = concat (mapInc (ecomp v) as (t+1)) 87 | > ++ [CON t tag (mktargs (length as) (t+1))] 88 | 89 | > ecomp v t (SApp f as) = fcomp v t f as 90 | > ecomp v t (SLet val ty b) = 91 | > (ecomp v (t+1) val) ++ 92 | > (ALET v (t+1)): 93 | > (ecomp (v+1) (t+2) b) 94 | > ecomp v t (SProj i b) = (ecomp v (t+1) b) ++ 95 | > [GETARG t i (t+1)] 96 | > ecomp v t (SPi e t) = [TYPE t] 97 | > ecomp v t (SConst c) = ccomp c t 98 | > ecomp v t _ = [TYPE t] 99 | 100 | > fcomp v t (SP n) as 101 | > | getarity n == length as 102 | > = concat (mapInc (ecomp v) as (t+1)) 103 | > ++ [CALL t n (mktargs (length as) (t+1))] 104 | > | otherwise 105 | > = concat (mapInc (ecomp v) as (t+1)) 106 | > ++ [CLOSURE t n (mktargs (length as) (t+1))] 107 | > fcomp v t f as = CLOSUREADD (ecomp v f) (map (ecomp v) as) 108 | > = (ecomp v (t+1) f) ++ 109 | > concat (mapInc (ecomp v) as (t+2)) 110 | > ++ [CLOSUREADD t (t+1) (mktargs (length as) (t+2))] 111 | 112 | > ccomp Star t = [TYPE t] 113 | -------------------------------------------------------------------------------- /Ivor/Constant.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.Constant where 4 | 5 | > import Data.Typeable 6 | 7 | 8 | -------------------------------------------------------------------------------- /Ivor/Construction.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > -- | 4 | > -- Module : Ivor.Construction 5 | > -- Copyright : Edwin Brady 6 | > -- Licence : BSD-style (see LICENSE in the distribution) 7 | > -- 8 | > -- Maintainer : eb@dcs.st-and.ac.uk 9 | > -- Stability : experimental 10 | > -- Portability : non-portable 11 | > -- 12 | > -- Some generic tactics for solving goals by applying constructors 13 | 14 | > module Ivor.Construction(auto,split,left,right,useCon,exists, 15 | > isItJust) where 16 | 17 | > import Ivor.TT 18 | > import Debug.Trace 19 | 20 | > -- | Tries to solve a simple goal automatically by trying each of these 21 | > -- in turn: 22 | > -- * Looking for an assumption ('trivial') 23 | > -- * 'intros' everything then solve by 'auto' 24 | > -- * Splitting the goal, then solving each subgoal by 'auto' 25 | > -- * If the goal is of a type with more than one constructor, try 'auto' 26 | > -- on each constructor in turn. 27 | > -- FIXME: not that this actually works yet. 28 | 29 | > auto :: Int -- ^ Search depth 30 | > -> Tactic 31 | > auto 0 = \g ctxt -> fail "auto got bored, try a bigger search depth" 32 | > auto n = \g ctxt -> if (allSolved ctxt) then return ctxt else 33 | > trace ("Auto "++ show n) $ 34 | > ((trivial >+> (auto n)) >|> 35 | > (intros1 >+> (auto n)) >|> 36 | > (split >+> (auto n)) >|> 37 | > (left >+> (auto (n-1))) >|> 38 | > (right >+> (auto (n-1)))) g ctxt 39 | 40 | > -- | Split a goal into subgoals. Type of goal must be a one constructor 41 | > -- family, with constructor @c@, then proceeds by 'refine' @c@. 42 | > split :: Tactic 43 | > split = useCon 1 0 44 | 45 | > -- | Split a goal into subgoals. Type of goal must be a two constructor 46 | > -- family, with constructors @l@ and @r@, then proceeds by 'refine' @l@. 47 | > left :: Tactic 48 | > left = useCon 2 0 49 | 50 | > -- | Split a goal into subgoals. Type of goal must be a two constructor 51 | > -- family, with constructors @l@ and @r@, then proceeds by 'refine' @r@. 52 | > right :: Tactic 53 | > right = useCon 2 1 54 | 55 | Get the goal, look at the type. Refine by the constructor of that type - 56 | check that there is the right number (num). 57 | 58 | > -- | Solve the goal by applying a numbered constructor 59 | > useCon :: Int -- ^ Ensure at least this number of constructors (0 for no constraint) 60 | > -> Int -- ^ Use this constructor (0 based, order of definition) 61 | > -> Tactic 62 | > useCon num use g ctxt = do 63 | > goal <- goalData ctxt False g 64 | > let ty = getApp (view (goalType goal)) 65 | > case ty of 66 | > (Name _ n) -> do cons <- getConstructors ctxt n 67 | > splitnCon cons g ctxt 68 | > _ -> fail "Not a type constructor" 69 | > where splitnCon cs | length cs >= num || num == 0 70 | > = refine (Name DataCon (cs!!use)) 71 | > splitnCon _ = \g ctxt -> fail $ "Not a " ++ show num ++ " constructor family" 72 | 73 | > -- | Solve an existential by providing a witness. 74 | > -- More generally; apply the first constructor of the 75 | > -- goal's type and provide the witness as its first non-inferrable argument. 76 | > exists :: IsTerm a => a -- ^Witness 77 | > -> Tactic 78 | > exists t = useCon 1 0 >+> fill t 79 | 80 | 81 | > -- | Try to solve a goal @A@ by evaluating a term of type @Maybe A@. If the 82 | > -- answer is @Just a@, fill in the goal with the proof term @a@. 83 | > isItJust :: IsTerm a => a -> Tactic 84 | > isItJust tm g ctxt = do 85 | > gd <- goalData ctxt False g 86 | > let gty = view $ goalType gd 87 | > vtm <- evalCtxt ctxt g tm 88 | > let (prf, ty) = (view vtm, viewType vtm) 89 | > -- make sure type is 'Maybe' 90 | > case ty of 91 | > (App (Name _ m) a) | m == (name "Maybe") 92 | > -> do case prf of 93 | > (App (Name _ n) _) | n == (name "Nothing") 94 | > -> fail "No solution found" 95 | > (App (App (Name _ j) _) p) | j == (name "Just") 96 | > -> fill p g ctxt 97 | > tm -> fail $ "Evaluated to " ++ show tm 98 | > _ -> fail $ "Type of decision procedure must be ++ " ++ 99 | > show (App (Name Unknown (name "Maybe")) gty) 100 | 101 | -------------------------------------------------------------------------------- /Ivor/CtxtTT.lhs: -------------------------------------------------------------------------------- 1 | > -- | 2 | > -- Module : Ivor.CtxtTT 3 | > -- Copyright : Edwin Brady 4 | > -- Licence : BSD-style (see LICENSE in the distribution) 5 | > -- 6 | > -- Maintainer : eb@dcs.st-and.ac.uk 7 | > -- Stability : experimental 8 | > -- Portability : non-portable 9 | > -- 10 | > -- Public interface to ivor contexts. 11 | 12 | > module Ivor.CtxtTT where 13 | 14 | > import Ivor.TTCore as TTCore 15 | > import Ivor.Errors 16 | > import Ivor.ViewTerm as VTerm 17 | > import Ivor.State 18 | > import Control.Monad.Error(Error,noMsg,strMsg) 19 | 20 | > data TTError = CantUnify ViewTerm ViewTerm 21 | > | NotConvertible ViewTerm ViewTerm 22 | > | Message String 23 | > | Unbound ViewTerm ViewTerm ViewTerm ViewTerm [Name] 24 | > | NoSuchVar Name 25 | > | CantInfer Name ViewTerm 26 | > | ErrContext String TTError 27 | > | AmbiguousName [Name] 28 | 29 | > type TTM = Either TTError 30 | 31 | > ttfail :: String -> TTM a 32 | > ttfail s = Left (Message s) 33 | 34 | > tt :: IvorM a -> TTM a 35 | > tt (Left err) = Left (getError err) 36 | > tt (Right v) = Right v 37 | 38 | > getError :: IError -> TTError 39 | > getError (ICantUnify l r) = CantUnify (view (Term (l, Ind TTCore.Star))) (view (Term (r, Ind TTCore.Star))) 40 | > getError (INotConvertible l r) = NotConvertible (view (Term (l, Ind TTCore.Star))) (view (Term (r, Ind TTCore.Star))) 41 | > getError (IMessage s) = Message s 42 | > getError (IUnbound clause clty rhs rhsty names) 43 | > = Unbound (view (Term (clause, Ind TTCore.Star))) 44 | > (view (Term (clty, Ind TTCore.Star))) 45 | > (view (Term (rhs, Ind TTCore.Star))) 46 | > (view (Term (rhsty, Ind TTCore.Star))) 47 | > names 48 | > getError (ICantInfer nm tm) = CantInfer nm (view (Term (tm, Ind TTCore.Star))) 49 | > getError (INoSuchVar n) = NoSuchVar n 50 | > getError (IAmbiguousName ns) = AmbiguousName ns 51 | > getError (IContext s e) = ErrContext s (getError e) 52 | 53 | > instance Show TTError where 54 | > show (CantUnify t1 t2) = "Can't unify " ++ show t1 ++ " and " ++ show t2 55 | > show (NotConvertible t1 t2) = show t1 ++ " and " ++ show t2 ++ " are not convertible" 56 | > show (Message s) = s 57 | > show (Unbound clause clty rhs rhsty ns) 58 | > = show ns ++ " unbound in clause " ++ show clause ++ " : " ++ show clty ++ 59 | > " = " ++ show rhs 60 | > show (CantInfer n tm) = "Can't infer value for " ++ show n ++ " in " ++ show tm 61 | > show (NoSuchVar n) = "No such name as " ++ show n 62 | > show (AmbiguousName ns) = "Ambiguous name " ++ show ns 63 | > show (ErrContext c err) = c ++ show err 64 | 65 | > instance Error TTError where 66 | > noMsg = Message "Ivor Error" 67 | > strMsg s = Message s 68 | 69 | > -- | Abstract type representing state of the system. 70 | > newtype Context = Ctxt IState 71 | 72 | > -- | Abstract type representing goal or subgoal names. 73 | > data Goal = Goal Name | DefaultGoal 74 | > deriving Eq 75 | 76 | > instance Show Goal where 77 | > show (Goal g) = show g 78 | > show (DefaultGoal) = "Default Goal" 79 | 80 | > goal :: String -> Goal 81 | > goal g = Goal $ UN g 82 | 83 | > defaultGoal :: Goal 84 | > defaultGoal = DefaultGoal 85 | 86 | > -- |A tactic is any function which manipulates a term at the given goal 87 | > -- binding. Tactics may fail, hence the monad. 88 | > type Tactic = Goal -> Context -> TTM Context 89 | 90 | > -- | Initialise a context, with no data or definitions and an 91 | > -- empty proof state. 92 | > emptyContext :: Context 93 | > emptyContext = Ctxt initstate 94 | 95 | > class IsTerm a where 96 | > -- | Typecheck a term 97 | > check :: Context -> a -> TTM Term 98 | > raw :: a -> TTM Raw 99 | 100 | > class IsData a where 101 | > -- Add a data type with case and elim rules an elimination rule 102 | > addData :: Context -> a -> TTM Context 103 | > addData ctxt x = addData' True ctxt x 104 | > -- Add a data type without an elimination rule 105 | > addDataNoElim :: Context -> a -> TTM Context 106 | > addDataNoElim ctxt x = addData' False ctxt x 107 | > addData' :: Bool -> Context -> a -> TTM Context 108 | 109 | -------------------------------------------------------------------------------- /Ivor/Datatype.lhs: -------------------------------------------------------------------------------- 1 | > module Ivor.Datatype where 2 | 3 | > import Ivor.TTCore 4 | > import Ivor.Gadgets 5 | > import Ivor.Typecheck 6 | > import Ivor.Nobby 7 | > import Ivor.PatternDefs 8 | > import Ivor.Errors 9 | > import Ivor.Values 10 | 11 | > import Debug.Trace 12 | > import Data.List 13 | 14 | > data Datadecl = Datadecl { 15 | > datatycon :: Name, 16 | > params :: [(Name,Raw)], 17 | > tycontype :: Raw, 18 | > constructors :: [(Name,Raw)] 19 | > } 20 | 21 | Elaborated version with elimination rule and iota schemes. 22 | 23 | > data RawDatatype = 24 | > RData { rtycon :: (Name,Raw), 25 | > rdatacons :: [(Name,Raw)], 26 | > rnum_params :: Int, 27 | > rerule :: (Name,Raw), 28 | > rcrule :: (Name,Raw), 29 | > re_ischemes :: [RawScheme], 30 | > rc_ischemes :: [RawScheme] 31 | > } 32 | > deriving Show 33 | 34 | > data Datatype n = 35 | > Data { tycon :: (n, Gval n), 36 | > datacons :: [(n, Gval n)], 37 | > num_params :: Int, 38 | > erule :: (n, Indexed n), 39 | > crule :: (n, Indexed n), 40 | > e_ischemes :: Maybe (PMFun Name), 41 | > c_ischemes :: Maybe (PMFun Name), 42 | > e_rawschemes :: [RawScheme], 43 | > c_rawschemes :: [RawScheme] 44 | > } 45 | > deriving Show 46 | 47 | > getPat (Sch p _ i) = p 48 | > getRed (Sch p _ i) = i 49 | 50 | > getArity [] = 2 -- empty data type should have elim rule of arity 2! 51 | > -- (actually not if they're dependent. Fix this.) 52 | > getArity ss = length (getPat (ss!!0)) 53 | 54 | checkType checks a raw data type, with its elimination rule and iota 55 | schemes, and returns a DataType, ready for compilation to entries in 56 | the context and an executable elimination rule. 57 | 58 | > checkType :: Gamma Name -> RawDatatype -> IvorM (Datatype Name) 59 | > checkType gamma (RData (ty,kind) cons numps (er,erty) (cr,crty) eschemes cschemes) = 60 | > do (kv, _) <- typecheck gamma kind 61 | > let erdata = Elims er cr (map fst cons) 62 | > let gamma' = extend gamma (ty,G (TCon (arity gamma kv) erdata) kv defplicit) 63 | > (consv,gamma'') <- checkCons gamma' 0 cons 64 | > (ev, _) <- typecheck gamma'' erty 65 | > (cv, _) <- typecheck gamma'' crty 66 | > -- let gamma''' = extend gamma'' (er,G (ElimRule dummyRule) ev defplicit) 67 | > ([(_, esch, _)], _, _) <- checkDef gamma'' er erty eschemes False False Nothing Nothing 68 | > ([(_, csch, _)], _, _) <- checkDef gamma'' cr crty cschemes False False Nothing Nothing 69 | > return (Data (ty,G (TCon (arity gamma kv) erdata) kv defplicit) consv numps 70 | > (er,ev) (cr,cv) (Just esch) (Just csch) eschemes cschemes) 71 | 72 | > checkTypeNoElim :: Gamma Name -> RawDatatype -> IvorM (Datatype Name) 73 | > checkTypeNoElim gamma (RData (ty,kind) cons numps (er,erty) (cr,crty) eschemes cschemes) = 74 | > do (kv, _) <- typecheck gamma kind 75 | > let erdata = Elims er cr (map fst cons) 76 | > let gamma' = extend gamma (ty,G (TCon (arity gamma kv) erdata) kv defplicit) 77 | > (consv,gamma'') <- checkCons gamma' 0 cons 78 | > (ev, _) <- typecheck gamma'' erty 79 | > (cv, _) <- typecheck gamma'' crty 80 | > -- let gamma''' = extend gamma'' (er,G (ElimRule dummyRule) ev defplicit) 81 | > return (Data (ty,G (TCon (arity gamma kv) erdata) kv defplicit) consv numps 82 | > (er,ev) (cr,cv) Nothing Nothing [] []) 83 | 84 | > checkCons gamma t [] = return ([], gamma) 85 | > checkCons gamma t ((cn,cty):cs) = -- trace ("Checking " ++ show (cn, cty)) $ 86 | > do (cv,_) <- typecheck gamma cty 87 | > let ccon = let fpos = forcepos cty in 88 | > G (DCon t (arity gamma cv) (forcepos cty)) cv defplicit 89 | > let gamma' = extend gamma (cn,ccon) 90 | > (rest,gamma'') <- checkCons gamma' (t+1) cs 91 | > return (((cn,ccon):rest), gamma'') 92 | > where forcepos cty = let nms = nub (guardedNames [] cty) in 93 | > map (argpos 0 cty) nms 94 | 95 | > argpos i (RBind x _ t) n 96 | > | x == n = i 97 | > | otherwise = argpos (i+1) t n 98 | > guardedNames ns (RBind n _ t) = guardedNames (n:ns) t 99 | > guardedNames ns (RApp f a) = guardedApp ns f [a] 100 | > guardedNames ns (Var n) | n `elem` ns = [n] 101 | > guardedNames ns _ = [] 102 | 103 | > guardedApp ns (RApp f a) as = guardedApp ns f (a:as) 104 | > guardedApp ns (Var n) as 105 | > | isCon n = concatMap (guardedNames ns) as 106 | > | otherwise = [] 107 | > isCon n = case lookupval n gamma of 108 | > Just (DCon t i _) -> True 109 | > Just (TCon _ _) -> True 110 | > _ -> False 111 | 112 | 113 | 114 | checkScheme takes a raw iota scheme and returns a scheme with a well-typed 115 | RHS (or fails if there is a type error). 116 | 117 | For a scheme of the form 118 | 119 | foo p0 p1 ... pn = t 120 | 121 | we get V 0 = pn ... V n = p0 122 | then pattern variables are retrieved by projection with Proj in typechecked t. 123 | 124 | > checkScheme :: Gamma Name -> Name -> RawScheme -> IvorM (Scheme Name) 125 | > checkScheme gamma n (RSch pats (RWRet ret)) = 126 | > do let ps = map (mkPat gamma) pats 127 | > let rhsvars = getPatVars gamma ps 128 | > let rhs = substVars gamma n rhsvars ret 129 | > return (Sch (reverse ps) [] (Ind rhs)) 130 | 131 | Make a pattern from a raw term. Anything weird, just make it a "PTerm". 132 | 133 | > mkPat :: Gamma Name -> Raw -> Pattern Name 134 | > mkPat gam (Var n) = mkPatV n (lookupval n gam) 135 | > where mkPatV n (Just (DCon t x _)) = PCon t n tyname [] 136 | > mkPatV n (Just (TCon x _)) = PCon 0 n (UN "Type") [] 137 | > mkPatV n _ = PVar n 138 | > tyname = case (getTyName gam n) of 139 | > Just x -> x 140 | > mkPat gam (RApp f a) = pat' (unwind f a) 141 | > where unwind (RApp f s) a = let (f',as) = unwind f s in 142 | > (f',(mkPat gam a):as) 143 | > unwind (RFileLoc _ _ t) a = unwind t a 144 | > unwind t a = (t, [mkPat gam a]) 145 | > pat' (Var n, as) = mkPatV n (lookupval n gam) (reverse as) 146 | > pat' (RFileLoc _ _ t, as) = pat' (t, as) 147 | > pat' _ = PTerm 148 | 149 | > mkPatV n (Just (DCon t x _)) as = PCon t n tyname as 150 | > mkPatV n (Just (TCon x _)) as = PCon 0 n (UN "Type") as 151 | > mkPatV _ _ _ = PTerm 152 | > tyname = case (getTyName gam (getname (getappfun f))) of 153 | > Just x -> x 154 | > getname (Var n) = n 155 | > getname (RFileLoc _ _ t) = getname t 156 | > mkPat gam _ {-(RBind _ _ _)-} = PTerm 157 | > {- 158 | > TODO: If a datatype has a placeholder in its indices, the value should 159 | > be inferred (i.e. it should be checked) otherwise we can't make a pattern 160 | > properly (and we'll certainly need this for optimisation) 161 | > mkPat gam x = error $ "Can't make a pattern from " ++ show x 162 | > -} 163 | 164 | Get the pattern variables from the patterns, and work out what the projection 165 | function for each name is. 166 | 167 | > getPatVars :: Gamma Name ->[Pattern Name] -> [(Name, TT Name)] 168 | > getPatVars gam xs = pv' 0 (reverse xs) 169 | > where pv' i [] = [] 170 | > pv' i (x:xs) = (project gam i x) ++ (pv' (i+1) xs) 171 | 172 | indexify (n,t) = (n,Ind t) 173 | 174 | Projection. 175 | 176 | > project :: Gamma Name -> Int -> Pattern Name -> [(Name, TT Name)] 177 | > project gam n x = project' n (\i -> V i) x 178 | > where project' n f (PVar x) = [(x,f n)] 179 | > project' n f (PCon _ fn ty es) = projargs n f 0 es ty 180 | > project' n f (PMarkCon fn es) = projargs n f 0 es (UN "FOO") 181 | > project' n f _ = [] -- Can't project from terms or marked vars. 182 | > projargs n f i [] _ = [] 183 | > projargs n f i (PMark _:xs) ty = projargs n f i xs ty 184 | > projargs n f i (x:xs) ty 185 | > = (project' n ((\a -> (Proj ty i a)).f) x) 186 | > ++ projargs n f (i+1) xs ty 187 | 188 | -- > argtypes ty = case lookuptype ty gam of 189 | -- > (Just (Ind ty)) -> map (getFnName.snd) 190 | -- > $ getExpected ty 191 | -- > getFnName (TyCon x _) = x 192 | -- > getFnName (App f x) = getFnName f 193 | -- > getFnName (Bind _ _ (Sc x)) = getFnName x 194 | -- > getFnName x = MN ("Dunno: "++show x, 0) 195 | 196 | Make a RHS of an iota scheme, substituting names with projection operations. 197 | ASSUMPTION: No bindings on the RHS. This should be true of all iota schemes. 198 | Takes the name of the elimination rule and assumes any reference to an 199 | elimination rule is a reference to this 200 | 201 | > substVars :: Gamma Name -> Name -> [(Name,TT Name)] -> Raw -> TT Name 202 | > substVars gam er ns r = sv' r 203 | > where sv' (Var x) = case (lookup x ns) of 204 | > Nothing -> mkGood x 205 | > (Just i) -> i 206 | > sv' (RApp f a) = App (sv' f) (sv' a) 207 | > sv' (RConst c) = Const c 208 | > sv' (RFileLoc _ _ t) = sv' t 209 | 210 | > mkGood x = case (lookupval x gam) of 211 | > (Just (DCon t i _)) -> Con t x i 212 | > (Just (TCon i _)) -> TyCon x i 213 | > (Just (ElimRule _)) -> Elim er 214 | > _ -> P x 215 | 216 | > dummyRule :: ElimRule 217 | > dummyRule _ = Nothing 218 | -------------------------------------------------------------------------------- /Ivor/Display.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} {- -*-literate-haskell-*- -} 2 | 3 | Functions for displaying proof state "helpfully". 4 | 5 | > module Ivor.Display where 6 | 7 | > import Ivor.Tactics 8 | > import Ivor.TTCore 9 | > import Ivor.Typecheck 10 | > import Ivor.Nobby 11 | > import Ivor.Values 12 | 13 | > displayHoleContext :: Gamma Name -> [Name] -> Name -> Indexed Name -> String 14 | > displayHoleContext gam hidden h tm = 15 | > case (findhole gam (Just h) tm (displayHole hidden)) of 16 | > Just x -> x 17 | > Nothing -> "" 18 | 19 | > displayHole :: [Name] -> Gamma Name -> Env Name -> Indexed Name -> String 20 | > displayHole hidden gam hs tm = dh hs ++ 21 | > "\n=======================================\n" ++ 22 | > show (normaliseEnv hs emptyGam tm) ++ "\n" 23 | > where dh [] = "" 24 | > dh ((n,B _ ty):xs) 25 | > | n `elem` hidden = dh xs 26 | > | otherwise = dh xs ++ (show n)++" : "++show ty++"\n" 27 | 28 | -------------------------------------------------------------------------------- /Ivor/Equality.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > -- | 4 | > -- Module : Ivor.Equality 5 | > -- Copyright : Edwin Brady 6 | > -- Licence : BSD-style (see LICENSE in the distribution) 7 | > -- 8 | > -- Maintainer : eb@dcs.st-and.ac.uk 9 | > -- Stability : experimental 10 | > -- Portability : non-portable 11 | > -- 12 | > -- Tactics for Heterogeneous Equality (injectivity, disjointness, etc) 13 | 14 | > module Ivor.Equality where 15 | 16 | > import Ivor.TTCore as TTCore 17 | > import Ivor.TT 18 | > import Ivor.TermParser 19 | > import Ivor.State 20 | > import Ivor.Gadgets 21 | > import Ivor.Nobby 22 | 23 | -------------------------------------------------------------------------------- /Ivor/Errors.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.Errors where 4 | 5 | > import Ivor.TTCore 6 | > import Control.Monad.Error 7 | 8 | > data IError = ICantUnify (Indexed Name) (Indexed Name) 9 | > | INotConvertible (Indexed Name) (Indexed Name) 10 | > | IMessage String 11 | > | IUnbound (Indexed Name) (Indexed Name) (Indexed Name) (Indexed Name) [Name] 12 | > | INoSuchVar Name 13 | > | ICantInfer Name (Indexed Name) 14 | > | IContext String IError 15 | > | IAmbiguousName [Name] 16 | > deriving (Show, Eq) 17 | 18 | > instance Error IError where 19 | > noMsg = IMessage "Ivor Error" 20 | > strMsg s = IMessage s 21 | 22 | > type IvorM = Either IError 23 | 24 | > ifail = Left 25 | 26 | > tacfail str = ifail (IMessage str) 27 | 28 | Generic error checking can go here: 29 | 30 | Check that all the names are real rather than implicit and inferred 31 | 32 | > checkRealNames :: [Name] -> Indexed Name -> IvorM () 33 | > checkRealNames [] tm = return () 34 | > checkRealNames (nm@(MN ("INFER", n)): ns) tm = ifail (ICantInfer nm tm) 35 | > checkRealNames (_:ns) tm = checkRealNames ns tm 36 | -------------------------------------------------------------------------------- /Ivor/EvalTT.lhs: -------------------------------------------------------------------------------- 1 | > -- | 2 | > -- Module : Ivor.TT 3 | > -- Copyright : Edwin Brady 4 | > -- Licence : BSD-style (see LICENSE in the distribution) 5 | > -- 6 | > -- Maintainer : eb@dcs.st-and.ac.uk 7 | > -- Stability : experimental 8 | > -- Portability : non-portable 9 | > -- 10 | > -- Public interface to evaluator. 11 | 12 | > module Ivor.EvalTT where 13 | 14 | > import Ivor.Evaluator 15 | > import Ivor.CtxtTT 16 | > import Ivor.Values 17 | > import Ivor.ViewTerm as VTerm 18 | > import Ivor.State 19 | > import Ivor.Nobby 20 | > import Ivor.TTCore 21 | > import qualified Ivor.Tactics as Tactics 22 | 23 | > -- |Normalise a term and its type (using old evaluator_ 24 | > eval :: Context -> Term -> Term 25 | > eval (Ctxt st) (Term (tm,ty)) = Term (normalise (defs st) tm, 26 | > normalise (defs st) ty) 27 | 28 | > -- |Reduce a term and its type to Weak Head Normal Form 29 | > whnf :: Context -> Term -> Term 30 | > whnf (Ctxt st) (Term (tm,ty)) = Term (eval_whnf (defs st) tm, 31 | > eval_whnf (defs st) ty) 32 | 33 | > -- |Reduce a term and its type to Normal Form (using new evaluator) 34 | > evalnew :: Context -> Term -> Term 35 | > evalnew (Ctxt st) (Term (tm,ty)) = Term (tidyNames (eval_nf (defs st) tm), 36 | > tidyNames (eval_nf (defs st) ty)) 37 | 38 | > -- |Reduce a term and its type to Normal Form (using new evaluator, not 39 | > -- reducing given names) 40 | > evalnewWithout :: Context -> Term -> [Name] -> Term 41 | > evalnewWithout (Ctxt st) (Term (tm,ty)) ns 42 | > = Term (tidyNames (eval_nf_without (defs st) tm ns), 43 | > tidyNames (eval_nf_without (defs st) ty ns)) 44 | 45 | > -- |Reduce a term and its type to Normal Form (using new evaluator, reducing 46 | > -- given names a maximum number of times) 47 | > evalnewLimit :: Context -> Term -> [(Name, Int)] -> Term 48 | > evalnewLimit (Ctxt st) (Term (tm,ty)) ns 49 | > = Term (eval_nf_limit (defs st) tm ns Nothing, 50 | > eval_nf_limit (defs st) ty ns Nothing) 51 | 52 | Specialise a pattern matching definition - support for 'spec' 53 | 54 | > specialise :: Context -> PMFun Name -> 55 | > [(Name, ([Int], Int))] -> -- functions with static args 56 | > [Name] -> -- frozen names 57 | > (PMFun Name, Context, [Name]) -- also, new names 58 | > specialise ctxt (PMFun ar ps) statics frozen = sp ctxt ps [] [] 59 | > where 60 | > sp ctxt [] names acc = (PMFun ar (reverse acc), ctxt, names) 61 | > sp ctxt@(Ctxt st) (p@(Sch args env ret):ps) names acc 62 | > = let ret' = eval_nf_limit (defs st) ret 63 | > (map (\x -> (x,0)) frozen) 64 | > (Just statics) in 65 | > sp ctxt ps names (Sch args env ret' : acc) 66 | 67 | sp ctxt (p@(PWithClause eq args scr pats):ps) names acc 68 | = let (pats', ctxt', names') = specialise ctxt pats statics frozen in 69 | sp ctxt' ps names' (p:acc) 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /Ivor/Gadgets.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.Gadgets where 4 | 5 | > class Forget a b | a->b where 6 | > forget :: a -> b 7 | 8 | > traceIndex :: [a] -> Int -> String -> a 9 | > traceIndex xs i str | length xs <= i = error $ " !! index too large: " ++ str 10 | > | otherwise = xs!!i 11 | 12 | > safeIndex :: [a] -> Int -> a -> a 13 | > safeIndex xs i def | length xs <= i = def 14 | > | otherwise = xs!!i 15 | 16 | =================== Result Monad ======================== 17 | 18 | > data Result r 19 | > = Success r 20 | > | Failure String 21 | > deriving (Show, Eq) 22 | 23 | > instance Monad Result where 24 | > (Success r) >>= k = k r 25 | > (Failure err) >>= k = Failure err 26 | > return = Success 27 | > fail s = Failure s 28 | 29 | > instance Functor Result where 30 | > fmap f (Failure str) = Failure str 31 | > fmap f (Success s) = Success (f s) 32 | 33 | ====================== Snoc Lists =========================== 34 | 35 | > data Spine x = Empty | Snoc (Spine x) x 36 | 37 | > infix 5 ?? 38 | > (??) :: Spine x -> Int -> x 39 | > (Snoc _ x) ?? 0 = x 40 | > (Snoc xs _) ?? n | n>0 = xs ?? (n-1) 41 | > (Snoc _ _) ?? _ = error "?? - negative index" 42 | 43 | > end (Snoc sp x) = x 44 | > start (Snoc sp x) = sp 45 | 46 | > size :: Spine x -> Int 47 | > size Empty = 0 48 | > size (Snoc xs x) = 1+(size xs) 49 | 50 | > lose :: Int -> Spine x -> Spine x 51 | > lose 0 (Snoc xs x) = xs 52 | > lose n (Snoc xs x) = (Snoc (lose (n-1) xs) x) 53 | 54 | > listify :: Spine x -> [x] 55 | > listify xs = list' [] xs 56 | > where list' acc Empty = acc 57 | > list' acc (Snoc xs x) = list' (x:acc) xs 58 | 59 | > revlistify :: Spine x -> [x] 60 | > revlistify Empty = [] 61 | > revlistify (Snoc xs x) = x:(revlistify xs) 62 | 63 | > instance Functor Spine where 64 | > fmap f Empty = Empty 65 | > fmap f (Snoc sp x) = Snoc (fmap f sp) (f x) 66 | 67 | ========= Functions I want in the standard library... ========= 68 | 69 | > lookupM :: (Monad m, Eq a) => a -> [(a,b)] -> m b 70 | > lookupM y [] = fail "Not found" 71 | > lookupM y ((x,v):xs) | x == y = return v 72 | > | otherwise = lookupM y xs 73 | 74 | Look for a file in the current directory, then each directory listed 75 | in turn. If present, return the contents, otherwise fail 76 | 77 | > findFile :: [FilePath] -> FilePath -> IO String 78 | > findFile fp fn = ff' (".":fp) fn 79 | > where ff' [] fn = fail "File not found in search path" 80 | > ff' (d:ds) fn = do 81 | > catch (do content <- readFile $ d ++ "/" ++ fn 82 | > return content) 83 | > (\e -> ff' ds fn) 84 | 85 | > unJust :: Maybe a -> a 86 | > unJust (Just a) = a -------------------------------------------------------------------------------- /Ivor/MakeData.lhs: -------------------------------------------------------------------------------- 1 | > module Ivor.MakeData where 2 | 3 | > import Ivor.TTCore 4 | > import Ivor.Datatype 5 | 6 | > import Debug.Trace 7 | 8 | Transform a raw data declaration (just parameters and constructors) 9 | into a full data definition with iota schemes. 10 | 11 | FIXME: Throughout all this, need to ensure that the elimination operator name, 12 | the target, methods and the motives are unique. 13 | 14 | > type Params = [(Name,Raw)] 15 | > type Constructors = [(Name,Raw)] 16 | 17 | > mkRawData :: Monad m => 18 | > Name -> Params -> Raw -> Constructors -> m RawDatatype 19 | > mkRawData name params contype cons = 20 | > let ecasetype = mkCaseType True name params contype cons 21 | > motiveName methNames 22 | > ccasetype = mkCaseType False name params contype cons 23 | > motiveName methNames 24 | > datacons = mkDatacons params cons 25 | > eischemes = mkSchemes True name (ruleName name "Elim") 26 | > params datacons motiveName methNames 27 | > cischemes = mkSchemes False name (ruleName name "Case") 28 | > params datacons motiveName methNames 29 | > tycontype = mkCon params contype in 30 | > return $ RData (name,tycontype) datacons (length params) 31 | > (ruleName name "Elim", ecasetype) -- elim rule 32 | > (ruleName name "Case", ccasetype) -- case rule 33 | > eischemes -- elim rule iota schemes 34 | > cischemes -- case rule iota schemes 35 | 36 | > where ruleName (UN n) suff = (UN (n++suff)) -- TMP HACK! 37 | > motiveName = (UN "Phi") 38 | > methName (UN n) = (UN ("meth_"++n)) 39 | > methNames = map (methName.fst) cons 40 | 41 | > mkSchemes :: Bool -> Name -> Name -> Params -> Constructors -> Name -> 42 | > [Name] -> [RawScheme] 43 | > mkSchemes rec n ername ps cs motive mns = mks cs mns mns 44 | > where mks [] [] mns = [] 45 | > mks ((c,cty):cs) (m:ms) mns 46 | > = (mkScheme rec n ername ps c cty motive mns m):(mks cs ms mns) 47 | 48 | > mkScheme rec n ername ps c cty motive mns meth 49 | > = RSch (mkIArgs ps c cty motive mns) 50 | > (RWRet (mkIRet rec n ername meth motive mns ps cty)) 51 | 52 | > mkIArgs ps c cty motive mns = getappargs (getrettype cty) ++ 53 | > [mkapp (Var c) (map Var (getargnames cty))] ++ 54 | > (map Var (motive:mns)) 55 | 56 | > mkIRet rec tyname ername meth motive mns ps cty = 57 | > mkapp (Var meth) (drop (length ps) (mkArgs cty)) 58 | > where mkArgs (RBind n (B Pi ty) sc) 59 | > | isrec ty tyname && rec 60 | > = (Var n):(mkRecApp ername ty n motive mns):(mkArgs sc) 61 | > | otherwise = (Var n):(mkArgs sc) 62 | > mkArgs (RFileLoc f l t) = mkArgs t 63 | > mkArgs _ = [] 64 | > mkRecApp en ty n motive mns = 65 | > mkapp (Var en) $ (getappargs ty)++(map Var (n:motive:mns)) 66 | 67 | 68 | > mkCon :: Params -> Raw -> Raw 69 | > mkCon [] ty = ty 70 | > mkCon ((x,xty):xs) ty = RBind x (B Pi xty) (mkCon xs ty) 71 | 72 | > mkDatacons :: Params -> Constructors -> Constructors 73 | > mkDatacons _ [] = [] 74 | > mkDatacons ps ((x,xty):xs) = (x,(mkCon ps xty)):(mkDatacons ps xs) 75 | 76 | > mkCaseType :: Bool -> Name -> Params -> Raw -> Constructors -> Name -> 77 | > [Name] -> Raw 78 | > mkCaseType rec n ps ty cs motiveName mns 79 | > = bindParams ps $ 80 | > bindIndices ty $ 81 | > bindTarget targetName n ps ty $ 82 | > bindMotive motiveName targetName n ps ty $ 83 | > bindMethods rec n motiveName ps cs mns $ 84 | > applyMethod motiveName targetName ty 85 | > where targetName = UN "target" -- TMP HACK! 86 | 87 | > bindParams [] rest = rest 88 | > bindParams ((n,ty):xs) rest = RBind n (B Pi ty) (bindParams xs rest) 89 | 90 | > bindIndices (RBind n (B Pi ty) sc) rest 91 | > = (RBind n (B Pi ty) (bindIndices sc rest)) 92 | > bindIndices (RFileLoc f l t) rest = bindIndices t rest 93 | > bindIndices sc rest = rest 94 | 95 | > bindTarget x n ps ty rest 96 | > = RBind x 97 | > (B Pi (mkapp (Var n) (map Var ((map fst ps)++(getargnames ty))))) 98 | > rest 99 | 100 | > bindMotive p x n ps ty rest 101 | > = RBind p 102 | > (B Pi (bindIndices ty $ 103 | > bindTarget x n ps ty $ 104 | > RStar)) rest 105 | 106 | > bindMethods rec tyname p ps [] [] rest = rest 107 | > bindMethods rec tyname p ps ((n,ty):cs) (mn:mns) rest 108 | > = RBind mn (B Pi (methtype ty)) (bindMethods rec tyname p ps cs mns rest) 109 | > where methtype (RBind a (B Pi argtype) sc) 110 | > | isrec argtype tyname && rec 111 | > = (RBind a (B Pi argtype) (mkrec a argtype sc)) 112 | > | otherwise = (RBind a (B Pi argtype) (methtype sc)) 113 | > methtype (RFileLoc _ _ t) = methtype t 114 | > methtype sc = mkapp (Var p) $ (getindices sc)++ 115 | > [mkapp (Var n) (map Var ((map fst ps)++(getargnames ty)))] 116 | > mkrec a argtype sc = (RBind (ih a) (B Pi (rectype a argtype p)) 117 | > (methtype sc)) 118 | > getindices x = drop (length ps) (getappargs x) 119 | > ih (UN a) = UN (a++"_IH") 120 | > rectype a aty p = mkapp (Var p) ((drop (length ps) (getappargs aty)++[Var a])) 121 | 122 | > applyMethod p x ty = mkapp (Var p) ((map Var (getargnames ty)) ++ [Var x]) 123 | 124 | 125 | > isrec t tyname = (Var tyname) == getappfun t 126 | 127 | > placeholder = Var (UN "Waitforit") 128 | 129 | -------------------------------------------------------------------------------- /Ivor/Makefile: -------------------------------------------------------------------------------- 1 | GHC = ghc 2 | GHCI = ghci 3 | CXX = g++ 4 | CC = gcc 5 | HSLINK = -L/usr/lib/ghc-6.0.1 -lHSrts -lHShaskell98 -lHSlang -lHSlang_cbits -lHSbase -lHSbase_cbits -lHSrts -lHSutil -lm -lgmp 6 | CXXFLAGS = -g -Wall -I/usr/lib/ghc-6.0.1/include 7 | CFLAGS = -g -Wall -I/usr/lib/ghc-6.0.1/include 8 | PACKAGES = -package util 9 | LIBTARGET = libttcore.a 10 | TARGET = tt 11 | PROF = 12 | OPTS = ${PROF} -auto-all -fglasgow-exts ${PACKAGES} 13 | 14 | OBJS = Parser.o Nobby.o TTCore.o Gadgets.o State.o Typecheck.o \ 15 | Main.o Datatype.o ICompile.o Grouper.o SC.o Bytecode.o \ 16 | CodegenC.o Tactics.o Display.o Unify.o MakeData.o TT.o 17 | 18 | SRCS = Parser.hs Nobby.lhs TTCore.lhs Gadgets.lhs State.lhs \ 19 | Typecheck.lhs Datatype.lhs ICompile.lhs \ 20 | Grouper.lhs SC.lhs Bytecode.lhs CodegenC.lhs Tactics.lhs \ 21 | Display.lhs Unify.lhs MakeData.lhs TT.lhs 22 | 23 | all: ${TARGET} 24 | 25 | ${TARGET}: 26 | ${GHC} --make ${OPTS} Main.lhs -o ${TARGET} 27 | # ${GHC} ${OPTS} ${OBJS} -o ${TARGET} 28 | 29 | logic: LogicDemo.lhs ${SRCS} 30 | ${GHC} --make ${OPTS} LogicDemo.lhs -o logic 31 | 32 | Parser.hs: Parser.y 33 | happy -g -a -c Parser.y -iParser.out -o Parser.hs.in 34 | sed 's/error \"reading EOF!\"/TokenEOF/' Parser.hs.in > Parser.hs 35 | rm Parser.hs.in 36 | 37 | ghci: Parser.hs 38 | ${GHCI} ${OPTS} -fglasgow-exts Main.lhs 39 | 40 | depend : Parser.hs 41 | ${GHC} -M ${OPTS} ${SRCS} 42 | 43 | doc : TT.lhs 44 | ghc -cpp -E -optP-P -D__HADDOCK__ TT.lhs -o TT.hs 45 | haddock -h TT.hs -o docs 46 | rm TT.hs 47 | 48 | clean: 49 | rm -f *.o *.hi Parser.hs Parser.out ${TARGET} 50 | 51 | decruft: 52 | rm -f *~ 53 | 54 | # Implicit rules for haskell source 55 | 56 | %.o: %.lhs 57 | ${GHC} -c ${OPTS} $< -o $@ 58 | 59 | %.o: %.hs 60 | ${GHC} -c ${OPTS} $< -o $@ 61 | 62 | %.hi: %.o 63 | @: 64 | 65 | # DO NOT DELETE: Beginning of Haskell dependencies 66 | Gadgets.o : Gadgets.lhs 67 | TT.o : TT.lhs 68 | TT.o : Gadgets.hi 69 | Nobby.o : Nobby.lhs 70 | Nobby.o : Gadgets.hi 71 | Nobby.o : TT.hi 72 | Typecheck.o : Typecheck.lhs 73 | Typecheck.o : Nobby.hi 74 | Typecheck.o : Gadgets.hi 75 | Typecheck.o : TT.hi 76 | Datatype.o : Datatype.lhs 77 | Datatype.o : Nobby.hi 78 | Datatype.o : Typecheck.hi 79 | Datatype.o : Gadgets.hi 80 | Datatype.o : TT.hi 81 | MakeData.o : MakeData.lhs 82 | MakeData.o : Datatype.hi 83 | MakeData.o : TT.hi 84 | ICompile.o : ICompile.lhs 85 | ICompile.o : Gadgets.hi 86 | ICompile.o : Nobby.hi 87 | ICompile.o : Datatype.hi 88 | ICompile.o : TT.hi 89 | Grouper.o : Grouper.lhs 90 | Grouper.o : Nobby.hi 91 | Grouper.o : TT.hi 92 | SC.o : SC.lhs 93 | SC.o : ICompile.hi 94 | SC.o : Nobby.hi 95 | SC.o : TT.hi 96 | SC.o : Grouper.hi 97 | Bytecode.o : Bytecode.lhs 98 | Bytecode.o : TT.hi 99 | Bytecode.o : SC.hi 100 | CodegenC.o : CodegenC.lhs 101 | CodegenC.o : SC.hi 102 | CodegenC.o : Bytecode.hi 103 | Unify.o : Unify.lhs 104 | Unify.o : Typecheck.hi 105 | Unify.o : TT.hi 106 | Unify.o : Nobby.hi 107 | Tactics.o : Tactics.lhs 108 | Tactics.o : Unify.hi 109 | Tactics.o : Gadgets.hi 110 | Tactics.o : Nobby.hi 111 | Tactics.o : Typecheck.hi 112 | Tactics.o : TT.hi 113 | Display.o : Display.lhs 114 | Display.o : Nobby.hi 115 | Display.o : Typecheck.hi 116 | Display.o : TT.hi 117 | Display.o : Tactics.hi 118 | Parser.o : Parser.hs 119 | Parser.o : Datatype.hi 120 | Parser.o : Gadgets.hi 121 | Parser.o : TT.hi 122 | State.o : State.lhs 123 | State.o : Unify.hi 124 | State.o : Display.hi 125 | State.o : Tactics.hi 126 | State.o : CodegenC.hi 127 | State.o : Bytecode.hi 128 | State.o : SC.hi 129 | State.o : Grouper.hi 130 | State.o : ICompile.hi 131 | State.o : MakeData.hi 132 | State.o : Datatype.hi 133 | State.o : Typecheck.hi 134 | State.o : Gadgets.hi 135 | State.o : Nobby.hi 136 | State.o : TT.hi 137 | State.o : Parser.hi 138 | Main.o : Main.lhs 139 | Main.o : State.hi 140 | Main.o : Parser.hi 141 | Main.o : Typecheck.hi 142 | Main.o : Nobby.hi 143 | Main.o : Gadgets.hi 144 | Main.o : TT.hi 145 | HumeTT.o : HumeTT.lhs 146 | HumeTT.o : Tactics.hi 147 | HumeTT.o : Bytecode.hi 148 | HumeTT.o : SC.hi 149 | HumeTT.o : Nobby.hi 150 | HumeTT.o : Gadgets.hi 151 | HumeTT.o : Typecheck.hi 152 | HumeTT.o : State.hi 153 | HumeTT.o : Parser.hi 154 | HumeTT.o : TT.hi 155 | # DO NOT DELETE: End of Haskell dependencies 156 | -------------------------------------------------------------------------------- /Ivor/Overloading.lhs: -------------------------------------------------------------------------------- 1 | Facilities for handling overloading. This is currently a bodge - terms 2 | contain 'ROpts' which are variables which could be one of several things. 3 | We convert such terms to a list of terms which contain all the possible 4 | combinations of 'Var', typecheck them all, and if only one succeeds, that's 5 | the right overloading. If more than one succeeds, there is an ambiguous name. 6 | 7 | > module Ivor.Overloading where 8 | 9 | > import Ivor.TTCore 10 | 11 | > getTerms :: Raw -> [Raw] 12 | > getTerms (Var n) = return $ Var n 13 | > getTerms (ROpts ns) = do n <- ns 14 | > return $ Var n 15 | > getTerms (RApp f a) = do f' <- getTerms f 16 | > a' <- getTerms a 17 | > return $ RApp f' a' 18 | > getTerms (RBind n (B b t) sc) 19 | > = do b' <- gtb b 20 | > t' <- getTerms t 21 | > sc' <- getTerms sc 22 | > return $ RBind n (B b' t') sc' 23 | > where gtb Lambda = return Lambda 24 | > gtb Pi = return Pi 25 | > gtb (Let t) = do t' <- getTerms t 26 | > return $ Let t' 27 | > gtb Hole = return Hole 28 | > gtb (Guess t) = do t' <- getTerms t 29 | > return $ Guess t' 30 | > gtb (Pattern t) = do t' <- getTerms t 31 | > return $ Guess t' 32 | > gtb MatchAny = return MatchAny 33 | > getTerms (RFileLoc f l t) = do t' <- getTerms t 34 | > return (RFileLoc f l t') 35 | > getTerms t = return t 36 | -------------------------------------------------------------------------------- /Ivor/Plugin.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > -- | 4 | > -- Module : Ivor.Plugin 5 | > -- Copyright : Edwin Brady 6 | > -- Licence : BSD-style (see LICENSE in the distribution) 7 | > -- 8 | > -- Maintainer : eb@dcs.st-and.ac.uk 9 | > -- Stability : experimental 10 | > -- Portability : portable 11 | > -- 12 | > -- Plugin loader 13 | 14 | > module Ivor.Plugin(Ivor.Plugin.load) where 15 | 16 | > import Ivor.TT 17 | > import Ivor.ShellState 18 | 19 | > -- import System.Plugins as Plugins 20 | > import Text.ParserCombinators.Parsec 21 | 22 | > -- | Load the given plugin file (which should be a full path to a .o or 23 | > -- .hs file) and update the Context. If it is a .hs file, it will be 24 | > -- compiled if necessary. 25 | > -- Plugins must contain the symbol 26 | > -- @plugin_context :: Monad m => Context -> m Context@ 27 | > -- which updates the context. It may optionally contain symbols 28 | > -- @plugin_parser :: Parser ViewTerm@ 29 | > -- which adds new parsing rules, 30 | > -- @plugin_shell :: ShellState -> IO ShellState@ 31 | > -- which updates the shell 32 | > -- @plugin_commands :: IO [(String, String -> COntext -> IO (String, Context))]@ 33 | > -- which adds new user defined commands (which may need to do some setting up themselves, hence the IO) 34 | > -- Returns the new context and the extra parsing rules and commands, if any. 35 | 36 | > load :: FilePath -> Context -> IO (Context, 37 | > Maybe (Parser ViewTerm), 38 | > Maybe (ShellState -> IO ShellState), 39 | > Maybe (IO [(String, String -> Context -> IO (String, Context))])) 40 | 41 | > load fn ctxt = fail "Currently disabled" 42 | 43 | -- > load fn ctxt = do 44 | -- > objIn <- compilePlugin fn 45 | -- > obj <- case objIn of 46 | -- > Left errs -> fail errs 47 | -- > Right ok -> return ok 48 | -- > contextMod <- Plugins.load_ obj [] "plugin_context" 49 | -- > -- mv <- Plugins.load fn [] ["/Users/edwin/.ghc/i386-darwin-6.6.1/package.conf"] "initialise" 50 | -- > (mod, contextFn) <- case contextMod of 51 | -- > LoadFailure msg -> fail $ "Plugin loading failed: " ++ 52 | -- > show msg 53 | -- > LoadSuccess mod v -> return (mod, v) 54 | -- > parserMod <- Plugins.reload mod "plugin_parser" 55 | -- > parserules <- case parserMod of 56 | -- > LoadFailure msg -> return Nothing 57 | -- > LoadSuccess _ v -> return $ Just v 58 | -- > cmdMod <- Plugins.reload mod "plugin_commands" 59 | -- > cmds <- case cmdMod of 60 | -- > LoadFailure msg -> return Nothing 61 | -- > LoadSuccess _ v -> return $ Just v 62 | -- > shellMod <- Plugins.reload mod "plugin_shell" 63 | -- > shellfn <- case shellMod of 64 | -- > LoadFailure msg -> return Nothing 65 | -- > LoadSuccess _ v -> return $ Just v 66 | -- > ctxt' <- case contextFn ctxt of 67 | -- > Just x -> return x 68 | -- > Nothing -> fail "Error in running plugin_context" 69 | -- > return $ (ctxt', parserules, shellfn, cmds) 70 | 71 | -- Make a .o from a .hs, so that we can load Haskell source as well as object 72 | -- files 73 | 74 | -- > compilePlugin :: FilePath -> IO (Either String FilePath) 75 | -- > compilePlugin hs 76 | -- > | isExt ".hs" hs || isExt ".lhs" hs = 77 | -- > do status <- makeAll hs [] 78 | -- > case status of 79 | -- > MakeSuccess c out -> return $ Right out 80 | -- > MakeFailure errs -> return $ Left (concat (map (++"\n") errs)) 81 | -- > | isExt ".o" hs = return $ Right hs 82 | -- > | elem '.' hs = return (Left $ "unrecognised file type " ++ hs) 83 | -- > | otherwise = compilePlugin (hs++".o") 84 | -- > where isExt ext fn = case span (/='.') fn of 85 | -- > (file, e) -> ext == e -------------------------------------------------------------------------------- /Ivor/Primitives.lhs: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Ivor/23d8bc68d705c2e11009f137edb3f5eced84d960/Ivor/Primitives.lhs -------------------------------------------------------------------------------- /Ivor/Scopecheck.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.Scopecheck(scopeCheck) where 4 | 5 | > import Ivor.TTCore 6 | > import Ivor.Nobby 7 | > import Ivor.Typecheck 8 | > import Ivor.Values 9 | 10 | Typechecking on terms we assume to be okay - in other words, just convert 11 | bound names to a de Bruijn index. 12 | 13 | > scopeCheck :: Gamma Name -> Env Name -> Raw -> TT Name 14 | > scopeCheck gam = sc where 15 | > sc :: Env Name -> Raw -> TT Name 16 | > sc env (Var n) = 17 | > case lookup n env of 18 | > Just _ -> P n 19 | > Nothing -> case glookup n gam of 20 | > Just ((DCon tag i _), _) -> Con tag n i 21 | > Just ((TCon i _),_) -> TyCon n i 22 | > _ -> P n 23 | > sc env (RApp f a) = App (sc env f) (sc env a) 24 | > sc env (RConst c) = Const c 25 | > sc env (RBind n b scope) = 26 | > let b' = scBinder env b 27 | > sc' = sc ((n,b'):env) scope in 28 | > Bind n b' (pToV n sc') 29 | > sc env RStar = Star 30 | > sc env RInfer = error "Can't fastcheck a term with placeholders" 31 | > sc env t = error $ "Can't fastcheck " ++ show t 32 | 33 | > scBinder :: Env Name -> Binder Raw -> Binder (TT Name) 34 | > scBinder env (B (Let v) t) 35 | > = let v' = sc env v 36 | > t' = sc env t in 37 | > B (Let v') t' 38 | > scBinder env (B Lambda t) 39 | > = let t' = sc env t in 40 | > B Lambda t' 41 | > scBinder env (B Pi t) 42 | > = let t' = sc env t in 43 | > B Pi t' 44 | > scBinder env (B (Guess v) t) 45 | > = error "Can't fastcheck a term with guesses" 46 | > scBinder env (B (Pattern v) t) 47 | > = error "Can't fastcheck a term with patterns" 48 | > scBinder env (B MatchAny t) 49 | > = error "Can't fastcheck a term with patterns" 50 | > scBinder env (B Hole t) 51 | > = error "Can't fastcheck a term with holes" 52 | 53 | 54 | -------------------------------------------------------------------------------- /Ivor/ShellState.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > -- | 4 | > -- Module : Ivor.Shell 5 | > -- Copyright : Edwin Brady 6 | > -- Licence : BSD-style (see LICENSE in the distribution) 7 | > -- 8 | > -- Maintainer : eb@dcs.st-and.ac.uk 9 | > -- Stability : experimental 10 | > -- Portability : non-portable 11 | > -- 12 | > -- Shell interface to theorem prover 13 | 14 | > module Ivor.ShellState(ShellState(..)) where 15 | 16 | > import Ivor.TT as TT 17 | > import Text.ParserCombinators.Parsec 18 | 19 | > data ShellState = Shell { 20 | > repldata :: Maybe (String, String, String), 21 | > prompt :: String, 22 | > finished :: Bool, 23 | > context :: !Context, 24 | > -- | Get reply from last shell command 25 | > response :: String, 26 | > usertactics :: [(String, String -> Goal -> Context -> TTM Context)], 27 | > usercommands :: [(String, String -> Context -> IO (String, Context))], 28 | > imported :: [String], 29 | > extensions :: Maybe (Parser ViewTerm), 30 | > -- search path for modules to load 31 | > modulePath :: [FilePath] 32 | > } 33 | 34 | 35 | -------------------------------------------------------------------------------- /Ivor/Specialise.lhs: -------------------------------------------------------------------------------- 1 | > {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.Specialise where 4 | 5 | > import Ivor.Gadgets 6 | > import Ivor.TTCore 7 | > import Ivor.Nobby 8 | > import Ivor.Typecheck 9 | > import Ivor.Errors 10 | > import Ivor.Values 11 | > import Ivor.Evaluator 12 | 13 | > import Debug.Trace 14 | > import Data.List 15 | > import Control.Monad 16 | 17 | Specialise pattern matching definitions 18 | 19 | specialise :: Context -> Patterns -> 20 | [(Name, ([Int], Int))] -> -- functions with static args 21 | [Name] -> -- frozen names 22 | (Patterns, Context, [Name]) -- also, new names 23 | specialise ctxt p = (p, ctxt, []) -- TODO 24 | -------------------------------------------------------------------------------- /Ivor/State.lhs: -------------------------------------------------------------------------------- 1 | \> {-# OPTIONS_GHC -fglasgow-exts #-} 2 | 3 | > module Ivor.State where 4 | 5 | > import Ivor.TTCore 6 | > import Ivor.Nobby 7 | > import Ivor.Gadgets 8 | > import Ivor.Typecheck 9 | > import Ivor.Datatype 10 | > import Ivor.MakeData 11 | > import Ivor.Tactics as Tactics 12 | > import Ivor.Display 13 | > import Ivor.Unify 14 | > import Ivor.Errors 15 | > import Ivor.Values 16 | > import Ivor.PMComp 17 | 18 | > import System.Environment 19 | > import Data.List 20 | > import Debug.Trace 21 | 22 | State of the system, include all definitions, pattern matching rules, 23 | compiled terms, etc. 24 | 25 | > data IState = ISt { 26 | > -- All definitions 27 | > defs :: !(Gamma Name), 28 | > -- All datatype definitions 29 | > datadefs :: [(Name,Datatype Name)], 30 | > -- All elimination rules in their pattern matching form 31 | > -- (with type) 32 | > eliminators :: [(Name, (Indexed Name, 33 | > ([RawScheme], PMFun Name)))], 34 | > -- List of holes to be solved in proof state 35 | > holequeue :: ![Name], 36 | > -- Premises we're not interested in, so don't show 37 | > hidden :: [Name], 38 | > -- Current proof term (FIXME: Combine with holequeue, and make it efficient) 39 | > proofstate :: !(Maybe (Indexed Name)), 40 | > -- Actions required of last tactic 41 | > actions :: ![TacticAction], 42 | > -- List of fresh names for tactics to use 43 | > namesupply :: [Name], 44 | > -- Output from last operation 45 | > response :: String, 46 | > -- Previous state 47 | > undoState :: !(Maybe IState) 48 | > } 49 | 50 | > initstate = ISt (emptyGam) [] [] [] [] Nothing [] mknames "" Nothing 51 | > where mknames = [MN ("myName",x) | x <- [1..]] 52 | 53 | > respond :: IState -> String -> IState 54 | > respond st str = st { response = (response st) ++ str } 55 | 56 | > gensym :: IState -> (Name, IState) 57 | > gensym st = (head (namesupply st), 58 | > st { namesupply = tail (namesupply st) }) 59 | 60 | > jumpqueue hole q = nub (hole: (q \\ [hole])) 61 | > stail (x:xs) = xs 62 | > stail [] = [] 63 | 64 | > prf st = case (proofstate st) of 65 | > Nothing -> error "Can't happen" 66 | > (Just x) -> x 67 | 68 | > saveState st = let st' = st in 69 | > st { undoState = Just st' } 70 | 71 | Take a data type definition and add constructors and elim rule to the context. 72 | 73 | > doData :: Bool -> IState -> Name -> RawDatatype -> IvorM IState 74 | > doData elim st n r = do 75 | > let ctxt = defs st 76 | > dt <- if elim then checkType (defs st) r -- Make iota schemes 77 | > else checkTypeNoElim (defs st) r 78 | > ctxt <- gInsert (fst (tycon dt)) (snd (tycon dt)) ctxt 79 | > -- let ctxt' = (tycon dt):ctxt 80 | > ctxt <- addCons (datacons dt) ctxt 81 | > case e_ischemes dt of 82 | > Just eischemes -> 83 | > -- We've done elim rules 84 | > do let (Just cischemes) = c_ischemes dt 85 | > ctxt <- 86 | > addElim ctxt (erule dt) eischemes 87 | > newdefs <- 88 | > addElim ctxt (crule dt) cischemes 89 | > let newelims = (fst (erule dt), (snd (erule dt), 90 | > (e_rawschemes dt, eischemes))): 91 | > (fst (crule dt), (snd (crule dt), 92 | > (c_rawschemes dt, cischemes))): 93 | > eliminators st 94 | > let newdatadefs = (n,dt):(datadefs st) 95 | > return $ st { defs = newdefs, datadefs = newdatadefs, 96 | > eliminators = newelims 97 | > } 98 | > Nothing -> -- no elim rules 99 | > return $ st { defs = ctxt, 100 | > datadefs = (n,dt):(datadefs st) } 101 | > where addCons [] ctxt = return ctxt 102 | > addCons ((n,gl):xs) ctxt = do 103 | > ctxt <- addCons xs ctxt 104 | > gInsert n gl ctxt 105 | > addElim ctxt erule schemes = do 106 | > let rnm = fst erule 107 | > let rty = snd erule 108 | > newdefs <- gInsert rnm 109 | > (G (patternDef ctxt rnm rty schemes True False) rty defplicit) 110 | > ctxt 111 | > return newdefs 112 | 113 | > patternDef gam n (Ind ty) pmf t g = PatternDef pmf t g (pmcomp gam n ty pmf) 114 | 115 | 116 | > doMkData :: Bool -> IState -> Datadecl -> IvorM IState 117 | > doMkData elim st (Datadecl n ps rawty cs) 118 | > = do (gty,_) <- checkIndices (defs st) ps [] rawty 119 | > let ty = forget (normalise (defs st) gty) 120 | > -- TMP HACK: Do it twice, to fill in _ placeholders. 121 | > rd1 <- mkRawData n ps ty cs 122 | > dt1 <- checkTypeNoElim (defs st) rd1 123 | > let csfilled = map (forgetcon (length ps)) (datacons dt1) 124 | > rd <- mkRawData n ps ty csfilled 125 | > doData elim st n rd 126 | > where checkIndices gam [] env rawty = check gam env rawty Nothing 127 | > checkIndices gam ((n,nrawty):xs) env rawty = do 128 | > (Ind nty,_) <- check gam env nrawty Nothing 129 | > checkIndices gam xs (env++[(n,B Pi nty)]) rawty 130 | > -- also need to strip parameters 131 | > forgetcon numps (n, (G _ (Ind t) _)) = (n, (stripps numps (forget t))) 132 | > stripps 0 t = t 133 | > stripps n (RBind _ _ sc) = stripps (n-1) sc 134 | 135 | > suspendProof :: IState -> IvorM IState 136 | > suspendProof st = do case proofstate st of 137 | > (Just prf) -> do 138 | > let olddefs = defs st 139 | > newdef <- suspendFrom (defs st) prf (holequeue st) 140 | > return $ st { proofstate = Nothing, 141 | > defs = extend olddefs newdef, 142 | > holequeue = [] 143 | > } 144 | > _ -> fail "No proof in progress" 145 | 146 | > suspendFrom gam (Ind (Bind x (B (Guess v) ty) (Sc (P n)))) q | n == x = 147 | > return $ (x, G (Partial (Ind v) q) (finalise (Ind ty)) defplicit) 148 | > suspendFrom _ _ _ = fail "Not a suspendable proof" 149 | 150 | > resumeProof :: IState -> Name -> IvorM IState 151 | > resumeProof st n = case (proofstate st) of 152 | > Nothing -> 153 | > case glookup n (defs st) of 154 | > Just ((Partial (Ind v) q),(Ind ty)) -> do 155 | > -- recheck in case any of the names have changed 'status' 156 | > -- (e.g., from undefined to defined type constructors) 157 | > let vraw = forget v 158 | > let traw = forget ty 159 | > (Ind vrecheck, _) <- typecheck (defs st) vraw 160 | > (Ind trecheck, _) <- typecheck (defs st) traw 161 | > return $ st 162 | > { proofstate = Just 163 | > (Ind (Bind n (B (Guess (makePs vrecheck)) 164 | > (makePs trecheck)) 165 | > (Sc (P n)))), 166 | > defs = remove n (defs st), 167 | > holequeue = q 168 | > } 169 | > _ -> fail "Not a suspended proof" 170 | > (Just _) -> fail "Already a proof in progress" 171 | 172 | And an argument to the current proof (after any dependencies) 173 | e.g. adding z:C x to foo : (x:A)(y:B)Z = [x:A][y:B]H 174 | becomes foo : (x:A)(z:C x)(y:B) = [x:A][z:C x][y:B]H. 175 | 176 | > addArg :: IState -> Name -> TT Name -> IvorM IState 177 | > addArg st n ty = 178 | > case proofstate st of 179 | > Just (Ind (Bind n (B (Guess v) t) sc)) -> do 180 | > (v',t') <- addArgTy v t (getDeps ty) 181 | > return $ st { proofstate = Just (Ind (Bind n (B (Guess v') t') sc)) } 182 | > _ -> fail "Can't add argument now" 183 | > where 184 | > getDeps ty = filter (nonfree (defs st)) (getNames (Sc ty)) 185 | > nonfree gam n | Nothing <- lookupval n gam = True 186 | > | otherwise = False 187 | > addArgTy v t [] = return (Bind n (B Lambda ty) (Sc v), 188 | > Bind n (B Pi ty) (Sc t)) 189 | > addArgTy (Bind n (B Lambda nty) (Sc v)) 190 | > (Bind n' (B Pi nty') (Sc t)) ds 191 | > | n == n' = do (v',t') <- addArgTy v t (ds \\ [n]) 192 | > return (Bind n (B Lambda nty) (Sc v'), 193 | > Bind n (B Pi nty) (Sc t')) 194 | > addArgTy _ _ _ = fail "Can't add argument here" 195 | 196 | 197 | 198 | > dumpState :: IState -> String 199 | > dumpState st = dumpProofstate (proofstate st) 200 | > where dumpProofstate Nothing = "" 201 | > dumpProofstate (Just p) = dhole p (holequeue st) 202 | > 203 | > dhole p [] = show p 204 | > dhole p (n:ns) = displayHoleContext (defs st) (hidden st) n p ++ 205 | > "Next holes: " ++ show ns++"\n" 206 | -------------------------------------------------------------------------------- /Ivor/rts/Makefile: -------------------------------------------------------------------------------- 1 | TARGET = testdrive 2 | CC = gcc 3 | CFLAGS = -O 4 | 5 | OBJS = closure.o testdrive.o 6 | 7 | all: ${TARGET} 8 | 9 | ${TARGET}: ${OBJS} 10 | ${CC} ${CFLAGS} ${OBJS} -o ${TARGET} -lgc 11 | 12 | clean: 13 | rm -f ${TARGET} *.o *~ 14 | 15 | closure.o: closure.h 16 | testdrive.o: closure.h test.c 17 | 18 | -------------------------------------------------------------------------------- /Ivor/rts/closure.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | #include 3 | 4 | VAL DontCare; 5 | 6 | extern VAL eval(VAL x); 7 | 8 | void VM_init() 9 | { 10 | DontCare = MKVAL; 11 | DontCare->ty = TYPE; 12 | DontCare->info = NULL; 13 | } 14 | 15 | void showclosure(VAL f) { 16 | switch(f->ty) { 17 | case FUN: 18 | printf("FUN %d %d",((function*)(f->info))->ftag,((function*)(f->info))->next); 19 | break; 20 | case CON: 21 | printf("CON %d",TAG(f)); 22 | break; 23 | case TYPE: 24 | printf("TYPE"); 25 | break; 26 | } 27 | } 28 | 29 | closure* CLOSURE0(int ftag, int argspace) 30 | { 31 | closure* v = MKVAL; 32 | function* f = MKFUN; 33 | f->ftag = ftag; 34 | f->space = argspace; 35 | f->next = 0; 36 | f->args = MKARGS(argspace); 37 | v->ty = FUN; 38 | v->info=(void*)f; 39 | return eval(v); 40 | } 41 | 42 | closure* CLOSURE1(int ftag, int argspace, closure* val) 43 | { 44 | closure* v = MKVAL; 45 | function* f = MKFUN; 46 | f->ftag = ftag; 47 | f->space = argspace; 48 | f->next = 1; 49 | f->args = MKARGS(argspace); 50 | f->args[0] = val; 51 | v->ty = FUN; 52 | v->info=(void*)f; 53 | return eval(v); 54 | } 55 | 56 | closure* CLOSURE2(int ftag, int argspace, closure* val, closure* val2) 57 | { 58 | closure* v = MKVAL; 59 | function* f = MKFUN; 60 | f->ftag = ftag; 61 | f->space = argspace; 62 | f->next = 2; 63 | f->args = MKARGS(argspace); 64 | f->args[0] = val; 65 | f->args[1] = val2; 66 | v->ty = FUN; 67 | v->info=(void*)f; 68 | return eval(v); 69 | } 70 | 71 | closure* CLOSURE3(int ftag, int argspace, closure* val, closure* val2, 72 | closure* val3) 73 | { 74 | closure* v = MKVAL; 75 | function* f = MKFUN; 76 | f->ftag = ftag; 77 | f->space = argspace; 78 | f->next = 3; 79 | f->args = MKARGS(argspace); 80 | f->args[0] = val; 81 | f->args[1] = val2; 82 | f->args[2] = val3; 83 | v->ty = FUN; 84 | v->info=(void*)f; 85 | return eval(v); 86 | } 87 | 88 | closure* CLOSURE4(int ftag, int argspace, closure* val, closure* val2, 89 | closure* val3, closure* val4) 90 | { 91 | closure* v = MKVAL; 92 | function* f = MKFUN; 93 | f->ftag = ftag; 94 | f->space = argspace; 95 | f->next = 4; 96 | f->args = MKARGS(argspace); 97 | f->args[0] = val; 98 | f->args[1] = val2; 99 | f->args[2] = val3; 100 | f->args[3] = val4; 101 | v->ty = FUN; 102 | v->info=(void*)f; 103 | return eval(v); 104 | } 105 | 106 | closure* CLOSURE5(int ftag, int argspace, closure* val, closure* val2, 107 | closure* val3, closure* val4, closure* val5) 108 | { 109 | closure* v = MKVAL; 110 | function* f = MKFUN; 111 | f->ftag = ftag; 112 | f->space = argspace; 113 | f->next = 5; 114 | f->args = MKARGS(argspace); 115 | f->args[0] = val; 116 | f->args[1] = val2; 117 | f->args[2] = val3; 118 | f->args[3] = val4; 119 | f->args[4] = val5; 120 | v->ty = FUN; 121 | v->info=(void*)f; 122 | return eval(v); 123 | } 124 | 125 | closure* CLOSUREN(int ftag, int argspace, closure** args, int argsleft) 126 | { 127 | int i; 128 | closure* v = MKVAL; 129 | function* f = MKFUN; 130 | f->ftag = ftag; 131 | f->space = argspace; 132 | f->next = argsleft; 133 | f->args = MKARGS(argspace); 134 | i=0; 135 | while(argsleft>0) { 136 | f->args[i] = args[i]; 137 | i++; 138 | argsleft--; 139 | } 140 | v->ty = FUN; 141 | v->info=(void*)f; 142 | return eval(v); 143 | } 144 | 145 | function* copyFunction(function* f) 146 | { 147 | function* fnew; 148 | int i; 149 | 150 | fnew = MKFUN; 151 | fnew->ftag = f->ftag; 152 | fnew->space = f->space; 153 | fnew->next = f->next; 154 | fnew->args = MKARGS(f->next); 155 | for(i=0;inext;i++) { 156 | fnew->args[i] = f->args[i]; 157 | } 158 | return fnew; 159 | } 160 | 161 | closure* copyClosure(closure* c) 162 | { 163 | closure* cnew; 164 | cnew = MKVAL; 165 | cnew->ty = c->ty; 166 | switch(c->ty) { 167 | case FUN: 168 | cnew->info = (void*)copyFunction((function*)c->info); 169 | break; 170 | case CON: 171 | cnew->info = c->info; 172 | break; 173 | case TYPE: 174 | cnew->info = NULL; 175 | } 176 | return cnew; 177 | } 178 | 179 | closure* CLOSUREADD1(closure* fn, closure* val) 180 | { 181 | int next; 182 | closure* c = copyClosure(fn); 183 | function* f = (function*)(c -> info); 184 | if (f->next+1>f->space) { 185 | // We have all the arguments we need, so this doesn't make sense... 186 | f->args = MOREARGS(f->args,f->next+1); 187 | f->space = f->next+1; 188 | } 189 | next = f->next; 190 | f->args[next] = val; 191 | f->next+=1; 192 | return eval(c); 193 | } 194 | 195 | closure* CLOSUREADD2(closure* fn, closure* val, closure* val2) 196 | { 197 | int next; 198 | closure* c = copyClosure(fn); 199 | function* f = (function*)(c -> info); 200 | if (f->next+2>f->space) { 201 | f->args = MOREARGS(f->args,f->next+2); 202 | f->space = f->next+2; 203 | } 204 | next = f->next; 205 | f->args[next] = val; 206 | f->args[next+1] = val2; 207 | f->next+=2; 208 | return eval(c); 209 | } 210 | 211 | closure* CLOSUREADD3(closure* fn, closure* val, closure* val2, 212 | closure* val3) 213 | { 214 | int next; 215 | closure* c = copyClosure(fn); 216 | function* f = (function*)(c -> info); 217 | if (f->next+3>f->space) { 218 | f->args = MOREARGS(f->args,f->next+3); 219 | f->space = f->next+3; 220 | } 221 | next = f->next; 222 | f->args[next] = val; 223 | f->args[next+1] = val2; 224 | f->args[next+2] = val3; 225 | f->next+=3; 226 | return eval(c); 227 | } 228 | 229 | closure* CLOSUREADD4(closure* fn, closure* val, closure* val2, 230 | closure* val3, closure* val4) 231 | { 232 | int next; 233 | closure* c = copyClosure(fn); 234 | function* f = (function*)(c -> info); 235 | if (f->next+4>f->space) { 236 | f->args = MOREARGS(f->args,f->next+4); 237 | f->space = f->next+4; 238 | } 239 | next = f->next; 240 | f->args[next] = val; 241 | f->args[next+1] = val2; 242 | f->args[next+2] = val3; 243 | f->args[next+3] = val4; 244 | f->next+=4; 245 | return eval(c); 246 | } 247 | 248 | closure* CLOSUREADD5(closure* fn, closure* val, closure* val2, 249 | closure* val3, closure* val4, closure* val5) 250 | { 251 | int next; 252 | closure* c = copyClosure(fn); 253 | function* f = (function*)(c -> info); 254 | if (f->next+5>f->space) { 255 | f->args = MOREARGS(f->args,f->next+5); 256 | f->space = f->next+5; 257 | } 258 | next = f->next; 259 | f->args[next] = val; 260 | f->args[next+1] = val2; 261 | f->args[next+2] = val3; 262 | f->args[next+3] = val4; 263 | f->args[next+4] = val5; 264 | f->next+=5; 265 | return eval(c); 266 | } 267 | 268 | closure* MKCON0(int tag) 269 | { 270 | closure* v = MKVAL; 271 | constructor* c = MKCON; 272 | c->tag = tag; 273 | c->args = NULL; 274 | v->ty = CON; 275 | v->info=(void*)c; 276 | return v; 277 | } 278 | 279 | /* 280 | tmpv = MKVAL; 281 | tmpc = MKCON; 282 | tmpc->tag = tag; tmpc->args=MKARGS(1); tmpc->args[0]=val; 283 | tmpv->ty=CON-> 284 | */ 285 | 286 | closure* MKCON1(int tag,closure* val) 287 | { 288 | closure* v = MKVAL; 289 | constructor* c = MKCON; 290 | c->tag = tag; 291 | c->args = MKARGS(1); 292 | c->args[0] = val; 293 | v->ty = CON; 294 | v->info=(void*)c; 295 | return v; 296 | } 297 | 298 | closure* MKCONN(int tag,closure** args,int argsleft) 299 | { 300 | int i; 301 | closure* v = MKVAL; 302 | constructor* c = MKCON; 303 | c->tag = tag; 304 | c->args = MKARGS(argsleft); 305 | i=0; 306 | while(argsleft>0) { 307 | c->args[i] = args[i]; 308 | i++; 309 | argsleft--; 310 | } 311 | v->ty = CON; 312 | v->info=(void*)c; 313 | return v; 314 | } 315 | 316 | // Apply the unused arguments to the closure fn 317 | closure* CLOSUREADDN(closure* v, closure** args,int argsleft) 318 | { 319 | while(argsleft>0) { 320 | switch(argsleft) { 321 | case 5: 322 | v=CLOSUREADD5(v,*args,*(args+1),*(args+2), 323 | *(args+3),*(args+4)); 324 | args+=5; 325 | argsleft-=5; 326 | break; 327 | case 4: 328 | v=CLOSUREADD4(v,*args,*(args+1),*(args+2), 329 | *(args+3)); 330 | args+=4; 331 | argsleft-=4; 332 | break; 333 | case 3: 334 | v=CLOSUREADD3(v,*args,*(args+1),*(args+2)); 335 | args+=3; 336 | argsleft-=3; 337 | break; 338 | case 2: 339 | v=CLOSUREADD2(v,*args,*(args+1)); 340 | args+=2; 341 | argsleft-=2; 342 | break; 343 | default: 344 | // Slow way 345 | if (argsleft>5) { 346 | v=CLOSUREADD5(v,*args,*(args+1),*(args+2), 347 | *(args+3),*(args+4)); 348 | args+=5; 349 | argsleft-=5; 350 | } 351 | else { 352 | v=CLOSUREADD1(v,*(args++)); 353 | --argsleft; 354 | } 355 | } 356 | } 357 | return v; 358 | } 359 | -------------------------------------------------------------------------------- /Ivor/rts/closure.h: -------------------------------------------------------------------------------- 1 | #ifndef _CLOSURE_H 2 | #define _CLOSURE_H 3 | 4 | #include 5 | 6 | typedef enum { FUN, CON, TYPE } closure_type; 7 | 8 | // Simulate a let x = y in z binding. 9 | // This works because x=y evaluates to y, and y will always be non-null. 10 | // More generally, we could have #define LET(x,y,z) (((x=y) || 1) ? (z) : 0) 11 | #define LET(x,y,z) ((x=y) ? (z) : (VAL)0) 12 | 13 | typedef struct { 14 | closure_type ty; 15 | void* info; 16 | } closure ; 17 | 18 | typedef closure* VAL; 19 | 20 | 21 | typedef struct { 22 | int ftag; // Function tag 23 | int space; // How much space for arguments 24 | int next; // Where to put the next argument 25 | closure** args; 26 | } function; 27 | 28 | typedef struct { 29 | int tag; 30 | closure** args; 31 | } constructor; 32 | 33 | /// If we ever need a value we're not going to examine... Types, say. 34 | extern VAL DontCare; 35 | 36 | /// Set everything up. Call this before doing anything. 37 | void VM_init(); 38 | 39 | /// Having all these looks horrible, but it's for the sake of efficiency. 40 | closure* CLOSURE0(int ftag, int argspace); 41 | closure* CLOSURE1(int ftag, int argspace,closure* val); 42 | closure* CLOSURE2(int ftag, int argspace,closure* val, closure* val2); 43 | closure* CLOSURE3(int ftag, int argspace,closure* val, closure* val2, 44 | closure* val3); 45 | closure* CLOSURE4(int ftag, int argspace,closure* val, closure* val2, 46 | closure* val3, closure* val4); 47 | closure* CLOSURE5(int ftag, int argspace,closure* val, closure* val2, 48 | closure* val3, closure* val4, closure* val5); 49 | closure* CLOSUREADD1(closure* fn, closure* val); 50 | closure* CLOSUREADD2(closure* fn, closure* val, closure* val2); 51 | closure* CLOSUREADD3(closure* fn, closure* val, closure* val2, closure* val3); 52 | closure* CLOSUREADD4(closure* fn, closure* val, closure* val2, closure* val3, 53 | closure* val4); 54 | closure* CLOSUREADD5(closure* fn, closure* val, closure* val2, closure* val3, 55 | closure* val4, closure* val5); 56 | 57 | /// Less efficient ones for bigger cases (5 should usually be enough) 58 | closure* CLOSUREN(int ftag, int argspace, closure** args, int argsleft); 59 | closure* CLOSUREADDN(closure* fn, closure** args,int argsleft); 60 | 61 | 62 | closure* MKCON0(int tag); 63 | closure* MKCON1(int tag,closure* val); 64 | 65 | closure* MKCONN(int tag,closure** args,int argsleft); 66 | 67 | #define MKVAL (closure*)GC_MALLOC(sizeof(closure)) 68 | #define MKFUN (function*)GC_MALLOC(sizeof(function)) 69 | #define MKCON (constructor*)GC_MALLOC(sizeof(constructor)) 70 | #define MKTYPE DontCare 71 | #define MKARGS(x) (closure**)GC_MALLOC(sizeof(closure)*x); 72 | #define MOREARGS(args,x) (closure**)GC_REALLOC(args,sizeof(closure)*x); 73 | 74 | #define GETFUNARG(c,x) ((function*)(c->info))->args[x] 75 | #define GETCONARG(c,x) ((constructor*)(c->info))->args[x] 76 | #define TAG(c) ((constructor*)(c->info))->tag 77 | 78 | #define FARG(x) eval(f->args[x]) 79 | 80 | // Do some magic 81 | #define EVALCASE(fntag,arity,fn) \ 82 | case fntag: \ 83 | if (f->next==arity) { \ 84 | x=fn; \ 85 | } else { \ 86 | if (f->next>arity) { \ 87 | x=eval(CLOSUREADDN(fn,f->args+arity,f->next-arity)); \ 88 | } \ 89 | } \ 90 | break 91 | 92 | #define EVALDEFAULT default: printf("Nothing happens\n"); return x 93 | 94 | 95 | 96 | #endif // Whole file 97 | -------------------------------------------------------------------------------- /Ivor/rts/nat.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | #include 3 | 4 | #define FPLUS1 10 5 | #define FPLUS2 20 6 | #define ADDER1 40 7 | #define ADDER 50 8 | 9 | #define FTAG_EVM_plus 1 10 | VAL _EVM_plus(VAL v0,VAL v1); 11 | #define FTAG_EVMSC_1_plus 2 12 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3); 13 | #define FTAG_EVMSC_0_plus 3 14 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2); 15 | #define FTAG_EVM_natElim 0 16 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3); 17 | 18 | 19 | VAL plus2(VAL k, VAL ih); 20 | VAL adder1(VAL n,VAL a, VAL k); 21 | VAL adder(VAL n, VAL a); 22 | 23 | 24 | VAL eval(VAL x) { 25 | if (x->ty != FUN) return x; 26 | else { 27 | function* f = (function*)(x -> info); 28 | switch(f->ftag) { 29 | EVALCASE(FPLUS2,2,plus2(FARG(0),FARG(1))); 30 | EVALCASE(ADDER1,3,adder1(FARG(0),FARG(1),FARG(2))); 31 | EVALCASE(ADDER,2,adder(FARG(0),FARG(1))); 32 | EVALCASE(FTAG_EVM_plus,2,_EVM_plus(FARG(0),FARG(1))); 33 | EVALCASE(FTAG_EVMSC_1_plus,4,_EVMSC_1_plus(FARG(0),FARG(1),FARG(2),FARG(3))); 34 | EVALCASE(FTAG_EVMSC_0_plus,3,_EVMSC_0_plus(FARG(0),FARG(1),FARG(2))); 35 | EVALCASE(FTAG_EVM_natElim,4,_EVM_natElim(FARG(0),FARG(1),FARG(2),FARG(3))); 36 | EVALDEFAULT; 37 | } 38 | } 39 | return x; 40 | } 41 | 42 | VAL natElim(VAL n, VAL P, VAL mz, VAL ms) { 43 | switch(TAG(eval(n))) { 44 | case 0: 45 | return mz; 46 | break; 47 | case 1: 48 | return eval(CLOSUREADD2(ms, GETCONARG(n,0), 49 | natElim(GETCONARG(n,0), P, mz, ms))); 50 | break; 51 | default: 52 | return NULL; 53 | } 54 | } 55 | 56 | VAL plus1(VAL n) { 57 | return MKTYPE; 58 | } 59 | 60 | VAL plus2(VAL k, VAL ih) { 61 | return MKCON1(1,ih); 62 | } 63 | 64 | VAL plus(VAL m, VAL n) { 65 | return natElim(m,CLOSURE0(FPLUS1,1),n,CLOSURE0(FPLUS2,2)); 66 | } 67 | 68 | VAL adder1(VAL n,VAL a, VAL k) { 69 | return adder(GETCONARG(n,0),_EVM_plus(a,k)); 70 | } 71 | 72 | VAL adder(VAL n, VAL a) 73 | { 74 | switch(TAG(eval(n))) { 75 | case 0: 76 | return a; 77 | break; 78 | case 1: 79 | return CLOSURE2(ADDER1,3,n,a); 80 | default: 81 | return NULL; 82 | } 83 | } 84 | 85 | void shownat(VAL f) { 86 | switch(f->ty) { 87 | case FUN: 88 | printf("FUN %d %d",((function*)(f->info))->ftag,((function*)(f->info))->next); 89 | break; 90 | case CON: 91 | if (TAG(f)==0) printf("O"); 92 | if (TAG(f)==1) { 93 | printf("S"); 94 | shownat(GETCONARG(f,0)); 95 | } 96 | break; 97 | case TYPE: 98 | printf("TYPE"); 99 | } 100 | } 101 | 102 | 103 | VAL _EVM_plus(VAL v0,VAL v1) { 104 | 105 | VAL tmp6; 106 | VAL tmp5; 107 | VAL tmp4; 108 | VAL tmp3; 109 | VAL tmp2; 110 | VAL tmp1; 111 | VAL* args; 112 | tmp1 = v1; 113 | tmp3 = v0; 114 | tmp4 = v1; 115 | tmp2 = CLOSURE2(FTAG_EVMSC_0_plus,3,tmp3,tmp4); 116 | tmp3 = v0; 117 | tmp5 = v0; 118 | tmp6 = v1; 119 | tmp4 = CLOSURE2(FTAG_EVMSC_1_plus,4,tmp5,tmp6); 120 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 121 | } 122 | 123 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3) { 124 | 125 | VAL tmp1; 126 | VAL tmp0; 127 | VAL* args; 128 | tmp1 = v3; 129 | tmp0 = MKCON1(1,tmp1); 130 | return tmp0; 131 | } 132 | 133 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2) { 134 | 135 | VAL* args; 136 | VAL tmp0; 137 | tmp0 = MKTYPE; 138 | return tmp0; 139 | } 140 | 141 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3) { 142 | 143 | VAL tmp7; 144 | VAL tmp6; 145 | VAL tmp5; 146 | VAL tmp4; 147 | VAL tmp3; 148 | VAL tmp2; 149 | VAL tmp1; 150 | VAL tmp0; 151 | VAL* args; 152 | eval(v0); 153 | switch(TAG(v0)) { 154 | case 0: 155 | tmp0 = v2; 156 | return tmp0; 157 | 158 | case 1: 159 | tmp1 = v3; 160 | tmp3 = v0; 161 | tmp2 = GETCONARG(tmp3,0); 162 | tmp5 = v0; 163 | tmp4 = GETCONARG(tmp5,0); 164 | tmp5 = v1; 165 | tmp6 = v2; 166 | tmp7 = v3; 167 | tmp3 = _EVM_natElim(tmp4,tmp5,tmp6,tmp7); 168 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 169 | eval(tmp0); 170 | return tmp0; 171 | 172 | default: 173 | return NULL; 174 | } 175 | } 176 | 177 | int main() 178 | { 179 | VAL f; 180 | VAL one; 181 | VAL two; 182 | VAL three; 183 | VAL four; 184 | 185 | VAL tmp; 186 | VAL* args; 187 | 188 | VM_init(); 189 | 190 | one = MKCON1(1,MKCON0(0)); 191 | two = MKCON1(1,one); 192 | three = MKCON1(1,two); 193 | four = MKCON1(1,three); 194 | 195 | args = MKARGS(6); 196 | args[0] = four; 197 | args[1] = two; 198 | args[2] = four; 199 | args[3] = two; 200 | args[4] = four; 201 | args[5] = three; 202 | 203 | tmp = CLOSUREN(ADDER,6,args,6); 204 | // tmp = _EVM_plus(two,two); 205 | shownat(tmp); 206 | printf("\n"); 207 | 208 | // tmp = CLOSUREADD1(tmp,three); 209 | // shownat(tmp); 210 | // printf("\n"); 211 | 212 | // tmp = eval(CLOSUREADD1(tmp,two)); 213 | 214 | shownat(eval(tmp)); 215 | printf("\n"); 216 | 217 | return 0; 218 | } 219 | -------------------------------------------------------------------------------- /Ivor/rts/oldtest.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | #include 3 | 4 | #define FTAG_EVM_vectFold 11 5 | VAL _EVM_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5); 6 | #define FTAG_EVMSC_1_vectFold 12 7 | VAL _EVMSC_1_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7,VAL v8,VAL v9); 8 | #define FTAG_EVMSC_0_vectFold 13 9 | VAL _EVMSC_0_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7); 10 | #define FTAG_EVM_VectElim 10 11 | VAL _EVM_VectElim(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5); 12 | #define FTAG_EVM_fact 7 13 | VAL _EVM_fact(VAL v0); 14 | #define FTAG_EVMSC_1_fact 8 15 | VAL _EVMSC_1_fact(VAL v0,VAL v1,VAL v2); 16 | #define FTAG_EVMSC_0_fact 9 17 | VAL _EVMSC_0_fact(VAL v0,VAL v1); 18 | #define FTAG_EVM_mult 4 19 | VAL _EVM_mult(VAL v0,VAL v1); 20 | #define FTAG_EVMSC_1_mult 5 21 | VAL _EVMSC_1_mult(VAL v0,VAL v1,VAL v2,VAL v3); 22 | #define FTAG_EVMSC_0_mult 6 23 | VAL _EVMSC_0_mult(VAL v0,VAL v1,VAL v2); 24 | #define FTAG_EVM_plus 1 25 | VAL _EVM_plus(VAL v0,VAL v1); 26 | #define FTAG_EVMSC_1_plus 2 27 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3); 28 | #define FTAG_EVMSC_0_plus 3 29 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2); 30 | #define FTAG_EVM_natElim 0 31 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3); 32 | 33 | VAL eval(VAL x) { 34 | if (x->ty != FUN) return x; 35 | else { 36 | function* f = (function*)(x -> info); 37 | switch(f->ftag) { 38 | EVALCASE(FTAG_EVM_vectFold,6,_EVM_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5))); 39 | EVALCASE(FTAG_EVMSC_1_vectFold,10,_EVMSC_1_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5),FARG(6),FARG(7),FARG(8),FARG(9))); 40 | EVALCASE(FTAG_EVMSC_0_vectFold,8,_EVMSC_0_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5),FARG(6),FARG(7))); 41 | EVALCASE(FTAG_EVM_VectElim,6,_EVM_VectElim(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5))); 42 | EVALCASE(FTAG_EVM_fact,1,_EVM_fact(FARG(0))); 43 | EVALCASE(FTAG_EVMSC_1_fact,3,_EVMSC_1_fact(FARG(0),FARG(1),FARG(2))); 44 | EVALCASE(FTAG_EVMSC_0_fact,2,_EVMSC_0_fact(FARG(0),FARG(1))); 45 | EVALCASE(FTAG_EVM_mult,2,_EVM_mult(FARG(0),FARG(1))); 46 | EVALCASE(FTAG_EVMSC_1_mult,4,_EVMSC_1_mult(FARG(0),FARG(1),FARG(2),FARG(3))); 47 | EVALCASE(FTAG_EVMSC_0_mult,3,_EVMSC_0_mult(FARG(0),FARG(1),FARG(2))); 48 | EVALCASE(FTAG_EVM_plus,2,_EVM_plus(FARG(0),FARG(1))); 49 | EVALCASE(FTAG_EVMSC_1_plus,4,_EVMSC_1_plus(FARG(0),FARG(1),FARG(2),FARG(3))); 50 | EVALCASE(FTAG_EVMSC_0_plus,3,_EVMSC_0_plus(FARG(0),FARG(1),FARG(2))); 51 | EVALCASE(FTAG_EVM_natElim,4,_EVM_natElim(FARG(0),FARG(1),FARG(2),FARG(3))); 52 | } 53 | } 54 | return x; 55 | } 56 | 57 | VAL _EVM_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5) { 58 | 59 | VAL tmp12; 60 | VAL tmp11; 61 | VAL tmp10; 62 | VAL tmp9; 63 | VAL tmp8; 64 | VAL tmp7; 65 | VAL tmp6; 66 | VAL tmp5; 67 | VAL tmp4; 68 | VAL tmp3; 69 | VAL tmp2; 70 | VAL tmp1; 71 | VAL tmp0; 72 | VAL* args; 73 | tmp1 = v0; 74 | tmp2 = v2; 75 | tmp3 = v3; 76 | tmp5 = v0; 77 | tmp6 = v1; 78 | tmp7 = v2; 79 | tmp8 = v3; 80 | tmp9 = v4; 81 | tmp10 = v5; 82 | args = MKARGS(6); 83 | args[0] = tmp5; 84 | args[1] = tmp6; 85 | args[2] = tmp7; 86 | args[3] = tmp8; 87 | args[4] = tmp9; 88 | args[5] = tmp10; 89 | tmp4 = CLOSUREN(FTAG_EVMSC_0_vectFold,6,args,6); 90 | tmp5 = v4; 91 | tmp7 = v0; 92 | tmp8 = v1; 93 | tmp9 = v2; 94 | tmp10 = v3; 95 | tmp11 = v4; 96 | tmp12 = v5; 97 | args = MKARGS(6); 98 | args[0] = tmp7; 99 | args[1] = tmp8; 100 | args[2] = tmp9; 101 | args[3] = tmp10; 102 | args[4] = tmp11; 103 | args[5] = tmp12; 104 | tmp6 = CLOSUREN(FTAG_EVMSC_1_vectFold,6,args,6); 105 | return _EVM_VectElim(tmp1,tmp2,tmp3,tmp4,tmp5,tmp6); 106 | } 107 | 108 | VAL _EVMSC_1_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7,VAL v8,VAL v9) { 109 | 110 | VAL tmp3; 111 | VAL tmp2; 112 | VAL tmp1; 113 | VAL tmp0; 114 | VAL* args; 115 | tmp1 = v5; 116 | tmp2 = v7; 117 | tmp3 = v9; 118 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 119 | return tmp0; 120 | } 121 | 122 | VAL _EVMSC_0_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7) { 123 | 124 | VAL tmp0; 125 | VAL* args; 126 | tmp0 = v1; 127 | return tmp0; 128 | } 129 | 130 | VAL _EVM_VectElim(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5) { 131 | 132 | VAL tmp11; 133 | VAL tmp10; 134 | VAL tmp9; 135 | VAL tmp8; 136 | VAL tmp7; 137 | VAL tmp6; 138 | VAL tmp5; 139 | VAL tmp4; 140 | VAL tmp3; 141 | VAL tmp2; 142 | VAL tmp1; 143 | VAL tmp0; 144 | VAL* args; 145 | eval(v2); 146 | switch(TAG(v2)) { 147 | case 0: 148 | tmp0 = v4; 149 | return tmp0; 150 | 151 | case 1: 152 | tmp1 = v5; 153 | tmp3 = v2; 154 | tmp2 = GETCONARG(tmp3,1); 155 | tmp4 = v2; 156 | tmp3 = GETCONARG(tmp4,2); 157 | tmp5 = v2; 158 | tmp4 = GETCONARG(tmp5,3); 159 | tmp7 = v2; 160 | tmp6 = GETCONARG(tmp7,0); 161 | tmp8 = v2; 162 | tmp7 = GETCONARG(tmp8,1); 163 | tmp9 = v2; 164 | tmp8 = GETCONARG(tmp9,3); 165 | tmp9 = v3; 166 | tmp10 = v4; 167 | tmp11 = v5; 168 | tmp5 = _EVM_VectElim(tmp6,tmp7,tmp8,tmp9,tmp10,tmp11); 169 | tmp0 = CLOSUREADD4(tmp1,tmp2,tmp3,tmp4,tmp5); 170 | return tmp0; 171 | 172 | default: 173 | return NULL; 174 | } 175 | } 176 | 177 | VAL _EVM_fact(VAL v0) { 178 | 179 | VAL tmp5; 180 | VAL tmp4; 181 | VAL tmp3; 182 | VAL tmp2; 183 | VAL tmp1; 184 | VAL tmp0; 185 | VAL* args; 186 | tmp1 = v0; 187 | tmp3 = v0; 188 | tmp2 = CLOSURE1(FTAG_EVMSC_0_fact,1,tmp3); 189 | tmp4 = MKCON0(0); 190 | tmp3 = MKCON1(1,tmp4); 191 | tmp5 = v0; 192 | tmp4 = CLOSURE1(FTAG_EVMSC_1_fact,1,tmp5); 193 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 194 | } 195 | 196 | VAL _EVMSC_1_fact(VAL v0,VAL v1,VAL v2) { 197 | 198 | VAL tmp3; 199 | VAL tmp2; 200 | VAL tmp1; 201 | VAL tmp0; 202 | VAL* args; 203 | tmp1 = v2; 204 | tmp3 = v1; 205 | tmp2 = MKCON1(1,tmp3); 206 | return _EVM_mult(tmp1,tmp2); 207 | } 208 | 209 | VAL _EVMSC_0_fact(VAL v0,VAL v1) { 210 | 211 | VAL tmp0; 212 | VAL* args; 213 | tmp0 = MKTYPE; 214 | return tmp0; 215 | } 216 | 217 | VAL _EVM_mult(VAL v0,VAL v1) { 218 | 219 | VAL tmp6; 220 | VAL tmp5; 221 | VAL tmp4; 222 | VAL tmp3; 223 | VAL tmp2; 224 | VAL tmp1; 225 | VAL tmp0; 226 | VAL* args; 227 | tmp1 = v1; 228 | tmp3 = v0; 229 | tmp4 = v1; 230 | tmp2 = CLOSURE2(FTAG_EVMSC_0_mult,2,tmp3,tmp4); 231 | tmp3 = MKCON0(0); 232 | tmp5 = v0; 233 | tmp6 = v1; 234 | tmp4 = CLOSURE2(FTAG_EVMSC_1_mult,2,tmp5,tmp6); 235 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 236 | } 237 | 238 | VAL _EVMSC_1_mult(VAL v0,VAL v1,VAL v2,VAL v3) { 239 | 240 | VAL tmp2; 241 | VAL tmp1; 242 | VAL tmp0; 243 | VAL* args; 244 | tmp1 = v0; 245 | tmp2 = v3; 246 | return _EVM_plus(tmp1,tmp2); 247 | } 248 | 249 | VAL _EVMSC_0_mult(VAL v0,VAL v1,VAL v2) { 250 | 251 | VAL tmp0; 252 | VAL* args; 253 | tmp0 = MKTYPE; 254 | return tmp0; 255 | } 256 | 257 | VAL _EVM_plus(VAL v0,VAL v1) { 258 | 259 | VAL tmp6; 260 | VAL tmp5; 261 | VAL tmp4; 262 | VAL tmp3; 263 | VAL tmp2; 264 | VAL tmp1; 265 | VAL tmp0; 266 | VAL* args; 267 | tmp1 = v1; 268 | tmp3 = v0; 269 | tmp4 = v1; 270 | tmp2 = CLOSURE2(FTAG_EVMSC_0_plus,2,tmp3,tmp4); 271 | tmp3 = v0; 272 | tmp5 = v0; 273 | tmp6 = v1; 274 | tmp4 = CLOSURE2(FTAG_EVMSC_1_plus,2,tmp5,tmp6); 275 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 276 | } 277 | 278 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3) { 279 | 280 | VAL tmp1; 281 | VAL tmp0; 282 | VAL* args; 283 | tmp1 = v3; 284 | tmp0 = MKCON1(1,tmp1); 285 | return tmp0; 286 | } 287 | 288 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2) { 289 | 290 | VAL tmp0; 291 | VAL* args; 292 | tmp0 = MKTYPE; 293 | return tmp0; 294 | } 295 | 296 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3) { 297 | 298 | VAL tmp7; 299 | VAL tmp6; 300 | VAL tmp5; 301 | VAL tmp4; 302 | VAL tmp3; 303 | VAL tmp2; 304 | VAL tmp1; 305 | VAL tmp0; 306 | VAL* args; 307 | eval(v0); 308 | switch(TAG(v0)) { 309 | case 0: 310 | tmp0 = v2; 311 | return tmp0; 312 | 313 | case 1: 314 | tmp1 = v3; 315 | tmp3 = v0; 316 | tmp2 = GETCONARG(tmp3,0); 317 | tmp5 = v0; 318 | tmp4 = GETCONARG(tmp5,0); 319 | tmp5 = v1; 320 | tmp6 = v2; 321 | tmp7 = v3; 322 | tmp3 = _EVM_natElim(tmp4,tmp5,tmp6,tmp7); 323 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 324 | return tmp0; 325 | 326 | default: 327 | return NULL; 328 | } 329 | } 330 | 331 | -------------------------------------------------------------------------------- /Ivor/rts/test.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | #include 3 | 4 | #define FTAG_EVM_testval 5 5 | VAL _EVM_testval(); 6 | #define FTAG_EVM_plus 1 7 | VAL _EVM_plus(VAL v0); 8 | #define FTAG_EVMSC_2_plus 2 9 | VAL _EVMSC_2_plus(VAL v0,VAL v1,VAL v2,VAL v3); 10 | #define FTAG_EVMSC_1_plus 3 11 | VAL _EVMSC_1_plus(VAL v0,VAL v1); 12 | #define FTAG_EVMSC_0_plus 4 13 | VAL _EVMSC_0_plus(VAL v0,VAL v1); 14 | #define FTAG_EVM_NatElim 0 15 | VAL _EVM_NatElim(VAL v0,VAL v1,VAL v2,VAL v3); 16 | VAL eval(VAL x) { 17 | if (x->ty != FUN) return x; 18 | else { 19 | function* f = (function*)(x -> info); 20 | switch(f->ftag) { 21 | EVALCASE(FTAG_EVM_testval,0,_EVM_testval()); 22 | EVALCASE(FTAG_EVM_plus,1,_EVM_plus(FARG(0))); 23 | EVALCASE(FTAG_EVMSC_2_plus,4,_EVMSC_2_plus(FARG(0),FARG(1),FARG(2),FARG(3))); 24 | EVALCASE(FTAG_EVMSC_1_plus,2,_EVMSC_1_plus(FARG(0),FARG(1))); 25 | EVALCASE(FTAG_EVMSC_0_plus,2,_EVMSC_0_plus(FARG(0),FARG(1))); 26 | EVALCASE(FTAG_EVM_NatElim,4,_EVM_NatElim(FARG(0),FARG(1),FARG(2),FARG(3))); 27 | } 28 | } 29 | return x; 30 | } 31 | VAL _EVM_testval() { 32 | 33 | VAL tmp6; 34 | VAL tmp5; 35 | VAL tmp4; 36 | VAL tmp3; 37 | VAL tmp2; 38 | VAL tmp1; 39 | VAL tmp0; 40 | VAL* args; 41 | tmp5 = MKCON0(0); 42 | tmp4 = MKCON1(1,tmp5); 43 | tmp3 = MKCON1(1,tmp4); 44 | tmp2 = MKCON1(1,tmp3); 45 | tmp1 = MKCON1(1,tmp2); 46 | tmp6 = MKCON0(0); 47 | tmp5 = MKCON1(1,tmp6); 48 | tmp4 = MKCON1(1,tmp5); 49 | tmp3 = MKCON1(1,tmp4); 50 | tmp2 = MKCON1(1,tmp3); 51 | tmp0 = CLOSURE2(FTAG_EVM_plus,2,tmp1,tmp2); 52 | return tmp0; 53 | } 54 | 55 | VAL _EVM_plus(VAL v0) { 56 | 57 | VAL tmp5; 58 | VAL tmp4; 59 | VAL tmp3; 60 | VAL tmp2; 61 | VAL tmp1; 62 | VAL tmp0; 63 | VAL* args; 64 | tmp1 = v0; 65 | tmp3 = v0; 66 | tmp2 = CLOSURE1(FTAG_EVMSC_0_plus,1,tmp3); 67 | tmp4 = v0; 68 | tmp3 = CLOSURE1(FTAG_EVMSC_1_plus,1,tmp4); 69 | tmp5 = v0; 70 | tmp4 = CLOSURE1(FTAG_EVMSC_2_plus,1,tmp5); 71 | return _EVM_NatElim(tmp1,tmp2,tmp3,tmp4); 72 | } 73 | 74 | VAL _EVMSC_2_plus(VAL v0,VAL v1,VAL v2,VAL v3) { 75 | 76 | VAL tmp3; 77 | VAL tmp2; 78 | VAL tmp1; 79 | VAL tmp0; 80 | VAL* args; 81 | tmp2 = v2; 82 | tmp3 = v3; 83 | tmp1 = CLOSUREADD1(tmp2,tmp3); 84 | tmp0 = MKCON1(1,tmp1); 85 | return tmp0; 86 | } 87 | 88 | VAL _EVMSC_1_plus(VAL v0,VAL v1) { 89 | 90 | VAL tmp0; 91 | VAL* args; 92 | tmp0 = v1; 93 | return tmp0; 94 | } 95 | 96 | VAL _EVMSC_0_plus(VAL v0,VAL v1) { 97 | 98 | VAL tmp0; 99 | VAL* args; 100 | tmp0 = MKTYPE; 101 | return tmp0; 102 | } 103 | 104 | VAL _EVM_NatElim(VAL v0,VAL v1,VAL v2,VAL v3) { 105 | 106 | VAL tmp7; 107 | VAL tmp6; 108 | VAL tmp5; 109 | VAL tmp4; 110 | VAL tmp3; 111 | VAL tmp2; 112 | VAL tmp1; 113 | VAL tmp0; 114 | VAL* args; 115 | eval(v0); 116 | switch(TAG(v0)) { 117 | case 0: 118 | tmp0 = v2; 119 | return tmp0; 120 | 121 | case 1: 122 | tmp1 = v3; 123 | tmp3 = v0; 124 | tmp2 = GETCONARG(tmp3,0); 125 | tmp5 = v0; 126 | tmp4 = GETCONARG(tmp5,0); 127 | tmp5 = v1; 128 | tmp6 = v2; 129 | tmp7 = v3; 130 | tmp3 = _EVM_NatElim(tmp4,tmp5,tmp6,tmp7); 131 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 132 | return tmp0; 133 | 134 | default: 135 | return NULL; 136 | } 137 | } 138 | 139 | -------------------------------------------------------------------------------- /Ivor/rts/testdrive: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/edwinb/Ivor/23d8bc68d705c2e11009f137edb3f5eced84d960/Ivor/rts/testdrive -------------------------------------------------------------------------------- /Ivor/rts/testdrive.c: -------------------------------------------------------------------------------- 1 | #include "test.c" 2 | 3 | void shownat(VAL f) { 4 | switch(f->ty) { 5 | case FUN: 6 | printf("FUN %d %d",((function*)(f->info))->ftag,((function*)(f->info))->next); 7 | break; 8 | case CON: 9 | if (TAG(f)==0) printf("O"); 10 | if (TAG(f)==1) { 11 | printf("S"); 12 | shownat(GETCONARG(f,0)); 13 | } 14 | break; 15 | case TYPE: 16 | printf("TYPE"); 17 | } 18 | } 19 | 20 | int main() 21 | { 22 | VAL one; 23 | VAL two; 24 | VAL three; 25 | VAL four,five,six,seven,eight,nine,ten; 26 | VAL tmp; 27 | 28 | VM_init(); 29 | 30 | one = MKCON1(1,MKCON0(0)); 31 | two = MKCON1(1,one); 32 | three = MKCON1(1,two); 33 | four = MKCON1(1,three); 34 | five = MKCON1(1,four); 35 | six = MKCON1(1,five); 36 | seven = MKCON1(1,six); 37 | eight = MKCON1(1,seven); 38 | nine = MKCON1(1,eight); 39 | ten = MKCON1(1,nine); 40 | 41 | tmp = _EVM_fact(eight); 42 | shownat(tmp); 43 | printf("\n"); 44 | 45 | return 0; 46 | } 47 | 48 | -------------------------------------------------------------------------------- /Ivor/rts/testdrive2.c: -------------------------------------------------------------------------------- 1 | #include "newtest.c" 2 | 3 | void shownat(VAL f) { 4 | switch(f->ty) { 5 | case FUN: 6 | printf("FUN %d %d",((function*)(f->info))->ftag,((function*)(f->info))->next); 7 | break; 8 | case CON: 9 | if (TAG(f)==0) printf("O"); 10 | if (TAG(f)==1) { 11 | printf("S"); 12 | shownat(GETCONARG(f,0)); 13 | } 14 | break; 15 | case TYPE: 16 | printf("TYPE"); 17 | } 18 | } 19 | 20 | int main() 21 | { 22 | VAL one; 23 | VAL two; 24 | VAL three; 25 | VAL four,five,six,seven,eight,nine,ten; 26 | VAL tmp; 27 | 28 | VM_init(); 29 | 30 | one = MKCON1(1,MKCON0(0)); 31 | two = MKCON1(1,one); 32 | three = MKCON1(1,two); 33 | four = MKCON1(1,three); 34 | five = MKCON1(1,four); 35 | six = MKCON1(1,five); 36 | seven = MKCON1(1,six); 37 | eight = MKCON1(1,seven); 38 | nine = MKCON1(1,eight); 39 | ten = MKCON1(1,nine); 40 | 41 | tmp = _EVM_testval(); 42 | shownat(tmp); 43 | printf("\n"); 44 | 45 | return 0; 46 | } 47 | 48 | -------------------------------------------------------------------------------- /Ivor/test.c: -------------------------------------------------------------------------------- 1 | #include "closure.h" 2 | #include 3 | 4 | #define FTAG_EVM_vectFold 11 5 | VAL _EVM_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5); 6 | #define FTAG_EVMSC_1_vectFold 12 7 | VAL _EVMSC_1_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7,VAL v8,VAL v9); 8 | #define FTAG_EVMSC_0_vectFold 13 9 | VAL _EVMSC_0_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7); 10 | #define FTAG_EVM_VectElim 10 11 | VAL _EVM_VectElim(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5); 12 | #define FTAG_EVM_fact 7 13 | VAL _EVM_fact(VAL v0); 14 | #define FTAG_EVMSC_1_fact 8 15 | VAL _EVMSC_1_fact(VAL v0,VAL v1,VAL v2); 16 | #define FTAG_EVMSC_0_fact 9 17 | VAL _EVMSC_0_fact(VAL v0,VAL v1); 18 | #define FTAG_EVM_mult 4 19 | VAL _EVM_mult(VAL v0,VAL v1); 20 | #define FTAG_EVMSC_1_mult 5 21 | VAL _EVMSC_1_mult(VAL v0,VAL v1,VAL v2,VAL v3); 22 | #define FTAG_EVMSC_0_mult 6 23 | VAL _EVMSC_0_mult(VAL v0,VAL v1,VAL v2); 24 | #define FTAG_EVM_plus 1 25 | VAL _EVM_plus(VAL v0,VAL v1); 26 | #define FTAG_EVMSC_1_plus 2 27 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3); 28 | #define FTAG_EVMSC_0_plus 3 29 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2); 30 | #define FTAG_EVM_natElim 0 31 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3); 32 | 33 | VAL eval(VAL x) { 34 | if (x->ty != FUN) return x; 35 | else { 36 | function* f = (function*)(x -> info); 37 | switch(f->ftag) { 38 | EVALCASE(FTAG_EVM_vectFold,6,_EVM_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5))); 39 | EVALCASE(FTAG_EVMSC_1_vectFold,10,_EVMSC_1_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5),FARG(6),FARG(7),FARG(8),FARG(9))); 40 | EVALCASE(FTAG_EVMSC_0_vectFold,8,_EVMSC_0_vectFold(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5),FARG(6),FARG(7))); 41 | EVALCASE(FTAG_EVM_VectElim,6,_EVM_VectElim(FARG(0),FARG(1),FARG(2),FARG(3),FARG(4),FARG(5))); 42 | EVALCASE(FTAG_EVM_fact,1,_EVM_fact(FARG(0))); 43 | EVALCASE(FTAG_EVMSC_1_fact,3,_EVMSC_1_fact(FARG(0),FARG(1),FARG(2))); 44 | EVALCASE(FTAG_EVMSC_0_fact,2,_EVMSC_0_fact(FARG(0),FARG(1))); 45 | EVALCASE(FTAG_EVM_mult,2,_EVM_mult(FARG(0),FARG(1))); 46 | EVALCASE(FTAG_EVMSC_1_mult,4,_EVMSC_1_mult(FARG(0),FARG(1),FARG(2),FARG(3))); 47 | EVALCASE(FTAG_EVMSC_0_mult,3,_EVMSC_0_mult(FARG(0),FARG(1),FARG(2))); 48 | EVALCASE(FTAG_EVM_plus,2,_EVM_plus(FARG(0),FARG(1))); 49 | EVALCASE(FTAG_EVMSC_1_plus,4,_EVMSC_1_plus(FARG(0),FARG(1),FARG(2),FARG(3))); 50 | EVALCASE(FTAG_EVMSC_0_plus,3,_EVMSC_0_plus(FARG(0),FARG(1),FARG(2))); 51 | EVALCASE(FTAG_EVM_natElim,4,_EVM_natElim(FARG(0),FARG(1),FARG(2),FARG(3))); 52 | } 53 | } 54 | return x; 55 | } 56 | 57 | VAL _EVM_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5) { 58 | 59 | VAL tmp12; 60 | VAL tmp11; 61 | VAL tmp10; 62 | VAL tmp9; 63 | VAL tmp8; 64 | VAL tmp7; 65 | VAL tmp6; 66 | VAL tmp5; 67 | VAL tmp4; 68 | VAL tmp3; 69 | VAL tmp2; 70 | VAL tmp1; 71 | VAL tmp0; 72 | VAL* args; 73 | tmp1 = v0; 74 | tmp2 = v2; 75 | tmp3 = v3; 76 | tmp5 = v0; 77 | tmp6 = v1; 78 | tmp7 = v2; 79 | tmp8 = v3; 80 | tmp9 = v4; 81 | tmp10 = v5; 82 | args = MKARGS(6); 83 | args[0] = tmp5; 84 | args[1] = tmp6; 85 | args[2] = tmp7; 86 | args[3] = tmp8; 87 | args[4] = tmp9; 88 | args[5] = tmp10; 89 | tmp4 = CLOSUREN(FTAG_EVMSC_0_vectFold,6,args,6); 90 | tmp5 = v4; 91 | tmp7 = v0; 92 | tmp8 = v1; 93 | tmp9 = v2; 94 | tmp10 = v3; 95 | tmp11 = v4; 96 | tmp12 = v5; 97 | args = MKARGS(6); 98 | args[0] = tmp7; 99 | args[1] = tmp8; 100 | args[2] = tmp9; 101 | args[3] = tmp10; 102 | args[4] = tmp11; 103 | args[5] = tmp12; 104 | tmp6 = CLOSUREN(FTAG_EVMSC_1_vectFold,6,args,6); 105 | return _EVM_VectElim(tmp1,tmp2,tmp3,tmp4,tmp5,tmp6); 106 | } 107 | 108 | VAL _EVMSC_1_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7,VAL v8,VAL v9) { 109 | 110 | VAL tmp3; 111 | VAL tmp2; 112 | VAL tmp1; 113 | VAL tmp0; 114 | VAL* args; 115 | tmp1 = v5; 116 | tmp2 = v7; 117 | tmp3 = v9; 118 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 119 | return tmp0; 120 | } 121 | 122 | VAL _EVMSC_0_vectFold(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5,VAL v6,VAL v7) { 123 | 124 | VAL tmp0; 125 | VAL* args; 126 | tmp0 = v1; 127 | return tmp0; 128 | } 129 | 130 | VAL _EVM_VectElim(VAL v0,VAL v1,VAL v2,VAL v3,VAL v4,VAL v5) { 131 | 132 | VAL tmp11; 133 | VAL tmp10; 134 | VAL tmp9; 135 | VAL tmp8; 136 | VAL tmp7; 137 | VAL tmp6; 138 | VAL tmp5; 139 | VAL tmp4; 140 | VAL tmp3; 141 | VAL tmp2; 142 | VAL tmp1; 143 | VAL tmp0; 144 | VAL* args; 145 | eval(v2); 146 | switch(TAG(v2)) { 147 | case 0: 148 | tmp0 = v4; 149 | return tmp0; 150 | 151 | case 1: 152 | tmp1 = v5; 153 | tmp3 = v2; 154 | tmp2 = GETCONARG(tmp3,1); 155 | tmp4 = v2; 156 | tmp3 = GETCONARG(tmp4,2); 157 | tmp5 = v2; 158 | tmp4 = GETCONARG(tmp5,3); 159 | tmp7 = v2; 160 | tmp6 = GETCONARG(tmp7,0); 161 | tmp8 = v2; 162 | tmp7 = GETCONARG(tmp8,1); 163 | tmp9 = v2; 164 | tmp8 = GETCONARG(tmp9,3); 165 | tmp9 = v3; 166 | tmp10 = v4; 167 | tmp11 = v5; 168 | tmp5 = _EVM_VectElim(tmp6,tmp7,tmp8,tmp9,tmp10,tmp11); 169 | tmp0 = CLOSUREADD4(tmp1,tmp2,tmp3,tmp4,tmp5); 170 | return tmp0; 171 | 172 | default: 173 | return NULL; 174 | } 175 | } 176 | 177 | VAL _EVM_fact(VAL v0) { 178 | 179 | VAL tmp5; 180 | VAL tmp4; 181 | VAL tmp3; 182 | VAL tmp2; 183 | VAL tmp1; 184 | VAL tmp0; 185 | VAL* args; 186 | tmp1 = v0; 187 | tmp3 = v0; 188 | tmp2 = CLOSURE1(FTAG_EVMSC_0_fact,1,tmp3); 189 | tmp4 = MKCON0(0); 190 | tmp3 = MKCON1(1,tmp4); 191 | tmp5 = v0; 192 | tmp4 = CLOSURE1(FTAG_EVMSC_1_fact,1,tmp5); 193 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 194 | } 195 | 196 | VAL _EVMSC_1_fact(VAL v0,VAL v1,VAL v2) { 197 | 198 | VAL tmp2; 199 | VAL tmp1; 200 | VAL tmp0; 201 | VAL* args; 202 | tmp2 = v1; 203 | tmp1 = MKCON1(1,tmp2); 204 | tmp2 = v2; 205 | return _EVM_mult(tmp1,tmp2); 206 | } 207 | 208 | VAL _EVMSC_0_fact(VAL v0,VAL v1) { 209 | 210 | VAL tmp0; 211 | VAL* args; 212 | tmp0 = MKTYPE; 213 | return tmp0; 214 | } 215 | 216 | VAL _EVM_mult(VAL v0,VAL v1) { 217 | 218 | VAL tmp6; 219 | VAL tmp5; 220 | VAL tmp4; 221 | VAL tmp3; 222 | VAL tmp2; 223 | VAL tmp1; 224 | VAL tmp0; 225 | VAL* args; 226 | tmp1 = v1; 227 | tmp3 = v0; 228 | tmp4 = v1; 229 | tmp2 = CLOSURE2(FTAG_EVMSC_0_mult,2,tmp3,tmp4); 230 | tmp3 = MKCON0(0); 231 | tmp5 = v0; 232 | tmp6 = v1; 233 | tmp4 = CLOSURE2(FTAG_EVMSC_1_mult,2,tmp5,tmp6); 234 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 235 | } 236 | 237 | VAL _EVMSC_1_mult(VAL v0,VAL v1,VAL v2,VAL v3) { 238 | 239 | VAL tmp2; 240 | VAL tmp1; 241 | VAL tmp0; 242 | VAL* args; 243 | tmp1 = v0; 244 | tmp2 = v3; 245 | return _EVM_plus(tmp1,tmp2); 246 | } 247 | 248 | VAL _EVMSC_0_mult(VAL v0,VAL v1,VAL v2) { 249 | 250 | VAL tmp0; 251 | VAL* args; 252 | tmp0 = MKTYPE; 253 | return tmp0; 254 | } 255 | 256 | VAL _EVM_plus(VAL v0,VAL v1) { 257 | 258 | VAL tmp6; 259 | VAL tmp5; 260 | VAL tmp4; 261 | VAL tmp3; 262 | VAL tmp2; 263 | VAL tmp1; 264 | VAL tmp0; 265 | VAL* args; 266 | tmp1 = v1; 267 | tmp3 = v0; 268 | tmp4 = v1; 269 | tmp2 = CLOSURE2(FTAG_EVMSC_0_plus,2,tmp3,tmp4); 270 | tmp3 = v0; 271 | tmp5 = v0; 272 | tmp6 = v1; 273 | tmp4 = CLOSURE2(FTAG_EVMSC_1_plus,2,tmp5,tmp6); 274 | return _EVM_natElim(tmp1,tmp2,tmp3,tmp4); 275 | } 276 | 277 | VAL _EVMSC_1_plus(VAL v0,VAL v1,VAL v2,VAL v3) { 278 | 279 | VAL tmp1; 280 | VAL tmp0; 281 | VAL* args; 282 | tmp1 = v3; 283 | tmp0 = MKCON1(1,tmp1); 284 | return tmp0; 285 | } 286 | 287 | VAL _EVMSC_0_plus(VAL v0,VAL v1,VAL v2) { 288 | 289 | VAL tmp0; 290 | VAL* args; 291 | tmp0 = MKTYPE; 292 | return tmp0; 293 | } 294 | 295 | VAL _EVM_natElim(VAL v0,VAL v1,VAL v2,VAL v3) { 296 | 297 | VAL tmp7; 298 | VAL tmp6; 299 | VAL tmp5; 300 | VAL tmp4; 301 | VAL tmp3; 302 | VAL tmp2; 303 | VAL tmp1; 304 | VAL tmp0; 305 | VAL* args; 306 | eval(v0); 307 | switch(TAG(v0)) { 308 | case 0: 309 | tmp0 = v2; 310 | return tmp0; 311 | 312 | case 1: 313 | tmp1 = v3; 314 | tmp3 = v0; 315 | tmp2 = GETCONARG(tmp3,0); 316 | tmp5 = v0; 317 | tmp4 = GETCONARG(tmp5,0); 318 | tmp5 = v1; 319 | tmp6 = v2; 320 | tmp7 = v3; 321 | tmp3 = _EVM_natElim(tmp4,tmp5,tmp6,tmp7); 322 | tmp0 = CLOSUREADD2(tmp1,tmp2,tmp3); 323 | return tmp0; 324 | 325 | default: 326 | return NULL; 327 | } 328 | } 329 | 330 | -------------------------------------------------------------------------------- /Jones/Main.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | Jones the Steam. 4 | Simple program for starting up an interactive shell with Ivor library. 5 | 6 | > import Ivor.TT 7 | > import Ivor.Shell 8 | 9 | > main :: IO () 10 | > main = do let shell = addModulePath (newShell emptyContext) 11 | > (prefix ++ "/lib/ivor") 12 | > ctxt <- runShell "> " shell 13 | > putStrLn "Finished" 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2006 Edwin Brady 2 | School of Computer Science, University of St Andrews 3 | All rights reserved. 4 | 5 | This code is derived from software written by Edwin Brady 6 | (eb@dcs.st-and.ac.uk). 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 16 | 3. None of the names of the copyright holders may be used to endorse 17 | or promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 21 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 23 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 24 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 27 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 28 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 29 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 30 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | *** End of disclaimer. *** 33 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # DB = 2 | # PREFIX = /usr/local 3 | DB = --user 4 | PREFIX = $(HOME) 5 | 6 | # Set this to -p for profiling libraries too 7 | PROFILE = 8 | 9 | CABALOPTS = -O 10 | 11 | package: 12 | echo "module Ivor.Prefix where prefix = \"$(PREFIX)\"" > Ivor/Prefix.hs 13 | runhaskell Setup.lhs configure $(DB) $(CABALOPTS) --ghc --prefix=$(PREFIX) $(PROFILE) 14 | runhaskell Setup.lhs build 15 | 16 | install: .PHONY 17 | runhaskell Setup.lhs install $(DB) 18 | mkdir -p $(PREFIX)/lib/ivor 19 | install lib/*.tt $(PREFIX)/lib/ivor 20 | 21 | unregister: 22 | runhaskell Setup.lhs unregister $(DB) 23 | 24 | doc: 25 | runhaskell Setup.lhs haddock 26 | 27 | test: 28 | make -C tests 29 | 30 | cabal-package: 31 | runhaskell Setup.lhs sdist 32 | 33 | jones: .PHONY package install 34 | cd Jones; ghc $(GHCOPTS) Main.lhs -o jones -package ivor 35 | 36 | jones_install: jones 37 | install Jones/jones $(PREFIX)/bin 38 | 39 | iovor: .PHONY package install 40 | cd IOvor; ghc --make $(GHCOPTS) Main.lhs -o iovor -package ivor 41 | 42 | iovor_install: iovor 43 | install IOvor/iovor $(PREFIX)/bin 44 | install IOvor/iobasics.tt $(PREFIX)/lib/ivor 45 | 46 | clean: 47 | runhaskell Setup.lhs clean 48 | rm -f Jones/jones *.o *.hi 49 | rm -f IOvor/iovor *.o *.hi 50 | make -C tests clean 51 | 52 | decruft: 53 | rm -f *~ 54 | make -C Ivor decruft 55 | make -C tests decruft 56 | 57 | .PHONY: 58 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | > import Distribution.Simple 2 | 3 | > main = defaultMain 4 | 5 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Short term things to do: 2 | 3 | * Allow holes in pattern matching definitions 4 | * Need an easier way of updating a context with an input file 5 | (currently have to create a shell, then load, then create a new 6 | shell if you want to modify the context further) 7 | * Improve error messages! 8 | * Recursive functions shouldn't reduce at type level. 9 | * Either better than Monad m? Define an Error type. 10 | * Fix naming bug --- terms of form t1 -> t2 automatically give t1 the 11 | name X, which can clash. Particularly a problem in data type declarations. 12 | * Current naive proof state representation is far too slow. Come up 13 | with something better. 14 | * Keep track of level in proof state. 15 | * Keep track of binding level in context, and check at point of use. 16 | * Allow dump of global context to disk, for fast reloading. 17 | * Syntax for equality. 18 | * Elimination with a motive. 19 | * Unit tests - at least check nat.tt, vect.tt, JM equality, 20 | primitives, simple staging, compiler. 21 | * More readable high level language for function definition. Really 22 | just has to use tactic engine to translate simple case expressions into 23 | D-case calls. 24 | * Separate API into several files for clarity. 25 | * Allow call _ in raw terms; i.e. allow the typechecker to 26 | spot recursive calls, rather than needing a tactic to do so. 27 | * Finish compiler by: 28 | - Finding a method of exporting primitive types 29 | - Implement compilation of D-Case 30 | 31 | Things which could be done to the library, in no particular order 32 | (other than the order I thought of them in...): 33 | 34 | * A higher level dependently typed language might be useful (e.g. like 35 | Coq's language). If not useful, at least fun :). 36 | * Namespace management. 37 | * Some useful error messages from the Parsec parsers would be nice. 38 | * Proper type universes, of some form. 39 | * Generate DRec and DNoConfusion as well as DElim/DCase. 40 | * Build in Sigma types? (At least a nicer syntax?) 41 | * Infix operators, especially = would be nice. 42 | 43 | Tactics: 44 | 45 | * Injectivity. 46 | * Discriminate. 47 | * Inversion. 48 | 49 | -------------------------------------------------------------------------------- /docs/HCAR.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage{hcar} 4 | \usepackage{url} 5 | 6 | \begin{document} 7 | 8 | \begin{hcarentry}{Ivor} 9 | \report{Edwin Brady} 10 | \status{Active Development} 11 | \makeheader 12 | 13 | Ivor is a tactic-based theorem proving engine with a Haskell API. Unlike 14 | other systems such as Coq and Agda, the tactic engine is primarily 15 | intended to be used by programs, rather than a human operator. To this 16 | end, the API provides a collection of primitive tactics and 17 | combinators for building new tactics. This allows easy construction of 18 | domain specific tactics, while keeping the core type theory small and 19 | independently checkable. 20 | 21 | The primary aim of the library is to support research into generative 22 | programming and resource bounded computation in Hume 23 | (\url{http://www.hume-lang.org/}). In this setting, we have developed a 24 | dependently typed framework for representing program execution cost, 25 | and used the Ivor library to implement domain specific tactics for 26 | constructing programs within this framework. However the library is 27 | more widely applicable, some potential uses being: 28 | 29 | \begin{itemize} 30 | \item A core language for a richly typed functional language. 31 | \item The underlying implementation for a theorem prover (see first order 32 | logic theorem prover example at 33 | \url{http://www.dcs.st-and.ac.uk/~eb/Ivor}). 34 | \item An implementation framework for a domain specific language requiring 35 | strong correctness properties. 36 | \end{itemize} 37 | 38 | Ivor features a dependent type theory similar to Luo's ECC with 39 | definitions, with additional (experimental) multi-stage programming 40 | support. Optionally, it can be extended with heterogenous equality, 41 | primitive types and operations, new parser rules and user defined 42 | tactics. By default, all programs in the type theory terminate, but in 43 | the spirit of flexibilty, the library can be configured to allow 44 | general recursion. 45 | 46 | The library is in active development, although at an early 47 | stage. Future plans include development of more basic tactics (for 48 | basic properties such as injectivity and disjointness of constructors, 49 | and elimination with a motive), a compiler (with optimisations) and a 50 | larger collection of standard definitions. 51 | 52 | \FurtherReading 53 | \url{http://www.dcs.st-and.ac.uk/~eb/Ivor} 54 | \end{hcarentry} 55 | 56 | \end{document} 57 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | all: humett.pdf 2 | 3 | SOURCES = humett.tex dtp.bib macros.ltx library.ltx local.ltx \ 4 | intro.tex tt.tex interface.tex shell.tex tactics.tex \ 5 | combinators.tex conclusion.tex 6 | 7 | humett.pdf: $(SOURCES) 8 | pdflatex humett 9 | -bibtex humett 10 | -pdflatex humett 11 | 12 | humett.ps: humett.dvi 13 | dvips -o humett.ps humett 14 | 15 | humett.dvi: $(SOURCES) 16 | -latex humett 17 | -bibtex humett 18 | -latex humett 19 | -latex humett 20 | 21 | clean: 22 | rm -f *.dvi *.pdf *.aux *.bbl *.blg *.log -------------------------------------------------------------------------------- /docs/combinators.tex: -------------------------------------------------------------------------------- 1 | \section{Building New Tactics} 2 | -------------------------------------------------------------------------------- /docs/conclusion.tex: -------------------------------------------------------------------------------- 1 | \section{Conclusion} 2 | -------------------------------------------------------------------------------- /docs/dtp.bib: -------------------------------------------------------------------------------- 1 | @phdthesis{ brady-thesis, 2 | author = {Edwin Brady}, 3 | title = {Practical Implementation of a Dependently Typed Functional Programming Language}, 4 | year = 2005, 5 | school = {University of Durham} 6 | } 7 | 8 | @article{view-left, 9 | journal = {Journal of Functional Programming}, 10 | number = {1}, 11 | volume = {14}, 12 | title = {The View From The Left}, 13 | year = {2004}, 14 | author = {Conor McBride and James McKinna}, 15 | pages = {69--111} 16 | } 17 | 18 | @misc{epigram-afp, 19 | author = {Conor McBride}, 20 | title = {Epigram: Practical Programming with Dependent Types}, 21 | year = {2004}, 22 | howpublished = {Lecture Notes, International Summer School on Advanced Functional Programming} 23 | } 24 | 25 | @misc{coq-manual, 26 | howpublished = {\verb+http://coq.inria.fr/+}, 27 | title = {The {Coq} Proof Assistant --- Reference Manual}, 28 | year = {2004}, 29 | author = {{Coq Development Team}} 30 | } 31 | 32 | @inproceedings{extraction-coq, 33 | title = {A New Extraction for {Coq}}, 34 | year = {2002}, 35 | booktitle = {Types for proofs and programs}, 36 | editor = {Herman Geuvers and Freek Wiedijk}, 37 | publisher = {Springer}, 38 | author = {Pierre Letouzey}, 39 | series = {LNCS} 40 | } 41 | 42 | @techreport{lego-manual, 43 | title = {\textsc{Lego} Proof Development System: User's Manual}, 44 | year = {1992}, 45 | institution = {Department of Computer Science, University of Edinburgh}, 46 | author = {Zhaohui Luo and Robert Pollack} 47 | } 48 | 49 | @inproceedings{cayenne, 50 | author = "Lennart Augustsson", 51 | title = "Cayenne - a Language with Dependent Types", 52 | booktitle = "International Conference on Functional Programming", 53 | pages = "239--250", 54 | year = "1998", 55 | url = "citeseer.nj.nec.com/augustsson98cayenne.html" 56 | } 57 | 58 | @book{luo94, 59 | title = {Computation and Reasoning -- A Type Theory for Computer Science}, 60 | year = {1994}, 61 | publisher = {OUP}, 62 | author = {Zhaohui Luo}, 63 | series = {International Series of Monographs on Computer Science} 64 | } 65 | 66 | @phdthesis{goguen-thesis, 67 | school = {University of Edinburgh}, 68 | title = {A Typed Operational Semantics for Type Theory}, 69 | year = {1994}, 70 | author = {Healfdene Goguen} 71 | } 72 | 73 | @phdthesis{mcbride-thesis, 74 | month = {May}, 75 | school = {University of Edinburgh}, 76 | title = {Dependently Typed Functional Programs and their proofs}, 77 | year = {2000}, 78 | author = {Conor McBride} 79 | } 80 | 81 | @misc{mckinnabrady-phase, 82 | title = {Phase Distinctions in the Compilation of {Epigram}}, 83 | year = 2005, 84 | author = {James McKinna and Edwin Brady}, 85 | note = {Draft} 86 | } 87 | 88 | @article{pugh-omega, 89 | title = "The {Omega} {Test}: a fast and practical integer programming algorithm for dependence analysis", 90 | author = "William Pugh", 91 | journal = "Communication of the ACM", 92 | year = 1992, 93 | pages = {102--114} 94 | } 95 | 96 | 97 | @Article{RegionTypes, 98 | refkey = "C1753", 99 | title = "Region-Based Memory Management", 100 | author = "M. Tofte and J.-P. Talpin", 101 | pages = "109--176", 102 | journal = "Information and Computation", 103 | month = "1~" # feb, 104 | year = "1997", 105 | volume = "132", 106 | number = "2" 107 | } 108 | 109 | @phdthesis{ pedro-thesis, 110 | author = {Pedro Vasconcelos}, 111 | title = {Space Cost Modelling for Concurrent Resource Sensitive Systems}, 112 | year = 2006, 113 | school = {University of St Andrews} 114 | } 115 | -------------------------------------------------------------------------------- /docs/hcar.sty: -------------------------------------------------------------------------------- 1 | \ProvidesPackage{hcar} 2 | 3 | \newif\ifhcarfinal 4 | \hcarfinalfalse 5 | \DeclareOption{final}{\hcarfinaltrue} 6 | \ProcessOptions 7 | 8 | \RequirePackage{keyval} 9 | \RequirePackage{color} 10 | \RequirePackage{array} 11 | 12 | \ifhcarfinal 13 | \RequirePackage[T1]{fontenc} 14 | \RequirePackage{lmodern} 15 | \RequirePackage{tabularx} 16 | \RequirePackage{booktabs} 17 | \RequirePackage{framed} 18 | \RequirePackage[obeyspaces,T1]{url} 19 | \RequirePackage 20 | [bookmarks=true,colorlinks=true, 21 | urlcolor=urlcolor, 22 | linkcolor=linkcolor, 23 | breaklinks=true, 24 | pdftitle={Haskell Communities and Activities Report}]% 25 | {hyperref} 26 | \else 27 | \RequirePackage[obeyspaces]{url} 28 | \fi 29 | \urlstyle{sf} 30 | 31 | \definecolor{urlcolor}{rgb}{0.1,0.3,0} 32 | \definecolor{linkcolor}{rgb}{0.3,0,0} 33 | \definecolor{shadecolor}{rgb}{0.9,0.95,1}%{0.98,1.0,0.95} 34 | \definecolor{framecolor}{gray}{0.9} 35 | \definecolor{oldgray}{gray}{0.7} 36 | 37 | \newcommand{\FurtherReading}{\subsubsection*{Further reading}} 38 | \newcommand{\FuturePlans}{\subsubsection*{Future plans}} 39 | \newcommand{\Separate}{\smallskip\noindent} 40 | \newcommand{\FinalNote}{\smallskip\noindent} 41 | 42 | \newcommand{\urlpart}{\begingroup\urlstyle{sf}\Url} 43 | \newcommand{\email}[1]{\href{mailto:\EMailRepl{#1}{ at }}{$\langle$\urlpart{#1}$\rangle$}} 44 | \newcommand{\cref}[1]{($\rightarrow\,$\ref{#1})} 45 | 46 | \ifhcarfinal 47 | \let\hcarshaded=\shaded 48 | \let\endhcarshaded=\endshaded 49 | \else 50 | \newsavebox{\shadedbox} 51 | \newlength{\shadedboxwidth} 52 | \def\hcarshaded 53 | {\begingroup 54 | \setlength{\shadedboxwidth}{\linewidth}% 55 | \addtolength{\shadedboxwidth}{-2\fboxsep}% 56 | \begin{lrbox}{\shadedbox}% 57 | \begin{minipage}{\shadedboxwidth}\ignorespaces} 58 | \def\endhcarshaded 59 | {\end{minipage}% 60 | \end{lrbox}% 61 | \noindent 62 | \colorbox{shadecolor}{\usebox{\shadedbox}}% 63 | \endgroup} 64 | \fi 65 | 66 | \ifhcarfinal 67 | \newenvironment{hcartabularx} 68 | {\tabularx{\linewidth}{l>{\raggedleft}X}} 69 | {\endtabularx} 70 | \else 71 | \newenvironment{hcartabularx} 72 | {\begin{tabular}{@{}m{.3\linewidth}@{}>{\raggedleft}p{.7\linewidth}@{}}} 73 | {\end{tabular}} 74 | \fi 75 | 76 | \ifhcarfinal 77 | \let\hcartoprule=\toprule 78 | \let\hcarbottomrule=\bottomrule 79 | \else 80 | \let\hcartoprule=\hline 81 | \let\hcarbottomrule=\hline 82 | \fi 83 | 84 | \define@key{hcarentry}{chapter}[]{\let\level\chapter} 85 | \define@key{hcarentry}{section}[]{\let\level\section} 86 | \define@key{hcarentry}{subsection}[]{\let\level\subsection} 87 | \define@key{hcarentry}{subsubsection}[]{\let\level\subsubsection} 88 | \define@key{hcarentry}{level}{\let\level=#1} 89 | %\define@key{hcarentry}{label}{\def\entrylabel{\label{#1}}} 90 | \define@key{hcarentry}{new}[]% 91 | {\let\startnew=\hcarshaded\let\stopnew=\endhcarshaded 92 | \def\startupdated{\let\orig@addv\addvspace\let\addvspace\@gobble}% 93 | \def\stopupdated{\let\addvspace\orig@addv}} 94 | \define@key{hcarentry}{old}[]{\def\normalcolor{\color{oldgray}}\color{oldgray}}% 95 | \define@key{hcarentry}{updated}[]% 96 | {\def\startupdated 97 | {\leavevmode\let\orig@addv\addvspace\let\addvspace\@gobble\hcarshaded}% 98 | \def\stopupdated{\endhcarshaded\let\addvspace\orig@addv}} 99 | 100 | \def\@makeheadererror{\PackageError{hcar}{hcarentry without header}{}} 101 | 102 | \newenvironment{hcarentry}[2][]% 103 | {\let\level\subsection 104 | \let\startupdated=\empty\let\stopupdated=\empty 105 | \let\startnew=\empty\let\stopnew=\empty 106 | %\let\entrylabel=\empty 107 | \global\let\@makeheaderwarning\@makeheadererror 108 | \setkeys{hcarentry}{#1}% 109 | \startnew\startupdated 110 | \level{#2}% 111 | % test: 112 | \global\let\@currentlabel\@currentlabel 113 | %\stopupdated 114 | \let\report@\empty 115 | \let\groupleaders@\empty 116 | \let\members@\empty 117 | \let\contributors@\empty 118 | \let\participants@\empty 119 | \let\developers@\empty 120 | \let\maintainer@\empty 121 | \let\status@\empty 122 | \let\release@\empty 123 | \let\portability@\empty 124 | \let\entry@\empty}% 125 | {\stopnew\@makeheaderwarning}% 126 | 127 | \renewcommand{\labelitemi}{$\circ$} 128 | \settowidth{\leftmargini}{\labelitemi} 129 | \addtolength{\leftmargini}{\labelsep} 130 | 131 | \newcommand*\MakeKey[2]% 132 | {\expandafter\def\csname #1\endcsname##1% 133 | {\expandafter\def\csname #1@\endcsname{\Key@{#2}{##1}}\ignorespaces}} 134 | \MakeKey{report}{Report by:} 135 | \MakeKey{status}{Status:} 136 | \MakeKey{groupleaders}{Group leaders:} 137 | \MakeKey{members}{Members:} 138 | \MakeKey{contributors}{Contributors:} 139 | \MakeKey{participants}{Participants:} 140 | \MakeKey{developers}{Developers:} 141 | \MakeKey{maintainer}{Maintainer:} 142 | \MakeKey{release}{Current release:} 143 | \MakeKey{portability}{Portability:} 144 | \MakeKey{entry}{Entry:} 145 | 146 | \newcommand\Key@[2]{#1 & #2\tabularnewline} 147 | 148 | \newcommand\makeheader 149 | {\smallskip 150 | \begingroup 151 | \sffamily 152 | \small 153 | \noindent 154 | \let\ohrule\hrule 155 | \def\hrule{\color{framecolor}\ohrule}% 156 | \begin{hcartabularx} 157 | \hline 158 | \report@ 159 | \groupleaders@ 160 | \members@ 161 | \participants@ 162 | \developers@ 163 | \contributors@ 164 | \maintainer@ 165 | \status@ 166 | \release@ 167 | \portability@ 168 | \hcarbottomrule 169 | \end{hcartabularx} 170 | \endgroup 171 | \stopupdated 172 | \global\let\@makeheaderwarning\empty 173 | \@afterindentfalse 174 | \@xsect\smallskipamount} 175 | 176 | % columns/linebreaks, interchanged 177 | \newcommand\NCi{&\let\NX\NCii}% 178 | \newcommand\NCii{&\let\NX\NL}% 179 | \newcommand\NL{\\\let\NX\NCi}% 180 | \let\NX\NCi 181 | \newcommand\hcareditor[1]{ (ed.)&\\} 182 | \newcommand\hcarauthor[1]{#1\NX}% 183 | -------------------------------------------------------------------------------- /docs/humett.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \input{macros.ltx} 4 | \input{library.ltx} 5 | \input{local.ltx} 6 | 7 | \NatPackage 8 | 9 | \begin{document} 10 | 11 | \title{\prover{} --- A Type Theory Based Theorem Proving Library} 12 | \author{Edwin Brady} 13 | 14 | \maketitle 15 | 16 | % Introduction 17 | \input{intro.tex} 18 | 19 | % The type theory 20 | \input{tt.tex} 21 | 22 | % The interface 23 | \input{interface.tex} 24 | 25 | % The shell 26 | \input{shell.tex} 27 | 28 | % Primitive tactics 29 | \input{tactics.tex} 30 | 31 | % Making new tactics; combinators 32 | \input{combinators.tex} 33 | 34 | \input{conclusion} 35 | 36 | \bibliographystyle{alpha} 37 | \bibliography{dtp} 38 | 39 | \end{document} 40 | -------------------------------------------------------------------------------- /docs/interface.tex: -------------------------------------------------------------------------------- 1 | \section{The API} 2 | -------------------------------------------------------------------------------- /docs/intro.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | -------------------------------------------------------------------------------- /docs/local.ltx: -------------------------------------------------------------------------------- 1 | \newcommand{\prover}{\textsc{HumeTT}} -------------------------------------------------------------------------------- /docs/shell.tex: -------------------------------------------------------------------------------- 1 | \section{The Shell} 2 | -------------------------------------------------------------------------------- /docs/tactics.tex: -------------------------------------------------------------------------------- 1 | \section{Primitive Tactics} 2 | -------------------------------------------------------------------------------- /docs/tt.tex: -------------------------------------------------------------------------------- 1 | \section{$\source$ --- The Core Type Theory} -------------------------------------------------------------------------------- /emacs/ivor-mode.el: -------------------------------------------------------------------------------- 1 | (eval-when-compile 2 | (require 'comint)) 3 | 4 | (defvar ivor-mode-map 5 | (let ((map (make-sparse-keymap))) 6 | (define-key map "\C-j" 'newline-and-indent) 7 | (define-key map "\C-n" 'ivor-send-to-shell) 8 | (define-key map "\C-c\C-n" 'ivor-send-all-to-shell) 9 | (define-key map "\C-c\C-s" 'ivor-start) 10 | (define-key map "\C-c\C-d" 'ivor-stop) 11 | (define-key map "\C-c\C-r" 'ivor-restart) 12 | (define-key map "\C-c\C-u" 'ivor-undo) 13 | map) 14 | "Keymap for `ivor-mode'.") 15 | 16 | (add-to-list 'auto-mode-alist '("\\.tt\\'" . ivor-mode)) 17 | 18 | (defvar ivor-mode-syntax-table 19 | (let ((st (make-syntax-table))) 20 | (modify-syntax-entry ?{ ". 1" st) 21 | (modify-syntax-entry ?} ". 4" st) 22 | (modify-syntax-entry ?- ". 1b2b3" st) 23 | (modify-syntax-entry ?\n "> b" st) 24 | st) 25 | "Syntax table for `ivor-mode'.") 26 | 27 | ;;;(regexp-opt '("Data" "Rec" "Qed" "Freeze" "Thaw" "Eval" "Check" "Load" 28 | ;;; "Suspend" "Resume" "Compile" "Repl" "Equality" "Drop" 29 | ;;; "Primitives" "Forget" "Let" "Axiom" "Focus" "Declare" "Where" 30 | ;;; "Plugin")) 31 | 32 | ;;;(regexp-opt '("attack" "claim" "local" "refine" "solve" "fill" "return" 33 | ;;; "quote" "call" "abandon" "rename" "intro" "intros" "arg" 34 | ;;; "equiv" "generalise" "dependent" "replace" "axiomatise" 35 | ;;; "compute" "unfold" "trivial" "by" "induction" "case" 36 | ;;; "auto" "left" "right" "split" "exists" "decide")) 37 | 38 | (defconst ivor-font-lock-keywords 39 | (list '("\\<\\(Axiom\\|C\\(?:heck\\|ompile\\)\\|D\\(?:ata\\|eclare\\|rop\\)\\|E\\(?:quality\\|val\\)\\|F\\(?:o\\(?:cus\\|rget\\)\\|reeze\\)\\|L\\(?:et\\|oad\\)\\|Primitives\\|Qed\\|Re\\(?:c\\|pl\\|sume\\)\\|Suspend\\|Thaw\\|Plugin\\|Where\\)\\>" 40 | . font-lock-keyword-face) 41 | '("a\\(?:bandon\\|rg\\|ttack\\|uto\\|xiomatise\\)\\|by\\|c\\(?:a\\(?:ll\\|se\\)\\|laim\\|ompute\\)\\|de\\(?:cide\\|pendent\\)\\|e\\(?:quiv\\|xists\\)\\|fill\\|generalise\\|in\\(?:duction\\|tros?\\)\\|l\\(?:eft\\|ocal\\)\\|quote\\|r\\(?:e\\(?:fine\\|name\\|place\\|turn\\)\\|ight\\)\\|s\\(?:olve\\|plit\\)\\|trivial\\|unfold" . font-lock-builtin-face) 42 | '("<\\([^:]*\\):[^>]*>" . (1 font-lock-string-face keep t)) 43 | '("<\\([^>:]*\\)>" . (1 font-lock-string-face keep t)) 44 | '("^\\([a-zA-Z0-9\\'\\_]+\\)\\s-*:" . (1 font-lock-function-name-face keep t)) 45 | '("^\\([a-zA-Z0-9\\'\\_]+\\)\\s-*=" . (1 font-lock-function-name-face keep t)) 46 | '("Rec\\s-+\\([a-zA-Z0-9\\'\\_]+\\)\\s-*:" . (1 font-lock-function-name-face t t)) 47 | '("\\b\\([a-zA-Z0-9\\'\\_]+\\)\\s-*:" . (1 font-lock-variable-name-face keep t)) 48 | '("\\b\\([a-zA-Z0-9\\'\\_]+\\)\\s-*," . (1 font-lock-variable-name-face keep t)) 49 | ) 50 | "Highlighting for Ivor mode") 51 | 52 | ;;;(defvar tt-font-lock-keywords 53 | ;;; '(("Data" (1 font-lock-keyword-face))) 54 | ;;; "Keyword highlighting specification for `ivor-mode'.") 55 | 56 | 57 | ;;(defvar tt-imenu-generic-expression 58 | ;; ...) 59 | 60 | ;;(defvar tt-outline-regexp 61 | ;; ...) 62 | 63 | ;;;###autoload 64 | (define-derived-mode ivor-mode fundamental-mode "Ivor" 65 | "A major mode for editing Ivor files." 66 | (set (make-local-variable 'comment-start) "-- ") 67 | (set (make-local-variable 'comment-start-skip) "#+\\s-*") 68 | (set (make-local-variable 'font-lock-defaults) 69 | '(ivor-font-lock-keywords)) 70 | (set (make-local-variable 'indent-line-function) 'ivor-indent-line) 71 | ;; (set (make-local-variable 'imenu-generic-expression) 72 | ;; ivor-imenu-generic-expression) 73 | ;; (set (make-local-variable 'outline-regexp) ivor-outline-regexp) 74 | ) 75 | 76 | ;;; Indentation 77 | ;; 1. Qed line is indented to 0 78 | ;; 2. After 'Data' indent each line 4 until a semicolon, or 2 if the line 79 | ;; begins with '|' or '=' 80 | 81 | 82 | (defun ivor-indent-line () 83 | "Indent current line of Ivor code." 84 | (interactive) 85 | (let ((savep (> (current-column) (current-indentation))) 86 | (indent (condition-case nil (max (ivor-calculate-indentation) 0) 87 | (error 0)))) 88 | (if savep 89 | (save-excursion (indent-line-to indent)) 90 | (indent-line-to indent)))) 91 | 92 | (defun ivor-calculate-indentation () 93 | "Return the column to which the current line should be indented." 94 | ;; Default is the indentation of the previous line 95 | (cond 96 | ((ivor-isQed) 0) 97 | ((ivor-first-is "[ \\t]*|") (ivor-under-eq)) 98 | ((ivor-eq-no-semi) 4) 99 | ((ivor-first-is "[ \\t]*=") 2) 100 | (t (ivor-get-previous-indentation)) 101 | ) 102 | ) 103 | 104 | (defun ivor-isQed () 105 | (save-excursion 106 | (beginning-of-line) 107 | (looking-at "Qed"))) 108 | 109 | (defun ivor-eq-no-semi () 110 | (save-excursion 111 | (forward-line -1) 112 | (beginning-of-line) 113 | (looking-at ".*=[^;]*$"))) 114 | 115 | (defun ivor-under-eq () 116 | "Indent to under the = sign on the previous line, or 4 spaces if none" 117 | (save-excursion 118 | (forward-line -1) 119 | (beginning-of-line) 120 | (let ((this-line (thing-at-point 'line))) 121 | (let ((eq-point (string-match "=" this-line))) 122 | (progn (if (eq eq-point nil) 123 | 2 124 | eq-point)))))) 125 | 126 | (defun ivor-first-is (str) 127 | (save-excursion 128 | (beginning-of-line) 129 | (looking-at str))) 130 | 131 | (defun ivor-get-previous-indentation () 132 | "Return the indentation of the previous line" 133 | (save-excursion 134 | (forward-line -1) 135 | (current-indentation))) 136 | 137 | (defun ivor-send-to-shell () 138 | "Read the current line and send it to the shell process, if any" 139 | (interactive) 140 | (progn (save-excursion 141 | (beginning-of-line) 142 | (let* ((this-line (thing-at-point 'line)) 143 | (chomped (substring this-line 0 (- (length this-line) 1)))) 144 | (progn (set-buffer (get-buffer "*Ivor*")) 145 | (insert chomped) 146 | (comint-send-input)))) 147 | (forward-line 1) 148 | (beginning-of-line) 149 | ) 150 | ) 151 | 152 | (defun ivor-send-all-to-shell () 153 | "Send the buffer up to the current point to the shell process" 154 | (interactive) 155 | (let ((contents (buffer-substring 1 (point)))) 156 | (progn (set-buffer (get-buffer "*Ivor*")) 157 | (insert contents) 158 | (comint-send-input)))) 159 | 160 | (defvar ivor-shell-exec "jones") 161 | (defvar ivor-shell-sep ";") 162 | 163 | (defun set-ivor-shell (executable) 164 | "Set the Ivor shell executable" 165 | (interactive "sShell executable: ") 166 | (setq ivor-shell-exec executable)) 167 | 168 | (defun set-ivor-sep (sep) 169 | "Set the Ivor shell command separator" 170 | (interactive "sShell separator: ") 171 | (setq ivor-shell-sep sep)) 172 | 173 | (defun ivor-start () 174 | "Start a shell with Ivor in it" 175 | (interactive) 176 | (when (not (bufferp (get-buffer "*Ivor*"))) 177 | (progn (shell "*Ivor*") 178 | (set-buffer (get-buffer "*Ivor*")) 179 | (insert ivor-shell-exec) 180 | (comint-send-input)))) 181 | 182 | (defun ivor-stop () 183 | "Stop the Ivor process" 184 | (interactive) 185 | (let ((dir (file-name-directory buffer-file-name))) 186 | (save-current-buffer 187 | (progn (set-buffer (get-buffer "*Ivor*")) 188 | (insert (concat "Drop" ivor-shell-sep)) 189 | (comint-send-input)))) 190 | (goto-char (point-min))) 191 | 192 | (defun ivor-restart () 193 | "Restart the Ivor process" 194 | (interactive) 195 | (let ((dir (file-name-directory buffer-file-name))) 196 | (save-current-buffer 197 | (progn (set-buffer (get-buffer "*Ivor*")) 198 | (insert (concat "Drop" ivor-shell-sep)) 199 | (comint-send-input) 200 | (insert (concat "cd " dir "; " ivor-shell-exec)) 201 | (comint-send-input)))) 202 | (goto-char (point-min))) 203 | 204 | (defun ivor-undo-proof () 205 | "Send undo command in a proof state." 206 | (interactive) 207 | (let ((dir (file-name-directory buffer-file-name))) 208 | (save-current-buffer 209 | (progn (set-buffer (get-buffer "*Ivor*")) 210 | (insert "Undo;") 211 | (comint-send-input)))) 212 | (goto-char (point-min))) 213 | 214 | (provide 'ivor-mode) 215 | -------------------------------------------------------------------------------- /examplett/ack.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | Primitives; 4 | 5 | natToInt : (x:Nat)Int; 6 | intros; 7 | induction x; 8 | fill 0; 9 | intros; 10 | fill addInt 1 k_IH; 11 | Qed; 12 | 13 | ack:(x,y:Nat); 14 | intro x; 15 | induction x; 16 | intros; 17 | return; 18 | fill (S y); 19 | intros; 20 | induction y0; 21 | return; 22 | call ack k (S O); 23 | intros; 24 | refine k_IH; 25 | fill call k_IH0; 26 | Qed; 27 | 28 | runack = [x,y:Int](natToInt (call 29 | (ack (intToNat x) (intToNat y)))); 30 | 31 | Eval runack 2 6; {- 15 -} 32 | Eval runack 3 4; {- 125 -} 33 | Eval runack 3 5; {- 253 -} 34 | 35 | Eval runack 4 4; {- no chance -} -------------------------------------------------------------------------------- /examplett/eq.tt: -------------------------------------------------------------------------------- 1 | Data Eq (A:*)(a:A) : (b:A)* where refl : Eq A a a; 2 | 3 | repl : (A:*)(a:A)(b:A)(q:Eq _ a b)(P:(a:A)*)(p:P a)(P b); 4 | intros; 5 | induction q; 6 | fill p; 7 | Qed; 8 | Freeze repl; 9 | 10 | trans : (A:*)(a:A)(b:A)(c:A)(p:Eq _ a b)(q:Eq _ b c)(Eq _ a c); 11 | intros; 12 | induction q; 13 | fill p; 14 | Qed; 15 | Freeze trans; 16 | 17 | sym : (A:*)(a:A)(b:A)(p:Eq _ a b)(Eq _ b a); 18 | intros; 19 | induction p; 20 | refine refl; 21 | Qed; 22 | Freeze sym; 23 | 24 | Repl Eq repl sym; 25 | 26 | eq_resp_f:(A,B:*)(f:(a:A)B)(x:A)(y:A)(q:Eq _ x y)(Eq _ (f x) (f y)); 27 | intros; 28 | induction q; 29 | refine refl; 30 | Qed; 31 | Freeze eq_resp_f; 32 | -------------------------------------------------------------------------------- /examplett/fin.tt: -------------------------------------------------------------------------------- 1 | Load "lt.tt"; 2 | 3 | Data Fin : (n:Nat)* where 4 | fz : (k:Nat)(Fin (S k)) 5 | | fs : (k:Nat)(i:Fin k)(Fin (S k)); 6 | 7 | mkFin : (m,n:Nat)(p:Lt m n)(Fin n); 8 | intros; 9 | induction p; 10 | intros; 11 | refine fz; 12 | intros; 13 | refine fs; 14 | fill p_IH; 15 | Qed; 16 | 17 | -------------------------------------------------------------------------------- /examplett/general.tt: -------------------------------------------------------------------------------- 1 | Data Nat:* = O:Nat | S:(k:Nat)Nat; 2 | 3 | General Y; 4 | 5 | genplus:(m:Nat)(n:Nat)Nat; 6 | by Y; 7 | intro PLUS m n; 8 | induction m; 9 | fill n; 10 | intros; 11 | fill S (PLUS k n); 12 | Qed; 13 | 14 | undefined:(A:*)A; 15 | by Y; 16 | intro UNDEF A; 17 | refine UNDEF; 18 | Qed; 19 | Freeze undefined; 20 | 21 | Data List (A:*) : * = nil:List A | cons:(x:A)(xs:List A)List A; 22 | 23 | head:(A:*)(xs:List A)A; 24 | intros; 25 | induction xs; 26 | refine undefined; 27 | intros; 28 | refine x; 29 | Qed; 30 | 31 | Eval head _ (cons _ O (nil Nat)); 32 | Eval head _ (nil Nat); 33 | -------------------------------------------------------------------------------- /examplett/interp.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | -------------------------------------------------------------------------------- /examplett/jmeq.tt: -------------------------------------------------------------------------------- 1 | Equality Eq refl; 2 | 3 | repl : (A:*)(x:A)(y:A)(q:Eq _ _ x y)(P:(m:A)*)(p:P x)(P y); 4 | intros; 5 | by EqElim _ _ _ q; 6 | fill p; 7 | Qed; 8 | Freeze repl; 9 | 10 | trans : (A:*)(a:A)(b:A)(c:A)(p:Eq _ _ a b)(q:Eq _ _ b c)(Eq _ _ a c); 11 | intros; 12 | by EqElim _ _ _ q; 13 | fill p; 14 | Qed; 15 | Freeze trans; 16 | 17 | sym : (A:*)(a:A)(b:A)(p:Eq _ _ a b)(Eq _ _ b a); 18 | intros; 19 | by EqElim _ _ _ p; 20 | refine refl; 21 | Qed; 22 | Freeze sym; 23 | 24 | Repl Eq repl sym; 25 | 26 | eq_resp_f:(A,B:*)(f:(a:A)B)(x:A)(y:A)(q:Eq _ _ x y)(Eq _ _ (f x) (f y)); 27 | intros; 28 | by EqElim _ _ _ q; 29 | refine refl; 30 | Qed; 31 | Freeze eq_resp_f; 32 | 33 | Data Nat:* = O:Nat | S:(k:Nat)Nat; 34 | 35 | plus' : (m:Nat)(n:Nat); 36 | intro m; 37 | induction m; 38 | intros; 39 | fill return n; 40 | intros; 41 | fill return (S (call (k_IH n0))); 42 | Qed; 43 | 44 | plus = [m:Nat][n:Nat](call (plus' m n)); 45 | 46 | simplifyO:(n:Nat)(Eq _ _ (plus O n) n); 47 | intros; 48 | refine refl; 49 | Qed; 50 | 51 | simplifyS:(m,n:Nat)(Eq _ _ (plus (S m) n) (S (plus m n))); 52 | intros; 53 | refine refl; 54 | Qed; 55 | 56 | eq_resp_S:(n:Nat)(m:Nat)(q:Eq _ _ n m)(Eq _ _ (S n) (S m)); 57 | intros; 58 | fill (eq_resp_f _ _ S n m q); 59 | Qed; 60 | Freeze eq_resp_S; 61 | 62 | s_injective:(n:Nat)(m:Nat)(q:Eq _ _ (S n) (S m))(Eq _ _ n m); 63 | intros; 64 | local unS:(m:Nat)Nat; 65 | intros; 66 | induction m0; 67 | fill n; 68 | intros; 69 | fill k; 70 | fill eq_resp_f _ _ unS _ _ q; 71 | Qed; 72 | Freeze s_injective; 73 | 74 | notO_S:(k:Nat)(not (Eq _ _ O (S k))); 75 | intros; 76 | equiv (q:Eq _ _ O (S k))False; 77 | intros; 78 | local dmotive : (x:Nat)(q:Eq _ _ O x)*; 79 | intros; 80 | induction x; 81 | fill True; 82 | intros; 83 | fill False; 84 | fill EqElim _ _ _ q dmotive II; 85 | Qed; 86 | Freeze notO_S; 87 | 88 | notn_S:(n:Nat)(not (Eq _ n (S n))); 89 | intro; 90 | induction n; 91 | fill notO_S O; 92 | intros; 93 | equiv (q:Eq _ (S k) (S (S k)))False; 94 | intros; 95 | claim q:Eq _ k (S k); 96 | fill k_IH q0; 97 | refine s_injective; 98 | fill q; 99 | Qed; 100 | Freeze notn_S; 101 | 102 | discriminate_Nat:(A:*)(k:Nat)(q:Eq _ O (S k))A; 103 | intros; 104 | local false:False; 105 | fill notO_S k q; 106 | induction false; 107 | Qed; 108 | Freeze discriminate_Nat; 109 | 110 | plusnO:(n:Nat)(Eq _ _ (plus n O) n); 111 | intro; 112 | induction n; 113 | refine refl; 114 | intros; 115 | equiv Eq _ _ (S (plus k O)) (S k); 116 | refine eq_resp_S; 117 | fill k_IH; 118 | Qed; 119 | Freeze plusnO; 120 | 121 | plusnSm:(n:Nat)(m:Nat)(Eq _ _ (plus n (S m)) (S (plus n m))); 122 | intros; 123 | induction n; 124 | refine refl; 125 | intros; 126 | refine eq_resp_S; 127 | fill k_IH; 128 | Qed; 129 | Freeze plusnSm; 130 | 131 | plus_comm:(n:Nat)(m:Nat)(Eq _ _ (plus n m) (plus m n)); 132 | intros; 133 | induction n; 134 | refine sym; 135 | refine plusnO; 136 | intros; 137 | equiv Eq _ _ (S (plus k m)) (plus m (S k)); 138 | replace k_IH; 139 | refine sym; 140 | refine plusnSm; 141 | Qed; 142 | Freeze plus_comm; 143 | 144 | plus_assoc:(m,n,p:Nat)(Eq _ _ (plus m (plus n p)) (plus (plus m n) p)); 145 | intros; 146 | induction m; 147 | refine refl; 148 | intros; 149 | equiv Eq _ _ (S (plus k (plus n p))) (plus (S (plus k n)) p); 150 | replace k_IH; 151 | refine refl; 152 | Qed; 153 | Freeze plus_assoc; 154 | 155 | plus_eq_fst : (m,n,p:Nat)(q:Eq _ _ (plus p m) (plus p n))(Eq _ _ m n); 156 | intro m n p; 157 | induction p; 158 | intros; 159 | fill q; 160 | intros; 161 | refine k_IH; 162 | refine s_injective; 163 | refine q0; 164 | Qed; 165 | Freeze plus_eq_fst; 166 | 167 | plus_eq_fst_sym : (m,n,p:Nat)(q:Eq _ _ (plus m p) (plus n p))(Eq _ _ m n); 168 | intro m n p; 169 | replace plus_comm m p; 170 | replace plus_comm n p; 171 | fill plus_eq_fst m n p; 172 | Qed; 173 | Freeze plus_eq_fst_sym; 174 | -------------------------------------------------------------------------------- /examplett/logic.tt: -------------------------------------------------------------------------------- 1 | Data And (A:*)(B:*) : * where and_intro : (a:A)(b:B)(And A B); 2 | 3 | Data Or (A:*)(B:*) : * where 4 | or_intro_l : (a:A)(Or A B) 5 | | or_intro_r : (b:B)(Or A B); 6 | 7 | Data Ex (A:*)(P:(a:A)*) : * where ex_intro : (x:A)(p:P x)(Ex A P); 8 | 9 | Data False : * where ; 10 | 11 | Data True : * where II : True ; 12 | 13 | not = [A:*](a:A)False; 14 | 15 | notElim = [A:*][p:not A][pp:A](p pp); 16 | 17 | Axiom classical:(P:*)(Or P (not P)); 18 | 19 | and_commutes : (A:*)(B:*)(p:And A B)(And B A); 20 | intros; 21 | induction p; 22 | intros; 23 | split; 24 | trivial; 25 | trivial; 26 | Qed; 27 | Freeze and_commutes; 28 | 29 | or_commutes : (A:*)(B:*)(p:Or A B)(Or B A); 30 | intros; 31 | induction p; 32 | intros; 33 | right; 34 | trivial; 35 | intros; 36 | left; 37 | trivial; 38 | Qed; 39 | Freeze or_commutes; 40 | 41 | implies : ((a:*)(Or a (not a)))-> 42 | (A:*)(B:*)(A -> B) -> (Or (not A) B); 43 | intros; 44 | case (X A); 45 | intros; 46 | right; 47 | refine X0; 48 | trivial; 49 | intros; 50 | left; 51 | trivial; 52 | Qed; 53 | 54 | 55 | -------------------------------------------------------------------------------- /examplett/lt.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | Data Lt : (m,n:Nat)* where 4 | ltO : (m:Nat)Lt O (S m) 5 | | ltS : (m,n:Nat)(p:Lt m n)Lt (S m) (S n); 6 | 7 | LtmSn : (m,n:Nat)(p:Lt m n)(Lt m (S n)); 8 | intros; 9 | induction p; 10 | intros; 11 | refine ltO; 12 | intros; 13 | refine ltS; 14 | fill p_IH; 15 | Qed; 16 | 17 | Ltmplus : (m,n,i:Nat)(p:Lt m n)(Lt m (plus n i)); 18 | intros; 19 | induction p; 20 | intros; 21 | refine ltO; 22 | intro m2 n1; 23 | intros; 24 | refine ltS; 25 | fill p_IH; 26 | Qed; 27 | -------------------------------------------------------------------------------- /examplett/nat.tt: -------------------------------------------------------------------------------- 1 | Load "eq.tt"; 2 | Load "logic.tt"; 3 | 4 | Data Nat:* where 5 | O:Nat 6 | | S:(k:Nat)Nat; 7 | 8 | plus : Nat -> Nat -> Nat; 9 | intro m; 10 | induction m; 11 | intros; 12 | fill X0; 13 | intros; 14 | fill S (k_IH X1); 15 | Qed; 16 | 17 | mult : (m:Nat) -> (n:Nat) -> Nat; 18 | intro m; 19 | induction m; 20 | intros; 21 | fill O; 22 | intros; 23 | fill (plus n0 (k_IH n0)); 24 | Qed; 25 | 26 | simplifyO:(n:Nat)(Eq _ (plus O n) n); 27 | intros; 28 | refine refl; 29 | Qed; 30 | 31 | simplifyS:(m,n:Nat)(Eq _ (plus (S m) n) (S (plus m n))); 32 | intros; 33 | refine refl; 34 | Qed; 35 | 36 | eq_resp_S:(n:Nat)(m:Nat)(q:Eq _ n m)(Eq _ (S n) (S m)); 37 | intros; 38 | fill (eq_resp_f _ _ S n m q); 39 | Qed; 40 | Freeze eq_resp_S; 41 | 42 | s_injective:(n:Nat)(m:Nat)(q:Eq _ (S n) (S m))(Eq _ n m); 43 | intros; 44 | local unS:(m:Nat)Nat; 45 | intros; 46 | induction m0; 47 | fill n; 48 | intros; 49 | fill k; 50 | fill eq_resp_f _ _ unS _ _ q; 51 | Qed; 52 | Freeze s_injective; 53 | 54 | notO_S:(k:Nat)(not (Eq _ O (S k))); 55 | intros; 56 | compute; 57 | intro q; 58 | local dmotive : (x:Nat)(q:Eq _ O x)*; 59 | intros; 60 | induction x; 61 | fill True; 62 | intros; 63 | fill False; 64 | fill EqElim _ _ _ q dmotive II; 65 | Qed; 66 | Freeze notO_S; 67 | 68 | notn_S:(n:Nat)(not (Eq _ n (S n))); 69 | intro; 70 | induction n; 71 | fill notO_S O; 72 | intros; 73 | unfold not; 74 | intros; 75 | claim q:Eq _ k (S k); 76 | fill k_IH q; 77 | refine s_injective; 78 | fill a; 79 | Qed; 80 | Freeze notn_S; 81 | 82 | discriminate_Nat:(A:*)(k:Nat)(q:Eq _ O (S k))A; 83 | intros; 84 | local false:False; 85 | fill notO_S k q; 86 | induction false; 87 | Qed; 88 | Freeze discriminate_Nat; 89 | 90 | plusnO:(n:Nat)(Eq _ (plus n O) n); 91 | intro; 92 | induction n; 93 | refine refl; 94 | intros; 95 | equiv Eq _ (S (plus k O)) (S k); 96 | refine eq_resp_S; 97 | fill k_IH; 98 | Qed; 99 | Freeze plusnO; 100 | 101 | plusnSm:(n:Nat)(m:Nat)(Eq _ (plus n (S m)) (S (plus n m))); 102 | intros; 103 | induction n; 104 | refine refl; 105 | intros; 106 | refine eq_resp_S; 107 | fill k_IH; 108 | Qed; 109 | Freeze plusnSm; 110 | 111 | plus_comm:(n:Nat)(m:Nat)(Eq _ (plus n m) (plus m n)); 112 | intros; 113 | induction n; 114 | refine sym; 115 | refine plusnO; 116 | intros; 117 | equiv Eq _ (S (plus k m)) (plus m (S k)); 118 | replace k_IH; 119 | refine sym; 120 | refine plusnSm; 121 | Qed; 122 | Freeze plus_comm; 123 | 124 | plus_assoc:(m,n,p:Nat)(Eq _ (plus m (plus n p)) (plus (plus m n) p)); 125 | intros; 126 | induction m; 127 | refine refl; 128 | intros; 129 | equiv Eq _ (S (plus k (plus n p))) (plus (S (plus k n)) p); 130 | replace k_IH; 131 | refine refl; 132 | Qed; 133 | Freeze plus_assoc; 134 | 135 | plus_eq_fst : (m,n,p:Nat)(q:Eq _ (plus p m) (plus p n))(Eq _ m n); 136 | intro m n p; 137 | induction p; 138 | intros; 139 | fill q; 140 | intros; 141 | refine k_IH; 142 | refine s_injective; 143 | refine q0; 144 | Qed; 145 | Freeze plus_eq_fst; 146 | 147 | plus_eq_fst_sym : (m,n,p:Nat)(q:Eq _ (plus m p) (plus n p))(Eq _ m n); 148 | intro m n p; 149 | replace plus_comm m p; 150 | replace plus_comm n p; 151 | fill plus_eq_fst m n p; 152 | Qed; 153 | Freeze plus_eq_fst_sym; 154 | 155 | multnO:(n:Nat)(Eq _ (mult n O) O); 156 | intro; 157 | induction n; 158 | refine refl; 159 | intros; 160 | equiv Eq _ (plus O (mult k O)) O; 161 | replace k_IH; 162 | refine refl; 163 | Qed; 164 | Freeze multnO; 165 | 166 | multnSm:(n:Nat)(m:Nat)(Eq _ (mult n (S m)) (plus n (mult n m))); 167 | intro; 168 | induction n; 169 | intros; 170 | refine refl; 171 | intros; 172 | equiv Eq _ (S (plus m0 (mult k (S m0)))) 173 | (S (plus k (plus m0 (mult k m0)))); 174 | refine eq_resp_S; 175 | replace (k_IH m0); 176 | generalise mult k m0; 177 | intros; 178 | replace (plus_comm m0 x); 179 | replace (plus_assoc k x m0); 180 | replace (plus_comm m0 (plus k x)); 181 | refine refl; 182 | Qed; 183 | Freeze multnSm; 184 | 185 | mult_comm : (m,n:Nat) -> (Eq _ (mult m n) (mult n m)); 186 | intro m; 187 | induction m; 188 | intros; 189 | replace (multnO n); 190 | refine refl; 191 | intros; 192 | replace (multnSm n0 k); 193 | replace sym (k_IH n0); 194 | refine refl; 195 | Qed; 196 | Freeze mult_comm; 197 | 198 | mult_distrib:(m,n,p:Nat)(Eq _ (plus (mult m p) (mult n p)) 199 | (mult (plus m n) p)); 200 | intros; 201 | induction m; 202 | refine refl; 203 | intros; 204 | equiv Eq _ (plus (plus p (mult k p)) (mult n p)) 205 | (plus p (mult (plus k n) p)); 206 | replace sym k_IH; 207 | generalise mult k p; 208 | generalise mult n p; 209 | intro x y; 210 | replace plus_assoc p y x; 211 | refine refl; 212 | Qed; 213 | 214 | mult_assoc:(m,n,p:Nat)(Eq _ (mult m (mult n p)) (mult (mult m n) p)); 215 | intro m; 216 | induction m; 217 | intros; 218 | compute; 219 | refine refl; 220 | intros; 221 | equiv Eq _ (plus (mult n0 p0) (mult k (mult n0 p0))) 222 | (mult (plus n0 (mult k n0)) p0); 223 | replace k_IH n0 p0; 224 | generalise mult k n0; 225 | intros; 226 | replace mult_distrib n0 x p0; 227 | refine refl; 228 | Qed; 229 | 230 | -------------------------------------------------------------------------------- /examplett/natsimpl.tt: -------------------------------------------------------------------------------- 1 | Data Nat:* = O:Nat | S:(k:Nat)Nat; 2 | 3 | plus : (m:Nat)(n:Nat)Nat; 4 | intro m; 5 | induction m; 6 | intros; 7 | fill n; 8 | intros; 9 | refine S; 10 | fill k_IH n0; 11 | Qed; 12 | 13 | adderType : (m:Nat)(n:Nat)*; 14 | intros; 15 | induction m; 16 | fill Nat; 17 | intros; 18 | fill (n:Nat)k_IH; 19 | Qed; 20 | 21 | adder: (m:Nat)(n:Nat)(adderType m n); 22 | intro m; 23 | induction m; 24 | intros; 25 | fill n; 26 | intros; 27 | compute; 28 | intros; 29 | fill k_IH (plus n0 n1); 30 | Qed; 31 | 32 | mult:(m:Nat)(n:Nat)Nat; 33 | intros; 34 | induction m; 35 | fill O; 36 | intros; 37 | fill (plus n k_IH); 38 | Qed; 39 | 40 | fact:(m:Nat)Nat; 41 | intros; 42 | induction m; 43 | fill (S O); 44 | intros; 45 | fill (mult (S k) k_IH); 46 | Qed; 47 | 48 | 49 | testval = fact (S (S (S (S (S (S (S (S (S O))))))))); 50 | 51 | Data Vect (A:*):(n:Nat)* 52 | = vnil:Vect A O 53 | | vcons:(k:Nat)(x:A)(xs:Vect A k)Vect A (S k); 54 | 55 | vectsum : (k:Nat)(v:Vect Nat k)Nat; 56 | intros; 57 | induction v; 58 | fill O; 59 | intros; 60 | fill (plus x xs_IH); 61 | Qed; 62 | 63 | testvect2 = vcons _ _ (S O) (vcons _ _ (S (S (S O))) (vnil Nat)); 64 | testval2 = vectsum _ testvect2; 65 | 66 | -------------------------------------------------------------------------------- /examplett/partial.tt: -------------------------------------------------------------------------------- 1 | {- Uustalu, Altenkirch and Capretta's Partiality monad -} 2 | 3 | Data Partial (A:*) : * = {- codata -} 4 | Now : (a:A)Partial A 5 | | Later : (p:Partial A)Partial A; 6 | 7 | Declare never:(A:*)Partial A; 8 | never = [A:*](Later _ (never A)); 9 | 10 | returnD = [A:*][a:A]Now _ a; 11 | 12 | {- corecursive -} 13 | Rec bindD : (A,B:*)(d:Partial A)(k:(a:A)(Partial B))Partial B; 14 | intros; 15 | case d; 16 | intros; 17 | fill k a; 18 | intros; 19 | fill Later _ (bindD _ _ p k); 20 | Qed; 21 | 22 | {- corecursive -} 23 | Rec lfpAux : (A,B:*)(k:(a0:A)(Partial B)) 24 | (f:(fk:(a1:A)Partial B)(fa:A)Partial B)(a:A)Partial B; 25 | intros; 26 | case f k a; 27 | intros; 28 | fill Now _ a0; 29 | intros; 30 | fill Later _ (lfpAux _ _ (f k) f a); 31 | Qed; 32 | 33 | lfp = [A,B:*][f:(k:(a:A)Partial B)((a:A)Partial B)][a:A] 34 | (lfpAux _ _ ([x:A]never B) f a); 35 | 36 | Load "nat.tt"; 37 | 38 | fact : (x:Nat)Partial Nat; 39 | intros; 40 | refine lfp Nat; 41 | intro factfn arg; 42 | case arg; 43 | refine returnD; 44 | fill (S O); 45 | intros; 46 | case (factfn k); 47 | intros; 48 | refine returnD; 49 | fill (mult a (S k)); 50 | intros; 51 | fill p; 52 | fill x; 53 | Qed; 54 | -------------------------------------------------------------------------------- /examplett/plus.tt: -------------------------------------------------------------------------------- 1 | Datatype Nat { 2 | TyCon Nat : *, 3 | Con O : Nat, 4 | Con S : (n:Nat)Nat, 5 | Elim natElim : (n:Nat)(P:(n:Nat)*) 6 | (mz:(P O)) 7 | (ms:(k:Nat)(ih:(P n))(P (S k))) 8 | (P n), 9 | Scheme O,P,mz,ms -> mz 10 | Scheme (S k),P,mz,ms -> ms k (natElim k P mz ms) 11 | }; 12 | 13 | plus : (m:Nat)(n:Nat)Nat; 14 | intro; 15 | intro; 16 | claim A:*; 17 | claim mzero:A; 18 | claim msuc:(k:Nat)(ih:A)A; 19 | try natElim m ([n:Nat]A) mzero msuc; 20 | mzero.try n; 21 | solve; 22 | msuc.focus; 23 | attack M; 24 | intro; 25 | intro; 26 | try (S ih); 27 | solve; 28 | M.cut; 29 | msuc.solve; 30 | msuc.cut; 31 | H.solve; 32 | H.cut; 33 | mzero.cut; 34 | plus.tidy; 35 | solve; 36 | Lift; 37 | 38 | -------------------------------------------------------------------------------- /examplett/staged.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | code = {'(plus (S (S O)) (S (S O)))}; 4 | 5 | plusQ = [a:Nat][b:Nat]{'plus a b}; 6 | 7 | Check code; 8 | Eval code; 9 | 10 | Eval !code; 11 | 12 | test = [a:Nat]{'[b:Nat]~(plusQ a b)}; 13 | 14 | test2 = {'[A:*][x:{{A}}]~(!{'x})}; 15 | 16 | 17 | 18 | Eval test (S (S (S O))); 19 | Eval !(test (S (S (S O)))) (S (S (S O))); 20 | 21 | code2 = {'plus ~code ~code}; 22 | code3 = {'{'plus ~code ~code}}; 23 | code4 = [x:{{Nat}}]{'plus ~x ~x}; 24 | 25 | Eval code4 {'(plus (S O) (S O))}; 26 | Eval !(code4 {'(plus (S O) (S O))}); 27 | 28 | plusST : (m,n:{{Nat}}){{Nat}}; 29 | intros; 30 | induction !m; 31 | fill n; 32 | intros; 33 | fill {'S ~k_IH}; 34 | Qed; 35 | 36 | val = code4 {'(plus (S O) (S O))}; 37 | 38 | Eval plusST val val; 39 | Eval !(plusST val val); 40 | 41 | Eval plusST; 42 | -------------------------------------------------------------------------------- /examplett/stageplus.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | -- plusST = lam m,n:{{Nat}}. 4 | -- case !m of 5 | -- O -> n 6 | -- S k -> {'S ~(plusST ~k n)} 7 | 8 | plusST:(m,n:{{Nat}}){{Nat}}; 9 | intros; 10 | induction !m; 11 | fill n; 12 | intros; 13 | fill {'S ~k_IH}; 14 | Qed; 15 | 16 | quote4 = {'plus (S (S O)) (S (S O))}; 17 | 18 | quote8 = plusST quote4 quote4; 19 | 20 | Eval quote8; 21 | Eval !quote8; 22 | 23 | quotefoo = [m:Nat][n:Nat]{'plus (S (S O)) (([p:Nat](plus m p)) n)}; 24 | 25 | mult:(m,n:Nat)Nat; 26 | intros; 27 | induction m; 28 | refine O; 29 | intros; 30 | refine (plus n k_IH); 31 | Qed; 32 | 33 | power:(m,x:Nat)Nat; 34 | induction m; 35 | fill (S O); 36 | intros; 37 | fill (mult x k_IH); 38 | Qed; 39 | 40 | -------------------------------------------------------------------------------- /examplett/test.tt: -------------------------------------------------------------------------------- 1 | Datatype Nat { 2 | TyCon Nat : *, 3 | Con O : Nat, 4 | Con S : (n:Nat)Nat, 5 | Elim natElim : (n:Nat)(P:(n:Nat)*) 6 | (mz:(P O)) 7 | (ms:(k:Nat)(ih:(P n))(P (S k))) 8 | (P n), 9 | Scheme O,P,mz,ms -> mz 10 | Scheme (S k),P,mz,ms -> ms k (natElim k P mz ms) 11 | }; 12 | 13 | holey_plus = [m:Nat][n:Nat](?H:Nat. 14 | (natElim n ([n:Nat]Nat) H ([k:Nat][ih:Nat](S ih)))); 15 | H. try m; 16 | H. solve; 17 | H. cut; 18 | Prf; 19 | holey_plus.solve; 20 | Lift; 21 | 22 | plus = [m:Nat][n:Nat](natElim n ([n:Nat]Nat) m ([k:Nat][ih:Nat](S ih))); 23 | mult = [m:Nat][n:Nat](natElim n ([n:Nat]Nat) O ([k:Nat][ih:Nat](plus m ih))); 24 | fact = [n:Nat](natElim n ([n:Nat]Nat) (S O) ([k:Nat][ih:Nat](mult ih (S k)))); 25 | 26 | double : (n:Nat)Nat; 27 | double. attack H; 28 | H. intro; 29 | H. x:Nat; 30 | H. y:Nat; 31 | H. try plus x y; 32 | H. solve; 33 | y. try n; 34 | y. solve; 35 | x. try n; 36 | x. solve; 37 | double. solve; 38 | Lift; 39 | 40 | id : (A:*)(a:A)A; 41 | id. attack H; 42 | H. intro; 43 | H. intro; 44 | H. try a; 45 | H. solve; 46 | H. cut; 47 | id. solve; 48 | Lift; 49 | 50 | Eval plus (S (S O)) (S (S O)); 51 | 52 | Datatype Vect { 53 | TyCon Vect : (A:*)(n:Nat)*, 54 | Con Vnil : (A:*)(Vect A O), 55 | Con Vcons : (A:*)(k:Nat)(a:A)(v:Vect A k)(Vect A (S k)), 56 | Elim VectElim : (A:*) 57 | (n:Nat) 58 | (v:Vect A n) 59 | (P:(n:Nat)(v:Vect A n)*) 60 | (mnil:(P O (Vnil A))) 61 | (mcons:(k:Nat)(a:A)(v:Vect A k)(ih:P k v) 62 | (P (S k) (Vcons A k a v))) 63 | (P n v), 64 | Scheme A,O,(Vnil A),P,mnil,mcons -> mnil 65 | Scheme A,(S k),(Vcons A k a v),P,mnil,mcons 66 | -> mcons k a v (VectElim A k v P mnil mcons) 67 | }; 68 | 69 | vectFold = [A:*][B:*][n:Nat][v:Vect A n][empty:B][tail:(a:A)(b:B)B] 70 | (VectElim A n v ([n:Nat][v:Vect A n]B) empty 71 | ([k:Nat][a:A][v:Vect A k][ih:B](tail a ih))); 72 | 73 | Eval VectElim Nat O (Vnil Nat) ([n:Nat][v:Vect Nat n]Nat) 74 | (S O) ([k:Nat][a:Nat][v:Vect Nat k][ih:Nat](S ih)); 75 | 76 | Eval VectElim Nat (S (S O)) (Vcons Nat (S O) (S O) (Vcons Nat O (S O) (Vnil Nat))) 77 | ([n:Nat][v:Vect Nat n]Nat) (S O) ([k:Nat][a:Nat][v:Vect Nat k][ih:Nat](S (S ih))); 78 | 79 | Output "rts/test"; 80 | 81 | Eval fact (S (S (S (S (S (S (S O))))))); 82 | 83 | Quit; 84 | -------------------------------------------------------------------------------- /examplett/vec.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | Data Vect (A:*) : (n:Nat)* = 4 | Vnil : (Vect A O) 5 | | Vcons : (k:Nat)(a:A)(v:Vect A k)(Vect A (S k)); 6 | 7 | vec_append : (A:*)(m,n:Nat)(xs:Vect A m)(ys:Vect A n)(Vect A (plus m n)); 8 | intros; 9 | induction xs; 10 | fill ys; 11 | intros; 12 | fill (Vcons _ _ a v_IH); 13 | Qed; 14 | -------------------------------------------------------------------------------- /examplett/vect.tt: -------------------------------------------------------------------------------- 1 | Load "fin.tt"; 2 | 3 | Data Vect (A:*):(n:Nat)* where 4 | vnil:Vect A O 5 | | vcons:(k:Nat)(x:A)(xs:Vect A k)Vect A (S k); 6 | 7 | vappend : (A:*)->(n,m:Nat)->(xs:Vect A n)->(ys:Vect A m)-> 8 | (Vect A (plus n m)); 9 | intros; 10 | induction xs; 11 | fill ys; 12 | intros; 13 | fill (vcons _ _ x xs_IH); 14 | Qed; 15 | 16 | vtail : (A:*)(k:Nat)(xs:Vect A (S k))Vect A k; 17 | local vtailAux : (A:*)(k:Nat)(k':Nat)(xs:Vect A k')(p:Eq _ (S k) k')Vect A k; 18 | Focus H; 19 | intros; 20 | refine (vtailAux _ k _ xs); 21 | refine refl; 22 | intro A k k' xs; 23 | induction xs; 24 | intros; 25 | fill discriminate_Nat _ _ (sym _ _ _ p); 26 | intros; 27 | replace s_injective _ _ p0; 28 | fill xs0; 29 | Qed; 30 | 31 | testvect = vcons _ _ (S O) (vnil Nat); 32 | 33 | vectsum : (k:Nat)(v:Vect Nat k)Nat; 34 | intros; 35 | induction v; 36 | fill O; 37 | intros; 38 | fill (plus x xs_IH); 39 | Qed; 40 | 41 | testvect2 = vcons _ _ (S O) (vcons _ _ (S (S (S O))) (vnil Nat)); 42 | testval2 = vectsum _ testvect2; 43 | 44 | lookup:(A:*)(n:Nat)(i:Fin n)(xs:Vect A n)A; 45 | local lookupAux:(A:*)(n:Nat)(i:Fin n)(n':Nat)(xs:Vect A n')(p:Eq _ n n')A; 46 | intro A n i; 47 | induction i; 48 | intro k n' xs; 49 | induction xs; 50 | intros; 51 | fill (discriminate_Nat _ _ (sym _ _ _ p)); 52 | intros; 53 | fill x; {- fz (x::xs) -} 54 | intro k i i_IH n' xs; 55 | induction xs; 56 | intros; 57 | fill (discriminate_Nat _ _ (sym _ _ _ p0)); 58 | intros; 59 | refine (i_IH k0); 60 | fill xs0; 61 | refine s_injective; 62 | trivial; 63 | intros; 64 | refine (lookupAux _ _ i _ xs); 65 | refine refl; 66 | Qed; 67 | 68 | lookupLt:(A:*)(n:Nat)(i:Nat)(p:Lt i n)(xs:Vect A n)A; 69 | intros; 70 | refine lookup; 71 | fill n; 72 | refine mkFin; 73 | fill i; 74 | fill p; 75 | fill xs; 76 | Qed; 77 | -------------------------------------------------------------------------------- /ivor.cabal: -------------------------------------------------------------------------------- 1 | Name: ivor 2 | Version: 0.1.14 3 | Author: Edwin Brady 4 | License: BSD3 5 | License-file: LICENSE 6 | Author: Edwin Brady 7 | Maintainer: Edwin Brady 8 | Homepage: http://www.dcs.st-and.ac.uk/~eb/Ivor/ 9 | Stability: experimental 10 | -- Build-depends: base, haskell98, parsec, mtl, directory, containers 11 | Extensions: MultiParamTypeClasses, FunctionalDependencies, 12 | ExistentialQuantification, OverlappingInstances 13 | Category: Theorem provers, Dependent Types 14 | Synopsis: Theorem proving library based on dependent type theory 15 | Description: Ivor is a type theory based theorem prover, with a 16 | Haskell API, designed for easy extending and embedding 17 | of theorem proving technology in Haskell 18 | applications. It provides an implementation of the 19 | type theory and tactics for building terms, more or 20 | less along the lines of systems such as Coq or Agda, 21 | and taking much of its inspiration from Conor 22 | McBride's presentation of OLEG. 23 | . 24 | The API provides a collection of primitive tactics and 25 | combinators for building new tactics. It is therefore 26 | possible to build new tactics to suit specific 27 | applications. Ivor features a dependent type theory 28 | similar to Luo's ECC with definitions (and similar to 29 | that implemented in Epigram), with dependent pattern 30 | matching, and experimental multi-stage programming 31 | support. Optionally, it can be extended with 32 | heterogeneous equality, primitive types and operations, 33 | new parser rules, user defined tactics and (if you 34 | want your proofs to be untrustworthy) a fixpoint 35 | combinator. 36 | 37 | Data-files: BUGS, INSTALL, TODO, docs/macros.ltx, docs/local.ltx, docs/tt.tex, docs/conclusion.tex, 38 | docs/intro.tex, docs/hcar.sty, docs/tactics.tex, docs/library.ltx, 39 | docs/shell.tex, docs/dtp.bib, docs/HCAR.tex, docs/Makefile, 40 | docs/combinators.tex, docs/humett.tex, docs/interface.tex, 41 | papers/tutorial/tutorial.tex, papers/tutorial/macros.ltx, papers/tutorial/theoremproving.tex, 42 | papers/tutorial/introduction.tex, papers/tutorial/hslibrary.tex, papers/tutorial/library.ltx, 43 | papers/tutorial/programming.tex, papers/tutorial/Makefile, papers/bib/literature.bib, 44 | papers/ivor/examples.tex, papers/ivor/code.tex, papers/ivor/macros.ltx, 45 | papers/ivor/ivor.tex, papers/ivor/corett.tex, papers/ivor/conclusions.tex, 46 | papers/ivor/intro.tex, papers/ivor/llncs.cls, papers/ivor/tactics.tex, 47 | papers/ivor/library.ltx, papers/ivor/dtp.bib, papers/ivor/alink.bib, 48 | papers/ivor/Makefile, papers/ivor/embounded.bib, 49 | lib/nat.tt, lib/lt.tt, lib/list.tt, lib/eq.tt, 50 | lib/basics.tt, lib/logic.tt, lib/vect.tt, lib/fin.tt 51 | 52 | 53 | Extra-source-files: emacs/ivor-mode.el, examplett/staged.tt, examplett/test.c, examplett/partial.tt, examplett/nat.tt, 54 | examplett/vec.tt, examplett/lt.tt, examplett/Test.hs, examplett/plus.tt, 55 | examplett/jmeq.tt, examplett/eq.tt, examplett/logic.tt, examplett/interp.tt, 56 | examplett/stageplus.tt, examplett/Nat.hs, examplett/general.tt, examplett/natsimpl.tt, 57 | examplett/test.tt, examplett/vect.tt, examplett/fin.tt, examplett/ack.tt, 58 | IOvor/IOPrims.lhs, IOvor/Main.lhs, IOvor/iobasics.tt, Jones/Main.lhs 59 | 60 | 61 | 62 | Build-depends: base >=3 && <5, parsec, mtl, directory, binary, containers 63 | Build-type: Simple 64 | 65 | Extensions: MultiParamTypeClasses, FunctionalDependencies, 66 | ExistentialQuantification, OverlappingInstances, 67 | TypeSynonymInstances, FlexibleInstances, PatternGuards 68 | -- Needs some -Wall cleanup 69 | -- GHC-options: -Wall 70 | 71 | Exposed-modules: 72 | Ivor.TT, Ivor.CtxtTT, Ivor.EvalTT, 73 | Ivor.Shell, Ivor.Primitives, 74 | Ivor.TermParser, Ivor.ViewTerm, Ivor.Equality, 75 | Ivor.Plugin, Ivor.Construction 76 | Other-modules: Ivor.Nobby, Ivor.TTCore, Ivor.State, 77 | Ivor.Tactics, Ivor.Typecheck, Ivor.Evaluator 78 | Ivor.Gadgets, Ivor.Values, 79 | Ivor.Datatype, Ivor.Display, 80 | Ivor.MakeData, Ivor.Unify, 81 | Ivor.ShellParser, Ivor.Constant, 82 | Ivor.Errors, 83 | Ivor.PatternDefs, Ivor.ShellState, Ivor.Scopecheck, 84 | Ivor.Overloading, Ivor.PMComp, 85 | Paths_ivor 86 | ghc-prof-options: -auto-all 87 | -------------------------------------------------------------------------------- /lib/basics.tt: -------------------------------------------------------------------------------- 1 | -- Some generally useful definitions 2 | -- Heterogeneous equality, nats, maybe, bools, lists. 3 | 4 | Load "eq.tt"; 5 | Load "nat.tt"; 6 | 7 | Data Maybe (A:*) : * 8 | = nothing : Maybe A 9 | | just : (a:A)(Maybe A); 10 | 11 | Data Bool : * = true : Bool | false : Bool; 12 | 13 | Data List (A:*) : * 14 | = nil : List A 15 | | cons : (x:A)->(xs:List A)->(List A); 16 | -------------------------------------------------------------------------------- /lib/eq.tt: -------------------------------------------------------------------------------- 1 | Equality Eq refl; 2 | 3 | repl : (A:*)(x:A)(y:A)(q:Eq _ _ x y)(P:(m:A)*)(p:P x)(P y); 4 | intros; 5 | by EqElim _ _ _ q; 6 | fill p; 7 | Qed; 8 | Freeze repl; 9 | 10 | trans : (A:*)(a:A)(b:A)(c:A)(p:Eq _ _ a b)(q:Eq _ _ b c)(Eq _ _ a c); 11 | intros; 12 | by EqElim _ _ _ q; 13 | fill p; 14 | Qed; 15 | Freeze trans; 16 | 17 | sym : (A:*)(a:A)(b:A)(p:Eq _ _ a b)(Eq _ _ b a); 18 | intros; 19 | by EqElim _ _ _ p; 20 | refine refl; 21 | Qed; 22 | Freeze sym; 23 | 24 | Repl Eq repl sym; 25 | 26 | eq_resp_f:(A,B:*)(f:(a:A)B)(x:A)(y:A)(q:Eq _ _ x y)(Eq _ _ (f x) (f y)); 27 | intros; 28 | by EqElim _ _ _ q; 29 | refine refl; 30 | Qed; 31 | Freeze eq_resp_f; 32 | -------------------------------------------------------------------------------- /lib/fin.tt: -------------------------------------------------------------------------------- 1 | Load "basics.tt"; 2 | Load "lt.tt"; 3 | 4 | Data Fin : (n:Nat)* 5 | = fz : (k:_)(Fin (S k)) 6 | | fs : (k:_)(i:Fin k)(Fin (S k)); 7 | 8 | Match weaken : (n:_)(i:Fin n)->(Fin (S n)) = 9 | weaken _ (fz _) = fz _ 10 | | weaken _ (fs _ i) = fs _ (weaken _ i); 11 | 12 | Match fin2Nat : (n:_)(i:Fin n)->Nat = 13 | fin2Nat _ (fz _) = O 14 | | fin2Nat _ (fs _ i) = S (fin2Nat _ i); 15 | 16 | -------------------------------------------------------------------------------- /lib/list.tt: -------------------------------------------------------------------------------- 1 | Load "nat.tt"; 2 | 3 | Data List (A:*) : * 4 | = nil : List A 5 | | cons : (x:A)->(xs:List A)->(List A); -------------------------------------------------------------------------------- /lib/logic.tt: -------------------------------------------------------------------------------- 1 | Data And (A:*)(B:*) : * = and_intro : (a:A)(b:B)(And A B); 2 | 3 | Data Or (A:*)(B:*) : * 4 | = or_intro_l : (a:A)(Or A B) 5 | | or_intro_r : (b:B)(Or A B); 6 | 7 | Data Ex (A:*)(P:(a:A)*) : * = ex_intro : (x:A)(p:P x)(Ex A P); 8 | 9 | Data False : * = ; 10 | 11 | Data True : * = II : True ; 12 | 13 | not = [A:*](a:A)False; 14 | 15 | notElim = [A:*][p:not A][pp:A](p pp); 16 | 17 | Axiom classical:(P:*)(Or P (not P)); 18 | 19 | and_commutes : (A:*)(B:*)(p:And A B)(And B A); 20 | intros; 21 | induction p; 22 | intros; 23 | refine and_intro; 24 | fill b; 25 | fill a; 26 | Qed; 27 | Freeze and_commutes; 28 | 29 | or_commutes : (A:*)(B:*)(p:Or A B)(Or B A); 30 | intros; 31 | induction p; 32 | intros; 33 | refine or_intro_r; 34 | fill a; 35 | intros; 36 | refine or_intro_l; 37 | fill b; 38 | Qed; 39 | Freeze or_commutes; 40 | -------------------------------------------------------------------------------- /lib/lt.tt: -------------------------------------------------------------------------------- 1 | Load "basics.tt"; 2 | 3 | Data le : (m,n:Nat)* = 4 | leO : (n:_)(le O n) 5 | | leS : (m,n:_)(p:le m n)(le (S m) (S n)); 6 | 7 | Match leSuc : (m,n:Nat)(p:le m n)(le m (S n)) = 8 | leSuc _ _ (leO _) = leO _ 9 | | leSuc _ _ (leS _ _ p) = leS _ _ (leSuc _ _ p); 10 | 11 | Match leSym : (m:Nat)(le m m) = 12 | leSym O = leO _ 13 | | leSym (S k) = leS _ _ (leSym k); 14 | 15 | Match lePlus : (m,n:Nat)(le m (plus m n)) = 16 | lePlus O n = leO _ 17 | | lePlus (S k) n = leS _ _ (lePlus k n); 18 | 19 | Data Compare : (m,n:Nat)* = 20 | cmpLT : (k,m:Nat)(Compare m (plus m (S k))) 21 | | cmpEQ : (n:Nat)(Compare n n) 22 | | cmpGT : (k,n:Nat)(Compare (plus n (S k)) n); 23 | 24 | Match Partial compareAux : (m,n:Nat)(Compare m n)->(Compare (S m) (S n)) = 25 | compareAux _ _ (cmpLT k _) = cmpLT k _ 26 | | compareAux _ _ (cmpEQ n) = cmpEQ _ 27 | | compareAux _ _ (cmpGT k _) = cmpGT k _; 28 | 29 | Match compare : (m,n:Nat)(Compare m n) = 30 | compare O (S k) = cmpLT _ O 31 | | compare O O = cmpEQ _ 32 | | compare (S k) O = cmpGT _ O 33 | | compare (S x) (S y) = compareAux _ _ (compare x y); 34 | 35 | Match mkLTaux : (m,n:Nat)(Compare m n)->(Maybe (le m n)) = 36 | mkLTaux _ _ (cmpLT k m) = just _ (lePlus m (S k)) 37 | | mkLTaux _ _ (cmpEQ m) = just _ (leSym m) 38 | | mkLTaux _ _ (cmpGT k m) = nothing _; 39 | 40 | mkLT = [m,n:Nat](mkLTaux _ _ (compare m n)); 41 | 42 | isBounded : (n,min,max:Nat)(Maybe (And (le min n) (le n max))); 43 | intros; 44 | induction mkLT min n; 45 | refine nothing; 46 | intros; 47 | induction mkLT n max; 48 | refine nothing; 49 | intros; 50 | refine just; 51 | refine and_intro; 52 | refine a; 53 | refine a0; 54 | Qed; 55 | 56 | -------------------------------------------------------------------------------- /lib/nat.tt: -------------------------------------------------------------------------------- 1 | Load "eq.tt"; 2 | Load "logic.tt"; 3 | 4 | Data Nat:* = O:Nat | S:(k:Nat)Nat; 5 | 6 | Match plus : Nat->Nat->Nat = 7 | plus O y = y 8 | | plus (S k) y = S (plus k y); 9 | 10 | Match mult : Nat->Nat->Nat = 11 | mult O y = O 12 | | mult (S k) y = plus y (mult k y); 13 | 14 | simplifyO:(n:_)(Eq _ _ (plus O n) n); 15 | intros; 16 | refine refl; 17 | Qed; 18 | 19 | simplifyS:(m,n:_)(Eq _ _ (plus (S m) n) (S (plus m n))); 20 | intros; 21 | refine refl; 22 | Qed; 23 | 24 | eq_resp_S:(n,m:_)(q:Eq _ _ n m)(Eq _ _ (S n) (S m)); 25 | intros; 26 | fill (eq_resp_f _ _ S n m q); 27 | Qed; 28 | Freeze eq_resp_S; 29 | 30 | s_injective:(n,m:_)(q:Eq _ _ (S n) (S m))(Eq _ _ n m); 31 | intros; 32 | local unS:(m:Nat)Nat; 33 | intros; 34 | induction m0; 35 | fill n; 36 | intros; 37 | fill k; 38 | fill eq_resp_f _ _ unS _ _ q; 39 | Qed; 40 | Freeze s_injective; 41 | 42 | notO_S:(k:_)(not (Eq _ _ O (S k))); 43 | intros; 44 | compute; 45 | intro q; 46 | local dmotive : (x:Nat)(q:Eq _ _ O x)*; 47 | intros; 48 | induction x; 49 | fill True; 50 | intros; 51 | fill False; 52 | fill EqElim _ _ _ q dmotive II; 53 | Qed; 54 | Freeze notO_S; 55 | 56 | notn_S:(n:_)(not (Eq _ _ n (S n))); 57 | intro; 58 | induction n; 59 | fill notO_S O; 60 | intros; 61 | unfold not; 62 | intros; 63 | claim q:Eq _ _ k (S k); 64 | fill k_IH q; 65 | refine s_injective; 66 | fill a; 67 | Qed; 68 | Freeze notn_S; 69 | 70 | discriminate_Nat:(A,k:_)(q:Eq _ _ O (S k))A; 71 | intros; 72 | local false:False; 73 | fill notO_S k q; 74 | induction false; 75 | Qed; 76 | Freeze discriminate_Nat; 77 | 78 | plusnO:(n:_)(Eq _ _ (plus n O) n); 79 | intro; 80 | induction n; 81 | refine refl; 82 | intros; 83 | equiv Eq _ _ (S (plus k O)) (S k); 84 | refine eq_resp_S; 85 | fill k_IH; 86 | Qed; 87 | Freeze plusnO; 88 | 89 | plusnSm:(n,m:_)(Eq _ _ (plus n (S m)) (S (plus n m))); 90 | intros; 91 | induction n; 92 | refine refl; 93 | intros; 94 | refine eq_resp_S; 95 | fill k_IH; 96 | Qed; 97 | Freeze plusnSm; 98 | 99 | plus_comm:(n,m:_)(Eq _ _ (plus n m) (plus m n)); 100 | intros; 101 | induction n; 102 | refine sym; 103 | refine plusnO; 104 | intros; 105 | equiv Eq _ _ (S (plus k m)) (plus m (S k)); 106 | replace k_IH; 107 | refine sym; 108 | refine plusnSm; 109 | Qed; 110 | Freeze plus_comm; 111 | 112 | plus_assoc:(m,n,p:_)(Eq _ _ (plus m (plus n p)) (plus (plus m n) p)); 113 | intros; 114 | induction m; 115 | refine refl; 116 | intros; 117 | equiv Eq _ _ (S (plus k (plus n p))) (plus (S (plus k n)) p); 118 | replace k_IH; 119 | refine refl; 120 | Qed; 121 | Freeze plus_assoc; 122 | 123 | plus_eq_fst : (m,n,p:_)(q:Eq _ _ (plus p m) (plus p n))(Eq _ _ m n); 124 | intro m n p; 125 | induction p; 126 | intros; 127 | fill q; 128 | intros; 129 | refine k_IH; 130 | refine s_injective; 131 | refine q0; 132 | Qed; 133 | Freeze plus_eq_fst; 134 | 135 | plus_eq_fst_sym : (m,n,p:_)(q:Eq _ _ (plus m p) (plus n p))(Eq _ _ m n); 136 | intro m n p; 137 | replace plus_comm m p; 138 | replace plus_comm n p; 139 | intros; 140 | fill plus_eq_fst m n p q; 141 | Qed; 142 | Freeze plus_eq_fst_sym; 143 | 144 | multnO:(n:_)(Eq _ _ (mult n O) O); 145 | intro; 146 | induction n; 147 | refine refl; 148 | intros; 149 | equiv Eq _ _ (plus O (mult k O)) O; 150 | replace k_IH; 151 | refine refl; 152 | Qed; 153 | Freeze multnO; 154 | 155 | multnSm:(n,m:_)(Eq _ _ (mult n (S m)) (plus n (mult n m))); 156 | intro; 157 | induction n; 158 | intros; 159 | refine refl; 160 | intros; 161 | equiv Eq _ _ (S (plus m0 (mult k (S m0)))) 162 | (S (plus k (plus m0 (mult k m0)))); 163 | refine eq_resp_S; 164 | replace (k_IH m0); 165 | generalise mult k m0; 166 | intros; 167 | replace (plus_comm m0 x); 168 | replace (plus_assoc k x m0); 169 | replace (plus_comm m0 (plus k x)); 170 | refine refl; 171 | Qed; 172 | Freeze multnSm; 173 | 174 | -------------------------------------------------------------------------------- /lib/vect.tt: -------------------------------------------------------------------------------- 1 | Load "basics.tt"; 2 | Load "fin.tt"; 3 | 4 | Data Vect (A:*):(n:Nat)* 5 | = vnil:Vect A O 6 | | vcons:(k:Nat)(x:A)(xs:Vect A k)Vect A (S k); 7 | 8 | Match lookup : (A:*)(n:Nat)(i:Fin n)(xs:Vect A n)A = 9 | lookup _ _ (fz _) (vcons _ _ x xs) = x 10 | | lookup _ _ (fs _ i) (vcons _ _ x xs) = lookup _ _ i xs; 11 | 12 | testvect = vcons _ _ O (vcons _ _ (S O) (vcons _ _ (S (S O)) (vnil Nat))); 13 | testfin = fs _ (fz (S O)); 14 | -------------------------------------------------------------------------------- /papers/ivor/Makefile: -------------------------------------------------------------------------------- 1 | all: ivor.pdf 2 | 3 | SOURCES = ivor.tex intro.tex corett.tex tactics.tex code.tex \ 4 | examples.tex conclusions.tex ../bib/literature.bib 5 | 6 | ivor.pdf: $(SOURCES) 7 | pdflatex ivor 8 | -bibtex ivor 9 | -pdflatex ivor 10 | 11 | ivor.ps: ivor.dvi 12 | dvips -o ivor.ps ivor 13 | 14 | ivor.dvi: $(SOURCES) 15 | -latex ivor 16 | -bibtex ivor 17 | -latex ivor 18 | -latex ivor 19 | 20 | package: ifl06.tar 21 | 22 | ifl06.tar: ivor.dvi ivor.ps ivor.pdf .PHONY 23 | mkdir -p ifl06 24 | cp ../bib/*.bib *.tex *.ltx *.bib *.ps *.pdf *.dvi *.cls ifl06 25 | tar cvf ivor06.tar ifl06 26 | 27 | .PHONY: 28 | -------------------------------------------------------------------------------- /papers/ivor/code.tex: -------------------------------------------------------------------------------- 1 | \section{Haskell Code} 2 | 3 | This appendix contains some of the more important definitions from the 4 | logic theorem prover and functional language implementation. The 5 | complete code for both examples is available from 6 | \url{http://www.dcs.st-and.ac.uk/~eb/Ivor}; the code presented here 7 | illustrates the building of complex tactics with \Ivor{}. 8 | 9 | \subsection{Propositional Logic} 10 | 11 | Two domain specific tactics are needed; firstly 12 | Secondly, we need a tactic to prove a contradiction as discussed in 13 | section \ref{example1}: 14 | 15 | \begin{verbatim} 16 | > contradiction :: String -> String -> Tactic 17 | > contradiction x y = claim (name "false") "False" >+> 18 | > induction "false" >+> 19 | > (try (fill $ x ++ " " ++ y) 20 | > idTac 21 | > (fill $ y ++ " " ++ x)) 22 | \end{verbatim} 23 | 24 | \subsection{\Funl{}} 25 | 26 | \label{funlapp} 27 | 28 | When building a function definition, we prove a \hdecl{theorem} of the 29 | appropriate type. Then the \hdecl{buildTerm} tactic traverses the 30 | structure of the raw term, constructing a proof of the 31 | theorem. -------------------------------------------------------------------------------- /papers/ivor/conclusions.tex: -------------------------------------------------------------------------------- 1 | \section{Related Work} 2 | 3 | The ability to extend a theorem prover with user defined tactics has 4 | its roots in Robin Milner's LCF~\cite{lcf-milner}. This introduced the 5 | programming language ML to allow users to write tactics; we follow the 6 | LCF approach in exposing the tactic engine as an API. 7 | %However, unlike 8 | %other systems, we have not treated the theorem prover as an end in 9 | %itself, but intend to expose the technology to any Haskell application 10 | %which may need it. 11 | The implementation of \Ivor{} is based on the 12 | presentation of \Oleg{} in Conor McBride's 13 | thesis~\cite{mcbride-thesis}. We use implementation 14 | techniques from \cite{not-a-number} for dealing with variables and 15 | renaming. 16 | 17 | The core language of \Epigram{}~\cite{view-left,epireloaded} is 18 | similar to $\source$, with extensions for observational 19 | equality. \Epigram{} is a dependently typed functional programming 20 | language, where types can be predicated on arbitrary values so that 21 | types can be read as precise specifications. 22 | Another recent language which shares the aim of begin theorem proving 23 | technology closer to programers is Sheard's 24 | $\Omega$mega~\cite{sheard-langfuture}. While \Ivor{} emphasises 25 | interactive theorem proving, $\Omega$mega emphasises programming but 26 | nevertheless allows more precise types to be given to programs through 27 | Generalised Algebraic Data Types~\cite{gadts} and extensible 28 | kinds. 29 | 30 | Other theorem provers such as \Coq{}~\cite{coq-manual}, 31 | \Agda{}~\cite{agda} and Isabelle~\cite{isabelle} have varying degrees 32 | of extensibility. 33 | %The interface design largely follows that of 34 | %\Coq{}. 35 | \Coq{} includes a high level domain specific language for 36 | combining tactics and creating new tactics, along the lines of the 37 | tactic combinators presented in section \ref{combinators}. This 38 | language is ideal for many purposes, such as our \hdecl{contradiction} 39 | tactic, but more complex examples such as \hdecl{buildTerm} would 40 | require extending \Coq{} itself. Using a 41 | DSEL~\cite{hudak-edsl} as provided by \Ivor{} gives complete 42 | flexibility in the construction of tactics, and allows a close 43 | relationship between the tactics and the structures on which they 44 | operate (e.g. \hdecl{Raw}). 45 | %In future, it may 46 | %be worth exploring automatic translation between \Ivor{} and other 47 | %theorem provers. 48 | 49 | Isabelle~\cite{isabelle} is a 50 | generic theorem prover, in that it includes a large body of object 51 | logics and a meta-language for defining new logics. It includes a 52 | typed, extensible tactic language, and can be called from ML programs, 53 | but unlike \Ivor{} is not based on a dependent type theory. 54 | There is therefore no \remph{proof term} associated with an Isabelle 55 | proof --- the proof term gives a derivation tree for the 56 | proof, allowing easy and independent rechecking without referring to 57 | the tactics used to build the proof. 58 | 59 | The implementation of \Funl{} allows a theorem prover to be attached 60 | to the language in a straightforward way, using \Ivor{}'s tactics 61 | directly. This would be a possible method of attaching a theorem 62 | prover to a more full featured programming language such as the 63 | Sparkle~\cite{sparkle} prover for Clean~\cite{clean}. Implementing a 64 | full language in this way would require some extra work to deal 65 | with general recursion and partial definitions (in particular, dealing 66 | with $\perp$ as a possible value), but the general method remains the same. 67 | 68 | \section{Conclusions and Further Work} 69 | 70 | We have seen an overview of the \Ivor{} library, including the term 71 | and tactic language. By exposing the tactic API and 72 | providing an interface for term construction and evaluation, we are 73 | able to embed theorem proving technology in a Haskell 74 | application. This in itself is not a new idea, having first been seen 75 | as far back as the LCF~\cite{lcf-milner} prover --- however, the 76 | theorem proving technology is not an end in itself, but a 77 | mechanism for constructing domain specific tools such as the 78 | propositional logic theorem prover in section \ref{example1} and the 79 | programming language with built in equational reasoning support in 80 | section \ref{example2}. 81 | 82 | The library includes several features we have not been able to discuss 83 | here, e.g. dependently typed pattern matching~\cite{coquand-pm}, which 84 | gives a better notation for \remph{programming} as well as proof. 85 | There is experimental support for multi-stage programming with 86 | dependent types, exploited in~\cite{dtpmsp-gpce}. The term language 87 | can be extended with primitive types and operations, e.g. integers and 88 | strings with associated arithmetic and string manipulation 89 | operators. Such features would be essential in a representation of a 90 | real programming language. In this paper, we have stated that 91 | $\source$ is strongly normalising, with no general recursion allowed, 92 | but again in the representation of a real programming language general 93 | recursion may be desirable --- however, this means that correctness 94 | proofs can no longer be total. The library can optionally allow 95 | general recursive definitions, but such definitions cannot be reduced 96 | by the typechecker. Finally, a command driven interface is available, 97 | which can be accessed as a Haskell API or used from a command line 98 | driver program, and allows user directed proof scripts in the style of 99 | other proof assistants. These and other features are fully documented 100 | on the web 101 | site\footnote{\url{http://www.cs.st-andrews.ac.uk/~eb/Ivor/}}. 102 | 103 | %% \subsection{Further Work} 104 | 105 | Development of the library has been driven by the requirements of 106 | our research into Hume~\cite{Hume-GPCE}, a resource aware functional 107 | language. We are investigating the use of dependent types in 108 | representing and verifying resource bounded functional 109 | programs~\cite{dt-framework}. 110 | For this, automatic generation of 111 | injectivity and disjointness lemmas for constructors will be 112 | essential~\cite{concon}. 113 | Future versions will include 114 | optimisations from \cite{brady-thesis} and some support for compiling 115 | $\source$ terms; this would not only improve the efficiency of the 116 | library (and in particular its use for evaluating certified code) 117 | but also facilitate the use of \Ivor{} in a real language 118 | implementation. Finally, an implementation of coinductive 119 | types~\cite{coinductive} is likely to be very useful; currently it can 120 | be achieved by implementing recursive functions which do not reduce at 121 | the type level, but a complete implementation with criteria for 122 | checking productivity would be valuable for modelling streams in Hume. 123 | -------------------------------------------------------------------------------- /papers/ivor/dtp.bib: -------------------------------------------------------------------------------- 1 | @phdthesis{ brady-thesis, 2 | author = {Edwin Brady}, 3 | title = {Practical Implementation of a Dependently Typed Functional Programming Language}, 4 | year = 2005, 5 | school = {University of Durham} 6 | } 7 | 8 | @article{view-left, 9 | journal = {Journal of Functional Programming}, 10 | number = {1}, 11 | volume = {14}, 12 | title = {The View From The Left}, 13 | year = {2004}, 14 | author = {Conor McBride and James McKinna}, 15 | pages = {69--111} 16 | } 17 | 18 | @misc{epigram-afp, 19 | author = {Conor McBride}, 20 | title = {Epigram: Practical Programming with Dependent Types}, 21 | year = {2004}, 22 | howpublished = {Lecture Notes, International Summer School on Advanced Functional Programming} 23 | } 24 | 25 | @misc{coq-manual, 26 | howpublished = {\verb+http://coq.inria.fr/+}, 27 | title = {The {Coq} Proof Assistant --- Reference Manual}, 28 | year = {2004}, 29 | author = {{Coq Development Team}} 30 | } 31 | 32 | @inproceedings{extraction-coq, 33 | title = {A New Extraction for {Coq}}, 34 | year = {2002}, 35 | booktitle = {Types for proofs and programs}, 36 | editor = {Herman Geuvers and Freek Wiedijk}, 37 | publisher = {Springer}, 38 | author = {Pierre Letouzey}, 39 | series = {LNCS} 40 | } 41 | 42 | @techreport{lego-manual, 43 | title = {\textsc{Lego} Proof Development System: User's Manual}, 44 | year = {1992}, 45 | institution = {Department of Computer Science, University of Edinburgh}, 46 | author = {Zhaohui Luo and Robert Pollack} 47 | } 48 | 49 | @book{luo94, 50 | title = {Computation and Reasoning -- A Type Theory for Computer Science}, 51 | year = {1994}, 52 | publisher = {OUP}, 53 | author = {Zhaohui Luo}, 54 | series = {International Series of Monographs on Computer Science} 55 | } 56 | 57 | @phdthesis{goguen-thesis, 58 | school = {University of Edinburgh}, 59 | title = {A Typed Operational Semantics for Type Theory}, 60 | year = {1994}, 61 | author = {Healfdene Goguen} 62 | } 63 | 64 | @phdthesis{mcbride-thesis, 65 | month = {May}, 66 | school = {University of Edinburgh}, 67 | title = {Dependently Typed Functional Programs and their proofs}, 68 | year = {2000}, 69 | author = {Conor McBride} 70 | } 71 | 72 | @misc{mckinnabrady-phase, 73 | title = {Phase Distinctions in the Compilation of {Epigram}}, 74 | year = 2005, 75 | author = {James McKinna and Edwin Brady}, 76 | note = {Draft} 77 | } 78 | 79 | @article{pugh-omega, 80 | title = "The {Omega} {Test}: a fast and practical integer programming algorithm for dependence analysis", 81 | author = "William Pugh", 82 | journal = "Communication of the ACM", 83 | year = 1992, 84 | pages = {102--114} 85 | } 86 | 87 | @Article{RegionTypes, 88 | refkey = "C1753", 89 | title = "Region-Based Memory Management", 90 | author = "M. Tofte and J.-P. Talpin", 91 | pages = "109--176", 92 | journal = "Information and Computation", 93 | month = "1~" # feb, 94 | year = "1997", 95 | volume = "132", 96 | number = "2" 97 | } 98 | 99 | @phdthesis{ pedro-thesis, 100 | author = {Pedro Vasconcelos}, 101 | title = {Space Cost Modelling for Concurrent Resource Sensitive Systems}, 102 | year = 2006, 103 | school = {University of St Andrews} 104 | } 105 | 106 | @book{curry-feys, 107 | title = {Combinatory Logic, volume 1}, 108 | year = {1958}, 109 | publisher = {North Holland}, 110 | author = {Haskell B. Curry and Robert Feys} 111 | } 112 | @inproceedings{howard, 113 | title = {The formulae-as-types notion of construction}, 114 | year = {1980}, 115 | booktitle = {To H.B.Curry: Essays on combinatory logic, lambda calculus and formalism}, 116 | editor = {Jonathan P. Seldin and J. Roger Hindley}, 117 | publisher = {Academic Press}, 118 | author = {William A. Howard}, 119 | note = {A reprint of an unpublished manuscript from 1969} 120 | } 121 | 122 | @misc{ydtm, 123 | author = {Thorsten Altenkirch and Conor McBride and James McKinna}, 124 | title = {Why Dependent Types Matter}, 125 | note = {Submitted for publication}, 126 | year = 2005} 127 | 128 | @inproceedings{regular-types, 129 | author = { Peter Morris and Conor McBride and Thorsten Altenkirch}, 130 | title = {Exploring The Regular Tree Types}, 131 | year = 2005, 132 | booktitle = {Types for Proofs and Programs 2004} 133 | } 134 | 135 | @inproceedings{xi_arraybounds, 136 | author = "Hongwei Xi and Frank Pfenning", 137 | title = {Eliminating Array Bound Checking through Dependent Types}, 138 | booktitle = "Proceedings of ACM SIGPLAN Conference on Programming Language Design and Implementation", 139 | year = 1998, 140 | month = "June", 141 | address = "Montreal", 142 | pages = "249--257", 143 | } 144 | 145 | @misc{interp-cayenne, 146 | url = {\verb+http://www.cs.chalmers.se/~augustss/cayenne/+}, 147 | title = {An exercise in dependent types: A well-typed interpreter}, 148 | year = {1999}, 149 | author = {Lennart Augustsson and Magnus Carlsson} 150 | } 151 | 152 | -------------------------------------------------------------------------------- /papers/ivor/embounded.bib: -------------------------------------------------------------------------------- 1 | @Book{BurnsWellings, 2 | author = {A. Burns and A.J. Wellings}, 3 | title = {{Real-Time Systems and Programming Languages (Third Edition)}}, 4 | publisher = {Addison Wesley Longman}, 5 | year = 2001 6 | } 7 | 8 | @Book{Ganssle:Book, 9 | author = {J.G. Ganssle}, 10 | title = {{The Art of Programming Embedded Systems}}, 11 | publisher = {Academic Press}, 12 | year = {1992}, 13 | note = {ISBN 0-12274880-8}, 14 | } 15 | 16 | @Book{Ganssle:Design, 17 | author = {J.G. Ganssle}, 18 | title = {{The Art of Designing Embedded Systems}}, 19 | publisher = {Newnes}, 20 | year = {1999}, 21 | note = {ISBN 0-75069869-1}, 22 | } 23 | 24 | @article{Ganssle:OnLanguage, 25 | author = {J.G. Ganssle}, 26 | title = {{On Language}}, 27 | journal ={{Electronic Eng. Times}}, 28 | month = "March", 29 | year = {2003} 30 | } 31 | 32 | @article{Ganssle:MicroMinis, 33 | author = {J.G. Ganssle}, 34 | title = {{Micro Minis}}, 35 | journal ={{Embedded Systems Programming}}, 36 | month = "March", 37 | year = {2003} 38 | } 39 | 40 | @article{Barr:EmbeddedSystProg, 41 | author = {M. Barr}, 42 | title = {{The Long Winter}}, 43 | journal ={{Electronic Systems Programming}}, 44 | month = "January", 45 | year = {2003} 46 | } 47 | 48 | @unpublished{Ganssle:WebSite, 49 | author = {The Ganssle Group}, 50 | title = {{Perfecting the Art of Building Embedded Systems}}, 51 | month = "May", 52 | year = 2003, 53 | note = {\url{http://www.ganssle.com}} 54 | } 55 | 56 | @article{Schoitsch, 57 | author = {E. Schoitsch}, 58 | title = {{Embedded Systems -- Introduction}}, 59 | journal = {ERCIM News}, 60 | pages = {10--11}, 61 | volume = 52, 62 | month = jan, 63 | year = 2003 64 | } 65 | 66 | @article{UMLESE, 67 | author = {C. Holland}, 68 | title = {{Telelogic Second Generation Tools}}, 69 | journal = {Embedded Systems Europe}, 70 | month = aug, 71 | year = 2002 72 | } 73 | 74 | @article{DSL, 75 | author = {P. Hudak}, 76 | title = {{Building Domain-Specific Embedded Languages}}, 77 | journal = {ACM Computing Surveys}, 78 | volume = 28, 79 | number = 4, 80 | month = dec, 81 | year = 1996 82 | } 83 | 84 | @article{DSL:devicedriver, 85 | author = {C. Conway}, 86 | title = {{A Domain-Specific Language for Device Drivers}}, 87 | journal = {ACM Computing Surveys}, 88 | volume = 28, 89 | number = 4, 90 | month = dec, 91 | year = 1996 92 | } 93 | 94 | @unpublished{Klocwork, 95 | author = {Klocwork}, 96 | year = 2003, 97 | } 98 | 99 | @inproceedings{Bernat1, 100 | author = {Bernat, G. and Burns, A. and Wellings, A.}, 101 | title = {{Portable Worst-Case Execution Time Analysis Using Java Byte Code}}, 102 | booktitle = {Proc. 12th Euromicro International Conf. on 103 | Real-Time Systems}, 104 | address = {Stockholm}, 105 | year = 2000, 106 | month = {June} 107 | } 108 | 109 | @inproceedings{Bernat2, 110 | author = {Bernat, G. and Colin, A. and Petters, S. M.}, 111 | title = {{WCET Analysis of Probabilistic Hard Real-Time Systems}}, 112 | booktitle = {Proc. 23rd IEEE Real-Time Systems Symposium (RTSS 2002)}, 113 | address = {Austin, TX. (USA)}, 114 | year = 2002, 115 | month = {December} 116 | } 117 | 118 | @inproceedings{SizedRecursion, 119 | author = {P. Vasconcelos and K. Hammond}, 120 | title = {{Inferring Costs for Recursive, Polymorphic and Higher-Order Functions}}, 121 | booktitle = {Proc. Implementation of Functional Languages (IFL 2003)}, 122 | publisher = {Springer-Verlag}, 123 | year = {2003} 124 | } 125 | 126 | @inproceedings{HAM, 127 | author = {K. Hammond and G.J. Michaelson}, 128 | title = {{An Abstract Machine Implementation for Hume}}, 129 | booktitle = {submitted to Intl. Conf. on Compilers, Architectures and Synthesis for Embedded Systems (CASES~03)}, 130 | year = {2003} 131 | } 132 | 133 | @unpublished{EmbeddedSystSurvey, 134 | author = {Embedded.com}, 135 | title = {Poll: What Language do you use for embedded work?}, 136 | note = {\url{http://www.embedded.com/pollArchive/?surveyno=2228}}, 137 | year = 2003, 138 | } 139 | 140 | @inproceedings{ESP, 141 | author = {S. Kumar and K. Li}, 142 | title = {Automatic Memory Management for Programmable Devices}, 143 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 144 | month = jun, 145 | year = 2002, 146 | pages = {245--255}, 147 | } 148 | 149 | @inproceedings{RegionJava, 150 | author = {F. Qian and L. Hendrie}, 151 | title = {An Adaptive Region-Based Allocator for Java}, 152 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 153 | month = jun, 154 | year = 2002, 155 | pages = {233--244}, 156 | } 157 | 158 | @inproceedings{RegionsRTSJ, 159 | author = {M. Deters and R.K. Cytron}, 160 | title = {Automated Discovery of Scoped Memory Regions for Real-Time Java}, 161 | booktitle = {Proc. ACM Intl. Symp. on Memory Management, Berlin, Germany}, 162 | month = jun, 163 | year = 2002, 164 | pages = {132--141}, 165 | } 166 | 167 | @inproceedings{RTGC, 168 | author = {S. Nettles and J. O'Toole}, 169 | title = {{Real-Time Replication Garbage Collection}}, 170 | booktitle = {ACM Sigplan Notices}, 171 | volume = 28, 172 | number = 6, 173 | month = jun, 174 | year = 1993, 175 | pages = {217--226}, 176 | } 177 | 178 | @inproceedings{Blelloch, 179 | author = {P. Cheng and G. Blelloch}, 180 | title = {{A Parallel, Real-Time Garbage Collector}}, 181 | booktitle = {ACM Sigplan Notices}, 182 | volume = 36, 183 | number = 5, 184 | month = may, 185 | year = 2001, 186 | pages = {125--136}, 187 | } 188 | 189 | @inproceedings{RegionsGC, 190 | author = {N. Hallenberg and M. Elsman and M. Tofte}, 191 | title = {{Combining Region Inference and Garbage Collection}}, 192 | booktitle = {Proc. ACM Conf. on Prog. Lang. Design and Impl. (PLDI~'02), Berlin, Germany}, 193 | month = jun, 194 | year = 2002, 195 | } 196 | 197 | 198 | @article{RTSJIssues, 199 | author = {K. Nilsen}, 200 | title = {{Issues in the Design and Implementation of Real-Time Java}}, 201 | booktitle = {Java Developers' Journal}, 202 | volume = 1, 203 | number = 1, 204 | year = 1996, 205 | pages = 44 206 | } 207 | 208 | 209 | 210 | @unpublished{CyCab, 211 | author = {RoboSoft SA}, 212 | title = {{CyCab Outdoor Vehicle, for Road and/or All-terrain Use}}, 213 | note = {\url{http://www.robosoft.fr/SHEET/01Mobil/2001Cycab/CyCab.html}}, 214 | year = 2003, 215 | month = may 216 | } 217 | 218 | 219 | @unpublished{Joyner, 220 | author = {I. Joyner}, 221 | title = {{C++??: a Critique of C++, 3rd Edition}}, 222 | year = 1996, 223 | institution = {Unisys - ACUS, Australia}, 224 | note = {\url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/cppcritique.ps}} 225 | } 226 | 227 | @unpublished{Sakkinen, 228 | author = {M. Sakkinen}, 229 | title = {{The Darker Side of C++ Revisited}}, 230 | year = 1993, 231 | institution = {Univerity of Jyv\"{a}skyl\"{a}}, 232 | note = {Technical Report 1993-I-13, \url{http://www.kcl.ac.uk/kis/support/cit//fortran/cpp/dark-cpl.ps}}, 233 | } 234 | 235 | @TechReport{BCLogicDelvb, 236 | author = {Hans-Wolfgang Loidl and Olha Shkaravska and Lennart Beringer}, 237 | title = {Preliminary investigations into a bytecode logic for Grail}, 238 | institution = {Institut f{\"u}r Informatik, LMU University and LFCS, Edinburgh University}, 239 | year = 2003, 240 | month = jan, 241 | note = {Project Deliverable} 242 | } 243 | 244 | @InProceedings{HWLtofillin, 245 | author = {Lennart Beringer and Kenneth MacKenzie and Ian Stark}, 246 | title = {Grail: a functional form for imperative mobile code}, 247 | booktitle = {FGC03 --- Workshop on Foundations of Global Computing}, 248 | year = 2003, 249 | address = {28--29 June 2003, Eindhoven, The Netherlands}, 250 | note = {Submitted} 251 | } 252 | 253 | 254 | @inproceedings{AbsInt:EmsoftTahoe, 255 | author = "C. Ferdinand and R. Heckmann and M. Langenbach and 256 | F. Martin and M. Schmidt and 257 | H. Theiling and S. Thesing and R. Wilhelm", 258 | title = {Reliable and Precise {WCET} Determination for a Real-Life Processor}, 259 | booktitle = {Proc. EMSOFT 2001, First Workshop on Embedded Software}, 260 | publisher = {Springer-Verlag}, 261 | series = {LNCS}, 262 | volume = 2211, 263 | pages = {469--485}, 264 | year = 2001 265 | } 266 | 267 | 268 | @inproceedings{AbsInt:Avionics, 269 | author = "S. Thesing and J. Souyris and R. Heckmann and 270 | F. Randimbivololona and M. Langenbach and 271 | R. Wilhelm and C. Ferdinand", 272 | title = {An Abstract Interpretation-Based Timing Validation 273 | of Hard Real-Time Avionics Software}, 274 | booktitle = {Proc. 2003 Intl. Conf. 275 | on Dependable Systems and Networks (DSN 2003)}, 276 | pages = {625--632}, 277 | year = 2003 278 | } 279 | 280 | -------------------------------------------------------------------------------- /papers/ivor/intro.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | %\Ivor{} is a tactic-based theorem proving engine with a Haskell 4 | %API. Unlike other systems such as \Coq{}~\cite{coq-manual} and 5 | %Agda~\cite{agda}, the tactic engine is primarily intended to be used 6 | %by programs, rather than a human operator. 7 | 8 | Type theory based theorem provers such as \Coq{}~\cite{coq-manual} and 9 | \Agda{}~\cite{agda} have been used as tools for verification of programs 10 | (e.g.~\cite{leroy-compiler,why-tool,mckinna-expr}), extraction of 11 | correct programs from proofs (e.g.~\cite{extraction-coq}) 12 | and formal proofs of mathematical properties 13 | (e.g.~\cite{fta,four-colour}). However, these tools are designed with a 14 | human operator in mind; the interface is textual which makes it 15 | difficult for an external program to interact with them. 16 | In contrast, the \Ivor{} library is designed to provide an 17 | implementation of dependent type theory (i.e. dependently typed 18 | $\lambda$-calculus) and tactics for proof and 19 | program development to a Haskell application programmer, via a stable, 20 | well-documented and lightweight (as far as possible) API. The goal is 21 | to allow: i) easy embedding of theorem proving tools in a Haskell 22 | application; and ii) easy extension of the theorem prover with 23 | \remph{domain specific} tactics, via a domain specific embedded 24 | language (DSEL) for tactic construction. 25 | 26 | %% \Coq{} 27 | %% provides an extraction mechanism~\cite{extraction-coq} which generates 28 | %% ML or Haskell code from a proof term, but this does not allow the easy 29 | %% \remph{construction} of proof terms by an external tool. It is also 30 | %% extensible to some extent, for example using a domain specific 31 | %% language for creating user tactics, but the result is difficult to 32 | %% embed in an external program. 33 | 34 | %More 35 | %recently, dependent types have been incorporated into programming 36 | %languages such as Cayenne~\cite{cayenne-icfp}, DML~\cite{xi-thesis} and 37 | %\Epigram{}~\cite{view-left,epigram-afp}. 38 | 39 | 40 | %% have been used for several 41 | %% large practical applications, including correctness proofs for a 42 | %% compiler~\cite{leroy-compiler} and a computer assisted proof of the 43 | %% four colour theorem~\cite{four-colour}. 44 | 45 | \subsection{Motivating Examples} 46 | 47 | Many situations can benefit from a dependently typed proof and 48 | programming framework accessible as a library from a Haskell program. 49 | For each of these, by using an implementation of a well understood 50 | type theory, we can be confident that the underlying framework is 51 | sound. 52 | 53 | %% --- provided of course that the implementation itself is correct. 54 | %% Implementing 55 | %% eliminates the need to prove that a language and proof system are consistent with 56 | %% each other or that a special purpose proof framework is sound. 57 | 58 | \begin{description} 59 | \item[Programming Languages] 60 | Dependent type theory is a possible internal representation for a 61 | functional programming language. 62 | %The core language of the Glasgow 63 | %Haskell Compiler is \SystemF{}~\cite{core} --- dependent type theory 64 | %generalises this by allowing types to be parametrised over values. 65 | Correctness 66 | properties of programs in purely functional languages can be proven by 67 | equational reasoning, 68 | e.g. with Sparkle~\cite{sparkle} for the Clean language~\cite{clean}, or 69 | Cover~\cite{cover} for translating Haskell into 70 | \Agda{}~\cite{agda}. However these tools 71 | separate the language implementation from the theorem prover --- every 72 | language feature must be translated into the theorem prover's 73 | representation, and any time the language implementation is changed, 74 | this translation must also be changed. 75 | In section 76 | \ref{example2}, we will see how \Ivor{} can be used to implement a 77 | language with a built-in theorem prover, with a common representation 78 | for both. 79 | 80 | \item[Verified DSL Implementation] 81 | 82 | We have previously implementated a verified domain specific 83 | language~\cite{dtpmsp-gpce} with \Ivor{}. The abstract syntax tree of 84 | a program is a dependent data structure, and the type system 85 | guarantees that invariant properties of the program are maintained 86 | during evaluation. Using staging annotations~\cite{multi-taha}, such 87 | an interpreter can be specialised to a translator. We are continuing 88 | to explore these techniques in the context of resource aware 89 | programming~\cite{dt-framework}. 90 | 91 | \item[Formal Systems] 92 | 93 | A formal system can be modelled in dependent type theory, and 94 | derivations within the system can be constructed and checked. 95 | A simple example is propositional logic --- the connectives 96 | $\land$, $\lor$ and $\to$ are represented as types, and a theorem 97 | prover is used to prove logical formulae. Having an implementation of 98 | type theory and an interactive theorem prover accessible as an API 99 | makes it easy to write tools for working in a formal system, whether 100 | for educational or practical purposes. In section \ref{example1}, I 101 | will give details of an implementation of propositional logic. 102 | 103 | \end{description} 104 | 105 | In general, the library can be used wherever formally certified code 106 | is needed --- evaluation of dependently typed \Ivor{} programs is 107 | possible from Haskell programs and the results can be inspected 108 | easily. Domain specific tactics are often required; e.g. an 109 | implementation of a programming language with subtyping may require a 110 | tactic for inserting coercions, or a computer arithmetic system may 111 | require an implementation of Pugh's Omega decision 112 | procedure~\cite{pugh-omega}. \Ivor{}'s API is designed to make 113 | implementation of such tactics as easy as possible. 114 | 115 | In \Ivor{}'s dependent type system, types may be predicated on 116 | arbitrary values. Programs and properties can be 117 | expressed within the same self-contained system --- properties are 118 | proved by construction, at the same time as the program is 119 | written. The tactic language can thus be used not only for 120 | constructing proofs but also for interactive program development. 121 | 122 | %\subsection{Why Do We Need Another Theorem Prover?} 123 | 124 | %Relationship to e.g. \Coq{}. 125 | -------------------------------------------------------------------------------- /papers/ivor/ivor.tex: -------------------------------------------------------------------------------- 1 | %\documentclass{article} 2 | \documentclass[orivec,dvips,10pt]{llncs} 3 | 4 | \usepackage{epsfig} 5 | \usepackage{path} 6 | \usepackage{url} 7 | \usepackage{amsmath,amssymb} 8 | 9 | \newenvironment{template}{\sffamily} 10 | 11 | \usepackage{graphics,epsfig} 12 | \usepackage{stmaryrd} 13 | 14 | \input{macros.ltx} 15 | \input{library.ltx} 16 | 17 | \NatPackage 18 | 19 | \newcommand{\Ivor}{\textsc{Ivor}} 20 | \newcommand{\Funl}{\textsc{Funl}} 21 | \newcommand{\Agda}{\textsc{Agda}} 22 | 23 | \newcommand{\mysubsubsection}[1]{ 24 | \noindent 25 | \textbf{#1} 26 | } 27 | \newcommand{\hdecl}[1]{\texttt{#1}} 28 | 29 | \begin{document} 30 | 31 | \title{\Ivor{}, a Proof Engine} 32 | \author{Edwin Brady} 33 | 34 | \institute{School of Computer Science, \\ 35 | University of St Andrews, St Andrews, Scotland. \\ \texttt{Email: eb@cs.st-andrews.ac.uk}.\\ 36 | \texttt{Tel: +44-1334-463253}, \texttt{Fax: +44-1334-463278} \vspace{0.1in} 37 | } 38 | 39 | \maketitle 40 | 41 | \begin{abstract} 42 | Dependent type theory has several practical applications in the fields 43 | of theorem proving, program verification and programming language 44 | design. \Ivor{} is a Haskell library designed to allow easy extending 45 | and embedding of a type theory based theorem prover in a Haskell 46 | application. In this paper, I give an overview of the library and show 47 | how it can be used to embed theorem proving technology in an 48 | implementation of a simple functional programming language; by using 49 | type theory as a core representation, we can construct and evaluate 50 | terms and prove correctness properties of those terms within the 51 | \remph{same} framework, ensuring consistency of the implementation and 52 | the theorem prover. 53 | 54 | \end{abstract} 55 | 56 | \input{intro} 57 | 58 | \input{corett} 59 | 60 | %\input{usage} 61 | 62 | \input{tactics} 63 | 64 | \input{examples} 65 | 66 | \input{conclusions} 67 | 68 | \section*{Acknowledgements} 69 | 70 | My thanks to Kevin Hammond and James McKinna for their comments on an 71 | earlier draft of this paper, and to the anonymous reviewers for their 72 | helpful comments. 73 | This work is generously supported by EPSRC grant EP/C001346/1. 74 | 75 | \bibliographystyle{abbrv} 76 | \begin{small} 77 | \bibliography{../bib/literature.bib} 78 | 79 | %\appendix 80 | 81 | %\input{code} 82 | 83 | \end{small} 84 | \end{document} 85 | -------------------------------------------------------------------------------- /papers/tutorial/Makefile: -------------------------------------------------------------------------------- 1 | all: tutorial.pdf 2 | 3 | SOURCES = tutorial.tex introduction.tex programming.tex theoremproving.tex \ 4 | hslibrary.tex 5 | 6 | tutorial.pdf: $(SOURCES) 7 | pdflatex tutorial 8 | -bibtex tutorial 9 | -pdflatex tutorial 10 | 11 | tutorial.ps: tutorial.dvi 12 | dvips -o tutorial.ps tutorial 13 | 14 | tutorial.dvi: $(SOURCES) 15 | -latex tutorial 16 | -bibtex tutorial 17 | -latex tutorial 18 | -latex tutorial 19 | 20 | .PHONY: 21 | -------------------------------------------------------------------------------- /papers/tutorial/hslibrary.tex: -------------------------------------------------------------------------------- 1 | \section{Haskell Library} 2 | 3 | % Shell, loading files 4 | % Terms, types and data structures 5 | % Adding definitions, pattern matching 6 | % Theorem proving 7 | % Defining tactics 8 | 9 | -------------------------------------------------------------------------------- /papers/tutorial/introduction.tex: -------------------------------------------------------------------------------- 1 | \section{Introduction} 2 | 3 | \Ivor{}~\cite{ivor} is a dependently typed theorem proving library for 4 | Haskell. -------------------------------------------------------------------------------- /papers/tutorial/programming.tex: -------------------------------------------------------------------------------- 1 | \section{Programming in $\source$} 2 | 3 | % Types, definitions 4 | % data structures, pattern matching, well founded definitions 5 | % parameters, indices, inductive families 6 | 7 | -------------------------------------------------------------------------------- /papers/tutorial/theoremproving.tex: -------------------------------------------------------------------------------- 1 | \section{Theorem Proving} 2 | 3 | % Elimination rules 4 | % Basic tactics 5 | 6 | -------------------------------------------------------------------------------- /papers/tutorial/tutorial.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | %\documentclass[orivec,dvips,10pt]{llncs} 3 | 4 | \usepackage{epsfig} 5 | \usepackage{path} 6 | \usepackage{url} 7 | \usepackage{amsmath,amssymb} 8 | 9 | \newenvironment{template}{\sffamily} 10 | 11 | \usepackage{graphics,epsfig} 12 | \usepackage{stmaryrd} 13 | 14 | \input{macros.ltx} 15 | \input{library.ltx} 16 | 17 | \NatPackage 18 | 19 | \newcommand{\Ivor}{\textsc{Ivor}} 20 | \newcommand{\Funl}{\textsc{Funl}} 21 | \newcommand{\Agda}{\textsc{Agda}} 22 | 23 | \newcommand{\mysubsubsection}[1]{ 24 | \noindent 25 | \textbf{#1} 26 | } 27 | \newcommand{\hdecl}[1]{\texttt{#1}} 28 | 29 | \begin{document} 30 | 31 | \title{\Ivor{}, a Tutorial} 32 | \author{Edwin Brady} 33 | 34 | %\institute{School of Computer Science, \\ 35 | % University of St Andrews, St Andrews, Scotland. \\ \texttt{Email: eb@cs.st-andrews.ac.uk}.\\ 36 | %\texttt{Tel: +44-1334-463253}, \texttt{Fax: +44-1334-463278} \vspace{0.1in} 37 | %} 38 | 39 | \maketitle 40 | 41 | \input{introduction} 42 | 43 | % Structure: 44 | 45 | % Programming in TT 46 | \input{programming} 47 | 48 | % Theorem proving in TT 49 | \input{theoremproving} 50 | 51 | % Haskell library 52 | \input{hslibrary} 53 | 54 | \bibliographystyle{abbrv} 55 | \begin{small} 56 | \bibliography{../bib/literature.bib} 57 | 58 | %\appendix 59 | 60 | %\input{code} 61 | 62 | \end{small} 63 | \end{document} 64 | -------------------------------------------------------------------------------- /release/Release.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | Build a release with documentation from the latest darcs version, 4 | and upload it. 5 | 6 | > module Main where 7 | 8 | > import System.Environment 9 | > import System.Exit 10 | > import System.Directory 11 | > import System.Process hiding (shell) 12 | > import Distribution.PackageDescription 13 | > import Distribution.PackageDescription.Parse 14 | > import Distribution.PackageDescription.Configuration 15 | > import Distribution.Package 16 | > import Distribution.Verbosity 17 | > import Data.Version 18 | 19 | > repo = "http://www-fp.dcs.st-and.ac.uk/~eb/darcs/Ivor/" 20 | > server = "eb@home-staff.dcs.st-and.ac.uk:public_html/Ivor/" 21 | 22 | > main :: IO () 23 | > main = do args <- getArgs 24 | > dest <- parseArgs args 25 | > release dest 26 | 27 | > parseArgs :: [String] -> IO String 28 | > parseArgs (dest:[]) = return dest 29 | > parseArgs [] = return server 30 | > parseArgs _ = do putStrLn "Usage:\n\trelease [upload_location]" 31 | > exitWith (ExitFailure 1) 32 | 33 | > release :: String -> IO () 34 | > release dest = do 35 | > shell $ "darcs get --partial " ++ repo 36 | > gpkg <- readPackageDescription verbose "Ivor/ivor.cabal" 37 | > let pkg = flattenPackageDescription gpkg 38 | > let pkgver = pkgVersion (package pkg) 39 | > let ver = getVer (versionBranch pkgver) 40 | > putStrLn $ "Making a release of Ivor version " ++ ver 41 | > let rootname = "ivor-"++ver 42 | > shell $ "rm -rf Ivor/_darcs" 43 | > shell $ "rm -rf Ivor/release" 44 | > shell $ "mv Ivor " ++ rootname 45 | > shell $ "tar zcvf "++rootname++".tgz "++rootname++"/" 46 | > setCurrentDirectory rootname 47 | > shell $ "make jones" 48 | > shell $ "strip Jones/jones" 49 | > shell $ "runhaskell Setup.lhs haddock" 50 | > setCurrentDirectory ".." 51 | > shell $ "gpg -b " ++ rootname ++ ".tgz" 52 | > shell $ "gpg -b " ++ rootname ++ "/Jones/jones" 53 | > shell $ "scp "++rootname++".tgz " ++ rootname ++"/Jones/jones " 54 | > ++rootname++".tgz.sig " ++ rootname ++ "/Jones/jones.sig " ++ dest 55 | > shell $ "scp "++rootname++"/dist/doc/html/ivor/* "++dest++"doc" 56 | > shell $ "rm -rf " ++ rootname 57 | 58 | > getVer [] = "none" 59 | > getVer (major:[]) = show major 60 | > getVer (major:minor:[]) = show major ++ "." ++ show minor 61 | > getVer (major:minor:pl:_) = show major ++ "." ++ show minor ++ "." ++ show pl 62 | 63 | > shell :: String -> IO () 64 | > shell cmd = do p <- runCommand cmd 65 | > waitForProcess p 66 | > return () 67 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | rm -f tests Test.hi Test.o 3 | ghc --make -package ivor -package HUnit Test.lhs -o tests 4 | ./tests 5 | 6 | clean: 7 | rm -f *.o *.hi tests 8 | 9 | decruft: 10 | rm -f *~ 11 | -------------------------------------------------------------------------------- /tests/Test.lhs: -------------------------------------------------------------------------------- 1 | > module Main where 2 | 3 | > import Test.HUnit 4 | > import Control.Monad.Error 5 | > import Text.ParserCombinators.Parsec 6 | > import System 7 | 8 | > import Ivor.TT 9 | > import Ivor.Shell 10 | 11 | > stdlibShell = addModulePath (newShell emptyContext) 12 | > (prefix ++ "/lib/ivor") 13 | 14 | > basicShell = importFile "basics.tt" stdlibShell 15 | > ackShell = importFile "ack.tt" stdlibShell 16 | > partialShell = importFile "partial.tt" stdlibShell 17 | > vectShell = importFile "vect.tt" stdlibShell 18 | > pattShell = importFile "patt.tt" stdlibShell 19 | 20 | > doEval :: ShellState -> String -> String 21 | > doEval st tm = case (parse (shellParseTerm st) "(test)" tm) of 22 | > Left err -> "Parse error: " ++ show err 23 | > Right vtm -> case check (getContext st) vtm of 24 | > Left str -> "Type error: " ++ show str 25 | > Right v -> show $ view $ eval (getContext st) v 26 | 27 | > nat1 st = doEval st "plus (S (S O)) (S (S O))" 28 | > ack1 st = doEval st "runack 3 4" 29 | > partial1 st = doEval st "fact (S (S (S O)))" 30 | > vect1 st = doEval st "lookup _ _ (fz (S (S O))) (vcons _ _ O (vcons _ _ (S O) (vcons _ _ (S (S O)) (vnil Nat))))" 31 | > vect2 st = doEval st "lookup _ _ (fs _ (fz (S O))) (vcons _ _ O (vcons _ _ (S O) (vcons _ _ (S (S O)) (vnil Nat))))" 32 | > vect3 st = doEval st "lookup _ _ (fs _ (fs _ (fz O))) (vcons _ _ O (vcons _ _ (S O) (vcons _ _ (S (S O)) (vnil Nat))))" 33 | 34 | > patt1 st = doEval st "treeSum _ testTree" 35 | > patt2 st = doEval st "vtail _ _ testvec" 36 | > patt3 st = doEval st "vadd _ (vcons _ _ (S (S (S O))) (vcons _ _ (S (S O)) (vnil Nat))) (vcons _ _ (S (S (S O))) (vcons _ _ (S (S O)) (vnil Nat)))" 37 | > patt4 st = doEval st "vlookup _ _ (fs _ (fz _)) testvec" 38 | > patt5 st = doEval st "minus (S (S (S O))) (S O) (leS _ _ (leO _))" 39 | > patt6 st = doEval st "envlookup _ (fs _ (fz _)) _ testValEnv" 40 | 41 | 42 | > tests :: IO Test 43 | > tests = do 44 | > nat <- basicShell 45 | > ack <- ackShell 46 | > partial <- partialShell 47 | > vect <- vectShell 48 | > patt <- pattShell 49 | > return $ test ["nat1" ~: "2+2" ~: "S (S (S (S O)))" ~=? nat1 nat, 50 | > "ack1" ~: "ack 3 4" ~: "125" ~=? ack1 ack, 51 | > "partial1" ~: "partialfact" ~: "Later Nat (Later Nat (Later Nat (Now Nat (S (S (S (S (S (S O)))))))))" ~=? partial1 partial, 52 | > "vect1" ~: "lookup 0 [0,1,2]" ~: "O" ~=? vect1 vect, 53 | > "vect2" ~: "lookup 1 [0,1,2]" ~: "S O" ~=? vect2 vect, 54 | > "vect3" ~: "lookup 2 [0,1,2]" ~: "S (S O)" ~=? vect3 vect, 55 | > "patt1" ~: "treesum" ~: "S (S (S (S O)))" ~=? patt1 patt, 56 | > "patt2" ~: "vtail" ~: "vcons Nat (S O) (S (S (S O))) (vcons Nat O (S (S O)) (vnil Nat))" ~=? patt2 patt, 57 | > "patt3" ~: "vadd" ~: "vcons Nat (S O) (S (S (S (S (S (S O)))))) (vcons Nat O (S (S (S (S O)))) (vnil Nat))" ~=? patt3 patt, 58 | > "patt4" ~: "vlookup" ~: "S (S (S O))" ~=? patt4 patt, 59 | > "patt5" ~: "3-1" ~: "S (S O)" ~=? patt5 patt, 60 | > "patt6" ~: "envlookup" ~: "false" ~=? patt6 patt] 61 | 62 | > main = do 63 | > t <- tests 64 | > counts <- runTestTT t 65 | > if errors counts + failures counts == 0 66 | > then exitWith ExitSuccess 67 | > else exitWith (ExitFailure 1) 68 | -------------------------------------------------------------------------------- /tests/ack.tt: -------------------------------------------------------------------------------- 1 | Load "basics.tt"; 2 | 3 | Primitives; 4 | 5 | natToInt : (x:Nat)Int; 6 | intros; 7 | induction x; 8 | fill 0; 9 | intros; 10 | fill addInt 1 k_IH; 11 | Qed; 12 | 13 | ack:(x,y:Nat); 14 | intro x; 15 | induction x; 16 | intros; 17 | return; 18 | fill (S y); 19 | intros; 20 | induction y0; 21 | return; 22 | call ack k (S O); 23 | intros; 24 | refine k_IH; 25 | fill call k_IH0; 26 | Qed; 27 | 28 | runack = [x,y:Int](natToInt (call 29 | (ack (intToNat x) (intToNat y)))); 30 | -------------------------------------------------------------------------------- /tests/partial.tt: -------------------------------------------------------------------------------- 1 | {- Uustalu, Altenkirch and Capretta's Partiality monad -} 2 | 3 | Data Partial (A:*) : * = {- codata -} 4 | Now : (a:A)Partial A 5 | | Later : (p:Partial A)Partial A; 6 | 7 | Declare never:(A:*)Partial A; 8 | never = [A:*](Later _ (never A)); 9 | 10 | returnD = [A:*][a:A]Now _ a; 11 | 12 | {- corecursive -} 13 | Rec bindD : (A,B:*)(d:Partial A)(k:(a:A)(Partial B))Partial B; 14 | intros; 15 | case d; 16 | intros; 17 | fill k a; 18 | intros; 19 | fill Later _ (bindD _ _ p k); 20 | Qed; 21 | 22 | {- corecursive -} 23 | Rec lfpAux : (A,B:*)(k:(a0:A)(Partial B)) 24 | (f:(fk:(a1:A)Partial B)(fa:A)Partial B)(a:A)Partial B; 25 | intros; 26 | case f k a; 27 | intros; 28 | fill Now _ a0; 29 | intros; 30 | fill Later _ (lfpAux _ _ (f k) f a); 31 | Qed; 32 | 33 | lfp = [A,B:*][f:(k:(a:A)Partial B)((a:A)Partial B)][a:A] 34 | (lfpAux _ _ ([x:A]never B) f a); 35 | 36 | Load "nat.tt"; 37 | 38 | Check lfp; 39 | 40 | fact : (x:Nat)Partial Nat; 41 | intros; 42 | refine lfp; 43 | fill Nat; 44 | intro factfn arg; 45 | case arg; 46 | refine returnD; 47 | fill (S O); 48 | intros; 49 | case (factfn k); 50 | intros; 51 | refine returnD; 52 | fill (mult a (S k)); 53 | intros; 54 | fill p; 55 | fill x; 56 | Qed; 57 | -------------------------------------------------------------------------------- /tests/patt.tt: -------------------------------------------------------------------------------- 1 | Load "basics.tt"; 2 | Load "vect.tt"; 3 | 4 | Env = Vect *; 5 | 6 | Data ValEnv : (n:Nat)(G:Env n)* = 7 | empty : ValEnv O (vnil *) 8 | | extend : (T:*)(t:T)(n:Nat)(G:Env n)(Gv:ValEnv n G) 9 | (ValEnv (S n) (vcons * n T G)); 10 | 11 | Match vlookup : (A:*)(n:Nat)(i:Fin n)(xs:Vect A n)A = 12 | vlookup _ _ (fz _) (vcons _ _ x xs) = x 13 | | vlookup _ _ (fs n i) (vcons _ n x xs) = vlookup _ _ i xs; 14 | 15 | Match envlookup : (n:Nat)(i:Fin n)(G:Env n)(Gv:ValEnv n G)(vlookup _ _ i G) = 16 | envlookup _ (fz _) _ (extend _ t _ _ r) = t 17 | | envlookup _ (fs _ j) _ (extend _ t _ _ r) = envlookup _ j _ r; 18 | 19 | testEnv = vcons _ _ Nat (vcons _ _ Bool (vcons _ _ Nat (vnil *))); 20 | 21 | testValEnv : ValEnv _ testEnv; 22 | refine extend; 23 | fill (S (S (S O))); 24 | refine extend; 25 | fill false; 26 | refine extend; 27 | fill (S (S O)); 28 | refine empty; 29 | Qed; 30 | 31 | Match minus : (m,n:Nat)(le n m)->Nat = 32 | minus m O (leO m) = m 33 | | minus (S m) (S n) (leS n m p) = minus m n p; 34 | 35 | Match plusp : Nat -> Nat -> Nat = 36 | plusp O x = x 37 | | plusp (S x) y = S (plusp x y); 38 | 39 | Data tree (A:*) : (n:Nat)* = 40 | leaf : tree A O 41 | | node : (n:Nat)(left:tree A n)(a:A) 42 | (m:Nat)(right:tree A m)(tree A (S (plus n m))); 43 | 44 | Match treeSum : (n:Nat)(t:tree Nat n)Nat = 45 | treeSum _ (leaf _) = O 46 | | treeSum _ (node _ _ l a _ r) = plus a (plus (treeSum _ l) (treeSum _ r)); 47 | 48 | testTree = node _ _ (node _ _ (leaf _) (S (S O)) _ (leaf _)) O 49 | _ (node _ _ (leaf _) (S (S O)) _ (leaf _)); 50 | 51 | testvec = (vcons _ _ (S (S (S (S O)))) (vcons _ _ (S (S (S O))) (vcons _ _ (S (S O)) (vnil Nat)))); 52 | 53 | Match vadd : (n:Nat)(xs,ys:Vect Nat n)->(Vect Nat n) = 54 | vadd _ (vnil _) (vnil _) = vnil Nat 55 | | vadd _ (vcons _ _ x xs) (vcons _ _ y ys) 56 | = vcons _ _ (plus x y) (vadd _ xs ys); 57 | 58 | Match vtail : (A:*)(n:Nat)(xs:Vect A (S n))(Vect A n) = 59 | vtail _ _ (vcons _ _ _ xs) = xs; 60 | 61 | 62 | Eval vlookup _ _ (fs _ (fz _)) testvec; --------------------------------------------------------------------------------