Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: ezyang/logitext
base: 8faa78cc5b
...
head fork: ezyang/logitext
compare: 67aefc745d
Checking mergeability… Don't worry, you can still create the pull request.
  • 12 commits
  • 6 files changed
  • 0 commit comments
  • 1 contributor
Commits on Apr 04, 2012
@ezyang Coq parsing code
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
a3d5619
@ezyang A more efficient, but harder to read version of the parser.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
47f87b6
@ezyang Some more Haskell in progress.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
8304c7e
@ezyang Actually parse.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
4f562ef
Commits on Apr 05, 2012
@ezyang Transform into DSL first-order logic
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
9a4b3fb
Commits on Apr 09, 2012
@ezyang CoqTop interaction.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
7b9e773
Commits on Apr 13, 2012
@ezyang Lots of updates yo.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
aff13c6
@ezyang Start developing recursion.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
38029c7
@ezyang Minor mods.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
6e18e59
@ezyang Writing the fold functions will be bitchy.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
7dacee4
@ezyang Add proofComplete, update things.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
67f0101
@ezyang Build out some of the more boring stuff.
Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
67aefc7
View
327 ClassicalFOL.hs
@@ -0,0 +1,327 @@
+{-# LANGUAGE GADTs, EmptyDataDecls, KindSignatures, ExistentialQuantification, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor, NoMonomorphismRestriction #-}
+
+module ClassicalFOL where
+
+import qualified Coq as C
+import Coq (CoqTerm(..))
+import Ltac
+import CoqTop
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Maybe
+import Data.Either
+import Data.List
+import Data.Foldable (traverse_)
+import Data.IORef
+import Data.Typeable
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Debug.Trace
+
+import Text.XML.Light
+
+-- We rely on naming being deterministic, so that we can have 'pure'
+-- proof data structures. This is really not practical for real
+-- proofs, where we really can't keep the all of the old proof states.
+
+type V = String
+type PredV = String
+type FunV = String
+
+-- Sequent
+data S = S [L] [L]
+ deriving (Show, Eq)
+
+-- Elements in the universe. Distinguish between a constant and a
+-- bound variable (probably not strictly necessary, but convenient)
+data U = Fun FunV [U]
+ | Var V
+ deriving (Show, Eq)
+
+instance CoqTerm U where
+ toCoq (Fun f xs) = C.App (C.Atom f) (map toCoq xs)
+ toCoq (Var x) = C.Atom x
+
+ fromCoq = coqToU Set.empty where
+
+-- XXX A bit specialized (not fromCoq because we need sets)
+coqToU s (C.Atom n) | n `Set.member` s = Var n
+ | otherwise = Fun n []
+coqToU s (C.App (C.Atom n) us) = Fun n (map (coqToU s) us)
+coqToU _ _ = error "U.fromCoq"
+
+data L = Pred PredV [U] -- could be (Pred "A" [])
+ | Conj L L
+ | Disj L L
+ | Imp L L
+ | Not L
+ | Top
+ | Bot
+ | Forall V L
+ | Exists V L
+ deriving (Show, Eq)
+
+instance CoqTerm L where
+ toCoq (Pred p []) = C.Atom p
+ toCoq (Pred p xs) = C.App (C.Atom p) (map toCoq xs)
+ toCoq (Conj a b) = C.App (C.Atom "and") [toCoq a, toCoq b]
+ toCoq (Disj a b) = C.App (C.Atom "or") [toCoq a, toCoq b]
+ toCoq (Imp a b) = C.Imp (toCoq a) (toCoq b)
+ toCoq (Not a) = C.App (C.Atom "not") [toCoq a]
+ toCoq Top = C.Atom "True"
+ toCoq Bot = C.Atom "False"
+ toCoq (Forall x a) = C.Forall [("x", C.Atom "U")] (toCoq a)
+ toCoq (Exists x a) = C.App (C.Atom "@ex") [C.Atom "U", C.Fun [(x, C.Atom "U")] (toCoq a)]
+
+ fromCoq = f Set.empty where
+ f s (C.Forall [] t) = f s t
+ f s (C.Forall ((n, C.Atom "U"):bs) t) = Forall n (f (Set.insert n s) (C.Forall bs t))
+ f s (C.Fun _ _) = error "L.fromCoq Fun"
+ f s (C.Typed t _) = f s t
+ f s (C.Imp t t') = Imp (f s t) (f s t')
+ f s (C.App (C.Atom "@ex") [C.Atom "U", C.Fun [(n, C.Atom "U")] t]) = Exists n (f (Set.insert n s) t)
+ f s (C.App (C.Atom "@ex") _) = error "L.fromCoq App ex"
+ f s (C.App (C.Atom "and") [t1, t2]) = Conj (f s t1) (f s t2)
+ f s (C.App (C.Atom "and") _) = error "L.fromCoq App and"
+ f s (C.App (C.Atom "or") [t1, t2]) = Disj (f s t1) (f s t2)
+ f s (C.App (C.Atom "or") _) = error "L.fromCoq App or"
+ f s (C.App (C.Atom "not") [t]) = Not (f s t)
+ f s (C.App (C.Atom "not") _) = error "L.fromCoq App not"
+ f s (C.App (C.Atom p) ts) = Pred p (map (coqToU s) ts)
+ f s (C.App _ _) = error "L.fromCoq App"
+ f s (C.Sort _) = error "L.fromCoq Sort"
+ f s (C.Num _) = error "L.fromCoq Num"
+ f s (C.Atom "True") = Top
+ f s (C.Atom "False") = Bot
+ f s (C.Atom n) = Pred n []
+
+listifyDisj :: L -> [L]
+listifyDisj Bot = []
+listifyDisj (Disj t ts) = t : listifyDisj ts
+listifyDisj _ = error "listifyDisj"
+
+disjList :: [L] -> L
+disjList [] = Bot
+disjList (x:xs) = Disj x (disjList xs)
+
+-- quickcheck: listifyDisj (disjList xs) == xs
+
+-- Building up a proof tree is a multi-stage process.
+--
+-- You start off with a Goal S, where S is the thing you want to prove,
+-- but not knowing what the right proof step is.
+--
+-- You might suggest some inference rule Q, in which case
+-- you now have an Pending _ (Q _). It's unknown if it will work, nor do
+-- we know what the subgoals will be.
+--
+-- Finally, after passing it to Coq, we discover if it's successful
+-- and replace it with a Proof term.
+
+data P = Goal S | Pending S (Q Int) | Proof S (Q P)
+ deriving (Show)
+
+data Q a = Exact Int
+ | Cut L a a
+ | LConj Int a
+ | LDisj Int a a
+ | LImp Int a a
+ | LBot Int
+ | LNot Int a
+ | LForall Int U a
+ | LExists Int a
+ | LContract Int a
+ | LWeaken Int a
+ | RConj Int a a
+ | RDisj Int a
+ | RImp Int a
+ | RNot Int a
+ | RForall Int a
+ | RExists Int U a
+ | RWeaken Int a
+ | RContract Int a
+ deriving (Functor, Show)
+
+-- preorder traversal (does a full rebuild)
+preorder fp fq a = tp a
+ where
+ -- XXX eep, only needs to be partial! Could use some GADTs here...
+ tp p@(Goal _) = fp p -- used for Goal -> Pending transition
+ tp p@(Pending _ _) = fp p -- used for Pending -> Proof transition
+ tp p@(Proof s q) = Proof s <$ fp p <*> tq q -- result discarded
+
+ tq q@(Exact n) = Exact n <$ fq q
+ tq q@(Cut l x y) = Cut l <$ fq q <*> tp x <*> tp y
+ tq q@(LConj n x) = LConj n <$ fq q <*> tp x
+ tq q@(LDisj n x y) = LDisj n <$ fq q <*> tp x <*> tp y
+ tq q@(LImp n x y) = LImp n <$ fq q <*> tp x <*> tp y
+ tq q@(LBot n) = LBot n <$ fq q
+ tq q@(LNot n x) = LNot n <$ fq q <*> tp x
+ tq q@(LForall n v x) = LForall n v <$ fq q <*> tp x
+ tq q@(LExists n x) = LExists n <$ fq q <*> tp x
+ tq q@(LContract n x) = LContract n <$ fq q <*> tp x
+ tq q@(LWeaken n x) = LWeaken n <$ fq q <*> tp x
+ tq q@(RConj n x y) = RConj n <$ fq q <*> tp x <*> tp y
+ tq q@(RDisj n x) = RDisj n <$ fq q <*> tp x
+ tq q@(RImp n x) = RImp n <$ fq q <*> tp x
+ tq q@(RNot n x) = RNot n <$ fq q <*> tp x
+ tq q@(RForall n x) = RForall n <$ fq q <*> tp x
+ tq q@(RExists n v x) = RExists n v <$ fq q <*> tp x
+ tq q@(RWeaken n x) = RWeaken n <$ fq q <*> tp x
+ tq q@(RContract n x) = RContract n <$ fq q <*> tp x
+
+proofComplete a = isJust (preorder fp fq a)
+ where fp p@(Goal _) = mzero
+ fp p@(Pending _ _) = mzero
+ fp p@(Proof _ _) = return undefined
+ fq _ = return undefined
+
+hyp n = "Hyp" ++ show n
+con n = "Con" ++ show n
+
+qNum Exact{} = 0
+qNum Cut{} = 2
+qNum LConj{} = 1
+qNum LDisj{} = 2
+qNum LImp{} = 2
+qNum LBot{} = 0
+qNum LNot{} = 1
+qNum LForall{} = 1
+qNum LExists{} = 1
+qNum LContract{} = 1
+qNum LWeaken{} = 1
+qNum RConj{} = 2
+qNum RDisj{} = 1
+qNum RImp{} = 1
+qNum RNot{} = 1
+qNum RForall{} = 1
+qNum RExists{} = 1
+qNum RWeaken{} = 1
+qNum RContract{} = 1
+
+qToTac (Exact n) = Tac "myExact" [hyp n]
+qToTac (Cut l _ _) = Tac "myCut" [C.render (toCoq l)]
+qToTac (LConj n _) = Tac "lConj" [hyp n]
+qToTac (LDisj n _ _) = Tac "lDisj" [hyp n]
+qToTac (LImp n _ _) = Tac "lImp" [hyp n]
+qToTac (LBot n) = Tac "lBot" []
+qToTac (LNot n _) = Tac "lNot" [hyp n]
+qToTac (LForall n v _) = Tac "lForall" [hyp n, C.render (toCoq v)]
+qToTac (LExists n _) = Tac "lExists" [hyp n]
+qToTac (LContract n _) = Tac "lContract" [hyp n]
+qToTac (LWeaken n _) = Tac "lWeaken" [hyp n]
+qToTac (RConj n _ _) = Tac "rConj" [con n]
+qToTac (RDisj n _) = Tac "rDisj" [con n]
+qToTac (RImp n _) = Tac "rImp" [con n]
+qToTac (RNot n _) = Tac "rNot" [con n]
+qToTac (RForall n _) = Tac "rForall" [con n]
+qToTac (RExists n v _) = Tac "rExists" [con n, C.render (toCoq v)]
+qToTac (RWeaken n _) = Tac "rWeaken" [con n]
+qToTac (RContract n _) = Tac "rContract" [con n]
+
+-- We need to do a rather special mechanism of feeding the proof to Coq,
+-- because we need to find out what the intermediate proof state at
+-- various steps looks like. (Also, we'd kind of like to save work...)
+
+-- using error, not fail! fail will have the wrong semantics
+-- when we're using Maybe
+maybeError s m = maybe (error s) return m
+eitherError = either (error . show) return
+
+-- NOTE Tactic failure may be from a built in (i.e. no clauses for
+-- match) or from an explicit fail, which can have a string resulting
+-- in "Error: Tactic failure: foo." We don't appear to have any
+-- need for sophisticated failure matching yet, and the errors are
+-- in general kind of useless, but maybe it will be useful later.
+-- Note that we have an opportunity for *unsound* error generation:
+-- "if there is an error, this message might be useful" (kind of like
+-- how humans, faced with a fact that is in fact false, can still make
+-- up plausible excuses.)
+
+data CoqError = TacticFailure | NoMoreSubgoals
+ deriving (Show)
+
+-- but bottom on input we don't understand
+parseResponse :: [Content] -> Either CoqError S
+parseResponse raw = do
+ let fake = Element (qn "fake") [] raw Nothing
+ extractHyp (C.Typed (C.Atom _) (C.App (C.Atom "Hyp") [l])) = Just l
+ extractHyp _ = Nothing
+ qn s = QName s Nothing Nothing
+ -- showElement fake `trace` return ()
+ when (isJust (findElement (qn "errorresponse") fake)) (Left TacticFailure)
+ -- yes, we're being partial here, but using ordering to
+ -- ensure that the errors get sequenced correctly
+ resp <- maybeError "pendingToHole: no response found" (findChild (qn "normalresponse") (Element (qn "fake") [] raw Nothing))
+ (\s -> when (s == "no-more-subgoals") (Left NoMoreSubgoals)) `traverse_` findAttr (qn "status") resp
+ hyps <- mapMaybe extractHyp
+ . rights
+ . map (C.parseTerm . strContent)
+ . findChildren (qn "hyp")
+ <$> maybeError "pendingToHole: no hyps found" (findChild (qn "hyps") resp)
+ goal <- eitherError . C.parseTerm . strContent =<< maybeError "pendingToHole: no goal found" (findChild (qn "goal") resp)
+ return (S (map fromCoq hyps) (listifyDisj (fromCoq goal)))
+
+refine :: P -> IO P
+refine p@(Goal s) = refine' s p
+refine p@(Pending s _) = refine' s p
+refine p@(Proof s _) = refine' s p
+
+data UpdateFailure = UpdateFailure
+ deriving (Typeable, Show)
+instance Exception UpdateFailure
+
+-- the S is kind of redundant but makes my life easier
+refine' :: S -> P -> IO P
+-- XXX not quite right
+refine' s@(S [] cs) p = coqtop "ClassicalFOL" $ \f -> do
+ -- XXX demand no errors
+ mapM_ f [ "Section scratch"
+ , "Parameter U : Set"
+ -- XXX factor these constants out
+ , "Variable z : U"
+ , "Variable f g h : U -> U"
+ , "Variable A B C : Prop"
+ , "Variable P Q R : Prop"
+ , "Set Printing All"
+ ]
+ -- despite being horrible mutation, this plays an important
+ -- synchronizing role for us; it lets us make sure that "what we
+ -- see" is what we expect; also, immediately after we run a tactic
+ -- is not /quite/ the right place to check the result
+ currentState <- newIORef Nothing
+ let run tac = do
+ -- putStrLn tac
+ r <- evaluate . parseResponse =<< f tac
+ case r of
+ Right x -> writeIORef currentState (Just x) >> return True
+ Left TacticFailure -> return False
+ Left NoMoreSubgoals -> writeIORef currentState Nothing >> return True
+ readState = readIORef currentState
+ checkState s = readState >>= \s' -> assert (Just s == s') (return ())
+ r <- run ("Goal " ++ C.render (toCoq (disjList cs)))
+ when (not r) $ error "refine: setting goal failed"
+ let fp p@(Goal s) = checkState s >> return p
+ -- TODO also check if change in number of subgoals is correct
+ fp p@(Pending s q) = do
+ checkState s
+ run (show (qToTac q)) >>= (`unless` throwIO UpdateFailure)
+ gs <- replicateM (qNum q) (fromJust <$> readState <* (run "admit" >>= (`unless` error "refine: could not admit")))
+ return (Proof s (fmap (Goal . (gs !!)) q))
+ fp (Proof s _) = checkState s >> return undefined
+ fq q = run (show (qToTac q)) >>= (`unless` error "refine: inconsistent proof state")
+ preorder fp fq p
+
+-- XXX partial (not a particularly stringent requirement; you can get
+-- around it with a few intros / tactic applications
+refine' _ _ = error "pendingToHole: meta-implication must be phrased as implication"
+
+main = do
+ let s = S [] [Pred "A" [], Not (Pred "A" [])]
+ -- XXX actually kinda slow...
+ print =<< refine (Goal s)
+ print =<< refine (Pending s (RNot 1 0))
+ print =<< refine (Proof s (RNot 1 (Goal (S [Pred "A" []] [Pred "A" []]))))
+ print =<< refine (Proof s (RNot 1 (Pending (S [Pred "A" []] [Pred "A" []]) (Exact 0))))
+ print =<< refine (Proof s (RNot 1 (Proof (S [Pred "A" []] [Pred "A" []]) (Exact 0))))
View
3  ClassicalFOL.v
@@ -215,9 +215,12 @@ Section universe.
Parameter U : Set.
Variable z : U. (* non-empty domain *)
+Variable f : U -> U. (* FOL function *)
Variables A B C : Prop. (* some convenient things to instantiate with *)
Variables P Q R : U -> Prop.
+Set Printing All.
+
(* an example *)
Goal denote ( [ True; C /\ C; (~ True) \/ True ] |= [ False; False; False; ((A -> B) -> A) -> A ] ).
sequent.
View
239 Coq.hs
@@ -0,0 +1,239 @@
+{-# LANGUAGE RankNTypes, TupleSections #-}
+
+module Coq (
+ Term(..)
+ , Binder
+ , Name
+ , Sort(..)
+ , term
+ , parseTerm
+ , CoqTerm(..)
+ , render
+ ) where
+
+import Control.Applicative hiding ((<|>), many)
+import Text.Parsec
+import qualified Text.Parsec.Token as P
+import Text.Parsec.Language (emptyDef)
+import Data.Functor.Identity
+import Data.List hiding (sort)
+
+coqStyle :: P.LanguageDef st
+coqStyle = emptyDef
+ { P.commentStart = "(*"
+ , P.commentEnd = "*)"
+ , P.nestedComments = True
+ , P.identStart = letter <|> oneOf "_"
+ , P.identLetter = alphaNum <|> oneOf "_'"
+ -- Ops are sloppy, but should work OK for our use case.
+ -- There might be a bug here.
+ , P.opStart = P.opLetter coqStyle
+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ -- Lifted straight out of the manual
+ , P.reservedOpNames =
+ ["!","%","&","&&","(","()",")",
+ "*","+","++",",","-","->",".",
+ ".(","..","/","/\\",":","::",":<",
+ ":=",":>",";","<","<-","<->","<:",
+ "<=","<>","=","=>","=_D",">",">->",
+ ">=","?","?=","@","[","\\/","]",
+ "^","{","|","|-","||","}","~"]
+ , P.reservedNames =
+ ["_","as","at","cofix","else","end",
+ "exists","exists2","fix","for","forall","fun",
+ "if","IF","in","let","match","mod",
+ "Prop","return","Set","then","Type","using",
+ "where","with"]
+ , P.caseSensitive = True
+ }
+
+lexer = P.makeTokenParser coqStyle
+
+reserved = P.reserved lexer
+identifier = P.identifier lexer
+reservedOp = P.reservedOp lexer
+integer = P.integer lexer
+whiteSpace = P.whiteSpace lexer
+
+-- http://coq.inria.fr/doc/Reference-Manual003.html
+
+-- Here is the restricted BNF we will support:
+--
+-- term ::= forall binders , term
+-- | fun binders => term
+-- | term : term
+-- | term -> term
+-- | term arg ... arg
+-- | @ qualid term ... term
+-- | qualid
+-- | sort
+-- | num
+-- arg ::= term
+-- binders ::= binder .. binder
+-- binder ::= name | ( name ... name : term )
+-- name ::= ident
+-- qualid ::= ident
+-- sort ::= Prop | Set | Type
+
+data Term = Forall [Binder] Term
+ | Fun [Binder] Term
+ | Typed Term Term -- extra info
+ | Imp Term Term
+ | App Term [Term]
+ | Sort Sort
+ | Num Integer
+ | Atom Name
+ deriving (Show, Eq)
+
+render :: Term -> String
+render (Forall bs t) = "(forall " ++ renderBinders bs ++ ", " ++ render t ++ ")"
+render (Fun bs t) = "(fun " ++ renderBinders bs ++ " => " ++ render t ++ ")"
+render (Typed t t') = "(" ++ render t ++ " : " ++ render t' ++ ")"
+render (Imp t t') = "(" ++ render t ++ " -> " ++ render t' ++ ")"
+render (App t ts) = "(" ++ render t ++ " " ++ intercalate " " (map render ts) ++ ")"
+render (Sort Prop) = "Prop"
+render (Sort Set) = "Set"
+render (Sort Type) = "Type"
+render (Num i) = show i
+render (Atom n) = n
+
+renderBinders :: [Binder] -> String
+renderBinders [] = error "renderBinders: empty binder"
+renderBinders [(n, t)] = "(" ++ n ++ ":" ++ render t ++ ")"
+renderBinders (x:xs) = renderBinders [x] ++ " " ++ renderBinders xs -- XXX code reuse at its finest
+
+-- We require the types of our binders! If you Set Printing All you
+-- should get them.
+type Binder = (Name, Term)
+type Name = String -- qualid's are squashed in here
+data Sort = Prop | Set | Type
+ deriving (Show, Eq)
+
+-- But the BNF is not enough to actually properly parse...
+-- (precedences?)
+--
+-- Fortunately, we already have a nice converted definition in
+-- parsing/g_constr.ml4. They also have some batshit weird interaction
+-- between their infix and prefix operators, so we don't use Parsec's
+-- nice table support.
+--
+-- Levels are pretty important to understanding g_constr.ml4; there is a
+-- good treatment here:
+-- http://caml.inria.fr/pub/docs/tutorial-camlp4/tutorial003.html
+-- Notationally, operconstr.90 === operconstr LEVEL 90; we've translated
+-- all of the NEXT and SELF identifiers.
+--
+-- We had to manually resolve some levels, so if you add more levels you
+-- will need to fix them.
+
+type P a = forall u. ParsecT String u Identity a
+
+global :: P Term
+global = Atom <$> identifier
+
+name :: P String
+name = identifier
+
+-- operconstr:
+-- 200 RIGHTA binder_constr
+-- 100 RIGHTA operconstr.90 ":" binder_constr
+-- operconstr.90 ":" operconstr.100
+-- 90 RIGHTA operconstr.10 "->" binder_constr
+-- operconstr.10 "->" operconstr.90
+-- 10 LEFTA operconstr.0 appl_arg+ // this one might be wrong
+-- "@" global operconstr.0*
+-- 0 atomic_constr
+-- "(" operconstr.200 ")"
+
+term :: P Term
+term = operconstr200
+
+-- There is a more efficient, left-factored representation for many of
+-- these rules, and some of the tries are not necessary, but sprinkling
+-- in try makes it easier to tell that things are correct, and
+-- performance is not a primary concern. If you're curious what the
+-- left-factored representation looks like, see Coq_efficient.hs
+
+operconstr200, operconstr100, operconstr90, operconstr10, operconstr0 :: P Term
+operconstr200 = try binder_constr <|> operconstr100
+operconstr100 = try (Typed <$> operconstr90 <* reservedOp ":" <*> binder_constr)
+ <|> try (Typed <$> operconstr90 <* reservedOp ":" <*> operconstr100)
+ <|> operconstr90
+operconstr90 = try (Imp <$> operconstr10 <* reservedOp "->" <*> binder_constr)
+ <|> try (Imp <$> operconstr10 <* reservedOp "->" <*> operconstr90)
+ <|> operconstr10
+operconstr10 = try (App <$> operconstr0 <*> many1 appl_arg)
+ -- XXX dropping the @ cuz we're lazy
+ <|> try (reservedOp "@" >> App <$> global <*> many operconstr0)
+ <|> operconstr0
+operconstr0 = try atomic_constr
+ <|> reservedOp "(" *> operconstr200 <* reservedOp ")"
+
+-- lconstr: operconstr.200
+lconstr :: P Term
+lconstr = operconstr200
+
+-- constr:
+-- operconstr.8
+-- "@" global
+constr :: P Term
+constr = try operconstr0
+ <|> (reservedOp "@" >> Atom . ('@':) <$> identifier)
+
+-- binder_constr:
+-- "forall" open_binders "," operconstr.200
+-- "fun" open_binders "=>" operconstr.200
+binder_constr :: P Term
+binder_constr = try (reserved "forall" >> Forall <$> open_binders <* reservedOp "," <*> operconstr200)
+ <|> (reserved "fun" >> Fun <$> open_binders <* reservedOp "=>" <*> operconstr200)
+
+-- open_binders:
+-- name name* ":" lconstr
+-- name name* binders
+-- closed_binder binders
+msBinder ns t = map (,t) ns
+open_binders :: P [Binder]
+open_binders = try (msBinder <$> many1 name <* reservedOp ":" <*> lconstr)
+ <|> ((++) <$> closed_binder <*> binders)
+
+-- binders: binder*
+binders :: P [Binder]
+binders = concat <$> many binder
+
+-- binder:
+-- closed_binder
+binder :: P [Binder]
+binder = closed_binder
+
+-- closed_binder:
+-- "(" name+ ":" lconstr ")"
+closed_binder :: P [Binder]
+closed_binder = reservedOp "(" >> msBinder <$> many name <* reservedOp ":" <*> lconstr <* reservedOp ")"
+
+-- appl_arg:
+-- "(" lconstr ")" -- we don't need the hack yay!
+-- operconstr.0
+appl_arg = try (reservedOp "(" >> lconstr <* reservedOp ")")
+ <|> operconstr0
+
+-- atomic_constr:
+-- global
+-- sort
+-- INT
+atomic_constr :: P Term
+atomic_constr = try global
+ <|> try (Sort <$> sort)
+ <|> Num <$> integer
+sort :: P Sort
+sort = Prop <$ reserved "Prop" <|> Set <$ reserved "Set" <|> Type <$ reserved "Type"
+
+parse_sample = "or ((forall x : U, P x) -> @ex U (fun x : U => P x)) False"
+sample = parse (term <* eof) "" parse_sample
+
+parseTerm = parse (whiteSpace >> term <* eof) ""
+
+-- XXX can haz test please (do it before you make changes)
+
+class CoqTerm a where
+ toCoq :: a -> Term
+ fromCoq :: Term -> a
View
84 CoqTop.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE RankNTypes, NoMonomorphismRestriction, ScopedTypeVariables #-}
+
+module CoqTop
+ ( coqtop
+ ) where
+
+import Prelude hiding (catch)
+import System.IO
+import System.Process
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+import Text.XML.Light.Input
+import Text.XML.Light
+import Data.List.Split
+
+-- You'll need ezyang's private copy of Coq https://github.com/ezyang/coq
+
+coqtopProcess theory err = CreateProcess
+ -- XXX Filepaths should be more generic...
+ { cmdspec = RawCommand "/home/ezyang/Dev/coq-git/bin/coqtop.opt"
+ [ "-coqlib"
+ , "/home/ezyang/Dev/coq-git"
+ , "-l"
+ , "/home/ezyang/Dev/logitext/" ++ theory ++ ".v"
+ , "-pgip"]
+ , cwd = Nothing
+ , env = Nothing
+ , std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = UseHandle err
+ , close_fds = True
+ }
+
+onlyOnce :: IO () -> IO (IO ())
+onlyOnce m = do
+ i <- newMVar m
+ return (modifyMVar_ i (\m -> m >> return (return ())))
+
+coqtopRaw theory = do
+ -- XXX We're not really doing good things with warnings.
+ -- Fortunately, fatal errors DO get put on stdout.
+ err <- openFile "/dev/null" WriteMode -- XXX gimme a platform independent version!
+ (Just fin, Just fout, _, pid) <- createProcess (coqtopProcess theory err)
+ hSetBuffering fin LineBuffering
+ hSetBuffering fout LineBuffering -- should be good enough to pick up on <ready/>
+ resultChan <- newChan
+ -- XXX do we really want to give them the <ready/> marker? (elim
+ -- keepDelimsR if not)
+ tout <- forkIO $
+ -- Lazy IO at its finest
+ let p (Elem e) | qName (elName e) == "ready" = True
+ p _ = False
+ in writeList2Chan resultChan . split (keepDelimsR (whenElt p)) =<< parseXML `fmap` hGetContents fout
+ _ <- readChan resultChan -- read out the intro message
+ -- XXX this doesn't do particularly good things if you don't
+ -- pass it enough information. Correct thing to do is on COQ
+ -- side say "I want more information!" Nor does it do good things
+ -- if you give it too much information... (de-synchronization risk)
+ interactVar <- newMVar (\s -> hPutStr fin (s ++ ".\n") >> readChan resultChan)
+ let interact s = withMVar interactVar (\f -> f s)
+ end <- onlyOnce $ do
+ killThread tout
+ hClose fin
+ hClose fout
+ m <- getProcessExitCode pid
+ maybe (terminateProcess pid) (const (return ())) m
+ -- We're erring on the safe side here. If no escape of coqtop
+ -- from bracket is enforced, this is impossible
+ modifyMVar_ interactVar (\_ -> return (error "coqtopRaw/end: coqtop is dead"))
+ return (interact, end)
+
+coqtop theory inner = bracket (coqtopRaw theory) snd (inner . fst)
+
+{-
+main =
+ coqtop "ClassicalFOL" $ \f -> do
+ let run s = f s >>= print >> putStrLn ""
+ run "Goal True."
+ run "trivial."
+ run "Qed."
+-}
View
152 Coq_efficient.hs
@@ -0,0 +1,152 @@
+module Coq where
+
+import Text.Parsec
+import qualified Text.Parsec.Token as P
+import Text.Parsec.Language (emptyDef)
+import Text.Parsec.Expr
+import Data.Functor.Identity
+
+coqStyle :: P.LanguageDef st
+coqStyle = emptyDef
+ { P.commentStart = "(*"
+ , P.commentEnd = "*)"
+ , P.nestedComments = True
+ , P.identStart = letter <|> oneOf "_"
+ , P.identLetter = alphaNum <|> oneOf "_'"
+ -- Ops are sloppy, but should work OK for our use case.
+ -- There might be a bug here.
+ , P.opStart = P.opLetter coqStyle
+ , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ -- Lifted straight out of the manual
+ , P.reservedOpNames =
+ ["!","%","&","&&","(","()",")",
+ "*","+","++",",","-","->",".",
+ ".(","..","/","/\\",":","::",":<",
+ ":=",":>",";","<","<-","<->","<:",
+ "<=","<>","=","=>","=_D",">",">->",
+ ">=","?","?=","@","[","\\/","]",
+ "^","{","|","|-","||","}","~"]
+ , P.reservedNames =
+ ["_","as","at","cofix","else","end",
+ "exists","exists2","fix","for","forall","fun",
+ "if","IF","in","let","match","mod",
+ "Prop","return","Set","then","Type","using",
+ "where","with"]
+ , P.caseSensitive = True
+ }
+
+lexer = P.makeTokenParser coqStyle
+
+reserved = P.reserved lexer
+identifier = P.identifier lexer
+reservedOp = P.reservedOp lexer
+integer = P.integer lexer
+
+-- http://coq.inria.fr/doc/Reference-Manual003.html
+
+-- Here is the restricted BNF we will support:
+--
+-- term ::= forall binders , term
+-- | fun binders => term
+-- | term : term
+-- | term -> term
+-- | term arg ... arg
+-- | @ qualid term ... term
+-- | qualid
+-- | sort
+-- | num
+-- arg ::= term
+-- binders ::= binder .. binder
+-- binder ::= name | ( name ... name : term )
+-- name ::= ident
+-- qualid ::= ident
+-- sort ::= Prop | Set | Type
+--
+-- But the BNF is not enough to actually properly parse...
+-- (precedences?)
+--
+-- Fortunately, we already have a nice converted definition in
+-- parsing/g_constr.ml4. They also have some batshit weird interaction
+-- between their infix and prefix operators, so we don't use Parsec's
+-- nice table support.
+--
+-- Levels are pretty important to understanding g_constr.ml4; there is a
+-- good treatment here:
+-- http://caml.inria.fr/pub/docs/tutorial-camlp4/tutorial003.html
+-- Notationally, operconstr.90 === operconstr LEVEL 90; we've translated
+-- all of the NEXT and SELF identifiers.
+--
+-- We had to manually resolve some levels, so if you add more levels you
+-- will need to fix them.
+
+global = identifier >> return ()
+name = identifier
+
+-- operconstr:
+-- 200 RIGHTA binder_constr
+-- 100 RIGHTA operconstr.90 ":" binder_constr
+-- operconstr.90 ":" operconstr.100
+-- 90 RIGHTA operconstr.10 "->" binder_constr
+-- operconstr.10 "->" operconstr.90
+-- 10 LEFTA operconstr.0 appl_arg+ // this one might be wrong
+-- "@" global operconstr.0*
+-- 0 atomic_constr
+-- "(" operconstr.200 ")"
+
+term = operconstr200
+operconstr200 = binder_constr <|> operconstr100
+operconstr100 = operconstr90 >> ((reservedOp ":" >> (binder_constr <|> operconstr100)) <|> return ())
+operconstr90 = operconstr10 >> ((reservedOp "->" >> (binder_constr <|> operconstr90)) <|> return ())
+operconstr10 = try (operconstr0 >> many1 appl_arg >> return ())
+ <|> (reservedOp "@" >> global >> many operconstr0 >> return ())
+ <|> operconstr0
+operconstr0 = atomic_constr
+ <|> (reservedOp "(" >> operconstr200 >> reservedOp ")")
+
+-- lconstr: operconstr.200
+lconstr = operconstr200
+
+-- constr:
+-- operconstr.8
+-- "@" global
+constr = operconstr0 <|> (reservedOp "@" >> global >> return ())
+
+-- binder_constr:
+-- "forall" open_binders "," operconstr.200
+-- "fun" open_binders "=>" operconstr.200
+binder_constr = (reserved "forall" >> open_binders >> reservedOp "," >> operconstr200)
+ <|> (reserved "fun" >> open_binders >> reservedOp "=>" >> operconstr200)
+
+-- open_binders:
+-- name name* ":" lconstr
+-- name name* binders
+-- closed_binder binders
+open_binders = (many1 name >> ((reservedOp ":" >> lconstr) <|> binders))
+ <|> (closed_binder >> binders)
+
+-- binders: binder*
+binders = many binder >> return ()
+
+-- binder:
+-- name
+-- closed_binder
+binder = (name >> return ()) <|> closed_binder
+
+-- closed_binder:
+-- "(" name+ ":" lconstr ")"
+closed_binder = reservedOp "(" >> many name >> reservedOp ":" >> lconstr >> reservedOp ")" >> return ()
+
+-- appl_arg:
+-- "(" lconstr ")" -- we don't need the hack yay!
+-- operconstr.0
+appl_arg = (reservedOp "(" >> lconstr >> reservedOp ")") <|> operconstr0
+
+-- atomic_constr:
+-- global
+-- sort
+-- INT
+atomic_constr = global <|> sort <|> (integer >> return ())
+sort = (reserved "Prop" <|> reserved "Set" <|> reserved "Type") >> return ()
+
+parse_sample = "or ((forall x : U, P x) -> @ex U (fun x : U => P x)) False"
+main = parseTest (term >> eof) "forall x : U, foo -> bar" -- parse_sample
View
22 Ltac.hs
@@ -0,0 +1,22 @@
+module Ltac where
+
+import Data.List
+
+data Expr = Seq Expr [Expr]
+ -- | Progress Expr
+ -- | Solve [Expr]
+ | Tac String [String] -- technically should point to tacarg; we only allow qualids for now
+
+-- Useful atomic tactics
+admit = Tac "admit" []
+
+-- This is kind of deficient for handling tacexpr_1, tacexpr_2,
+-- tacexpr_3 parsing rules
+instance Show Expr where
+ show (Seq e1 [e2]) = show e1 ++ "; " ++ show e2
+ show (Seq e es) = show e ++ "; [ " ++ intercalate " | " (map show es) ++ " ]"
+ -- show (Progress e) = "progress " ++ show e
+ -- show (Solve es) = "solve [" ++ intercalate "|" (map show es) ++ "]"
+ show (Tac s []) = s
+ -- XXX invariant: args must be appropriately parenthesized
+ show (Tac s as) = s ++ " " ++ intercalate " " as

No commit comments for this range

Something went wrong with that request. Please try again.