haskhol-core 1.0.0 → 1.1.0
raw patch · 28 files changed
+4125/−2823 lines, 28 filesdep +acid-statedep +filepathdep +ghc-primdep ~basedep ~containersdep ~deepseq
Dependencies added: acid-state, filepath, ghc-prim, hashable, mtl, safecopy, shelly, text, text-show, th-lift, unordered-containers
Dependency ranges changed: base, containers, deepseq, parsec, pretty, template-haskell
Files
- data/BaseCtxt/.dummy +0/−0
- haskhol-core.cabal +32/−13
- src/HaskHOL/Core.hs +31/−29
- src/HaskHOL/Core/Basics.hs +368/−186
- src/HaskHOL/Core/Basics.hs-boot +1/−2
- src/HaskHOL/Core/Basics/Nets.hs +69/−52
- src/HaskHOL/Core/Ext.hs +142/−114
- src/HaskHOL/Core/Ext/Protected.hs +90/−128
- src/HaskHOL/Core/Ext/QQ.hs +16/−19
- src/HaskHOL/Core/Kernel.hs +118/−107
- src/HaskHOL/Core/Kernel/Prims.hs +159/−143
- src/HaskHOL/Core/Kernel/Terms.hs +213/−179
- src/HaskHOL/Core/Kernel/Types.hs +191/−146
- src/HaskHOL/Core/Lib.hs +594/−290
- src/HaskHOL/Core/Lib/Families.hs +31/−0
- src/HaskHOL/Core/Lib/Lift.hs +0/−158
- src/HaskHOL/Core/Parser.hs +19/−53
- src/HaskHOL/Core/Parser.hs-boot +4/−5
- src/HaskHOL/Core/Parser/Elab.hs +78/−67
- src/HaskHOL/Core/Parser/Lib.hs +646/−229
- src/HaskHOL/Core/Parser/Prims.hs +50/−0
- src/HaskHOL/Core/Parser/Rep.hs +96/−27
- src/HaskHOL/Core/Parser/Rep.hs-boot +8/−0
- src/HaskHOL/Core/Parser/TermParser.hs +204/−106
- src/HaskHOL/Core/Parser/TypeParser.hs +36/−25
- src/HaskHOL/Core/Printer.hs +160/−255
- src/HaskHOL/Core/State.hs +283/−142
- src/HaskHOL/Core/State/Monad.hs +486/−348
+ data/BaseCtxt/.dummy view
haskhol-core.cabal view
@@ -1,32 +1,49 @@ name: haskhol-core-version: 1.0.0+version: 1.1.0 synopsis: The core logical system of HaskHOL, an EDSL for HOL theorem proving. description: More details can be found at the following page: - <haskhol.org>. + http://haskhol.org. license: BSD3 license-file: LICENSE author: Evan Austin <ecaustin@ittc.ku.edu> maintainer: Evan Austin <ecaustin@ittc.ku.edu> category: Theorem Provers-cabal-version: >=1.6+cabal-version: >=1.18 build-type: Simple stability: experimental-Homepage: haskhol.org+homepage: http://haskhol.org +data-dir: data+data-files: BaseCtxt/.dummy+ library- build-depends: base >=4.5 && <5- , template-haskell >=2.7 && <3 - , parsec >=3.1 && <4- , deepseq >=1.3 && <2- , containers >=0.5 && <1- , pretty >=1.1 && <2+ default-language: Haskell2010+ default-extensions: DeriveDataTypeable, OverloadedStrings,+ QuasiQuotes, TemplateHaskell+ build-depends: base >= 4.7 && < 4.8+ , ghc-prim >= 0.3+ , template-haskell >= 2.9+ , acid-state >= 0.12+ , containers >= 0.5+ , deepseq >= 1.3+ , filepath >= 1.3+ , hashable >= 1.2+ , mtl >= 2.2+ , parsec >= 3.1+ , pretty >= 1.1+ , safecopy >= 0.8+ , shelly >= 1.5+ , text >= 1.2+ , text-show >= 0.6+ , th-lift >= 0.7+ , unordered-containers >= 0.2 exposed-modules: HaskHOL.Core HaskHOL.Core.Basics HaskHOL.Core.Lib - HaskHOL.Core.Lib.Lift+ HaskHOL.Core.Lib.Families HaskHOL.Core.Kernel HaskHOL.Core.Kernel.Terms HaskHOL.Core.Kernel.Types @@ -46,10 +63,12 @@ HaskHOL.Core.Ext.QQ HaskHOL.Core.Kernel.Prims HaskHOL.Core.Parser.Elab- HaskHOL.Core.Parser.Lib + HaskHOL.Core.Parser.Lib + HaskHOL.Core.Parser.Prims HaskHOL.Core.Parser.Rep HaskHOL.Core.Parser.TermParser - HaskHOL.Core.Parser.TypeParser + HaskHOL.Core.Parser.TypeParser + Paths_haskhol_core ghc-prof-options: -prof -fprof-auto ghc-options: -Wall
src/HaskHOL/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-| Module: HaskHOL.Core Copyright: (c) The University of Kansas 2013@@ -14,23 +15,15 @@ -} module HaskHOL.Core ( -- * 'HOLTermRep' and 'HOLTypeRep' Overloads- newConstant -- :: HOLTypeRep ty thry => - -- String -> ty -> HOL Theory thry ()- , newAxiom -- :: HOLTermRep tm thry => - -- String -> tm -> HOL Theory thry HOLThm- , newBasicDefinition -- :: HOLTermRep tm thry => - -- tm -> HOL Theory thry HOLThm- , makeOverloadable -- :: HOLTypeRep ty thry => - -- String -> ty -> HOL Theory thry ()- , reduceInterface -- :: HOLTermRep tm thry => - -- String -> tm -> HOL Theory thry ()- , overrideInterface -- :: HOLTermRep tm thry => - -- String -> tm -> HOL Theory thry ()- , overloadInterface -- :: HOLTermRep tm thry => - -- String -> tm -> HOL Theory thry ()- , prioritizeOverload -- :: HOLTypeRep ty thry => ty -> HOL Theory thry ()- , newTypeAbbrev -- :: HOLTypeRep ty thry => - -- String -> ty -> HOL Theory thry ()+ newConstant+ , newAxiom+ , newBasicDefinition+ , makeOverloadable+ , reduceInterface+ , overrideInterface+ , overloadInterface+ , prioritizeOverload+ , newTypeAbbrev -- * Library and Utility Functions , module HaskHOL.Core.Lib -- * Logical Kernel@@ -45,10 +38,11 @@ , module HaskHOL.Core.Printer -- * HaskHOL Core Extensions , module HaskHOL.Core.Ext+ , Constraint -- | A re-export of 'Constraint' from @GHC.Prim@. ) where import HaskHOL.Core.Lib-import HaskHOL.Core.Kernel+import HaskHOL.Core.Kernel hiding (axiomThm, newDefinedConst, newDefinedTypeOp) import HaskHOL.Core.State hiding ( newConstant, newAxiom, newBasicDefinition ) import HaskHOL.Core.Basics import HaskHOL.Core.Parser hiding ( makeOverloadable, reduceInterface @@ -62,27 +56,32 @@ import qualified HaskHOL.Core.Parser as P ( makeOverloadable, reduceInterface , overrideInterface, overloadInterface , prioritizeOverload, newTypeAbbrev )++-- This re-export has to exist at the top-most module for some reason?+import GHC.Prim (Constraint)+ -- from state {-| A redefinition of 'S.newConstant' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-newConstant :: HOLTypeRep ty thry => String -> ty -> HOL Theory thry ()+newConstant :: HOLTypeRep ty Theory thry => Text -> ty -> HOL Theory thry () newConstant s = S.newConstant s <=< toHTy {-| A redefinition of 'S.newAxiom' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-newAxiom :: HOLTermRep tm thry => String -> tm -> HOL Theory thry HOLThm+newAxiom :: HOLTermRep tm Theory thry => Text -> tm -> HOL Theory thry HOLThm newAxiom s = S.newAxiom s <=< toHTm {-| A redefinition of 'S.newBasicDefinition' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-newBasicDefinition :: HOLTermRep tm thry => tm -> HOL Theory thry HOLThm-newBasicDefinition = S.newBasicDefinition <=< toHTm+newBasicDefinition :: HOLTermRep tm Theory thry => Text -> tm + -> HOL Theory thry HOLThm+newBasicDefinition lbl = S.newBasicDefinition lbl <=< toHTm -- from parser@@ -90,41 +89,44 @@ A redefinition of 'P.makeOverloadable' to overload it for all valid type representations as defined by 'HOLTypeRep'. -}-makeOverloadable :: HOLTypeRep ty thry => String -> ty -> HOL Theory thry ()+makeOverloadable :: HOLTypeRep ty Theory thry => Text -> ty + -> HOL Theory thry () makeOverloadable s = P.makeOverloadable s <=< toHTy {-| A redefinition of 'P.reduceInterface' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-reduceInterface :: HOLTermRep tm thry => String -> tm -> HOL Theory thry ()+reduceInterface :: HOLTermRep tm Theory thry => Text -> tm + -> HOL Theory thry () reduceInterface s = P.reduceInterface s <=< toHTm {-| A redefinition of 'P.overrideInterface' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-overrideInterface :: HOLTermRep tm thry => - String -> tm -> HOL Theory thry ()+overrideInterface :: HOLTermRep tm Theory thry => Text -> tm + -> HOL Theory thry () overrideInterface s = P.overrideInterface s <=< toHTm {-| A redefinition of 'P.overloadInterface' to overload it for all valid term representations as defined by 'HOLTermRep'. -}-overloadInterface :: HOLTermRep tm thry => String -> tm -> HOL Theory thry ()+overloadInterface :: HOLTermRep tm Theory thry => Text -> tm + -> HOL Theory thry () overloadInterface s = P.overloadInterface s <=< toHTm {-| A redefinition of 'P.prioritizeOverload' to overload it for all valid type representations as defined by 'HOLTypeRep'. -}-prioritizeOverload :: HOLTypeRep ty thry => ty -> HOL Theory thry ()+prioritizeOverload :: HOLTypeRep ty Theory thry => ty -> HOL Theory thry () prioritizeOverload = P.prioritizeOverload <=< toHTy {-| A redefinition of 'P.newTypeAbbrev' to overload it for all valid type representations as defined by 'HOLTypeRep'. -}-newTypeAbbrev :: HOLTypeRep ty thry => String -> ty -> HOL Theory thry ()+newTypeAbbrev :: HOLTypeRep ty Theory thry => Text -> ty -> HOL Theory thry () newTypeAbbrev s = P.newTypeAbbrev s <=< toHTy
src/HaskHOL/Core/Basics.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} {-| Module: HaskHOL.Core.Basics@@ -14,109 +14,133 @@ that do not have this dependence. -} module HaskHOL.Core.Basics- ( -- * Variable Term Generation- genVarWithName -- :: String -> HOLType -> HOL cls thry HOLTerm- , genVar -- :: HOLType -> HOL cls thry HOLTerm+ ( -- * Variable Term and Type Generation+ genVarWithName+ , genVar+ , unsafeGenVarWithName+ , unsafeGenVar+ , genSmallTyVar -- * Common Type Functions- , occursIn -- :: HOLType -> HOLType -> Bool- , tysubst -- :: HOLTypeEnv -> HOLType -> Either String HOLType- , alphaUtype -- :: HOLType -> HOLType -> Either String HOLType+ , occursIn+ , tysubst+ , alphaUtype -- * Common Term Functions- , freeIn -- :: HOLTerm -> HOLTerm -> Bool- , subst -- :: HOLTermEnv -> HOLTerm -> HOL cls thry HOLTerm- , alpha -- :: HOLTerm -> HOLTerm -> Either String HOLTerm- , alphaTyabs -- :: HOLType -> HOLTerm -> Either String HOLTerm- , findTerm -- :: (HOLTerm -> Bool) -> HOLTerm -> Maybe HOLTerm- , findTerms -- :: (HOLTerm -> Bool) -> HOLTerm -> [HOLTerm]- , findPath -- :: (HOLTerm -> Bool) -> HOLTerm -> Maybe String- , followPath -- :: String -> HOLTerm -> Maybe HOLTerm+ , freeIn+ , variables+ , subst + , alpha + , alphaTyabs+ , findTerm + , findTermM+ , findTerms+ , findTermsM+ , findPath + , followPath -- * Common Theorem Functions- , typeVarsInThm -- :: HOLThm -> [HOLType]- , thmFrees -- :: HOLThm -> [HOLTerm]+ , typeVarsInThm+ , thmFrees -- * Derived Destructors and Constructors for Basic Terms- , listMkComb -- :: HOLTerm -> [HOLTerm] -> Either String HOLTerm- , listMkAbs -- :: [HOLTerm] -> HOLTerm -> Either String HOLTerm- , mkArgs -- :: String -> [HOLTerm] -> [HOLType] -> [HOLTerm]- , rator -- :: HOLTerm -> Maybe HOLTerm- , rand -- :: HOLTerm -> Maybe HOLTerm- , bndvar -- :: HOLTerm -> Maybe HOLTerm- , body -- :: HOLTerm -> Maybe HOLTerm- , bndvarTyabs -- :: HOLTerm -> Maybe HOLType- , bodyTyabs -- :: HOLTerm -> Maybe HOLTerm- , stripComb -- :: HOLTerm -> (HOLTerm, [HOLTerm])- , stripAbs -- :: HOLTerm -> ([HOLTerm], HOLTerm)+ , listMkComb + , listMkAbs + , mkArgs + , rator + , rand + , bndvar + , body + , bndvarTyabs+ , bodyTyabs + , stripComb+ , stripTyComb + , stripAbs -- * Type Matching Functions- , typeMatch -- :: HOLType -> HOLType -> SubstTrip -> Maybe SubstTrip- , mkMConst -- :: String -> HOLType -> HOL cls thry HOLTerm- , mkIComb -- :: HOLTerm -> HOLTerm -> Maybe HOLTerm- , listMkIComb -- :: String -> [HOLTerm] -> HOL cls thry HOLTerm+ , typeMatch+ , mkMConst+ , mkIComb+ , listMkIComb -- * Predicates, Constructors, and Destructors for Binary Terms- , isBinary -- :: String -> HOLTerm -> Bool- , isBinop -- :: HOLTerm -> HOLTerm -> Bool- , destBinary -- :: String -> HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destBinop -- :: HOLTerm -> HOLTerm -> Maybe (HOLTerm, HOLTerm)- , mkBinary -- :: String -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkBinop -- :: HOLTerm -> HOLTerm -> HOLTerm -> Either String HOLTerm- , listMkBinop -- :: HOLTerm -> [HOLTerm] -> Either String HOLTerm- , binops -- :: HOLTerm -> HOLTerm -> [HOLTerm]+ , isBinary + , isBinop+ , destBinary+ , pattern Binary+ , destBinop+ , mkBinary+ , mkBinop+ , listMkBinop+ , binops -- * Predicates, Constructors, and Destructors for Complex Abstractions- , isGAbs -- :: HOLTerm -> Bool- , isBinder -- :: String -> HOLTerm -> Bool- , isTyBinder -- :: String -> HOLTerm -> Bool- , destGAbs -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destBinder -- :: String -> HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destTyBinder -- :: String -> HOLTerm -> Maybe (HOLType, HOLTerm)- , mkGAbs -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkBinder -- :: String -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkTyBinder -- :: String -> HOLType -> HOLTerm -> HOL cls thry HOLTerm- , listMkGAbs -- :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm- , stripGAbs -- :: HOLTerm -> ([HOLTerm], HOLTerm)+ , isGAbs+ , isBinder + , isTyBinder+ , destGAbs+ , destBinder+ , pattern Bind+ , destTyBinder+ , pattern TyBind+ , mkGAbs+ , mkBinder+ , mkTyBinder+ , listMkGAbs+ , stripGAbs -- * Predicates, Constructors, and Destructors for Propositions- , isConj -- :: HOLTerm -> Bool- , isImp -- :: HOLTerm -> Bool- , isForall -- :: HOLTerm -> Bool- , isExists -- :: HOLTerm -> Bool- , isDisj -- :: HOLTerm -> Bool- , isNeg -- :: HOLTerm -> Bool- , isUExists -- :: HOLTerm -> Bool- , isTyAll -- :: HOLTerm -> Bool- , isTyEx -- :: HOLTerm -> Bool- , destConj -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destImp -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destForall -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destExists -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destDisj -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destNeg -- :: HOLTerm -> Maybe HOLTerm- , destUExists -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destTyAll -- :: HOLTerm -> Maybe (HOLType, HOLTerm)- , destTyEx -- :: HOLTerm -> Maybe (HOLType, HOLTerm)- , mkConj -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkImp -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkForall -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkExists -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkDisj -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkNeg -- :: HOLTerm -> HOL cls thry HOLTerm- , mkUExists -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm- , mkTyAll -- :: HOLType -> HOLTerm -> HOL cls thry HOLTerm- , mkTyEx -- :: HOLType -> HOLTerm -> HOL cls thry HOLTerm- , listMkConj -- :: [HOLTerm] -> HOL cls thry HOLTerm- , listMkDisj -- :: [HOLTerm] -> HOL cls thry HOLTerm- , listMkForall -- :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm- , listMkExists -- :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm- , conjuncts -- :: HOLTerm -> [HOLTerm]- , disjuncts -- :: HOLTerm -> [HOLTerm]- , stripForall -- :: HOLTerm -> ([HOLTerm], HOLTerm)- , stripExists -- :: HOLTerm -> ([HOLTerm], HOLTerm)- , stripTyAll -- :: HOLTerm -> ([HOLType], HOLTerm)- , stripTyEx -- :: HOLTerm -> ([HOLType], HOLTerm)+ , isIff+ , isConj+ , isImp+ , isForall+ , isExists+ , isDisj+ , isNeg+ , isUExists+ , isTyAll+ , isTyEx+ , destIff+ , pattern (:<=>)+ , destConj+ , pattern (:/\)+ , destImp+ , pattern (:==>)+ , destForall+ , pattern Forall+ , destExists+ , pattern Exists+ , destDisj+ , pattern (:\/)+ , destNeg+ , pattern Neg+ , destUExists+ , pattern UExists+ , destTyAll+ , pattern TyAll+ , destTyEx+ , pattern TyEx+ , mkIff+ , mkConj+ , mkImp+ , mkForall+ , mkExists+ , mkDisj+ , mkNeg+ , mkUExists+ , mkTyAll+ , mkTyEx+ , listMkConj+ , listMkDisj+ , listMkForall+ , listMkExists+ , conjuncts+ , disjuncts+ , stripForall+ , stripExists+ , stripTyAll+ , stripTyEx -- * Predicates, Constructors, and Destructors for Other Terms- , isCons -- :: HOLTerm -> Bool- , isList -- :: HOLTerm -> Bool- , isLet -- :: HOLTerm -> Bool- , destCons -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destList -- :: HOLTerm -> Maybe [HOLTerm]- , destLet -- :: HOLTerm -> Maybe ([(HOLTerm, HOLTerm)], HOLTerm)- , destNumeral -- :: HOLTerm -> Maybe Integer+ , isCons+ , isList+ , isLet+ , destCons+ , destList+ , destLet+ , mkLet+ , destNumeral -- * Term Nets , module HaskHOL.Core.Basics.Nets ) where@@ -126,20 +150,52 @@ import HaskHOL.Core.State import HaskHOL.Core.Basics.Nets --- Term Generation+import Data.IORef+import System.IO.Unsafe (unsafePerformIO)++-- Term and Type Generation {-| Generates a new term variable consisting of a given prefix and the next value in the fresh term counter. -}-genVarWithName :: String -> HOLType -> HOL cls thry HOLTerm+genVarWithName :: Text -> HOLType -> HOL cls thry HOLTerm genVarWithName n ty = do count <- tickTermCounter- return $! mkVar (n ++ show count) ty+ return $! mkVar (n `append` pack (show count)) ty -- | A version of 'genVarWithName' that defaults to the prefix \"_\". genVar :: HOLType -> HOL cls thry HOLTerm genVar = genVarWithName "_" +{-# NOINLINE counter #-}+counter :: IORef Int+counter = unsafePerformIO $ newIORef 0++{-|+ An unsafe version of 'genVarWithName' that attempts to create a fresh variable+ using a global counter, atomically updated via 'unsafePerformIO'. Useful if+ fresh name generation is the only side effect of a function.+-}+{-# NOINLINE unsafeGenVarWithName #-}+unsafeGenVarWithName :: Text -> HOLType -> HOLTerm+unsafeGenVarWithName n ty = + unsafePerformIO $ atomicModifyIORef counter + (\ x -> (succ x, mkVar (n `append` pack (show x)) ty))++-- | A version of 'genVarWithNamePure' that defaults to the prefix \"__\".+{-# NOINLINE unsafeGenVar #-}+unsafeGenVar :: HOLType -> HOLTerm+unsafeGenVar = unsafeGenVarWithName "__"++{-|+ Generates a new small, type variable with a name built using the fresh type+ counter.+-}+genSmallTyVar :: HOL cls thry HOLType+genSmallTyVar =+ do count <- tickTypeCounter+ liftEither "genSmallTyVar" . mkSmall $ mkVarType (pack $ '_':show count)+ -- functions for manipulating types {-| Checks to see if the first type occurs in the second type. Note that the@@ -148,7 +204,7 @@ occursIn :: HOLType -> HOLType -> Bool occursIn ty bigTy | ty == bigTy = True- | otherwise = case view bigTy of+ | otherwise = case bigTy of TyApp _ args -> any (occursIn ty) args _ -> False @@ -166,14 +222,15 @@ tysubst :: HOLTypeEnv -> HOLType -> Either String HOLType tysubst env ty = note "tysubst" (lookup ty env) - <|> case view ty of- TyVar {} -> return ty+ <|> case ty of+ TyVar{} -> return ty TyApp tycon tyvars -> (tyApp tycon =<< mapM (tysubst env) tyvars) <?> "tysubst: bad type application" UType bv bod -> (mkUType bv =<< tysubst (filter (\ (x, _) -> x /= bv) env) bod) <?> "tysubst: bad universal type"+ _ -> error "tysubst: exhaustive warning." {-| Alpha conversion for universal types. Renames a bound type variable to match@@ -187,12 +244,12 @@ * The type variable is free in the body of the universal type. -} alphaUtype :: HOLType -> HOLType -> Either String HOLType-alphaUtype tv@(view -> TyVar True _) ty@(view -> UType tv0 bod)+alphaUtype tv@(TyVar True _) ty@(UType tv0 bod) | tv == tv0 = Right ty | tv `elem` tyVars bod = Left "alphaUtype: variable free in body of type." | otherwise = mkUType tv (typeSubst [(tv0, tv)] bod) <?> "alphaUtype: construction of universal type failed."-alphaUtype _ (view -> UType{}) = +alphaUtype _ UType{} = Left "alphaUtype: first type not a small type variable." alphaUtype _ _ = Left "alphaUtype: second type not a universal type." @@ -204,13 +261,23 @@ freeIn :: HOLTerm -> HOLTerm -> Bool freeIn tm1 tm2 = (tm1 `aConv` tm2) ||- (case view tm2 of+ (case tm2 of Comb l r -> freeIn tm1 l || freeIn tm1 r Abs bv bod -> not (varFreeIn bv tm1) && freeIn tm1 bod TyAbs bv bod -> bv `elem` typeVarsInTerm tm1 && freeIn tm1 bod TyComb tm _ -> freeIn tm1 tm _ -> False) +-- | Returns all variables in a term, free and bound both.+variables :: HOLTerm -> [HOLTerm]+variables = vars []+ where vars :: [HOLTerm] -> HOLTerm -> [HOLTerm]+ vars acc tm@Var{} = insert tm acc+ vars acc Const{} = acc+ vars acc (Abs v bod) = vars (insert v acc) bod+ vars acc (Comb l r) = vars (vars acc l) r+ vars _ _ = error "variables: exhaustive warning."+ {-| Basic term substitution. Throws a 'HOLException' when the substitution would result in an invalid term construction.@@ -219,21 +286,21 @@ environments in the systems, such that for the pair @(A, B)@ @B@ will be substituted for all instances of @A@. -}-subst :: HOLTermEnv -> HOLTerm -> HOL cls thry HOLTerm+subst :: HOLTermEnv -> HOLTerm -> Maybe HOLTerm subst ilist tm =- let (xs, ts) = unzip ilist in- do gs <- mapM (genVar . typeOf) xs- tm' <- liftEither "subst" $ ssubst (zip xs gs) tm+ let (xs, ts) = unzip ilist+ gs = map (unsafeGenVar . typeOf) xs in+ do tm' <- hush $ ssubst (zip xs gs) tm if tm' == tm then return tm- else return $! varSubst (zip gs ts) tm'+ else varSubst (zip gs ts) tm' where ssubst :: HOLTermEnv -> HOLTerm -> Either String HOLTerm ssubst [] t = Right t ssubst env t = case find (\ (t', _) -> t `aConv` t') env of Just (_, res) -> Right res Nothing ->- case view t of+ case t of Comb f x -> liftM1 mkComb (ssubst env f) =<< ssubst env x Abs bv bod -> @@ -260,13 +327,13 @@ * The variable is free in the body of the abstraction. -} alpha :: HOLTerm -> HOLTerm -> Either String HOLTerm-alpha v@(view -> Var _ ty) tm@(view -> Abs v0@(view -> Var _ ty0) bod)+alpha v@(Var _ ty) tm@(Abs v0@(Var _ ty0) bod) | v == v0 = Right tm | ty /= ty0 = Left "alpha: types of variables not equal." | v `varFreeIn` bod = Left "alpha: variable free in body of abstraction."- | otherwise = mkAbs v (varSubst [(v0, v)] bod) <?> + | otherwise = (mkAbs v #<< varSubst [(v0, v)] bod) <?> "alpha: construction of abstraction failed."-alpha _ (view -> Abs{}) = Left "alpha: first term not a variable."+alpha _ Abs{} = Left "alpha: first term not a variable." alpha _ _ = Left "alpha: second term not an abstraction." {-|@@ -281,12 +348,12 @@ * The type is free in the body of the type abstraction. -} alphaTyabs :: HOLType -> HOLTerm -> Either String HOLTerm-alphaTyabs ty@(view -> TyVar True _) tm@(view -> TyAbs ty0 bod)+alphaTyabs ty@(TyVar True _) tm@(TyAbs ty0 bod) | ty == ty0 = Right tm | ty `elem` typeVarsInTerm bod = Left "alphaTyabs: type free in body of type abstraction." | otherwise = mkTyAbs ty $ inst [(ty0, ty)] bod-alphaTyabs _ (view -> TyAbs{}) = +alphaTyabs _ TyAbs{} = Left "alphaTyabs: type not a small type variable." alphaTyabs _ _ = Left "alphaTyabs: term not a type abstraction."@@ -300,26 +367,56 @@ findTerm p tm | p tm = Just tm | otherwise =- case view tm of+ case tm of Abs _ bod -> findTerm p bod Comb l r -> findTerm p l <|> findTerm p r TyAbs _ bod -> findTerm p bod TyComb tm' _ -> findTerm p tm' _ -> Nothing +-- | The monadic version of 'findTerm'.+findTermM :: (Alternative m, Monad m) => (HOLTerm -> m Bool) -> HOLTerm + -> m HOLTerm+findTermM p tm =+ do c <- p tm + if c+ then return tm+ else case tm of+ Abs _ bod -> findTermM p bod+ Comb l r -> findTermM p l <|> findTermM p r+ TyAbs _ bod -> findTermM p bod+ TyComb tm' _ -> findTermM p tm'+ _ -> fail "findTermM"+ -- | Searches a term for all unique subterms that satisfy a given predicate. findTerms :: (HOLTerm -> Bool) -> HOLTerm -> [HOLTerm]-findTerms = findRec []- where findRec :: [HOLTerm] -> (HOLTerm -> Bool) -> HOLTerm -> [HOLTerm]- findRec tl p tm =+findTerms p = findRec []+ where findRec :: [HOLTerm] -> HOLTerm -> [HOLTerm]+ findRec tl tm = let tl' = if p tm then insert tm tl else tl in- case view tm of- Abs _ bod -> findRec tl' p bod- Comb l r -> findRec (findRec tl' p l) p r- TyAbs _ bod -> findRec tl' p bod- TyComb tm' _ -> findRec tl' p tm'+ case tm of+ Abs _ bod -> findRec tl' bod+ Comb l r -> findRec (findRec tl' l) r+ TyAbs _ bod -> findRec tl' bod+ TyComb tm' _ -> findRec tl' tm' _ -> tl' +-- | The monadic version of 'findTerms'.+findTermsM :: forall m. (Alternative m, Monad m) => (HOLTerm -> m Bool) + -> HOLTerm -> m [HOLTerm]+findTermsM p = findRec []+ where findRec :: (Alternative m, Monad m) => [HOLTerm] -> HOLTerm + -> m [HOLTerm]+ findRec tl tm =+ do c <- (p tm <|> return False)+ let tl' = if c then insert tm tl else tl+ case tm of+ Abs _ bod -> findRec tl' bod+ Comb l r -> liftM1 findRec (findRec tl' l) r+ TyAbs _ bod -> findRec tl' bod+ TyComb tm' _ -> findRec tl' tm'+ _ -> return tl'+ -- Director strings down a term {-| Searches a term for a subterm that satisfies a given predicate, returning@@ -341,7 +438,7 @@ findPath p tm | p tm = Just [] | otherwise =- case view tm of+ case tm of Abs _ bod -> liftM ((:) 'b') $ findPath p bod TyAbs _ bod -> liftM ((:) 't') $ findPath p bod Comb l r -> liftM ((:) 'r') (findPath p r) <|>@@ -356,23 +453,25 @@ -} followPath :: String -> HOLTerm -> Maybe HOLTerm followPath [] tm = Just tm-followPath ('l':t) (view -> Comb l _) = followPath t l-followPath ('r':t) (view -> Comb _ r) = followPath t r-followPath ('c':t) (view -> TyComb tm _) = followPath t tm-followPath ('b':t) (view -> Abs _ bod) = followPath t bod-followPath ('t':t) (view -> TyAbs _ bod) = followPath t bod+followPath ('l':t) (Comb l _) = followPath t l+followPath ('r':t) (Comb _ r) = followPath t r+followPath ('c':t) (TyComb tm _) = followPath t tm+followPath ('b':t) (Abs _ bod) = followPath t bod+followPath ('t':t) (TyAbs _ bod) = followPath t bod followPath _ _ = Nothing -- theorem manipulators -- | Returns the list of all free type variables in a theorem. typeVarsInThm :: HOLThm -> [HOLType]-typeVarsInThm (view -> Thm asl c) =+typeVarsInThm (Thm asl c) = foldr (union . typeVarsInTerm) (typeVarsInTerm c) asl+typeVarsInThm _ = error "typeVarsInThm: exhaustive warning." -- | Returns the list of all free term variables in a theorem. thmFrees :: HOLThm -> [HOLTerm]-thmFrees (view -> Thm asl c) = +thmFrees (Thm asl c) = foldr (union . frees) (frees c) asl+thmFrees _ = error "typeVarsInThm: exhaustive warning." -- more syntax {-|@@ -399,13 +498,13 @@ > mkArgs "x" avoids [ty1, ... tyn] === [x1:ty1, ..., xn:tyn] where {x1, ..., xn} are not elements of avoids -}-mkArgs :: String -> [HOLTerm] -> [HOLType] -> [HOLTerm]+mkArgs :: Text -> [HOLTerm] -> [HOLType] -> [HOLTerm] mkArgs s avoid (ty:[]) = [variant avoid $ mkVar s ty] mkArgs s avoid tys = mkRec 0 s avoid tys- where mkRec :: Int -> String -> [HOLTerm] -> [HOLType] -> [HOLTerm]+ where mkRec :: Int -> Text -> [HOLTerm] -> [HOLType] -> [HOLTerm] mkRec _ _ _ [] = [] mkRec n x avs (y:ys) =- let v' = variant avs $ mkVar (x ++ show n) y+ let v' = variant avs $ mkVar (x `append` pack (show n)) y vs = mkRec (n + 1) x (v':avs) ys in (v':vs) @@ -414,7 +513,7 @@ term is not a combination. -} rator :: HOLTerm -> Maybe HOLTerm-rator (view -> Comb l _) = Just l+rator (Comb l _) = Just l rator _ = Nothing {-|@@ -422,7 +521,7 @@ term is not a combination. -} rand :: HOLTerm -> Maybe HOLTerm-rand (view -> Comb _ r) = Just r+rand (Comb _ r) = Just r rand _ = Nothing {-|@@ -430,7 +529,7 @@ provided term is not an abstraction. -} bndvar :: HOLTerm -> Maybe HOLTerm-bndvar (view -> Abs bv _) = Just bv+bndvar (Abs bv _) = Just bv bndvar _ = Nothing {-|@@ -438,7 +537,7 @@ provided term is not an abstraction. -} body :: HOLTerm -> Maybe HOLTerm-body (view -> Abs _ bod) = Just bod+body (Abs _ bod) = Just bod body _ = Nothing {-|@@ -446,7 +545,7 @@ provided term is not a type abstraction. -} bndvarTyabs :: HOLTerm -> Maybe HOLType-bndvarTyabs (view -> TyAbs bv _) = Just bv+bndvarTyabs (TyAbs bv _) = Just bv bndvarTyabs _ = Nothing {-|@@ -454,7 +553,7 @@ provided term is not a type abstraction. -} bodyTyabs :: HOLTerm -> Maybe HOLTerm-bodyTyabs (view -> TyAbs _ bod) = Just bod+bodyTyabs (TyAbs _ bod) = Just bod bodyTyabs _ = Nothing {-|@@ -465,6 +564,13 @@ stripComb = revSplitList destComb {-|+ Destructs a complex type combination returning its function term and its + list of argument types.+-}+stripTyComb :: HOLTerm -> (HOLTerm, [HOLType])+stripTyComb = revSplitList destTyComb++{-| Destructs a complex abstraction returning its list of bound variables and its body term. -}@@ -484,7 +590,7 @@ return snd <*> typeMatchRec vty cty ([], sofar) where typeMatchRec :: HOLType -> HOLType -> ([HOLType], SubstTrip) -> Maybe ([HOLType], SubstTrip)- typeMatchRec v@(view -> TyVar{}) c acc@(env, (sfar, opTys, opOps))+ typeMatchRec v@TyVar{} c acc@(env, (sfar, opTys, opOps)) | v `elem` env = Just acc | otherwise = case lookup v sfar of@@ -492,13 +598,13 @@ | c' == c -> Just acc | otherwise -> Nothing Nothing -> Just (env, ((v, c):sfar, opTys, opOps))- typeMatchRec (view -> UType tvv varg) - (view -> UType tvc carg) (env, sfar) =+ typeMatchRec (UType tvv varg) + (UType tvc carg) (env, sfar) = let carg' = if tvv == tvc then carg else typeSubst [(tvc, tvv)] carg in typeMatchRec varg carg' (tvv:env, sfar)- typeMatchRec (view -> TyApp vop vargs) - (view -> TyApp cop cargs) acc@(env, (sfar, opTys, opOps))+ typeMatchRec (TyApp vop vargs) + (TyApp cop cargs) acc@(env, (sfar, opTys, opOps)) | vop == cop = foldr2M typeMatchRec acc vargs cargs | isTypeOpVar vop && isTypeOpVar cop = do copTy <- hush . uTypeFromTypeOpVar cop $ length cargs@@ -532,7 +638,7 @@ * Type matching fails. -}-mkMConst :: String -> HOLType -> HOL cls thry HOLTerm+mkMConst :: Text -> HOLType -> HOL cls thry HOLTerm mkMConst name ty = do uty <- getConstType name <?> "mkMConst: not a constant name" (mkConstFull name . fromJust $ typeMatch uty ty ([], [], [])) <?>@@ -559,7 +665,7 @@ * Any internal call to mkIComb fails. -}-listMkIComb :: String -> [HOLTerm] -> HOL cls thry HOLTerm+listMkIComb :: Text -> [HOLTerm] -> HOL cls thry HOLTerm listMkIComb cname args = do cnst <- mkConst cname ([]::HOLTypeEnv) <?> "listMkIComb: not a constant name"@@ -571,13 +677,13 @@ Predicate that tests if a term is a binary application whose operator has the given name. -}-isBinary :: String -> HOLTerm -> Bool-isBinary s (view -> Comb (view -> Comb (view -> Const s' _ _) _) _) = s == s'+isBinary :: Text -> HOLTerm -> Bool+isBinary s (Comb (Comb (Const s' _) _) _) = s == s' isBinary _ _ = False -- | A version of 'isBinary' that tests for operator terms, not strings. isBinop :: HOLTerm -> HOLTerm -> Bool-isBinop op (view -> Comb (view -> Comb op' _) _) = op' == op+isBinop op (Comb (Comb op' _) _) = op' == op isBinop _ _ = False {-|@@ -585,15 +691,18 @@ with 'Nothing' if the provided term is not a binary application with the specified operator name. -}-destBinary :: String -> HOLTerm -> Maybe (HOLTerm, HOLTerm)-destBinary s (view -> Comb (view -> Comb (view -> Const s' _ _) l) r)+destBinary :: Text -> HOLTerm -> Maybe (HOLTerm, HOLTerm)+destBinary s (Comb (Comb (Const s' _) l) r) | s == s' = Just (l, r) | otherwise = Nothing destBinary _ _ = Nothing +-- | The pattern synonym equivalent of 'destBinary'.+pattern Binary s l r <- Comb (Comb (Const s _) l) r+ -- | A version of 'destBinary' that tests for operator terms, not strings. destBinop :: HOLTerm -> HOLTerm -> Maybe (HOLTerm, HOLTerm)-destBinop op (view -> Comb (view -> Comb op' l) r)+destBinop op (Comb (Comb op' l) r) | op' == op = Just (l, r) | otherwise = Nothing destBinop _ _ = Nothing@@ -604,11 +713,12 @@ or the provided arguments must match the constant's general type. Throws a 'HOLException' if any of the internal calls to 'mkConst' or 'mkComb' fail. -}-mkBinary :: String -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkBinary :: Text -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm mkBinary s l r = (do c <- mkConst s ([]::HOLTypeEnv)- fromRightM $ mkComb (fromRight $ mkComb c l) r)- <?> "mkBinary: " ++ s+ let c' = inst [(tyA, typeOf l), (tyB, typeOf r)] c+ fromRightM $ mkComb (fromRight $ mkComb c' l) r)+ <?> "mkBinary: " ++ show s {-| A version of 'mkBinary' that accepts the operator as a pre-constructed term.@@ -638,16 +748,16 @@ isGAbs = isJust . destGAbs -- | Predicate that tests if a term is an abstraction of specified binder name.-isBinder :: String -> HOLTerm -> Bool-isBinder s (view -> Comb (view -> Const s' _ _) (view -> Abs{})) = s == s'+isBinder :: Text -> HOLTerm -> Bool+isBinder s (Comb (Const s' _) Abs{}) = s == s' isBinder _ _ = False {-| Predicate that tests if a term is an abtraction of a specified type binder name. -}-isTyBinder :: String -> HOLTerm -> Bool-isTyBinder s (view -> Comb (view -> Const s' _ _) (view -> TyAbs{})) = s == s'+isTyBinder :: Text -> HOLTerm -> Bool+isTyBinder s (Comb (Const s' _) TyAbs{}) = s == s' isTyBinder _ _ = False {-| @@ -656,9 +766,11 @@ details. -} destGAbs :: HOLTerm -> Maybe (HOLTerm, HOLTerm)-destGAbs tm@(view -> Abs{}) = destAbs tm-destGAbs (view -> Comb (view -> Const "GABS" _ _) (view -> Abs _ bod)) =- firstM rand =<< (destGeq . snd $ stripForall bod)+destGAbs tm@Abs{} = destAbs tm+destGAbs (Comb (Const "GABS" _) (Abs _ bod)) =+ do (ltm, rtm) <- destGeq . snd $ stripForall bod+ ltm' <- rand ltm+ return (ltm', rtm) where destGeq :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destGeq = destBinary "GEQ" destGAbs _ = Nothing@@ -668,23 +780,29 @@ its body term. Fails with 'Nothing' if the provided term is not an abstraction with the specified binder name. -}-destBinder :: String -> HOLTerm -> Maybe (HOLTerm, HOLTerm)-destBinder s (view -> Comb (view -> Const s' _ _) (view -> Abs bv t))+destBinder :: Text -> HOLTerm -> Maybe (HOLTerm, HOLTerm)+destBinder s (Comb (Const s' _) (Abs bv t)) | s == s' = Just (bv, t) | otherwise = Nothing destBinder _ _ = Nothing +-- | The pattern synonym equivalent of 'destBinder'.+pattern Bind s bv tm <- Comb (Const s _) (Abs bv tm)+ {-| Destructs a type abstraction of specified binder name into its bound type variable and its body term. Fails with 'Nothing' if the provided term is not a type abstraction with the specified type binder name. -}-destTyBinder :: String -> HOLTerm -> Maybe (HOLType, HOLTerm)-destTyBinder s (view -> Comb (view -> Const s' _ _) (view -> TyAbs bv t))+destTyBinder :: Text -> HOLTerm -> Maybe (HOLType, HOLTerm)+destTyBinder s (Comb (Const s' _) (TyAbs bv t)) | s == s' = Just (bv, t) | otherwise = Nothing destTyBinder _ _ = Nothing +-- | The pattern synonym equivalent of 'destTyBinder'.+pattern TyBind s ty tm <- Comb (Const s _) (TyAbs ty tm)+ {-| Constructor for generalized abstractions. Generalized abstractions extend term abstractions to the more general of notion of a function mapping some@@ -701,8 +819,8 @@ just calls 'mkAbs'. -} mkGAbs :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm-mkGAbs tm1@(view -> Var{}) tm2 =- liftEither "mkGAbs: simple abstraction failed" $ mkAbs tm1 tm2+mkGAbs tm1@Var{} tm2 =+ mkAbs tm1 tm2 <#?> "mkGAbs: simple abstraction failed" mkGAbs tm1 tm2 = let fvs = frees tm1 in (do fTy <- mkFunTy (typeOf tm1) $ typeOf tm2@@ -725,11 +843,11 @@ @(A -> *) -> *@, such that a well-typed term of the form @c (\\x . t)@ can be produced. -}-mkBinder :: String -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkBinder :: Text -> HOLTerm -> HOLTerm -> HOL cls thry HOLTerm mkBinder op v tm = (do c <- mkConst op [(tyA, typeOf v)] fromRightM $ mkComb c =<< mkAbs v tm)- <?> "mkBinder: " ++ op+ <?> "mkBinder: " ++ show op {-| Constructs a type abstraction given a type binder name, a type variable to@@ -740,11 +858,11 @@ @(% 'a . *) -> *@, such that a well-typed term of the form @c (\\\\x . t)@ can be produced. -}-mkTyBinder :: String -> HOLType -> HOLTerm -> HOL cls thry HOLTerm+mkTyBinder :: Text -> HOLType -> HOLTerm -> HOL cls thry HOLTerm mkTyBinder op v tm = (do c <- mkConst op ([]::HOLTypeEnv) fromRightM $ mkComb c =<< mkTyAbs v tm)- <?> "mkTyBinder: " ++ op+ <?> "mkTyBinder: " ++ show op -- | A specific version of 'listMkAbs' for general abstractions. listMkGAbs :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm@@ -755,6 +873,11 @@ stripGAbs = splitList destGAbs -- common special cases of binary ops+-- | Predicate for biconditionals.+isIff :: HOLTerm -> Bool+isIff (Comb (Comb (Const "=" (TyBool :-> _)) _) _) = True+isIff _ = False+ -- | Predicate for boolean conjunctions. isConj :: HOLTerm -> Bool isConj = isBinary "/\\"@@ -777,7 +900,7 @@ -- | Predicate for boolean negations. isNeg :: HOLTerm -> Bool-isNeg (view -> Comb (view -> Const "~" _ _) _) = True+isNeg (Comb (Const "~" _) _) = True isNeg _ = False -- | Predicate for unique, existential quantification.@@ -792,45 +915,90 @@ isTyEx :: HOLTerm -> Bool isTyEx = isTyBinder "??" +-- | Destructor for biconditionals.+destIff :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destIff (Comb (Comb (Const "=" (TyBool :-> _)) l) r) = Just (l, r)+destIff _ = Nothing++-- | The pattern synonym equivalent of 'destIff'.+pattern l :<=> r <- Comb (Comb (Const "=" (TyBool :-> TyBool :-> TyBool)) l) r+ -- | Destructor for boolean conjunctions. destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destConj = destBinary "/\\" +-- | The pattern synonym equivalent of 'destConj'.+pattern l :/\ r <- Binary "/\\" l r+ -- | Destructor for boolean implications. destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destImp = destBinary "==>" +-- | The pattern synonym equivalent of 'destImp'.+pattern l :==> r <- Binary "==>" l r+ -- | Destructor for universal term quantification. destForall :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destForall = destBinder "!" +-- | The pattern synonym equivalent of 'destForall'.+pattern Forall bv tm <- Bind "!" bv tm+ -- | Destructor for existential term quantification. destExists :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destExists = destBinder "?" +-- | The pattern synonym equivalent of 'destExists'.+pattern Exists bv tm <- Bind "?" bv tm+ -- | Destructor for boolean disjunctions. destDisj :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destDisj = destBinary "\\/" +-- | The pattern synonym equivalent of 'destDisj'.+pattern l :\/ r <- Binary "\\/" l r+ -- | Destructor for boolean negations. destNeg :: HOLTerm -> Maybe HOLTerm-destNeg (view -> Comb (view -> Const "~" _ _) p) = Just p+destNeg (Comb (Const "~" _) p) = Just p destNeg _ = Nothing +-- | The pattern synonym equivalent of 'destNeg'.+pattern Neg tm <- (Comb (Const "~" _) tm)+ -- | Destructor for unique, existential quantification. destUExists :: HOLTerm -> Maybe (HOLTerm, HOLTerm) destUExists = destBinder "?!" +-- | The pattern synonym equivalent of 'destUExists'.+pattern UExists bv tm <- Bind "?!" bv tm+ -- | Destructor for term-level universal type quantification. destTyAll :: HOLTerm -> Maybe (HOLType, HOLTerm) destTyAll = destTyBinder "!!" +-- | The pattern synonym equivalent of 'destTyAll'.+pattern TyAll ty tm <- TyBind "!!" ty tm+ -- | Destructor for term-level existential type quantification. destTyEx :: HOLTerm -> Maybe (HOLType, HOLTerm) destTyEx = destTyBinder "??" +-- | The pattern synonym equivalent of 'destTyEx'.+pattern TyEx ty tm <- TyBind "??" ty tm+ {-| Constructor for boolean conjunctions. Throws a 'HOLException' if the internal+ calls to 'mkComb' fail.+-}+mkIff :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkIff l r =+ (do bicond <- mkConst "=" [(tyA, tyBool)]+ fromRightM $ flip mkComb r =<< mkComb bicond l)+ <?> "mkIff"++{-|+ Constructor for boolean conjunctions. Throws a 'HOLException' if the internal call to 'mkBinary' fails. -} mkConj :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm@@ -966,8 +1134,8 @@ destList :: HOLTerm -> Maybe [HOLTerm] destList tm = let (tms, nil) = splitList destCons tm in- case view nil of- (Const "NIL" _ _) -> Just tms+ case nil of+ (Const "NIL" _) -> Just tms _ -> Nothing {-|@@ -979,27 +1147,41 @@ destLet :: HOLTerm -> Maybe ([(HOLTerm, HOLTerm)], HOLTerm) destLet tm = case stripComb tm of- (view -> Const "LET" _ _, a:args) ->+ (Const "LET" _, a:args) -> let (vars, lebod) = stripGAbs a eqs = zip vars args in- case view lebod of- Comb (view -> Const "LET_END" _ _) bod -> Just (eqs, bod)+ case lebod of+ Comb (Const "LET_END" _) bod -> Just (eqs, bod) _ -> Nothing _ -> Nothing {-|+ Constructs a let binding term provided a list of variable/value pairs and a+ body term.+-}+mkLet :: [(HOLTerm, HOLTerm)] -> HOLTerm -> HOL cls thry HOLTerm+mkLet assigs bod =+ do tmLetEnd <- mkConst "LET_END" [(tyA, typeOf bod)]+ let (ls, rs) = unzip assigs+ lend = fromRight $ mkComb tmLetEnd bod+ lbod <- listMkGAbs ls lend+ let (ty1, ty2) = fromJust . destFunTy $ typeOf lbod+ tmLet <- mkConst "LET" [(tyA, ty1), (tyB, ty2)]+ liftO $ listMkComb tmLet (lbod:rs)++{-| Converts a numeral term to an 'Integer'. Fails with 'Nothing' if internally the term is not of the form > NUMERAL bits _0, where bits is a series of BIT0 and BIT1 terms -} destNumeral :: HOLTerm -> Maybe Integer-destNumeral (view -> Comb (view -> Const "NUMERAL" _ _) r) = destNum r- where destNum :: HOLTerm -> Maybe Integer- destNum (view -> Const "_0" _ _) = Just 0- destNum (view -> Comb (view -> Const "BIT0" _ _) r') =+destNumeral (Comb (Const "NUMERAL" _) r) = destNum r+ where destNum :: Num a => HOLTerm -> Maybe a+ destNum (Const "_0" _) = Just 0+ destNum (Comb (Const "BIT0" _) r') = liftM (2 *) $ destNum r'- destNum (view -> Comb (view -> Const "BIT1" _ _) r') =+ destNum (Comb (Const "BIT1" _) r') = liftM (\ x -> 1 + 2 * x) $ destNum r' destNum _ = Nothing destNumeral _ = Nothing
src/HaskHOL/Core/Basics.hs-boot view
@@ -1,8 +1,7 @@ module HaskHOL.Core.Basics where import HaskHOL.Core.Kernel-import HaskHOL.Core.State -genVar :: HOLType -> HOL cls thry HOLTerm+unsafeGenVar :: HOLType -> HOLTerm stripComb :: HOLTerm -> (HOLTerm, [HOLTerm])
src/HaskHOL/Core/Basics/Nets.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}-+{-# LANGUAGE PatternSynonyms #-} {-| Module: HaskHOL.Core.Basics.Nets Copyright: (c) The University of Kansas 2013@@ -19,17 +18,16 @@ -} module HaskHOL.Core.Basics.Nets ( Net- , netEmpty -- :: Net a- , netEnter -- :: Ord a => [HOLTerm] -> (HOLTerm, a) -> Net a -> - -- HOL cls thry (Net a)- , netLookup -- :: HOLTerm -> Net a -> [a]- , netMerge -- :: Ord a => Net a -> Net a -> Net a+ , netEmpty+ , netMap+ , netEnter+ , netLookup+ , netMerge ) where import HaskHOL.Core.Lib import HaskHOL.Core.Kernel-import HaskHOL.Core.State-import {-# SOURCE #-} HaskHOL.Core.Basics (genVar, stripComb)+import {-# SOURCE #-} HaskHOL.Core.Basics (unsafeGenVar, stripComb) -- ordered, unique insertion for sets as lists setInsert :: Ord a => a -> [a] -> [a]@@ -54,13 +52,15 @@ -- The data type that defines a label for each node in a term net. data TermLabel = VNet -- variables- | LCNet String Int -- local constants- | CNet String Int -- constants+ | LCNet Text Int -- local constants+ | CNet Text Int -- constants | LNet Int -- term abstraction | LTyAbs -- type abstraction | LTyComb -- type combination- deriving (Eq, Show)- + deriving (Eq, Ord, Show, Typeable)++deriveSafeCopy 0 'base ''TermLabel+ {-| Internally, 'Net's are represented with a tree structure; each node has a list of labeled branches and a list of values. The node labels are generated via@@ -81,49 +81,68 @@ of the form @x \`op\` x@ will match any term of the form @a \`op\` b@ regardless of the values of @a@ and @b@. -}-data Net a = NetNode [(TermLabel, Net a)] [a] deriving Show+data Net a = NetNode !(Map TermLabel (Net a)) [a] deriving (Show, Typeable) +--EvNote: GHC7.10 broke auto-deriving for SafeCopy+deriveSafeCopy 0 'base ''Net+{-+instance SafeCopy a => SafeCopy (Net a) where+ putCopy (NetNode m xs) = contain $ do p1 <- getSafePut+ p2 <- getSafePut+ p1 m+ p2 xs+ return ()+ getCopy = contain $ do g1 <- getSafeGet+ g2 <- getSafeGet+ return NetNode <*> g1 <*> g2+ version = 0+ kind = base+-}+ -- | The empty 'Net'. netEmpty :: Net a-netEmpty = NetNode [] []+netEmpty = NetNode mapEmpty [] +-- | A version of 'map' for Nets.+netMap :: (a -> b) -> Net a -> Net b+netMap f (NetNode xs ys) =+ NetNode (mapMap (netMap f) xs) $ map f ys+ {- Generates a net node label given a pattern term. Differs from labelToLookup in that it accepts a list of variables to treat as local constants when generating the label. -}-labelToStore :: [HOLTerm] -> HOLTerm -> HOL cls thry (TermLabel, [HOLTerm])+labelToStore :: [HOLTerm] -> HOLTerm -> (TermLabel, [HOLTerm]) labelToStore lconsts tm = let (op, args) = stripComb tm in- case view op of- (Const x _ _) -> return (CNet x (length args), args)+ case op of+ (Const x _) -> (CNet x (length args), args) (Abs bv bod) -> - do bod' <- if bv `elem` lconsts- then do v <- genVar $ typeOf bv- return $! varSubst [(bv, v)] bod- else return bod- return (LNet (length args), bod':args)- (TyAbs _ t) -> return (LTyAbs, [t])- (TyComb t _) -> return (LTyComb, [t])- (Var x _) -> return $! if op `elem` lconsts- then (LCNet x (length args), args)- else (VNet, [])+ let bod' = if bv `elem` lconsts+ then let v = unsafeGenVar $ typeOf bv in+ fromJust $ varSubst [(bv, v)] bod+ else bod in+ (LNet (length args), bod':args)+ (TyAbs _ t) -> (LTyAbs, [t])+ (TyComb t _) -> (LTyComb, [t])+ (Var x _) -> if op `elem` lconsts+ then (LCNet x (length args), args)+ else (VNet, []) _ -> error "labelToStore: stripComb broken" {- Used by enter in order to update a net. Recursively generates node labels for the provided pattern using labelToStore. -}-netUpdate :: Ord a => [HOLTerm] -> (a, [HOLTerm], Net a) -> HOL cls thry (Net a)+netUpdate :: Ord a => [HOLTerm] -> (a, [HOLTerm], Net a) -> Net a netUpdate _ (b, [], NetNode edges tips) = - return . NetNode edges $ setInsert b tips+ NetNode edges $ setInsert b tips netUpdate lconsts (b, tm:rtms, NetNode edges tips) =- do (label, ntms) <- labelToStore lconsts tm- let (child, others) = case remove (\ (x, _) -> x == label) edges of- Just edges' -> (snd `ffComb` id) edges'- Nothing -> (netEmpty, edges)- newChild <- netUpdate lconsts (b, ntms++rtms, child)- return $! NetNode ((label, newChild):others) tips+ let (label, ntms) = labelToStore lconsts tm+ (child, others) = fromMaybe (netEmpty, edges) $ mapRemove label edges+ newChild = netUpdate lconsts (b, ntms++rtms, child) in+ NetNode (mapInsert label newChild others) tips {-| Inserts a new element, paired with a pattern term, into a provided net. The @@ -133,7 +152,7 @@ Never fails. -}-netEnter :: Ord a => [HOLTerm] -> (HOLTerm, a) -> Net a -> HOL cls thry (Net a)+netEnter :: Ord a => [HOLTerm] -> (HOLTerm, a) -> Net a -> Net a netEnter lconsts (tm, b) net = netUpdate lconsts (b, [tm], net) {-@@ -143,8 +162,8 @@ labelForLookup :: HOLTerm -> (TermLabel, [HOLTerm]) labelForLookup tm = let (op, args) = stripComb tm in- case view op of- (Const x _ _ ) -> (CNet x (length args), args)+ case op of+ (Const x _) -> (CNet x (length args), args) (Abs _ bod) -> (LNet (length args), bod:args) (TyAbs _ t) -> (LTyAbs, [t]) (TyComb t _) -> (LTyComb, [t])@@ -160,11 +179,11 @@ follow ([], NetNode _ tips) = tips follow (tm:rtms, NetNode edges _) = let (label, ntms) = labelForLookup tm- collection = case lookup label edges of+ collection = case mapLookup label edges of Just child -> follow (ntms++rtms, child) Nothing -> [] in if label == VNet then collection- else case lookup VNet edges of+ else case mapLookup VNet edges of Just vn -> collection ++ follow (rtms, vn) Nothing -> collection @@ -183,14 +202,12 @@ -} netMerge :: Ord a => Net a -> Net a -> Net a netMerge (NetNode l1 data1) (NetNode l2 data2) =- NetNode (foldr addNode (foldr addNode [] l1) l2) $ setMerge data1 data2- where addNode :: Ord a => (TermLabel, Net a) -> [(TermLabel, Net a)] ->- [(TermLabel, Net a)]- addNode p@(lab, net) l =- case remove (\ (x, _) -> x == lab) l of- Just ((lab', net'), rest) ->- (lab', netMerge net net'):rest- Nothing -> p:l- --- Lift derivations-deriveLiftMany [''TermLabel, ''Net]+ NetNode (mapFoldrWithKey addNode (mapFoldrWithKey addNode mapEmpty l1) l2) $+ setMerge data1 data2+ where addNode :: Ord a => TermLabel -> Net a -> Map TermLabel (Net a) ->+ Map TermLabel (Net a)+ addNode lab net l =+ case mapRemove lab l of+ Just (net', rest) ->+ mapInsert lab (netMerge net net') rest+ Nothing -> mapInsert lab net l
src/HaskHOL/Core/Ext.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}-+{-# LANGUAGE ScopedTypeVariables #-} {-| Module: HaskHOL.Core.Ext Copyright: (c) The University of Kansas 2013@@ -28,8 +27,8 @@ -- $QQ , module HaskHOL.Core.Ext.QQ -- * Theory Extension Methods- , extendCtxt -- :: Typeable thry => HOLContext thry -> - -- HOL cls thry () -> Name -> String -> Q [Dec]+ , templateProvers+ , extendTheory -- * Template Haskell Re-Exports , module Language.Haskell.TH {-| Re-exports 'Q', 'Dec', and 'Exp' for the purpose of writing type@@ -41,75 +40,74 @@ -} ) where -import HaskHOL.Core.Lib-import HaskHOL.Core.Kernel hiding (typeOf)-import HaskHOL.Core.State+import HaskHOL.Core.Lib hiding (combine)+import HaskHOL.Core.State.Monad import HaskHOL.Core.Ext.Protected import HaskHOL.Core.Ext.QQ import Data.Char (toUpper, toLower)-import Data.Typeable (typeOf, typeRepArgs, TypeRep) import Language.Haskell.TH (Q, Dec, Exp) import Language.Haskell.TH.Quote (QuasiQuoter)-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax +import Prelude hiding (FilePath)+import Paths_haskhol_core+import Shelly+import System.FilePath (combine)+ {-|- Extends a theory by evaluating a provided computation, returning a list of- declarations containing:+ The 'templateTypes' splice automatically generates the types and type + families associated with a theory extension. It constructs the following: * A new empty data declaration associated with the new theory. - * A new type class associated with the new theory to be used with- @DerivedCtxt@ along with the appropriate instances.-- * The context value for the new theory.-- * A class constraint alias that can be safely exported for use in type- signatures external to the library where it was defined.-- * A quasiquoter for the new theory.-- * A compile-time proof function for the new theory.+ * A type synonym for the application of the new data type. - For example:+ * A closed type family for constraining computations to be used only with+ contexts containing this checkpoint.+ + The first argument is the context to be extended and the second argument is+ the name of the new theory checkpoint.+ For example, - > extendCtxt ctxtBase loadBoolLib "bool"+ > templateTypes ctxtBase "Bool" - will produce the following code+ will produce the following declarations: - > data BoolThry deriving Typeable+ > data BoolThry+ > instance CtxtName BoolThry where+ > ctxtName _ = "BoolCtxt" > type BoolType = ExtThry BoolThry BaseThry >- > class BaseCtxt a => BoolContext a- > instance BaseCtxt b => BoolContext (ExtThry BoolThry b)- > instance BoolContext b => BoolContext (ExtThry a b)- > - > class BoolContext a => BoolCtxt a- > instance BoolContext a => BoolCtxt a- >- > ctxtBool :: HOLContext BoolType- > ctxtBool = ...- >- > bool :: QuasiQuoter- > bool = baseQuoter ctxtBool- >- > proveBool :: String -> HOL Proof BoolType HOLThm -> Q [Dec]- > proveBool = proveCompileTime ctxtBool+ > type family BoolContext a :: Bool where+ > BoolContext BaseThry = False+ > BoolContext (ExtThry a b) = (a == BoolThry) || (BoolContext b) >- > proveBoolMany :: [String] -> HOL Proof BoolType [HOLThm] -> Q [Dec]- > proveBoolMany = proveCompileTimeMany ctxtBool--} -extendCtxt :: Typeable thry =>- HOLContext thry -> HOL cls thry () -> String -> Q [Dec]-extendCtxt ctx ld lbl =- -- lower case label for quasiquoter - let lowLbl = toLower (head lbl) : tail lbl+ > type instance BoolThry == BoolThry = True++ Regrettably, Template Haskell cannot currently handle splicing type + equalities. Thus, to provide a cleaner interface, it is recommended to+ manually construct another type family to be used as the main 'Constraint':++ > type family BoolCtxt a :: Constraint where+ > BoolCtxt a = (BaseCtxt a, BoolContext a ~ True)++ Note that this new 'Constraint' can also be used to enforce the linearity of+ type theory contexts.+-}+templateTypes :: forall thry. CtxtName thry => TheoryPath thry -> String + -> Q [Dec]+templateTypes _ lbl = -- upper case label for everything else- upLbl = toUpper (head lbl) : tail lbl+ let upLbl = toUpper (head lbl) : tail lbl -- type of old theory- oldThry = buildOldThry . head . typeRepArgs $ typeOf ctx+ oldThry = ConT . mkName $+ let oldCtxt = ctxtName (undefined::thry)+ oldType = take (length oldCtxt - 4) oldCtxt in+ if oldType == "Base" then "BaseThry"+ else oldType ++ "Type" -- general use type variables aName = mkName "a" aVar = VarT aName@@ -117,78 +115,65 @@ -- build data types dataName = mkName $ upLbl ++ "Thry" dataType = ConT dataName- dataDec = DataD [] dataName [] [] [''Typeable]+ -- splices: instance CtxtName _Thry where ...+ instDec = InstanceD [] (AppT (ConT ''CtxtName) (ConT dataName))+ [FunD 'ctxtName [Clause [WildP] + (NormalB (LitE (StringL $ upLbl ++ "Ctxt"))) []]]+ dataDec = DataD [] dataName [] [] [] tyName = mkName $ upLbl ++ "Type"- newThry = extThry `AppT` dataType `AppT` oldThry+ newThry = ConT ''ExtThry `AppT` dataType `AppT` oldThry+ -- splices: type _Type = ExtThry _Thry oldThry tyDec = TySynD tyName [] newThry -- build class and instances clsName = mkName $ upLbl ++ "Context"- oldThryName = let oldt = stripList (\ x -> case x of- AppT l r -> Just (l, r)- _ -> Nothing ) oldThry in- case oldt of- (ConT x:[]) -> show x- (_:ConT x:_) -> show x- _ -> error "extendCtxt: bad theory type."- -- ConT XThry ---> XCtxt- oldClsName = mkName $ take (length oldThryName - 4) oldThryName ++ - "Ctxt"- clsCon = ConT clsName- clsDec = ClassD [ClassP oldClsName [aVar]] clsName [PlainTV aName] [] []- clsIn1Dec = InstanceD [ClassP oldClsName [bVar]]- (clsCon `AppT` (extThry `AppT` dataType `AppT` bVar)) []- clsIn2Dec = InstanceD [ClassP clsName [bVar]]- (clsCon `AppT` (extThry `AppT` aVar `AppT` bVar)) []+ -- splices: type instance _Context BaseThry = False+ famBase =TySynEqn [ConT ''BaseThry] $ PromotedT 'False+ famCond = AppT (AppT (ConT ''(||))+ (AppT (ConT clsName) bVar))+ (AppT (AppT (ConT ''(==)) aVar) (ConT dataName)) + -- splices: type instance _Context (ExtThry a b) = + -- (a == _Thry) || (_Context b) + famInd = TySynEqn [AppT (AppT (ConT ''ExtThry) aVar) bVar] famCond+ -- splices: type family _Context a :: Bool+ fam = ClosedTypeFamilyD clsName [PlainTV aName] (Just $ ConT ''Bool)+ [famBase, famInd] -- class wrapper- clsName' = mkName $ upLbl ++ "Ctxt"- clsCon' = ConT clsName'- clsDec' = ClassD [ClassP clsName [aVar]] clsName' [PlainTV aName] [] []- clsInDec' = InstanceD [ClassP clsName [aVar]] (clsCon' `AppT` aVar) []--- build context type; we build value later- ctxtName = mkName $ "ctxt" ++ upLbl- ctxtTySig = SigD ctxtName $ ConT ''HOLContext `AppT` newThry+ -- splices: type instance _Thry == _Thry = True+ clsEq = TySynInstD ''(==) . + TySynEqn [ConT dataName, ConT dataName] $ PromotedT 'True in+ return [ dataDec, tyDec, instDec -- types+ , fam+ , clsEq+ ]++{-|+ The 'templateProvers' splice automatically generates the 'QuasiQuoter'+ associated with a theory extension. The provided+ name should be the theory context checkpoint built with the 'extendTheory' + splice.++ For example,++ > templateProvers 'ctxtBool++ will produce the following declarations:++ > bool :: QuasiQuoter+ > bool = baseQuoter ctxtBool+-}+templateProvers :: Name -> Q [Dec]+templateProvers ctxName = -- build QuasiQuoter+ let upLbl = drop 4 $ nameBase ctxName+ lowLbl = toLower (head upLbl) : tail upLbl+ --tyName = mkName $ upLbl ++ "Type" qqName = mkName lowLbl+ -- splices: _ :: QuasiQuoter qqTySig = SigD qqName $ ConT ''QuasiQuoter+ -- splices: _ = baseQuoter ctxt_ qqDec = ValD (VarP qqName) (NormalB $ - VarE 'baseQuoter `AppE` VarE ctxtName) []--- build provers- -- Q [Dec]- qdecType = ConT ''Q `AppT` (ListT `AppT` ConT ''Dec)- cont b = if b then AppT ListT else id- name b = mkName $ "prove" ++ upLbl ++ if b then "Many" else ""- proveName b = if b then 'proveCompileTimeMany - else 'proveCompileTime- -- HOL Proof newThry HOLThm- holType b = ConT ''HOL `AppT` ConT ''Proof `AppT` - newThry `AppT` cont b (ConT ''HOLThm)- proverTySig b = SigD (name b) $- ArrowT `AppT` cont b (ConT ''String) `AppT`- (ArrowT `AppT` holType b `AppT` qdecType)- proveDec b = ValD (VarP $ name b) (NormalB $ - VarE (proveName b) `AppE` VarE ctxtName) [] in--- build values- do lctx <- lift =<< runIO (execHOLCtxt ld ctx)- let ctxtDec = ValD (VarP ctxtName) (NormalB lctx) []- return [ dataDec, tyDec -- types- , clsDec, clsIn1Dec, clsIn2Dec -- class and instances- , clsDec', clsInDec' -- class alias- , ctxtTySig, ctxtDec -- context value- , qqTySig, qqDec -- quasiquoter- , proverTySig False, proveDec False -- provers- , proverTySig True, proveDec True- ]- -- where extThry :: Type- extThry = ConT ''ExtThry- - buildOldThry :: TypeRep -> Type- buildOldThry ty = - case typeRepArgs ty of- [] -> ConT . mkName $ show ty- ts -> let ts' = map buildOldThry ts in- foldl1 (\ acc x -> extThry `AppT` acc `AppT` x) ts' + VarE 'baseQuoter `AppE` VarE ctxName) [] in+ return [ qqTySig, qqDec ] -- Documentation copied from sub-modules @@ -210,3 +195,46 @@ documentation for 'base' for a brief discussion on when quasi-quoting should be used vs. 'toHTm'. -}++{-|+ The 'extendTheory' splice acts as a compile-time wrapper to 'runHOL', used for+ the purpose of creating new theory contexts. It takes three arguments:++ * The theory to be extended.++ * The base name of the new theory to be created.++ * The 'HOL' computation that will perform the extension.++ For example:++ > extendTheory ctxtBase "Bool" $ ...++ Additionally, 'extendTheory' calls the 'templateTypes' splice to create the+ type class wizardy associated with theory contexts and creates an+ appropriately typed wrapper for 'mkTheoryPath', e.g.:++ > ctxtBool :: TheoryPath BoolType+ > ctxtBool = mkTheoryPath+-}+extendTheory :: CtxtName thry => TheoryPath thry -> String -> HOL Theory thry ()+ -> Q [Dec]+extendTheory old new ld =+ -- run the load function+ do runIO $+ do dir <- getDataDir+ let new' = dir `combine` (new ++ "Ctxt")+ shelly $ + do cond <- test_d . fromText $ pack new'+ when cond . echo . pack $+ "Note: Using existing theory context for " ++ new+ unless cond . liftIO $+ runHOL (ld >> checkpointProofs) old new'+ -- splices: ctxt_ :: TheoryPath _Type+ -- ctxt_ = mkTheoryPath+ let cname = mkName $ "ctxt" ++ new+ ctype = ConT . mkName $ new ++ "Type"+ tySig = SigD cname (ConT ''TheoryPath `AppT` ctype)+ def = ValD (VarP cname) (NormalB (VarE 'mkTheoryPath)) []+ tyDefs <- templateTypes old new+ return $! tyDefs ++ [tySig, def]
src/HaskHOL/Core/Ext/Protected.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE ExistentialQuantification, FlexibleInstances, - FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables,- TemplateHaskell, TypeFamilies, TypeSynonymInstances, - UndecidableInstances, ViewPatterns #-}-+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, + TypeFamilies, TypeSynonymInstances #-} {-| Module: HaskHOL.Core.Ext.Protected Copyright: (c) The University of Kansas 2013@@ -26,31 +23,22 @@ @Protected@ class and the 'liftProtectedExp' and 'liftProtected' methods. -} module HaskHOL.Core.Ext.Protected- ( Protected(protect, serve)- , PData+ ( Protected+ , protect+ , protectM+ , serve+ , unsafeServe+ , unsafeProtect , PType , PTerm , PThm- , liftProtectedExp -- :: (Protected a, Typeable thry) => - -- PData a thry -> Q Exp- , liftProtected -- :: (Protected a, Typeable thry) => - -- String -> PData a thry -> Q [Dec]- , proveCompileTime -- :: Typeable thry => HOLContext thry -> String ->- -- HOL Proof thry HOLThm -> Q [Dec]- , proveCompileTimeMany -- :: Typeable thry => HOLContext thry -> [String] - -- -> HOL Proof thry [HOLThm] -> Q [Dec]- , extractBasicDefinition -- :: Typeable thry => HOLContext thry -> - -- String -> String -> Q [Dec]- , extractAxiom -- :: Typeable thry => - -- HOLContext thry -> String -> Q [Dec]+ , liftProtectedExp+ , liftProtected ) where -import HaskHOL.Core.Lib-import HaskHOL.Core.Kernel hiding (typeOf)+import HaskHOL.Core.Kernel import HaskHOL.Core.State-import HaskHOL.Core.Parser -import Data.Typeable (typeOf, typeRepArgs) import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -68,23 +56,34 @@ * Some boilerplate code to enable template haskell lifting. -} class Lift a => Protected a where+ -- | The associated type for the 'Protected' class. data PData a thry -- | Protects a value by sealing it against a provided context.- protect :: HOLContext thry -> a -> PData a thry+ protect :: TheoryPath thry -> a -> PData a thry+ -- | Protects a value by sealing it against the current context.+ protectM :: forall b cls thry. (b ~ a) => b -> HOL cls thry (PData b thry)+ protectM a = return $! protect (undefined :: TheoryPath thry) a {-| Unseals a protected value, returning it in a monadic computation whose current working theory satisfies the context that the value was originally sealed with. -} serve :: PData a thry -> HOL cls thry a- liftTy :: a -> Name+ -- | Unseals a protected value, returning a pure, unprotected value.+ unsafeServe :: PData a thry -> a+ {- | An alias to the internal 'PData' constructor to create a fully + polymorphic \"protected\" value. -}+ unsafeProtect :: a -> PData a thry+ liftTy :: a -> Type protLift :: PData a thry -> Q Exp instance Protected HOLThm where data PData HOLThm thry = PThm HOLThm protect _ = PThm serve (PThm thm) = return thm- liftTy _ = ''HOLThm+ unsafeServe (PThm thm) = thm+ unsafeProtect = PThm+ liftTy _ = ConT ''HOLThm protLift (PThm thm) = conE 'PThm `appE` lift thm -- | Type synonym for protected 'HOLThm's. type PThm thry = PData HOLThm thry@@ -93,7 +92,9 @@ data PData HOLTerm thry = PTm HOLTerm protect _ = PTm serve (PTm tm) = return tm- liftTy _ = ''HOLTerm+ unsafeServe (PTm tm) = tm+ unsafeProtect = PTm+ liftTy _ = ConT ''HOLTerm protLift (PTm tm) = conE 'PTm `appE` lift tm -- | Type synonym for protected 'HOLTerm's. type PTerm thry = PData HOLTerm thry@@ -102,41 +103,80 @@ data PData HOLType thry = PTy HOLType protect _ = PTy serve (PTy ty) = return ty- liftTy _ = ''HOLType+ unsafeServe (PTy ty) = ty+ unsafeProtect = PTy+ liftTy _ = ConT ''HOLType protLift (PTy ty) = conE 'PTy `appE` lift ty -- | Type synonym for protected 'HOLType's. type PType thry = PData HOLType thry -instance HOLTermRep (PTerm thry) thry where- toHTm = serve+instance Protected Int where+ data PData Int thry = PInt Int+ protect _ = PInt+ serve (PInt n) = return n+ unsafeServe (PInt n) = n+ unsafeProtect = PInt+ liftTy _ = ConT ''Int+ protLift (PInt n) = conE 'PInt `appE` lift n -instance HOLTypeRep (PType thry) thry where- toHTy = serve+instance Protected a => Protected [a] where+ data PData [a] thry = PList [PData a thry]+ protect c as = PList $ map (protect c) as+ serve (PList as) = mapM serve as+ unsafeServe (PList as) = map unsafeServe as+ unsafeProtect as = PList $ map unsafeProtect as+ liftTy _ = AppT ListT $ liftTy (undefined::a)+ protLift (PList as) = conE 'PList `appE` listE (map protLift as) +instance (Protected a, Protected b) => Protected (a, b) where+ data PData (a, b) thry = PPair (PData a thry) (PData b thry)+ protect c (a, b) = PPair (protect c a) (protect c b)+ serve (PPair a b) = do a' <- serve a+ b' <- serve b+ return (a', b')+ unsafeServe (PPair a b) = (unsafeServe a, unsafeServe b)+ unsafeProtect (a, b) = PPair (unsafeProtect a) (unsafeProtect b)+ liftTy _ = AppT (AppT (TupleT 2) (liftTy (undefined::a))) + (liftTy (undefined::b))+ protLift (PPair a b) = conE 'PPair `appE` protLift a `appE` protLift b +instance (Protected a, Protected b, Protected c) => Protected (a, b, c) where+ data PData (a, b, c) thry = + PTrip (PData a thry) (PData b thry) (PData c thry)+ protect ctx (a, b, c) = + PTrip (protect ctx a) (protect ctx b) (protect ctx c)+ serve (PTrip a b c) = do a' <- serve a+ b' <- serve b+ c' <- serve c+ return (a', b', c')+ unsafeServe (PTrip a b c) = (unsafeServe a, unsafeServe b, unsafeServe c)+ unsafeProtect (a, b, c) = + PTrip (unsafeProtect a) (unsafeProtect b) (unsafeProtect c)+ liftTy _ = AppT (AppT (AppT (TupleT 3) (liftTy (undefined::a)))+ (liftTy (undefined::b)))+ (liftTy (undefined::c))+ protLift (PTrip a b c) = + conE 'PTrip `appE` protLift a `appE` protLift b `appE` protLift c+ {- Builds the theory contrainst for a lifted, protected value. For example: - > buildThryType (x::PData a Bool)+ > buildThryType (x::PData a BoolType) builds the context > forall thry. BoolCtxt thry => PData a thry -}-buildThryType :: forall a thry. (Protected a, Typeable thry) => - PData a thry -> Type+buildThryType :: forall a thry. (Protected a, CtxtName thry) => + PData a thry -> Q Type buildThryType _ =- let tyname = mkName "thry"- ctxtName = mkName $ topTheory ++ "Ctxt"- cls = ClassP ctxtName [VarT tyname] in- ForallT [PlainTV tyname] [cls] . - AppT (AppT (ConT ''PData) . ConT $ liftTy (undefined :: a)) $ - VarT tyname- where topTheory :: String- topTheory = - let base = show . head . typeRepArgs $ typeOf (undefined :: thry) in- take (length base - 4) base+ do tyname <- newName "thry"+ let cls = ClassP (mkName $ ctxtName (undefined::thry)) [VarT tyname]+ return . ForallT [PlainTV tyname] [cls] . + AppT (AppT (ConT ''PData) $ liftTy (undefined :: a)) $ + VarT tyname+ {-| Lifts a protected data value as an expression using an ascribed type.@@ -148,11 +188,10 @@ > [| x :: forall thry. BoolCtxt thry => PData a Bool |] -}-liftProtectedExp :: (Protected a, Typeable thry) => - PData a thry -> Q Exp+liftProtectedExp :: (Protected a, CtxtName thry) => PData a thry -> Q Exp liftProtectedExp pdata = do pdata' <- protLift pdata- let ty = buildThryType pdata+ ty <- buildThryType pdata return $! SigE pdata' ty {-| @@ -169,89 +208,12 @@ See 'extractAxiom' for a basic example of how this function may be used. -}-liftProtected :: (Protected a, Typeable thry) => +liftProtected :: (Protected a, CtxtName thry) => String -> PData a thry -> Q [Dec] liftProtected lbl pdata = do pdata' <- protLift pdata- let ty = buildThryType pdata- name = mkName lbl+ ty <- buildThryType pdata+ let name = mkName lbl tysig = SigD name ty dec = ValD (VarP name) (NormalB pdata') [] return [tysig, dec]----- Compile Time Proof---EvNote: long-term idea: change debuging printing to be based on cabal flag-{-|- Evaluates a proof compilation, protects it with the theory used to evaluate- it, and then lifts it as a declaration of a given name with an ascribed type- signature.-- Relies internally on 'protect' and 'liftProtected' to guarantee that the- resultant theorem is sealed with the right type.--}-proveCompileTime :: Typeable thry => HOLContext thry -> String -> - HOL Proof thry HOLThm -> Q [Dec]-proveCompileTime ctx lbl th =- do thm <- runIO $ - do putStr $ "proving: " ++ lbl ++ "..."- thm <- evalHOLCtxt (setBenignFlag FlagDebug >> th) ctx- putStrLn "...proved."- return thm- liftProtected lbl $ protect ctx thm--{-|- A version of 'proveCompileTime' that works for a proof computation returning- multiple theorems.-- Note that each resultant theorem must have a unique, provided name.--}-proveCompileTimeMany :: Typeable thry => HOLContext thry -> [String] -> - HOL Proof thry [HOLThm] -> Q [Dec]-proveCompileTimeMany ctx lbls ths =- let n = length lbls in- do thms <- runIO $ - do putStrLn $ "proving " ++ show n ++ " theorems"- thms <- evalHOLCtxt (setBenignFlag FlagDebug >> ths) ctx- if length thms /= n- then fail $ "proveCompileTimeMany: number of " ++ - "theorems and labels does not agree."- else do putStrLn $ unwords lbls ++ " proved."- return thms- liftM concat . mapM (\ (lbl, thm) -> liftProtected lbl $ - protect ctx thm) $ zip lbls thms---- Extraction functions for Core State values-{-|- Extracts a basic term definition from a provided context, protecting and - lifting it with 'liftProtected'. The extraction is performed by looking for - a definition whose left hand side matches a provided constant name.- For example:-- > extractBasicDefinition ctxtBool "defT" "T"-- will return the spliceable list of declarations for the following theorem-- @ |- T = (\ p:bool . p) = (\ p:bool . p) @--}-extractBasicDefinition :: Typeable thry => - HOLContext thry -> String -> String -> Q [Dec]-extractBasicDefinition ctx lbl name =- do defns <- runIO $ evalHOLCtxt definitions ctx- let mb = find (\ x -> case destEq $ concl x of- Just (view -> Const l _ _, _) -> l == name- _ -> False) defns- case mb of- Nothing -> fail "extractBasicDefinition: definition not found"- Just th -> liftProtected lbl $ protect ctx th--{-|- Extracts an axiom from a provided context, protecting and lifting it with- 'liftProtected'. The extraction is performed by looking for an axioms of- a given name, as specified when the axiom was created with 'newAxiom'.--}-extractAxiom :: Typeable thry => HOLContext thry -> String -> Q [Dec]-extractAxiom ctx lbl =- do ax <- runIO $ evalHOLCtxt - (getAxiom lbl <?> "extractAxiom: axiom not found") ctx- liftProtected lbl $ protect ctx ax
src/HaskHOL/Core/Ext/QQ.hs view
@@ -17,9 +17,9 @@ expressing 'HOLTerm's as 'String's, i.e. @\"\\ x . x\"@. -} module HaskHOL.Core.Ext.QQ- ( baseQuoter -- :: Typeable thry => HOLContext thry -> QuasiQuoter- , base -- :: QuasiQuoter- , str -- :: QuasiQuoter+ ( baseQuoter+ , baseQQ+ , str ) where import HaskHOL.Core.Lib@@ -33,11 +33,7 @@ -} import Language.Haskell.TH import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax (Lift(..)) --- Only used here, not really necessary to include in Core.Lib-import Data.Char (isSpace)- {-| This is the base quasi-quoter for the HaskHOL system. When provided with a theory context value, it constucts a theory specific quasi-quoter that parses@@ -46,25 +42,27 @@ Note that, at this point in time, we only allowing quoting at the expression level. -}-baseQuoter :: Typeable thry => HOLContext thry -> QuasiQuoter-baseQuoter ctxt = QuasiQuoter quoteBaseExps nothing nothing nothing- where quoteBaseExps x =- liftProtectedExp =<< - (runIO . evalHOLCtxt (liftM (protect ctxt) $ toHTm x) $ ctxt)+baseQuoter :: CtxtName thry => TheoryPath thry -> QuasiQuoter+baseQuoter thry = QuasiQuoter quoteBaseExps nothing nothing nothing+ where quoteBaseExps :: String -> Q Exp + quoteBaseExps (':':x) = liftProtectedExp =<< runIO+ (runHOLProof (liftM (protect thry) . toHTy $ pack x) thry)+ quoteBaseExps x = liftProtectedExp =<< runIO + (runHOLProof (liftM (protect thry) . toHTm $ pack x) thry) nothing _ = fail "quoting here not supported" {-| An instance of 'baseQuoter' for the core theory context, 'ctxtBase'. Example: - > [base| x = y |]+ > [baseQQ| x = y |] will parse the provided string and construct the 'HOLTerm' @x = y@ at compile time. Note that this term is protected, such that it has to be accessed via 'serve'. This is advantageous in computations that may be run many times, for example: - > do tm <- serve [base| x = y |]+ > do tm <- serve [baseQQ| x = y |] > ... will parse the term exactly once, only checking the @thry@ tag of the@@ -78,16 +76,15 @@ that themselves are evaluated at copmile time to minimize the amount of work Template Haskell has to do. -}-base :: QuasiQuoter-base = baseQuoter ctxtBase+baseQQ :: QuasiQuoter+baseQQ = baseQuoter ctxtBase {-|- This is a specialized quasi-quoter for 'String's. It can be used to strip+ This is a specialized quasi-quoter for 'Text's. It can be used to strip white space and automatically escape special characters. It is typically used in conjunction with 'toHTm' directly or indirectly. -} str :: QuasiQuoter str = QuasiQuoter quoteStrExp nothing nothing nothing- where quoteStrExp x = lift $ trim x- trim = dropWhile isSpace . dropWhileEnd isSpace+ where quoteStrExp x = [| textStrip $ pack $(litE $ StringL x) |] nothing _ = fail "quoting here not supported"
src/HaskHOL/Core/Kernel.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-| Module: HaskHOL.Core.Kernel Copyright: (c) The University of Kansas 2013@@ -9,8 +10,6 @@ This module exports the logical kernel of HaskHOL. It consists of: - * The view pattern required to pattern match on terms outside of the kernel.- * A safe view of HOL theorems for HaskHOL. * The primitive inference rules of the system.@@ -26,37 +25,35 @@ -} module HaskHOL.Core.Kernel ( -- * A View of HOL Types, Terms, and Theorems- -- ** A Quick Note on View Patterns+ -- ** A Quick Note on Pattern Synonyms -- $ViewPatterns- view -- :: a -> b -- ** Destructors and Accessors for Theorems- , HOLThm- , HOLThmView(..)- , destThm -- :: HOLThm -> ([HOLTerm], HOLTerm)- , hyp -- :: HOLThm -> [HOLTerm]- , concl -- :: HOLThm -> HOLTerm+ HOLThm+ , pattern Thm+ , destThm+ , hyp+ , concl -- * HOL Light Primitive Inference Rules- , primREFL -- :: HOLTerm -> HOLThm- , primTRANS -- :: HOLThm -> HOLThm -> Either String HOLThm- , primMK_COMB -- :: HOLThm -> HOLThm -> Either String HOLThm - , primABS -- :: HOLTerm -> HOLThm -> Either String HOLThm - , primBETA -- :: HOLTerm -> Either String HOLThm- , primASSUME -- :: HOLTerm -> Maybe HOLThm- , primEQ_MP -- :: HOLThm -> HOLThm -> Either String HOLThm- , primDEDUCT_ANTISYM_RULE -- :: HOLThm -> HOLThm -> HOLThm- , primINST_TYPE -- :: Inst a b => [(a, b)] -> HOLThm -> HOLThm- , primINST_TYPE_FULL -- :: SubstTrip -> HOLThm -> HOLThm- , primINST -- :: HOLTermEnv -> HOLThm -> HOLThm+ , primREFL+ , primTRANS+ , primMK_COMB + , primABS + , primBETA+ , primASSUME+ , primEQ_MP+ , primDEDUCT_ANTISYM+ , primINST_TYPE+ , primINST_TYPE_FULL+ , primINST -- * HOL2P Primitive Inference Rules- , primTYABS -- :: HOLType -> HOLThm -> Either String HOLThm- , primTYAPP2 -- :: HOLType -> HOLType -> HOLThm -> Either String HOLThm- , primTYAPP -- :: HOLType -> HOLThm -> Maybe HOLThm- , primTYBETA -- :: HOLTerm -> Either String HOLThm+ , primTYABS+ , primTYAPP2+ , primTYAPP+ , primTYBETA -- * Stateless HOL Primitive Theory Extensions- , axiomThm -- :: HOLTerm -> HOLThm- , newDefinedConst -- :: HOLTerm -> Either String (HOLTerm, HOLThm)- , newDefinedTypeOp -- :: String -> String -> String -> HOLThm -> Either - -- String (TypeOp, HOLTerm, HOLTerm, HOLThm, HOLThm)+ , axiomThm+ , newDefinedConst+ , newDefinedTypeOp -- * Primitive Re-Exports , module HaskHOL.Core.Kernel.Types , module HaskHOL.Core.Kernel.Terms@@ -67,13 +64,18 @@ import HaskHOL.Core.Kernel.Types import HaskHOL.Core.Kernel.Terms +import Data.Hashable+ {- Used to quickly make an equality between two terms we know to be of the same type. Not exposed to the user. -} safeMkEq :: HOLTerm -> HOLTerm -> HOLTerm-safeMkEq l = CombIn $ CombIn (tmEq $ typeOf l) l+safeMkEq l r = + let eq = tmEq $ typeOf l in+ CombIn (CombIn eq l) r + {- Unions two lists of terms, ordering the result modulo alpha-equivalence. Not exposed to the user.@@ -108,6 +110,12 @@ termImage _ [] = [] termImage f (h:t) = termUnion [f h] $ termImage f t +termImageM :: Monad m => (HOLTerm -> m HOLTerm) -> [HOLTerm] -> m [HOLTerm]+termImageM _ [] = return []+termImageM f (h:t) = + do h' <- f h+ liftM (termUnion [h']) $ termImageM f t+ {- HOL Light Theorem Primitives -}@@ -116,11 +124,11 @@ term. -} destThm :: HOLThm -> ([HOLTerm], HOLTerm)-destThm (ThmIn a c) = (a, c)+destThm (ThmIn as c) = (as, c) -- | Accessor for the hypotheses, or assumption terms, of a theorem. hyp :: HOLThm -> [HOLTerm]-hyp (ThmIn a _) = a+hyp (ThmIn as _) = as -- | Accessor for the conclusion term of a theorem. concl :: HOLThm -> HOLTerm@@ -141,7 +149,7 @@ Never fails. -} primREFL :: HOLTerm -> HOLThm-primREFL t = ThmIn [] $ safeMkEq t t+primREFL tm = ThmIn [] $ safeMkEq tm tm {-|@ A1 |- t1 = t2 A2 |- t2 = t3@@ -156,11 +164,11 @@ * One, or both, of the theorem conclusions is not an equation. -} primTRANS :: HOLThm -> HOLThm -> Either String HOLThm-primTRANS (ThmIn a1 (CombIn eql@(CombIn (ConstIn "=" _ Prim) _) m1)) - (ThmIn a2 (CombIn (CombIn (ConstIn "=" _ Prim) m2) r))+primTRANS (ThmIn as1 (CombIn eql@(CombIn (TmEq _) _) m1)) (ThmIn as2 (m2 := r)) | m1 `aConv` m2 =- Right . ThmIn (termUnion a1 a2) $ CombIn eql r- | otherwise = Left "primTRANS: middle terms don't agree" + let as' = termUnion as1 as2 in+ Right . ThmIn as' $ CombIn eql r+ | otherwise = Left "primTRANS: middle terms don't agree" primTRANS _ _ = Left "primTRANS: not both equations" -- Basic Congruence Rules@@ -179,14 +187,13 @@ * The types of the function terms and argument terms do not agree. -}-primMK_COMB :: HOLThm -> HOLThm -> Either String HOLThm -primMK_COMB (ThmIn a1 (CombIn (CombIn (ConstIn "=" _ Prim) l1) r1))- (ThmIn a2 (CombIn (CombIn (ConstIn "=" _ Prim) l2) r2)) =+primMK_COMB :: HOLThm -> HOLThm -> Either String HOLThm +primMK_COMB (ThmIn as1 (l1 := r1)) (ThmIn as2 (l2 := r2)) = case typeOf l1 of- (TyAppIn (TyPrim "fun" _) (ty:_:_))+ TyAppIn TyOpFun (ty:_:_) | typeOf l2 `tyAConv` ty ->- Right . - ThmIn (termUnion a1 a2) . safeMkEq (CombIn l1 l2) $ CombIn r1 r2+ let as' = termUnion as1 as2 in+ Right . ThmIn as' $ safeMkEq (CombIn l1 l2) (CombIn r1 r2) | otherwise -> Left "primMK_COMB: types do not agree" _ -> Left "primMK_COMB: not a function type" primMK_COMB _ _ = Left "primMK_COMB: not both equations"@@ -203,19 +210,19 @@ * The conclusion of the theorem is not an equation. -}-primABS :: HOLTerm -> HOLThm -> Either String HOLThm -primABS v@VarIn{} (ThmIn a (CombIn (CombIn (ConstIn "=" _ Prim) l) r))- | any (varFreeIn v) a = - Left "primABS: variable is free in assumptions" +primABS :: HOLTerm -> HOLThm -> Either String HOLThm +primABS v@VarIn{} (ThmIn as (l := r))+ | any (varFreeIn v) as = + Left "primABS: variable is free in assumptions" | otherwise = - Right . ThmIn a . safeMkEq (AbsIn v l) $ AbsIn v r+ Right . ThmIn as $ safeMkEq (AbsIn v l) (AbsIn v r) primABS _ _ = Left "primABS: not an equation" -- Beta Reduction {-|@- (\\ x . t[x]) x--------------------------------- |- (\\ x . t) x = t[x]+ (\\ x . t) x+----------------------------+ |- (\\ x . t) x = t @ Fails with 'Left' in the following cases:@@ -226,8 +233,9 @@ to the bound variable. -} primBETA :: HOLTerm -> Either String HOLThm-primBETA tm@(CombIn (AbsIn bv bod) arg)- | arg == bv = Right . ThmIn [] $ safeMkEq tm bod+primBETA t@(CombIn (AbsIn bv bod) arg)+ | arg == bv = + Right . ThmIn [] $ safeMkEq t bod | otherwise = Left "primBETA_PRIM: not a trivial beta reduction" primBETA _ = Left "primBETA_PRIM: not a valid application" @@ -238,12 +246,12 @@ t |- t @ - Fails with 'Nothing' if the term is not a proposition.+ Fails with 'Left' if the term is not a proposition. -}-primASSUME :: HOLTerm -> Maybe HOLThm+primASSUME :: HOLTerm -> Either String HOLThm primASSUME tm- | typeOf tm == tyBool = Just $ ThmIn [tm] tm- | otherwise = Nothing+ | typeOf tm == tyBool = Right $ ThmIn [tm] tm+ | otherwise = Left "primASSUME" {-|@ A1 |- t1 = t2 A2 |- t1@@ -259,22 +267,25 @@ equation are not alpha-equivalent. -} primEQ_MP :: HOLThm -> HOLThm -> Either String HOLThm-primEQ_MP (ThmIn a1 (CombIn (CombIn (ConstIn "=" _ Prim) l) r)) (ThmIn a2 c)- | l `aConv` c = Right $ ThmIn (termUnion a1 a2) r+primEQ_MP (ThmIn as1 (l := r)) (ThmIn as2 c)+ | l `aConv` c = + let as' = termUnion as1 as2 in+ Right $ ThmIn as' r | otherwise = Left "primEQ_MP: terms do not agree" primEQ_MP _ _ = Left "primEQ_MP: term is not an equation" {-|@- A |- p B |- q ------------------------------------ (A - {q}) U (B - {p}) |- p \<=\> q+ A |- p B |- q +--------------------------------+ (A - q) U (B - p) |- p \<=\> q @ Never fails. -}-primDEDUCT_ANTISYM_RULE :: HOLThm -> HOLThm -> HOLThm-primDEDUCT_ANTISYM_RULE (ThmIn a p) (ThmIn b q) =- ThmIn (termRemove q a `termUnion` termRemove p b) $ safeMkEq p q+primDEDUCT_ANTISYM :: HOLThm -> HOLThm -> HOLThm+primDEDUCT_ANTISYM (ThmIn as p) (ThmIn bs q) =+ let as' = termRemove q as `termUnion` termRemove p bs in+ ThmIn as' $ safeMkEq p q -- Instantiation Rules {-|@@@ -287,15 +298,15 @@ Never fails. -} primINST_TYPE :: Inst a b => [(a, b)] -> HOLThm -> HOLThm-primINST_TYPE tyenv (ThmIn a t) = +primINST_TYPE tyenv (ThmIn as t) = let instFun = inst tyenv in- ThmIn (termImage instFun a) $ instFun t+ ThmIn (termImage instFun as) $ instFun t -- | A version of 'primINST_TYPE' that instantiates a theorem via 'instFull'. primINST_TYPE_FULL :: SubstTrip -> HOLThm -> HOLThm-primINST_TYPE_FULL tyenv (ThmIn a t) =+primINST_TYPE_FULL tyenv (ThmIn as t) = let instFun = instFull tyenv in- ThmIn (termImage instFun a) $ instFun t+ ThmIn (termImage instFun as) $ instFun t {-|@ [(t1, x1), ..., (tn, xn)] A |- t @@ -304,12 +315,13 @@ |- t[t1, ..., tn/x1, ..., xn] @ - Never fails.+ Fails with 'Nothing' in the case where a bad substitution list is provided. -}-primINST :: HOLTermEnv -> HOLThm -> HOLThm-primINST env (ThmIn a t) = +primINST :: HOLTermEnv -> HOLThm -> Maybe HOLThm+primINST env (ThmIn as t) = let instFun = varSubst env in- ThmIn (termImage instFun a) $ instFun t+ do as' <- termImageM instFun as + liftM (ThmIn as') $ instFun t {- HOL2P Primitive Inference Rules@@ -334,13 +346,12 @@ * The type variable to bind is free in the conclusion of the theorem. -} primTYABS :: HOLType -> HOLThm -> Either String HOLThm-primTYABS tv@(TyVarIn True _) - (ThmIn a (CombIn (CombIn (ConstIn "=" _ Prim) l) r))- | tv `notElem` typeVarsInTerms a =+primTYABS tv@(TyVarIn True _) (ThmIn as (l := r))+ | tv `notElem` typeVarsInTerms as = let fvs = frees l `union` frees r in if any (\ x -> tv `elem` tyVars (typeOf x)) fvs then Left "primTYABS: type variable is free in conclusion"- else Right . ThmIn a . safeMkEq (TyAbsIn tv l) $ TyAbsIn tv r+ else Right . ThmIn as $ safeMkEq (TyAbsIn tv l) (TyAbsIn tv r) | otherwise = Left "primTYABS: type variable is free in assumptions" primTYABS (TyVarIn True _) _ = @@ -363,16 +374,16 @@ * One, or both, of the type arguments is not small. -} primTYAPP2 :: HOLType -> HOLType -> HOLThm -> Either String HOLThm-primTYAPP2 ty1 ty2 (ThmIn a (CombIn (CombIn (ConstIn "=" _ Prim) l) r))+primTYAPP2 ty1 ty2 (ThmIn as (l := r)) | ty1 `tyAConv` ty2 = case typeOf l of- UTypeIn{} + UTypeIn{} | not $ isSmall ty1 -> Left "primTYAPP2: ty1 not small" | not $ isSmall ty2 -> Left "primTYAPP2: ty2 not small" | otherwise -> - Right . ThmIn a . safeMkEq (TyCombIn l ty1) $ TyCombIn r ty2+ Right . ThmIn as $ safeMkEq (TyCombIn l ty1) (TyCombIn r ty2) _ -> Left "primTYAPP2: terms not of universal type" | otherwise = Left "primTYAPP2: type arguments not alpha-convertible"@@ -389,13 +400,12 @@ Note that 'primTYAPP' is equivalent to 'primTYAPP2' when the same type is applied to both sides, i.e. - @ primTYAPP ty === primTYAPP2 ty ty- @+ @ primTYAPP ty === primTYAPP2 ty ty @ -}-primTYAPP :: HOLType -> HOLThm -> Maybe HOLThm-primTYAPP ty (ThmIn a (CombIn (CombIn (ConstIn "=" _ Prim) l) r)) = - Just . ThmIn a $ safeMkEq (TyCombIn l ty) (TyCombIn r ty)-primTYAPP _ _ = Nothing+primTYAPP :: HOLType -> HOLThm -> Either String HOLThm+primTYAPP ty thm@(ThmIn _ (_ := _)) = + primTYAPP2 ty ty thm+primTYAPP _ _ = Left "primTYAPP" -- Type Beta Reduction @@ -414,7 +424,8 @@ -} primTYBETA :: HOLTerm -> Either String HOLThm primTYBETA tm@(TyCombIn (TyAbsIn tv bod) argt)- | argt == tv = Right . ThmIn [] $ safeMkEq tm bod+ | argt == tv = + Right . ThmIn [] $ safeMkEq tm bod | otherwise = Left "primTYBETA: not a trivial type beta reduction" primTYBETA _ = Left "primTYBETA: not a valid type application" @@ -432,7 +443,7 @@ axioms is not tracked until the stateful layer of the system is introduced so be careful using this function. -}-axiomThm :: HOLTerm -> HOLThm +axiomThm :: HOLTerm -> HOLThm axiomThm = ThmIn [] {-|@@@ -458,13 +469,13 @@ the desired type of the constant. -} newDefinedConst :: HOLTerm -> Either String (HOLTerm, HOLThm)-newDefinedConst tm@(CombIn (CombIn (ConstIn "=" _ Prim) (VarIn cname ty)) r)- | not (freesIn [] r) =+newDefinedConst ((VarIn cname ty) := r)+ | not $ freesIn [] r = Left "newDefinedConst: not closed"- | not (subset (typeVarsInTerm r) (tyVars ty)) =+ | not $ typeVarsInTerm r `subset` tyVars ty = Left "newDefinedConst: type vars not refelcted in const" | otherwise = - let c = ConstIn cname ty $ Defined tm+ let c = ConstIn cname ty (DefinedIn $ hash r) dth = ThmIn [] $ safeMkEq c r in Right (c, dth) newDefinedConst _ = Left "newDefinedConst: not an equation"@@ -507,43 +518,43 @@ * The two theorems proving the bijection, as shown in the sequent above. -}-newDefinedTypeOp :: String -> String -> String -> HOLThm -> +newDefinedTypeOp :: Text -> Text -> Text -> HOLThm -> Either String (TypeOp, HOLTerm, HOLTerm, HOLThm, HOLThm)-newDefinedTypeOp tyname absname repname dth'@(ThmIn [] (CombIn p x))+newDefinedTypeOp tyname absname repname (ThmIn [] c@(CombIn p x)) | containsUType $ typeOf x = Left "newDefinedTypeOp: must not contain universal types" | not $ freesIn [] p = Left "newDefinedTypeOp: predicate is not closed" | otherwise = - let tys = sort (<=) (typeVarsInTerm p)+ let tys = sort (<=) $ typeVarsInTerm p arity = length tys- atyop = TyDefined tyname arity dth'+ hsh = hash c+ atyop = TyDefinedIn tyname arity hsh rty = typeOf x aty = TyAppIn atyop tys atm = VarIn "a" aty rtm = VarIn "r" rty absCon = ConstIn absname (TyAppIn tyOpFun [rty, aty]) $ - MkAbstract tyname arity dth'- repCon = ConstIn repname (TyAppIn tyOpFun [aty, rty]) $ - DestAbstract tyname arity dth' in+ MkAbstractIn tyname arity hsh+ repCon = ConstIn repname (TyAppIn tyOpFun [aty, rty]) $+ DestAbstractIn tyname arity hsh+ c1 = CombIn absCon $ CombIn repCon atm + c2 = CombIn p rtm + c3 = CombIn repCon $ CombIn absCon rtm in Right (atyop, absCon, repCon,- ThmIn [] (safeMkEq (CombIn absCon (CombIn repCon atm)) atm),- ThmIn [] (safeMkEq (CombIn p rtm) $ - safeMkEq (CombIn repCon (CombIn absCon rtm)) rtm))+ ThmIn [] $ safeMkEq c1 atm,+ ThmIn [] . safeMkEq c2 $ safeMkEq c3 rtm) newDefinedTypeOp _ _ _ _ = Left "newDefinedTypeOp: poorly formed predicate" -- Documentation copied from HaskHOL.Core.Prims {-$ViewPatterns- The primitive data types of HaskHOL are implemented using view patterns in+ The primitive data types of HaskHOL are implemented using pattern synonyms in order to simulate private data types: * Internal constructors are hidden to prevent manual construction of terms. - * View constructors (those of 'HOLTypeView', 'HOLTermView', and 'HOLThmView') - are exposed to enable pattern matching. -- * View patterns, as defined by instances of the 'view' function from the - @Viewable@ class, provide a conversion between the two sets of constructors.+ * Unideriectional pattern synonyms ('Thm', etc.) are exposed to enable + pattern matching. -}
src/HaskHOL/Core/Kernel/Prims.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, +{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, PatternSynonyms, TemplateHaskell #-} {-|@@ -28,35 +29,45 @@ module HaskHOL.Core.Kernel.Prims ( -- * HOL types HOLType(..)- , HOLTypeView(..)+ , pattern TyVar+ , pattern TyApp+ , pattern UType , TypeOp(..)+ , pattern TyOpVar+ , pattern TyPrimitive+ , pattern TyDefined , HOLTypeEnv , SubstTrip -- * HOL terms , HOLTerm(..)- , HOLTermView(..)+ , pattern Var+ , pattern Const+ , pattern Comb+ , pattern Abs+ , pattern TyComb+ , pattern TyAbs , ConstTag(..)+ , pattern Primitive+ , pattern Defined+ , pattern MkAbstract+ , pattern DestAbstract , HOLTermEnv -- * HOL theorems , HOLThm(..)- , HOLThmView(..)- -- * The View pattern class- , Viewable(..)+ , pattern Thm ) where import HaskHOL.Core.Lib +import Data.Hashable+import GHC.Generics++import Language.Haskell.TH.Lift+ {- A quick note on how the primitive data types of HaskHOL are implemented -- - view patterns are used to simulate private data types for HOL types and - terms:- * Internal constructors are hidden to prevent manual construction of terms.- - * View constructors (those of 'HOLTypeView', 'HOLTermView', and 'HOLThmView')- are exposed to enable pattern matching. - - * View patterns, as defined by instances of the 'view' function from the - @Viewable@ class, provide a conversion between the two sets of constructors.+ unidirectional pattern synonyms are used to simulate private data types for + HOL types, terms, and theorems. -} {-@@ -69,53 +80,63 @@ There are two principle changes to Harrison's implementation: 1. Type operators have been introduced, via the 'TypeOp' data type, to - facilitate a stateless logical kernel following from Freek Wiedijk's + facilitate a semi-stateless logical kernel following from Freek Wiedijk's Stateless HOL system. 2. Universal types and type operator variables have been introduced to move the logic from simply typed to polymorphic following from Norbert Voelker's HOL2P system. -}- {-| The 'HOLType' data type defines the internal constructors for HOL types in- HaskHOL. For more details, see the documentation for its view pattern data- type, 'HOLTypeView'.+ HaskHOL. -}-data HOLType- = TyVarIn !Bool !String- | TyAppIn !TypeOp ![HOLType]+data HOLType + = TyVarIn !Bool !Text+ | TyAppIn !TypeOp ![HOLType] | UTypeIn !HOLType !HOLType- deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Generic) --- | The view pattern data type for HOL types.-data HOLTypeView- -- | A type variable consisting of a constraint flag and name.- = TyVar Bool String- {-| - A type application consisting of a type operator and a list of type- arguments. See 'TypeOp' for more details.- -}- | TyApp TypeOp [HOLType]- {-| - A universal type consisting of a bound type and a body type. Note that - the bound type must be a small, type variable.- -}- | UType HOLType HOLType+instance Hashable HOLType +-- | A type variable consisting of a constraint flag and name.+pattern TyVar b s <- TyVarIn b s+ +{-| + A type application consisting of a type operator and a list of type+ arguments. See 'TypeOp' for more details.+-}+pattern TyApp op tys <- TyAppIn op tys+{-| + A universal type consisting of a bound type and a body type. Note that + the bound type must be a small, type variable.+-}+pattern UType tv bod <- UTypeIn tv bod+ {-| The data type for type operators, 'TypeOp', is a mashing together of the representation of type operators from both both HOL2P and Stateless HOL. For more information regarding construction of the different operators, see- the documentation of the following functions: 'mkTypeOpVar', 'newPrimTypeOp',- 'newDefinedTypeOp'+ the documentation of the following functions: 'mkTypeOpVar', + 'newPrimitiveTypeOp', and 'newDefinedTypeOp' -} data TypeOp - = TyOpVar !String- | TyPrim !String !Int- | TyDefined !String !Int !HOLThm- deriving (Eq, Ord, Typeable)+ = TyOpVarIn !Text+ | TyPrimitiveIn !Text !Int+ | TyDefinedIn !Text !Int !Int -- Hash of concl of thm+ deriving (Eq, Ord, Typeable, Generic) +instance Hashable TypeOp++-- | A type operator variable consisting of a name.+pattern TyOpVar s <- TyOpVarIn s++-- | A type operator primitive consisting of a name and arity.+pattern TyPrimitive s n <- TyPrimitiveIn s n++-- | A defined type operator consisting of a name and arity.+pattern TyDefined s n <- TyDefinedIn s n _+ {- In order to keep HaskHOL's type system decidable, we follow the same \"smallness\" constraint used by HOL2P: type variables that are constrained @@ -152,16 +173,10 @@ -} type SubstTrip = (HOLTypeEnv, [(TypeOp, HOLType)], [(TypeOp, TypeOp)]) --- Viewable and Show instances for HOLType-instance Viewable HOLType HOLTypeView where- view (TyVarIn b s) = TyVar b s- view (TyAppIn tyop tys) = TyApp tyop tys- view (UTypeIn v b) = UType v b- instance Show TypeOp where- show (TyOpVar s) = '_' : s- show (TyPrim s _) = s- show (TyDefined s _ _) = s+ show (TyOpVarIn s) = '_' : show s+ show (TyPrimitiveIn s _) = show s+ show (TyDefinedIn s _ _) = show s {- The following data types combined provide the definition of HOL terms in @@ -185,70 +200,86 @@ type, 'HOLTermView'. -} data HOLTerm- = VarIn !String !HOLType- | ConstIn !String !HOLType !ConstTag- | CombIn !HOLTerm !HOLTerm- | AbsIn !HOLTerm !HOLTerm- | TyCombIn !HOLTerm !HOLType- | TyAbsIn !HOLType !HOLTerm- deriving (Eq, Ord, Typeable)+ = VarIn !Text !HOLType+ | ConstIn !Text !HOLType !ConstTag + | CombIn !HOLTerm !HOLTerm+ | AbsIn !HOLTerm !HOLTerm+ | TyCombIn !HOLTerm !HOLType+ | TyAbsIn !HOLType !HOLTerm+ deriving (Eq, Ord, Typeable, Generic) --- | The view pattern data type for HOL terms.-data HOLTermView- -- | A term variable consisting of a name and type.- = Var String HOLType- {-| - A term constant consisting of a name, type, and tag. See 'ConstTag' for - more information.- -}- | Const String HOLType ConstTag- -- | A term application consisting of a function term and argument term.- | Comb HOLTerm HOLTerm- {-| - A term abstraction consisting of a bound term and a body term. Note that- the bound term must be a type variable.- -}- | Abs HOLTerm HOLTerm- {-| - A term-level, type application consisting of a body term and an argument - type. Note that the body term must have a universal type.- -}- | TyComb HOLTerm HOLType- {-| - A term-level, type abstraction consisting of a bound type and a body term.- Note that the bound type must be a small, type variable.- -}- | TyAbs HOLType HOLTerm+instance Hashable HOLTerm++-- | A term variable consisting of a name and type.+pattern Var s ty <- VarIn s ty ++{-| + A term constant consisting of a name, type, and tag. See 'ConstTag' for + more information.+-}+pattern Const s ty <- ConstIn s ty _++-- | A term application consisting of a function term and argument term.+pattern Comb l r <- CombIn l r+ +{-| + A term abstraction consisting of a bound term and a body term. Note that+ the bound term must be a type variable.+-}+pattern Abs bv bod <- AbsIn bv bod++{-| + A term-level, type application consisting of a body term and an argument + type. Note that the body term must have a universal type.+-}+pattern TyComb tm ty <- TyCombIn tm ty+ +{-| + A term-level, type abstraction consisting of a bound type and a body term.+ Note that the bound type must be a small, type variable.+-}+pattern TyAbs ty tm <- TyAbsIn ty tm {-| The data type for constant tags, 'ConstTag', follows identically from the implementation in Stateless HOL. For more information regarding construction of the different tags, see the documentation of the following functions:- 'newPrimConst', 'newDefinedConst', and 'newDefinedTypeOp'.+ 'newPrimitiveConst', 'newDefinedConst', and 'newDefinedTypeOp'. -} data ConstTag- = Prim- | Defined !HOLTerm- | MkAbstract !String !Int !HOLThm- | DestAbstract !String !Int !HOLThm- deriving (Eq, Ord, Typeable)+ = PrimitiveIn+ | DefinedIn !Int -- hash+ | MkAbstractIn !Text !Int !Int -- name, arity, hash+ | DestAbstractIn !Text !Int !Int -- name, arity, hash+ deriving (Eq, Ord, Typeable, Generic) --- | Type synonym for the commonly used, list-based, term environment.-type HOLTermEnv = [(HOLTerm, HOLTerm)]+instance Hashable ConstTag -{- - The Viewable instance for terms. - Note that the Show instance for terms is more complicated than for types and, - as such, is included separately in the HaskHOL.Core.Printer module.+-- | A primitive constant tag.+pattern Primitive <- PrimitiveIn++-- | A defined constant tag.+pattern Defined <- DefinedIn _++{-| A defined constant tag for type construction consisting of a name and + arity. -}-instance Viewable HOLTerm HOLTermView where- view (VarIn s ty) = Var s ty- view (ConstIn s ty tag) = Const s ty tag- view (CombIn l r) = Comb l r- view (AbsIn v bod) = Abs v bod- view (TyAbsIn tv tb) = TyAbs tv tb- view (TyCombIn tm ty) = TyComb tm ty+pattern MkAbstract s n <- MkAbstractIn s n _ +{-| A defined constant tag for type destruction consisting of a name and + arity.+-}+pattern DestAbstract s n <- DestAbstractIn s n _++instance Show ConstTag where+ show PrimitiveIn = "Prim"+ show (DefinedIn _) = "Defined"+ show (MkAbstractIn s _ _) = "Mk__" ++ show s+ show (DestAbstractIn s _ _) = "Dest__" ++ show s++-- | Type synonym for the commonly used, list-based, term environment.+type HOLTermEnv = [(HOLTerm, HOLTerm)]+ {-| The 'HOLThm' data type defines HOL Theorems in HaskHOL. A theorem is defined simply as a list of assumption terms and a conclusion term.@@ -258,30 +289,12 @@ Axioms can be tracked once the stateful layer of the prover is introduced, though. For more details see the documentation for `newAxiom`. -}-data HOLThm = ThmIn ![HOLTerm] !HOLTerm- deriving (Eq, Ord, Typeable)---- | The view pattern data type for HOL theorems.-data HOLThmView = Thm [HOLTerm] HOLTerm--instance Viewable HOLThm HOLThmView where- view (ThmIn asl c) = Thm asl c--{-| - The @Viewable@ class is used to provide a polymorphic view pattern for- HaskHOL's primitive data types.--}-class Viewable a b where- {-| - The view pattern function for HaskHOL's primitive data types:- - * For types - Converts from 'HOLType' to 'HOLTypeView'.- - * For terms - Converts from 'HOLTerm' to 'HOLTermView'.+data HOLThm = ThmIn ![HOLTerm] !HOLTerm deriving (Eq, Ord, Typeable, Generic)+ +instance Hashable HOLThm - * For theorems - Converts from 'HOLThm' to 'HOLThmView'.- -}- view :: a -> b+-- | The pattern synonym for HOL theorems.+pattern Thm as c <- ThmIn as c {- Deepseq instances for the primitive data types. These are included as they @@ -293,32 +306,35 @@ rnf (UTypeIn tv tb) = rnf tv `seq` rnf tb instance NFData TypeOp where- rnf (TyOpVar s) = rnf s- rnf (TyPrim s n) = rnf s `seq` rnf n- rnf (TyDefined s n thm) = rnf s `seq` rnf n `seq` rnf thm+ rnf (TyOpVarIn s) = rnf s+ rnf (TyPrimitiveIn s n) = rnf s `seq` rnf n+ rnf (TyDefinedIn s n h) = rnf s `seq` rnf n `seq` rnf h instance NFData HOLTerm where rnf (VarIn s ty) = rnf s `seq` rnf ty- rnf (ConstIn s ty d) = rnf s `seq` rnf ty `seq` rnf d+ rnf (ConstIn s ty tag) = rnf s `seq` rnf ty `seq` rnf tag rnf (CombIn l r) = rnf l `seq` rnf r rnf (AbsIn bv bod) = rnf bv `seq` rnf bod rnf (TyAbsIn bty bod) = rnf bty `seq` rnf bod rnf (TyCombIn tm ty) = rnf tm `seq` rnf ty instance NFData ConstTag where- rnf Prim = ()- rnf (Defined tm) = rnf tm- rnf (MkAbstract s i thm) = rnf s `seq` rnf i `seq` rnf thm- rnf (DestAbstract s i thm) = rnf s `seq` rnf i `seq` rnf thm+ rnf PrimitiveIn = ()+ rnf (DefinedIn h) = rnf h+ rnf (MkAbstractIn s i h) = rnf s `seq` rnf i `seq` rnf h+ rnf (DestAbstractIn s i h) = rnf s `seq` rnf i `seq` rnf h instance NFData HOLThm where rnf (ThmIn asl c) = rnf asl `seq` rnf c -{- - These are the automatically derived Lift instances for the primitive data- types. These instances are used by the compile-time operations found in- the HaskHOL.Core.Protected module.--}-$(deriveLiftMany [ ''TypeOp, ''HOLType- , ''ConstTag, ''HOLTerm- , ''HOLThm])+deriveSafeCopy 0 'base ''TypeOp+deriveSafeCopy 0 'base ''HOLType+deriveSafeCopy 0 'base ''ConstTag+deriveSafeCopy 0 'base ''HOLTerm+deriveSafeCopy 0 'base ''HOLThm++instance Lift Text where+ lift t = [| pack $(lift $ unpack t) |]++deriveLiftMany [''TypeOp, ''HOLType, ''ConstTag, ''HOLTerm, ''HOLThm]+
src/HaskHOL/Core/Kernel/Terms.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, PatternSynonyms #-} {-| Module: HaskHOL.Core.Kernel.Terms@@ -25,60 +25,71 @@ -- ** A High-Level Overview of HOL Terms -- $HOLTerms HOLTerm- , HOLTermView(..)+ , pattern Var+ , pattern Const+ , pattern Comb+ , pattern Abs+ , pattern TyComb+ , pattern TyAbs , ConstTag+ , pattern Primitive+ , pattern Defined+ , pattern MkAbstract+ , pattern DestAbstract , HOLTermEnv -- * HOL Light Term Primitives -- ** Alpha-Equivalence of Terms- , alphaOrder -- :: HOLTerm -> HOLTerm -> Ordering- , aConv -- :: HOLTerm -> HOLTerm -> Bool+ , alphaOrder+ , aConv -- ** Predicates, Constructors, and Destructors for Basic Terms- , isVar -- :: HOLTerm -> Bool- , isConst -- :: HOLTerm -> Bool- , isAbs -- :: HOLTerm -> Bool- , isComb -- :: HOLTerm -> Bool- , mkVar -- :: String -> HOLType -> HOLTerm- , mkAbs -- :: HOLTerm -> HOLTerm -> Either String HOLTerm- , mkComb -- :: HOLTerm -> HOLTerm -> Either String HOLTerm- , destVar -- :: HOLTerm -> Maybe (String, HOLType)- , destConst -- :: HOLTerm -> Maybe (String, HOLType)- , destComb -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , destAbs -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+ , isVar+ , isConst+ , isAbs+ , isComb+ , mkVar+ , mkAbs+ , mkComb+ , destVar+ , destConst+ , destComb+ , destAbs -- ** Term and Type Variable Extractors- , frees -- :: HOLTerm -> [HOLTerm]- , catFrees -- :: [HOLTerm] -> [HOLTerm]- , freesIn -- :: [HOLTerm] -> HOLTerm -> Bool- , varFreeIn -- :: HOLTerm -> HOLTerm -> Bool- , typeVarsInTerm -- :: HOLTerm -> [HOLType]- , typeVarsInTerms -- :: [HOLTerm] -> [HOLType]+ , frees+ , catFrees+ , freesIn+ , varFreeIn+ , typeVarsInTerm+ , typeVarsInTerms -- ** Term Substitution and Instantiation- , varSubst -- :: HOLTermEnv -> HOLTerm -> HOLTerm+ , varSubst , Inst- , inst -- :: Inst a b => [(a, b)] -> HOLTerm -> HOLTerm- , instFull -- :: SubstTrip -> HOLTerm -> HOLTerm- , instConst -- :: TypeSubst a b => HOLTerm -> [(a, b)] -> Maybe HOLTerm- , instConstFull -- :: HOLTerm -> SubstTrip -> Maybe HOLTerm+ , inst+ , instFull+ , instConst+ , instConstFull -- ** Commonly Used Terms and Functions- , tmEq -- :: HOLType -> HOLTerm- , isEq -- :: HOLTerm -> Bool- , primMkEq -- :: HOLTerm -> HOLTerm -> Maybe HOLTerm- , destEq -- :: HOLTerm -> Maybe (HOLTerm, HOLTerm)- , variant -- :: [HOLTerm] -> HOLTerm -> HOLTerm- , variants -- :: [HOLTerm] -> [HOLTerm] -> [HOLTerm]+ , tmEq+ , pattern TmEq+ , pattern (:=)+ , isEq+ , primMkEq+ , destEq+ , variant+ , variants -- * Stateless HOL Term Primitives -- ** Constructors for Constant Tags- , newPrimConst -- :: String -> HOLType -> HOLTerm+ , newPrimitiveConst -- ** Type Operator Variable Extractors- , typeOpVarsInTerm -- :: HOLTerm -> [TypeOp]- , typeOpVarsInTerms -- :: [HOLTerm] -> [TypeOp]+ , typeOpVarsInTerm+ , typeOpVarsInTerms -- * HOL2P Term Primitives -- ** Predicates, Constructors, and Destructors for Term-Level Types- , isTyAbs -- :: HOLTerm -> Bool- , isTyComb -- :: HOLTerm -> Bool- , mkTyAbs -- :: HOLType -> HOLTerm -> Either String HOLTerm- , mkTyComb -- :: HOLTerm -> HOLType -> Either String HOLTerm- , destTyAbs -- :: HOLTerm -> Maybe (HOLType, HOLTerm)- , destTyComb -- :: HOLTerm -> Maybe (HOLTerm, HOLType)+ , isTyAbs+ , isTyComb+ , mkTyAbs+ , mkTyComb+ , destTyAbs+ , destTyComb ) where import HaskHOL.Core.Lib@@ -94,55 +105,57 @@ -- | Provides an ordering for two terms modulo alpha-equivalence alphaOrder :: HOLTerm -> HOLTerm -> Ordering alphaOrder = orda []- where orda :: HOLTermEnv -> HOLTerm -> HOLTerm -> Ordering- orda env tm1 tm2- | tm1 == tm2 && all (uncurry (==)) env = EQ- | otherwise =- case (tm1, tm2) of- (VarIn{}, VarIn{}) -> ordav env tm1 tm2- (ConstIn{}, ConstIn{}) -> tm1 `aorder` tm2- (CombIn s1 t1, CombIn s2 t2) ->- case orda env s1 s2 of- EQ -> orda env t1 t2- res -> res- (AbsIn x1@(VarIn _ ty1) t1, AbsIn x2@(VarIn _ ty2) t2) ->- case tyAlphaOrder ty1 ty2 of- EQ -> orda ((x1, x2):env) t1 t2- res -> res- (AbsIn{}, AbsIn{}) -> compare tm1 tm2- (TyAbsIn tv1@(TyVarIn True _) tb1, - TyAbsIn tv2@(TyVarIn True _) tb2) ->- orda env tb1 $ inst [(tv2, tv1)] tb2- (TyAbsIn{}, TyAbsIn{}) -> compare tm1 tm2- (TyCombIn t1 ty1, TyCombIn t2 ty2) ->- case orda env t1 t2 of- EQ -> tyAlphaOrder ty1 ty2- res -> res- (ConstIn{}, _) -> LT- (_, ConstIn{}) -> GT- (VarIn{}, _) -> LT- (_, VarIn{}) -> GT- (CombIn{}, _) -> LT- (_, CombIn{}) -> GT- (AbsIn{}, _) -> LT- (_, AbsIn{}) -> GT- (TyAbsIn{}, _) -> LT- (_, TyAbsIn{}) -> GT+ where orda :: [(HOLTerm, HOLTerm)] -> HOLTerm -> HOLTerm -> Ordering+ orda env tm1@VarIn{} tm2@VarIn{} = ordav env tm1 tm2+ orda _ tm1@ConstIn{} tm2@ConstIn{} = tm1 `aorder` tm2+ orda env (CombIn s1 t1) (CombIn s2 t2) =+ case orda env s1 s2 of+ EQ -> orda env t1 t2+ res -> res+ orda env (AbsIn x1@(VarIn _ ty1) t1) + (AbsIn x2@(VarIn _ ty2) t2) =+ case tyAlphaOrder ty1 ty2 of+ EQ -> orda ((x1, x2):env) t1 t2+ res -> res+ orda _ tm1@AbsIn{} tm2@AbsIn{} = compare tm1 tm2+ orda env (TyAbsIn tv1@(TyVarIn True _) tb1) + (TyAbsIn tv2@(TyVarIn True _) tb2) =+ let tb2' = inst [(tv2, tv1)] tb2 in+ orda env tb1 tb2'+ orda _ tm1@TyAbsIn{} tm2@TyAbsIn{} = compare tm1 tm2+ orda env (TyCombIn t1 ty1) (TyCombIn t2 ty2) =+ case orda env t1 t2 of+ EQ -> tyAlphaOrder ty1 ty2+ res -> res+ orda _ ConstIn{} _ = LT+ orda _ _ ConstIn{} = GT+ orda _ VarIn{} _ = LT+ orda _ _ VarIn{} = GT+ orda _ CombIn{} _ = LT+ orda _ _ CombIn{} = GT+ orda _ AbsIn{} _ = LT+ orda _ _ AbsIn{} = GT+ orda _ TyAbsIn{} _ = LT+ orda _ _ TyAbsIn{} = GT - ordav :: HOLTermEnv -> HOLTerm -> HOLTerm -> Ordering+ ordav :: [(HOLTerm, HOLTerm)] -> HOLTerm -> HOLTerm -> Ordering ordav [] x1 x2 = x1 `aorder` x2- ordav ((t1, t2):oenv) x1 x2- | x1 == t1 = if x2 == x2 then EQ else LT- | otherwise = if x2 == t2 then GT else ordav oenv x1 x2+ ordav ((l, r):oenv) x1 x2+ | x1 == l = if x2 == r then EQ else LT+ | otherwise = if x2 == r then GT else ordav oenv x1 x2 aorder :: HOLTerm -> HOLTerm -> Ordering- aorder tm1@(VarIn s1 ty1) tm2@(VarIn s2 ty2)- | s1 == s2 = tyAlphaOrder ty1 ty2- | otherwise = compare tm1 tm2- aorder tm1@(ConstIn s1 ty1 d1) tm2@(ConstIn s2 ty2 d2)- | s1 == s2 && d1 == d2 = tyAlphaOrder ty1 ty2- | otherwise = compare tm1 tm2- aorder tm1 tm2 = compare tm1 tm2+ aorder (VarIn s1 ty1) (VarIn s2 ty2) =+ case compare s1 s2 of+ EQ -> tyAlphaOrder ty1 ty2+ res -> res+ aorder (ConstIn s1 ty1 tag1) (ConstIn s2 ty2 tag2) =+ case compare s1 s2 of+ EQ -> case compare tag1 tag2 of+ EQ -> tyAlphaOrder ty1 ty2+ res -> res+ res -> res+ aorder x y = compare x y -- | Tests if two terms are alpha-equivalent aConv :: HOLTerm -> HOLTerm -> Bool@@ -169,7 +182,7 @@ isComb _ = False -- | Constructs a term variable of a given name and type.-mkVar :: String -> HOLType -> HOLTerm+mkVar :: Text -> HOLType -> HOLTerm mkVar = VarIn {-| @@ -191,8 +204,9 @@ mkComb :: HOLTerm -> HOLTerm -> Either String HOLTerm mkComb f a = case typeOf f of- (TyAppIn (TyPrim "fun" _) (ty:_)) -> - if typeOf a `tyAConv` ty then Right $ CombIn f a+ (TyAppIn (TyPrimitiveIn "fun" _) (ty:_)) -> + if typeOf a `tyAConv` ty+ then Right $ CombIn f a else Left "mkComb: argument type mismatch." _ -> Left "mkComb: argument not of function type." @@ -200,7 +214,7 @@ Destructs a term variable, returning its name and type. Fails with 'Nothing' if the provided term is not a variable. -}-destVar :: HOLTerm -> Maybe (String, HOLType)+destVar :: HOLTerm -> Maybe (Text, HOLType) destVar (VarIn s ty) = Just (s, ty) destVar _ = Nothing @@ -209,7 +223,7 @@ tag information is returned. Fails with 'Nothing' if the provided term is not a constant. -}-destConst :: HOLTerm -> Maybe (String, HOLType)+destConst :: HOLTerm -> Maybe (Text, HOLType) destConst (ConstIn s ty _) = Just (s, ty) destConst _ = Nothing @@ -231,12 +245,12 @@ -- | Returns a list of all free, term variables in a term. frees :: HOLTerm -> [HOLTerm]-frees tm@VarIn{} = [tm] frees ConstIn{} = [] frees (AbsIn bv bod) = frees bod \\ [bv] frees (CombIn s t) = frees s `union` frees t-frees (TyAbsIn _ tm) = frees tm-frees (TyCombIn tm _) = frees tm+frees (TyAbsIn _ t) = frees t+frees (TyCombIn t _) = frees t+frees t@VarIn{} = [t] -- | Returns a list of all free, term variables in a list of terms. catFrees :: [HOLTerm] -> [HOLTerm]@@ -244,12 +258,12 @@ -- | Checks a list of term variables to see if they are all free in a give term. freesIn :: [HOLTerm] -> HOLTerm -> Bool-freesIn acc tm@VarIn{} = tm `elem` acc freesIn _ ConstIn{} = True freesIn acc (AbsIn bv bod) = freesIn (bv:acc) bod freesIn acc (CombIn s t) = freesIn acc s && freesIn acc t freesIn acc (TyAbsIn _ t) = freesIn acc t freesIn acc (TyCombIn t _) = freesIn acc t+freesIn acc t@VarIn{} = t `elem` acc -- | Checks if a variable or constant term is free in a given term. varFreeIn :: HOLTerm -> HOLTerm -> Bool@@ -266,10 +280,14 @@ typeVarsInTerm :: HOLTerm -> [HOLType] typeVarsInTerm (VarIn _ ty) = tyVars ty typeVarsInTerm (ConstIn _ ty _) = tyVars ty-typeVarsInTerm (CombIn s t) = typeVarsInTerm s `union` typeVarsInTerm t-typeVarsInTerm (AbsIn bv t) = typeVarsInTerm bv `union` typeVarsInTerm t-typeVarsInTerm (TyAbsIn tv tm) = typeVarsInTerm tm \\ [tv]-typeVarsInTerm (TyCombIn tm ty) = typeVarsInTerm tm `union` tyVars ty+typeVarsInTerm (CombIn s t) = + typeVarsInTerm s `union` typeVarsInTerm t+typeVarsInTerm (AbsIn bv t) = + typeVarsInTerm bv `union` typeVarsInTerm t+typeVarsInTerm (TyAbsIn tv tm) = + typeVarsInTerm tm \\ [tv]+typeVarsInTerm (TyCombIn tm ty) = + typeVarsInTerm tm `union` tyVars ty {-| Returns a list of all free, type variables in a list of terms, not including@@ -281,40 +299,46 @@ {-| Performs a basic term substitution using a substitution environment containing- pairs consisting of a term variable and a term to be substituted for that - variable. Note that the order of elements in a substitution pair follows the- convention of most Haskell libraries, rather than the traditional HOL - convention:+ pairs of term variables and terms. + Note that the substitution environment is treated as an association list, such+ that: - * The second element is substituted for the first, i.e. the substitution pair+ * The term variable acts as an index in the list, i.e. the substitution pair @(A, \\ x.x)@ indicates that the lambda term @\\x.x@ should be substituted for the term variable @A@.++ Substitution fails with 'Nothing' in the case where a bad substitution list is+ presented. -}-varSubst :: HOLTermEnv -> HOLTerm -> HOLTerm-varSubst [] term = term-varSubst theta term =- varSubstRec (filter validPair theta) term+varSubst :: HOLTermEnv -> HOLTerm -> Maybe HOLTerm+varSubst [] term = Just term+varSubst theta term+ | all validPair theta = hush $ varSubstRec theta term+ | otherwise = Nothing where validPair :: (HOLTerm, HOLTerm) -> Bool validPair (VarIn _ ty, t) = ty `tyAConv` typeOf t validPair _ = False - varSubstRec :: HOLTermEnv -> HOLTerm -> HOLTerm- varSubstRec env tm@VarIn{} = lookupd tm env tm- varSubstRec _ tm@ConstIn{} = tm+ varSubstRec :: HOLTermEnv -> HOLTerm -> Either String HOLTerm+ varSubstRec _ tm@ConstIn{} = Right tm varSubstRec env (CombIn s t) =- CombIn (varSubstRec env s) $ varSubstRec env t+ liftM1 mkComb (varSubstRec env s) =<< varSubstRec env t varSubstRec env tm@(AbsIn v s) = let env' = filter (\ (x, _) -> x /= v) env in- if null env' then tm- else let s' = varSubstRec env' s in- if s' == s then tm- else if any (\ (x, t) -> varFreeIn v t && - varFreeIn x s) env'- then let v' = variant [s'] v in- AbsIn v' $ varSubstRec ((v, v'):env') s- else AbsIn v $ varSubstRec env' s- varSubstRec env (TyAbsIn tv t) = TyAbsIn tv $ varSubstRec env t- varSubstRec env (TyCombIn t ty) = TyCombIn (varSubstRec env t) ty+ if null env' then Right tm+ else do s' <- varSubstRec env' s+ if s' == s + then Right tm+ else if any (\ (x, t) -> varFreeIn v t && + varFreeIn x s) env'+ then let v' = variant [s'] v in+ mkAbs v' =<< varSubstRec ((v, v'):env') s+ else mkAbs v =<< varSubstRec env' s+ varSubstRec env (TyAbsIn tv t) = + mkTyAbs tv =<< varSubstRec env t+ varSubstRec env (TyCombIn t ty) = + liftM1 mkTyComb (varSubstRec env t) ty+ varSubstRec env tm@VarIn{} = Right $ lookupd tm env tm {-| The @Inst@ class provides the framework for type instantiation in HaskHOL.@@ -328,7 +352,7 @@ three different possible instantiation environment types and, therefore, three different ways to handle renaming: - * For @(x::'HOLTerm', r::'HOLTerm')@ substitution pairs we rename in the case + * For @(x::'HOLType', r::'HOLType')@ substitution pairs we rename in the case where a type abstraction binds a type variable present in @r@ and @x@ is present in the body of the type abstraction. @@ -336,7 +360,7 @@ renaming as our logic does not permit the binding of type operator variables. - * For @(x::'TypeOp', r::'HOLTerm')@ substitution pairs we rename in the case + * For @(x::'TypeOp', r::'HOLType')@ substitution pairs we rename in the case where a type abstraction binds a type variable present in @r@ and @x@ is present in the body of the type abstraction. @@ -357,20 +381,22 @@ let tyenv' = filter (\ (x, _) -> x /= tv) tyenv in if null tyenv' then Right tm else if any (\ (x, r) -> tv `elem` tyVars r && - x `elem` typeVarsInTerm t) tyenv'+ x `elem` typeVarsInTerm t) tyenv' -- avoid capture by renaming type variable then let tvt = typeVarsInTerm t tvpatts = map fst tyenv' tvrepls = catTyVars . mapMaybe (`lookup` tyenv') $ tvt `intersect` tvpatts- tv' = variantTyVar ((tvt \\ tvpatts) `union` tvrepls) tv in- liftM (TyAbsIn tv') $ instRec env ((tv, tv'):tyenv') t- else liftM (TyAbsIn tv) $ instRec env tyenv' t+ tv' = variantTyVar ((tvt \\ tvpatts) `union` tvrepls) + tv in+ liftM (fromRight . mkTyAbs tv') $+ instRec env ((tv, tv'):tyenv') t+ else liftM (fromRight . mkTyAbs tv) $ instRec env tyenv' t instTyAbs _ _ tm = Right tm instance Inst TypeOp TypeOp where instTyAbs env tyenv (TyAbsIn tv t) = - liftM (TyAbsIn tv) $ instRec env tyenv t+ liftM (fromRight . mkTyAbs tv) $ instRec env tyenv t instTyAbs _ _ tm = Right tm instance Inst TypeOp HOLType where@@ -383,8 +409,9 @@ tvrepls = catTyVars . mapMaybe (`lookup` tyenv) $ tvbs `intersect` tvpatts tv' = variantTyVar tvrepls tv in- liftM (TyAbsIn tv') . instRec env tyenv $ inst [(tv, tv')] t- else liftM (TyAbsIn tv) $ instRec env tyenv t+ liftM (fromRight . mkTyAbs tv') . + instRec env tyenv $ inst [(tv, tv')] t+ else liftM (fromRight . mkTyAbs tv) $ instRec env tyenv t instTyAbs _ _ tm = Right tm {-|@@ -407,32 +434,35 @@ instRec :: Inst a b => HOLTermEnv -> [(a, b)] -> HOLTerm -> Either HOLTerm HOLTerm instRec env tyenv tm@(VarIn n ty) =- let ty' = typeSubst tyenv ty- tm' = VarIn n ty' in+ let tm' = mkVar n $ typeSubst tyenv ty in if lookupd tm' env tm == tm then Right tm' else Left tm' -- Clash-instRec _ tyenv (ConstIn c ty tag) =+instRec _ tyenv (ConstIn s ty tag) = let ty' = typeSubst tyenv ty in- Right $ ConstIn c ty' tag+ Right $ ConstIn s ty' tag instRec env tyenv (CombIn f x) =- return CombIn <*> instRec env tyenv f <*> instRec env tyenv x+ do f' <- instRec env tyenv f+ x' <- instRec env tyenv x+ return . fromRight $ mkComb f' x' instRec env tyenv (AbsIn y@(VarIn _ ty) t) =- do y' <- instRec [] tyenv y+ do y'<- instRec [] tyenv y case instRec ((y', y):env) tyenv t of- Right t' -> Right $ AbsIn y' t'+ Right t' -> return . fromRight $ mkAbs y' t' e@(Left w') -> if w' /= y' then e else do ifrees <- mapM (instRec [] tyenv) $ frees t case variant ifrees y' of- VarIn x _ -> - let z = VarIn x ty in- instRec env tyenv . AbsIn z $ varSubst [(y, z)] t+ (VarIn x _) -> + let z = mkVar x ty in+ instRec env tyenv . fromRight $ + mkAbs z #<< varSubst [(y, z)] t _ -> e instRec env tyenv tm@TyAbsIn{} = instTyAbs env tyenv tm instRec env tyenv (TyCombIn tm ty) = do tm' <- instRec env tyenv tm- return . TyCombIn tm' $ typeSubst tyenv ty-instRec _ _ _ = Left undefined+ let ty' = typeSubst tyenv ty+ return . fromRight $ mkTyComb tm' ty'+instRec _ _ AbsIn{} = error "instRec: bad term construction." {-| A version of 'inst' that accepts a triplet of type substitution environments.@@ -446,8 +476,9 @@ 'mkConst' to guarantee that only constants are constructed. -} instConst :: TypeSubst a b => HOLTerm -> [(a, b)] -> Maybe HOLTerm-instConst (ConstIn name uty tag) tyenv = - Just $ ConstIn name (typeSubst tyenv uty) tag+instConst (ConstIn s uty tag) tyenv = + let ty = typeSubst tyenv uty in+ Just $ ConstIn s ty tag instConst _ _ = Nothing {-| @@ -455,46 +486,55 @@ environments. -} instConstFull :: HOLTerm -> SubstTrip -> Maybe HOLTerm-instConstFull (ConstIn name uty tag) tyenv = - Just $ ConstIn name (typeSubstFull tyenv uty) tag+instConstFull (ConstIn s uty tag) tyenv = + let ty = typeSubstFull tyenv uty in+ Just $ ConstIn s ty tag instConstFull _ _ = Nothing -- | Constructs an instance of the HOL equality constant, @=@, for a given type. tmEq :: HOLType -> HOLTerm tmEq ty = - ConstIn "=" (TyAppIn tyOpFun [ty, TyAppIn tyOpFun [ty, tyBool]]) Prim+ ConstIn "=" (TyAppIn tyOpFun [ty, TyAppIn tyOpFun [ty, tyBool]]) + PrimitiveIn +-- | The pattern synonym equivalent of 'tmEq'.+pattern TmEq ty <- Const "=" (TyFun ty (TyFun _ TyBool))++-- | The infix pattern synonym for term equality.+pattern l := r <- Comb (Comb (Const "=" _) l) r+ -- | Predicate for equations, i.e. terms of the form @l = r@. isEq :: HOLTerm -> Bool-isEq (CombIn (CombIn (ConstIn "=" _ Prim) _) _) = True+isEq (CombIn (CombIn (ConstIn "=" _ PrimitiveIn) _) _) = True isEq _ = False {-| Constructs an equation term given the left and right hand side arguments. Fails with 'Left' if the types of the terms are not alpha-equivalent. -}-primMkEq :: HOLTerm -> HOLTerm -> Either String HOLTerm+primMkEq :: HOLTerm -> HOLTerm -> Maybe HOLTerm primMkEq l r | typeOf l `tyAConv` typeOf r =- Right $ CombIn (CombIn (tmEq $ typeOf l) l) r- | otherwise = Left "primMkEq"+ hush $ liftM1 mkComb (mkComb (tmEq $ typeOf l) l) r+ | otherwise = Nothing {-| Destructs an equation term, returning the left and right hand side arguments. Fails with 'Nothing' if the term is not an equation, i.e. of the form @l = r@. -} destEq :: HOLTerm -> Maybe (HOLTerm, HOLTerm)-destEq (CombIn (CombIn (ConstIn "=" _ Prim) l) r) =+destEq (CombIn (CombIn (ConstIn "=" _ PrimitiveIn) l) r) = Just (l, r) destEq _ = Nothing {-| Renames a term variable to avoid sharing a name with any of a given list of- term variables. Rreturns the original term if it's not a term variable.+ term variables. Returns the original term if it's not a term variable. -} variant :: [HOLTerm] -> HOLTerm -> HOLTerm variant avoid v@(VarIn s ty)- | any (varFreeIn v) avoid = variant avoid $ VarIn (s++"'") ty+ | any (varFreeIn v) avoid = + variant avoid $ mkVar (s `snoc` '\'') ty | otherwise = v variant _ tm = tm @@ -516,20 +556,23 @@ {-| Constructs a primitive constant given a name and type. Note that primitive- constants are tagged with a @Prim@ 'ConstTag' indicating that they have no- definition.+ constants are tagged with a @Primitive@ 'ConstTag' indicating that they have + no definition. -} -newPrimConst :: String -> HOLType -> HOLTerm-newPrimConst name ty = ConstIn name ty Prim+newPrimitiveConst :: Text -> HOLType -> HOLTerm+newPrimitiveConst name ty = ConstIn name ty PrimitiveIn -- | Returns the list of all type operator variables in a term. typeOpVarsInTerm :: HOLTerm -> [TypeOp] typeOpVarsInTerm (VarIn _ ty) = typeOpVars ty typeOpVarsInTerm (ConstIn _ ty _) = typeOpVars ty-typeOpVarsInTerm (CombIn s t) = typeOpVarsInTerm s `union` typeOpVarsInTerm t-typeOpVarsInTerm (AbsIn bv t) = typeOpVarsInTerm bv `union` typeOpVarsInTerm t-typeOpVarsInTerm (TyAbsIn _ tm) = typeOpVarsInTerm tm-typeOpVarsInTerm (TyCombIn tm ty) = typeOpVarsInTerm tm `union` typeOpVars ty+typeOpVarsInTerm (CombIn s t) = + typeOpVarsInTerm s `union` typeOpVarsInTerm t+typeOpVarsInTerm (AbsIn bv t) = + typeOpVarsInTerm bv `union` typeOpVarsInTerm t+typeOpVarsInTerm (TyAbsIn _ t) = typeOpVarsInTerm t+typeOpVarsInTerm (TyCombIn t ty) = + typeOpVarsInTerm t `union` typeOpVars ty -- | Returns the list of all type operator variables in a list of terms. typeOpVarsInTerms :: [HOLTerm] -> [TypeOp]@@ -554,16 +597,9 @@ with 'Left' in the following cases: * The bound type is not a small type variable.-- * The bound type variable occurs in the type of a free variable in the body - term. -} mkTyAbs :: HOLType -> HOLTerm -> Either String HOLTerm-mkTyAbs tv@(TyVarIn True s) bod- | not . any (\ x -> tv `elem` tyVars (typeOf x)) $ frees bod =- Right $ TyAbsIn tv bod- | otherwise = - Left $ "mkTyAbs: tyvar " ++ s ++ " occurs in type of free variable in body term."+mkTyAbs tv@(TyVarIn True _) bod = Right $ TyAbsIn tv bod mkTyAbs _ _ = Left "mkTyAbs: first argument not a small type variable." {-|@@ -578,7 +614,8 @@ mkTyComb tm ty | isSmall ty = case typeOf tm of- UTypeIn{} -> Right $ TyCombIn tm ty+ UTypeIn{} -> + Right $ TyCombIn tm ty _ -> Left "mkTyComb: term must have universal type." | otherwise = Left "mkTyComb: type argument not small."@@ -602,16 +639,13 @@ -- Documentation copied from HaskHOL.Core.Prims {-$ViewPatterns- The primitive data types of HaskHOL are implemented using view patterns in+ The primitive data types of HaskHOL are implemented using pattern synonyms in order to simulate private data types: * Internal constructors are hidden to prevent manual construction of terms. - * View constructors (those of 'HOLTypeView', 'HOLTermView', and 'HOLThmView')- are exposed to enable pattern matching. -- * View patterns, as defined by instances of the 'view' function from the - @Viewable@ class, provide a conversion between the two sets of constructors.+ * Unidirectional pattern synonyms ('Var', etc.) are exposed to enable pattern + matching. -} {-$HOLTerms@@ -620,7 +654,7 @@ Corresponding with the 'HOLType' data type, 'HOLTerm' follows closely from the definition of terms in HOL Light. Again, the appropriate modifications- have been made to facilitate a stateless and polymorphic term language.+ have been made to facilitate a semi-stateless and polymorphic term language. Most notably this includes: (1) The introduction of tags for constants to carry information formerly
src/HaskHOL/Core/Kernel/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, PatternSynonyms #-} {-| Module: HaskHOL.Core.Kernel.Types@@ -25,62 +25,74 @@ -- ** A High-Level Overview of HOL Types -- $HOLTypes HOLType- , HOLTypeView(..)+ , pattern TyVar+ , pattern TyApp+ , pattern UType -- ** A Quick Note on Type Variable Distinction -- $TypeDistinction , TypeOp+ , pattern TyOpVar+ , pattern TyPrimitive+ , pattern TyDefined , HOLTypeEnv , SubstTrip -- * HOL Light Type Primitives -- ** Alpha-Equivalence of Types- , tyAlphaOrder -- :: HOLType -> HOLType -> Ordering- , tyAConv -- :: HOLType -> HOLType -> Bool+ , tyAlphaOrder+ , tyAConv -- ** Predicates, Constructors, and Destructors for Basic Types- , isVarType -- :: HOLType -> Bool- , isType -- :: HOLType -> Bool- , mkVarType -- :: String -> HOLType- , destVarType -- :: HOLType -> Maybe String- , destType -- :: HOLType -> Maybe (String, [HOLType])+ , isVarType+ , isType+ , mkVarType+ , destVarType+ , destType -- ** Type Variable Extractors- , tyVars -- :: HOLType -> [HOLType]- , catTyVars -- :: [HOLType] -> [HOLType]+ , tyVars+ , catTyVars -- ** Type Substitution , TypeSubst- , typeSubst -- :: TypeSubst a b => [(a, b)] -> HOLType -> HOLType- , typeSubstFull -- :: SubstTrip -> HOLType -> HOLType+ , typeSubst+ , typeSubstFull -- ** Commonly Used Types and Functions- , tyBool -- :: HOLType- , tyA -- :: HOLType- , tyB -- :: HOLType- , destFunTy -- :: HOLType -> Maybe (HOLType, HOLType)- , typeOf -- :: HOLTerm -> HOLType+ , tyBool+ , pattern TyBool+ , pattern TyFun+ , pattern (:->)+ , tyA+ , pattern TyA+ , tyB+ , pattern TyB+ , destFunTy+ , typeOf -- * Stateless HOL Type Primitives -- ** Predicates, Constructors, and Destructors for Type Operators- , isTypeOpVar -- :: TypeOp -> Bool- , newPrimTypeOp -- :: String -> Int -> TypeOp- , mkTypeOpVar -- :: String -> TypeOp- , destTypeOp -- :: TypeOp -> (String, Int)+ , isTypeOpVar+ , newPrimitiveTypeOp+ , mkTypeOpVar+ , destTypeOp -- ** Commonly Used Type Operators- , tyOpBool -- :: TypeOp- , tyOpFun -- :: TypeOp- , tyApp -- :: TypeOp -> [HOLType] -> Either String HOLType+ , tyOpBool+ , pattern TyOpBool+ , tyOpFun+ , pattern TyOpFun+ , tyApp -- ** Type Operator Variable Extractors- , typeOpVars -- :: HOLType -> [TypeOp]- , catTypeOpVars -- :: [HOLType] -> [TypeOp]+ , typeOpVars+ , catTypeOpVars -- * HOL2P Type Primitives -- ** Predicates, Constructors, and Destructors for Universal Types- , isUType -- :: HOLType -> Bool- , isSmall -- :: HOLType -> Bool- , mkUType -- :: HOLType -> HOLType -> Either String HOLType- , mkUTypes -- :: [HOLType] -> HOLType -> Either String HOLType- , uTypeFromTypeOpVar -- :: TypeOp -> Int -> Either String HOLType- , mkSmall -- :: HOLType -> Either String HOLType- , destUType -- :: HOLType -> Maybe (HOLType, HOLType)- , destUTypes -- :: HOLType -> Maybe ([HOLType], HOLType)+ , isUType + , isSmall + , mkUType+ , mkUTypes + , uTypeFromTypeOpVar+ , mkSmall+ , destUType+ , destUTypes -- ** Commonly Used Functions- , containsUType -- :: HOLType -> Bool- , variantTyVar -- :: [HOLType] -> HOLType -> HOLType- , variantTyVars -- :: [HOLType] -> [HOLType] -> HOLType+ , containsUType+ , variantTyVar+ , variantTyVars ) where import HaskHOL.Core.Lib@@ -95,30 +107,27 @@ -- | Provides an ordering for two types modulo alpha-equivalence. tyAlphaOrder :: HOLType -> HOLType -> Ordering tyAlphaOrder = tyorda []- where tyorda :: HOLTypeEnv -> HOLType -> HOLType -> Ordering- tyorda env ty1 ty2- | ty1 == ty2 && all (uncurry (==)) env = EQ- | otherwise =- case (ty1, ty2) of- (TyVarIn{}, TyVarIn{}) -> alphavars env ty1 ty2- (TyAppIn tyop1 args1, TyAppIn tyop2 args2) ->- case compare tyop1 tyop2 of- EQ -> tyordas env args1 args2- res -> res- (UTypeIn v1 t1, UTypeIn v2 t2) -> - tyorda ((v1, v2):env) t1 t2- (TyVarIn{}, _) -> LT- (_, TyVarIn{}) -> GT- (TyAppIn{}, _) -> LT- (_, TyAppIn{}) -> GT+ where tyorda :: [(HOLType, HOLType)] -> HOLType -> HOLType -> Ordering+ tyorda env ty1@TyVarIn{} ty2@TyVarIn{} = + alphavars env ty1 ty2+ tyorda env (TyAppIn tyop1 args1) (TyAppIn tyop2 args2) =+ case compare tyop1 tyop2 of+ EQ -> tyordas env args1 args2+ res -> res+ tyorda env (UTypeIn v1 t1) (UTypeIn v2 t2) = + tyorda ((v1, v2):env) t1 t2+ tyorda _ TyVarIn{} _ = LT+ tyorda _ _ TyVarIn{} = GT+ tyorda _ TyAppIn{} _ = LT+ tyorda _ _ TyAppIn{} = GT - alphavars :: HOLTypeEnv -> HOLType -> HOLType -> Ordering- alphavars [] ty1 ty2 = compare ty1 ty2- alphavars ((t1, t2):oenv) ty1 ty2- | ty1 == t1 = if ty2 == t2 then EQ else LT- | otherwise = if ty2 == t2 then GT else alphavars oenv ty1 ty2+ alphavars :: [(HOLType, HOLType)] -> HOLType -> HOLType -> Ordering+ alphavars [] x y = x `compare` y+ alphavars ((t1, t2):oenv) x y+ | x == t1 = if y == t2 then EQ else LT+ | otherwise = if y == t2 then GT else alphavars oenv x y - tyordas :: HOLTypeEnv -> [HOLType] -> [HOLType] -> Ordering+ tyordas :: [(HOLType, HOLType)] -> [HOLType] -> [HOLType] -> Ordering tyordas _ [] [] = EQ tyordas _ [] _ = LT tyordas _ _ [] = GT@@ -145,14 +154,14 @@ Constructs a type variable of a given name. Note that the resultant type variable is unconstrained. -}-mkVarType :: String -> HOLType+mkVarType :: Text -> HOLType mkVarType = TyVarIn False {-| Destructs a type variable, returning its name. Fails with 'Nothing' if called on a non-variable type. -}-destVarType :: HOLType -> Maybe String+destVarType :: HOLType -> Maybe Text destVarType (TyVarIn _ s) = Just s destVarType _ = Nothing @@ -170,9 +179,10 @@ operator variables. -} tyVars :: HOLType -> [HOLType]-tyVars tv@TyVarIn{} = [tv]+tyVars (UTypeIn tv ty) = + tyVars ty \\ [tv] tyVars (TyAppIn _ args) = catTyVars args-tyVars (UTypeIn tv ty) = tyVars ty \\ [tv]+tyVars tv@TyVarIn{} = [tv] {-| Returns the list of all type variables in a list of types, not including type@@ -222,13 +232,13 @@ typeSubst' = typeTypeSubst instance TypeSubst TypeOp TypeOp where- validSubst (_, TyOpVar{}) = False- validSubst (TyOpVar{}, _) = True+ validSubst (_, TyOpVarIn{}) = False+ validSubst (TyOpVarIn{}, _) = True validSubst _ = False typeSubst' = typeOpSubst instance TypeSubst TypeOp HOLType where- validSubst (TyOpVar{}, UTypeIn{}) = True+ validSubst (TyOpVarIn{}, UTypeIn{}) = True validSubst _ = False typeSubst' = typeOpInst @@ -260,14 +270,13 @@ typeTypeSubst :: HOLTypeEnv -> HOLType -> HOLType typeTypeSubst [] t = t typeTypeSubst tyenv t =- typeSubstRec (filter validSubst tyenv) t- where typeSubstRec :: HOLTypeEnv -> HOLType -> HOLType- typeSubstRec tyins ty@TyVarIn{} = assocd ty tyins ty+ fromRight $ typeSubstRec (filter validSubst tyenv) t+ where typeSubstRec :: HOLTypeEnv -> HOLType -> Either String HOLType typeSubstRec tyins (TyAppIn op args) =- TyAppIn op $ map (typeSubstRec tyins) args+ tyApp op =<< mapM (typeSubstRec tyins) args typeSubstRec tyins ty@(UTypeIn tv tbody) = let tyins' = filter (\ (x, _) -> x /= tv) tyins in- if null tyins' then ty+ if null tyins' then Right ty -- test for name capture, renaming instances of tv if necessary else if any (\ (x, t') -> tv `elem` tyVars t' && x `elem` tyVars tbody) tyins'@@ -276,37 +285,54 @@ tvrepls = catTyVars . mapMaybe (`lookup` tyins') $ intersect tvbs tvpatts tv' = variantTyVar ((tvbs \\ tvpatts) `union` - tvrepls) tv in- UTypeIn tv' $ typeSubstRec ((tv, tv') : tyins') tbody- else UTypeIn tv $ typeSubstRec tyins' tbody + tvrepls) tv in+ mkUType tv' =<< typeSubstRec ((tv, tv'):tyins') tbody+ else mkUType tv =<< typeSubstRec tyins' tbody+ typeSubstRec tyins ty@TyVarIn{} = Right $ assocd ty tyins ty -- | Alias to the primitive boolean type. {-# INLINEABLE tyBool #-} tyBool :: HOLType-tyBool = TyAppIn tyOpBool []+tyBool = fromRight $ tyApp tyOpBool [] +-- | The pattern synonym equivalent of 'tyBool'.+pattern TyBool <- TyApp TyOpBool []++-- | The pattern synonym for easily matching on function types.+pattern TyFun ty1 ty2 <- TyApp TyOpFun [ty1, ty2] ++-- | An infix alias to 'TyFun'.+pattern ty1 :-> ty2 <- TyFun ty1 ty2+ -- Used for error cases in type checking only. Not exported. {-# INLINEABLE tyBottom #-} tyBottom :: HOLType-tyBottom = TyAppIn tyOpBottom []+tyBottom = fromRight $ tyApp tyOpBottom [] -- | Alias to the unconstrained type variable @A@. {-# INLINEABLE tyA #-} tyA :: HOLType tyA = TyVarIn False "A" +-- | The pattern synonym equivalent of 'tyA'.+pattern TyA <- TyVar False "A"+ -- | Alias to the unconstrained type variable @B@. {-# INLINEABLE tyB #-} tyB :: HOLType tyB = TyVarIn False "B" +-- | The pattern synonym equivalent of 'tyB'.+pattern TyB <- TyVar False "B"+ {-| Specialized version of 'destType' that returns the domain and range of a function type. Fails with 'Nothing' if the type to be destructed isn't a primitive function type. -} destFunTy :: HOLType -> Maybe (HOLType, HOLType)-destFunTy (TyAppIn (TyPrim "fun" _) [ty1, ty2]) = Just (ty1, ty2)+destFunTy (TyAppIn (TyPrimitiveIn "fun" _) [ty1, ty2]) = + Just (ty1, ty2) destFunTy _ = Nothing {-|@@ -324,29 +350,32 @@ case destType $ typeOf x of Just (_, _ : ty : _) -> ty _ -> tyBottom-typeOf (AbsIn (VarIn _ ty) tm) =- TyAppIn tyOpFun [ty, typeOf tm]+typeOf (AbsIn (VarIn _ ty) t) =+ fromRight $ tyApp tyOpFun [ty, typeOf t] typeOf AbsIn{} = tyBottom-typeOf (TyAbsIn tv tb) = UTypeIn tv $ typeOf tb+typeOf (TyAbsIn tv tb) = + fromRight . mkUType tv $ typeOf tb typeOf (TyCombIn t ty) = case typeOf t of- (UTypeIn tv tbody) -> typeSubst [(tv, ty)] tbody+ (UTypeIn tv tbody) -> + typeSubst [(tv, ty)] tbody _ -> tyBottom + {- Stateless HOL Type Primitives -} -- | Predicate for type operator variables. isTypeOpVar :: TypeOp -> Bool-isTypeOpVar TyOpVar{} = True+isTypeOpVar TyOpVarIn{} = True isTypeOpVar _ = False {-| Constructs a primitive type operator of a given name and arity. Primitive type operators are used to represent constant, but undefined, types. -}-newPrimTypeOp :: String -> Int -> TypeOp-newPrimTypeOp = TyPrim+newPrimitiveTypeOp :: Text -> Int -> TypeOp+newPrimitiveTypeOp = TyPrimitiveIn {-| Constructs a type operator variable of a given name. Note that type@@ -357,32 +386,40 @@ in a term have the same arity. The same protection is not provided for terms that are manually constructed. -}-mkTypeOpVar :: String -> TypeOp-mkTypeOpVar = TyOpVar+mkTypeOpVar :: Text -> TypeOp+mkTypeOpVar = TyOpVarIn {-| Destructs a type operator, returning its name and arity. Note that we use -1 to indicate the arity of a type operator variable since that information is not carried. -}-destTypeOp :: TypeOp -> (String, Int)-destTypeOp (TyOpVar name) = (name, -1)-destTypeOp (TyPrim name arity) = (name, arity)-destTypeOp (TyDefined name arity _) = (name, arity)+destTypeOp :: TypeOp -> (Text, Int)+destTypeOp (TyOpVarIn name) = (name, -1)+destTypeOp (TyPrimitiveIn name arity) = (name, arity)+destTypeOp (TyDefinedIn name arity _) = (name, arity) -- | Alias to the primitive boolean type operator. {-# INLINEABLE tyOpBool #-} tyOpBool :: TypeOp-tyOpBool = TyPrim "bool" 0+tyOpBool = TyPrimitiveIn "bool" 0++-- | The pattern synonym equivalent of 'tyOpBool'.+pattern TyOpBool <- TyPrimitive "bool" 0+ -- Used for error cases in type checking only. Not exported. {-# INLINEABLE tyOpBottom #-} tyOpBottom :: TypeOp-tyOpBottom = TyPrim "_|_" 0+tyOpBottom = TyPrimitiveIn "_|_" 0+ -- | Alias to the primitive function type operator. {-# INLINEABLE tyOpFun #-} tyOpFun :: TypeOp-tyOpFun = TyPrim "fun" 2+tyOpFun = TyPrimitiveIn "fun" 2 +-- | The pattern synonym equivalent of 'tyOpFun'.+pattern TyOpFun <- TyPrimitive "fun" 2+ {-| Constructs a type application from a provided type operator and list of type arguments. Fails with 'Left' in the following cases:@@ -392,9 +429,9 @@ * A type operator's arity disagrees with the length of the argument list. -} tyApp :: TypeOp -> [HOLType] -> Either String HOLType-tyApp tyOp@TyOpVar{} [] = +tyApp tyOp@TyOpVarIn{} [] = Left $ "tyApp: " ++ show tyOp ++ ": TyOpVar applied to zero args."-tyApp tyOp@TyOpVar{} args = Right $ TyAppIn tyOp args+tyApp tyOp@TyOpVarIn{} args = Right $ TyAppIn tyOp args tyApp tyOp args = let (_, arity) = destTypeOp tyOp in if arity == length args @@ -403,9 +440,13 @@ -- | Returns the list of all type operator variables in a type. typeOpVars :: HOLType -> [TypeOp]-typeOpVars (TyAppIn op@TyOpVar{} args) = foldr (union . typeOpVars) [op] args-typeOpVars (UTypeIn _ tbody) = typeOpVars tbody-typeOpVars _ = []+typeOpVars (TyAppIn op@TyOpVarIn{} args) = + foldr (union . typeOpVars) [op] args+typeOpVars (TyAppIn _ args) =+ concatMap typeOpVars args+typeOpVars (UTypeIn _ tbody) = + typeOpVars tbody+typeOpVars TyVarIn{} = [] -- | Returns the list of all type operator variables in a list of types. catTypeOpVars :: [HOLType] -> [TypeOp]@@ -416,40 +457,39 @@ typeOpSubst :: [(TypeOp, TypeOp)] -> HOLType -> HOLType typeOpSubst [] t = t typeOpSubst tyopenv t =- tyOpSubstRec (filter validSubst tyopenv) t- where tyOpSubstRec :: [(TypeOp, TypeOp)] -> HOLType -> HOLType+ fromRight $ tyOpSubstRec (filter validSubst tyopenv) t+ where tyOpSubstRec :: [(TypeOp, TypeOp)] -> HOLType -> Either String HOLType tyOpSubstRec tyopins (TyAppIn op args) =- let args' = map (tyOpSubstRec tyopins) args in- case tryFind (\ (tp, tr) ->- if tp /= op ||- snd (destTypeOp tr) /= length args - then Nothing- else Just tr) tyopins of- Nothing -> TyAppIn op args'- Just op' -> TyAppIn op' args'+ do args' <- mapM (tyOpSubstRec tyopins) args+ case tryFind (\ (tp, tr) ->+ if tp /= op || snd (destTypeOp tr) /= length args + then Nothing+ else Just tr) tyopins of+ Nothing -> tyApp op args'+ Just op' -> tyApp op' args' tyOpSubstRec tyopins (UTypeIn tv tbody) =- UTypeIn tv $ tyOpSubstRec tyopins tbody- tyOpSubstRec _ ty = ty+ mkUType tv =<< tyOpSubstRec tyopins tbody+ tyOpSubstRec _ ty@TyVarIn{} = Right ty -- instantiation of type operator variables with universal types. typeOpInst :: [(TypeOp, HOLType)] -> HOLType -> HOLType typeOpInst [] t = t-typeOpInst tyopenv t = tyOpInstRec (filter validSubst tyopenv) t+typeOpInst tyopenv t = fromRight $ tyOpInstRec (filter validSubst tyopenv) t where arityOf :: HOLType -> Maybe Int arityOf ty = return (length . fst) <*> destUTypes ty - tyOpInstRec :: [(TypeOp, HOLType)] -> HOLType -> HOLType+ tyOpInstRec :: [(TypeOp, HOLType)] -> HOLType -> Either String HOLType tyOpInstRec tyopins ty@(TyAppIn op args) =- let args' = map (tyOpInstRec tyopins) args in- case tryFind (\ (tp, tr) ->- if tp /= op || - arityOf tr /= (Just $ length args) - then Nothing- else destUTypes tr) tyopins of- Nothing -> TyAppIn op args'- Just (rtvs, rtbody)- | isSmall rtbody -> typeSubst (zip rtvs args') rtbody- | otherwise -> ty+ do args' <- mapM (tyOpInstRec tyopins) args+ case tryFind (\ (tp, tr) ->+ if tp /= op || arityOf tr /= (Just $ length args) + then Nothing+ else destUTypes tr) tyopins of+ Nothing -> tyApp op args'+ Just (rtvs, rtbody)+ | isSmall rtbody ->+ return $ typeSubst (zip rtvs args') rtbody+ | otherwise -> return ty tyOpInstRec tyopins (UTypeIn tv tbody) = if any (\ (x, ty) -> tv `elem` tyVars ty && x `elem` typeOpVars tbody) tyopins@@ -458,12 +498,11 @@ tvpatts = map fst tyopins tvrepls = catTyVars . mapMaybe (`lookup` tyopins) $ intersect tvbs tvpatts- tv' = variantTyVar tvrepls tv in- UTypeIn tv' . tyOpInstRec tyopins $ - typeSubst [(tv, tv')] tbody- else UTypeIn tv $ tyOpInstRec tyopins tbody- tyOpInstRec _ ty = ty- + tv' = variantTyVar tvrepls tv+ tbody' = typeSubst [(tv, tv')] tbody in+ mkUType tv' =<< tyOpInstRec tyopins tbody'+ else mkUType tv =<< tyOpInstRec tyopins tbody+ tyOpInstRec _ ty@TyVarIn{} = Right ty {- HOL2P Type Primitives@@ -489,14 +528,15 @@ 'Left' if the bound type is not a small, type variable. -} mkUType :: HOLType -> HOLType -> Either String HOLType-mkUType tv@(TyVarIn True _) tybody = Right $ UTypeIn tv tybody+mkUType tv@(TyVarIn True _) tybody = + Right $ UTypeIn tv tybody mkUType _ _ = Left "mkUType" {-| Constructs a compound universal type given a list of bound types and a body. Fails with 'Left' if any internal call to 'mkUType' fails. -} mkUTypes :: [HOLType] -> HOLType -> Either String HOLType-mkUTypes = flip (foldrM mkUType)+mkUTypes vs b = foldrM mkUType b vs <?> "mkUTypes" {-| Constructs a compound universal type from a type operator variable and a given@@ -512,10 +552,12 @@ * The type operator argument is not a variable. -} uTypeFromTypeOpVar :: TypeOp -> Int -> Either String HOLType-uTypeFromTypeOpVar s@TyOpVar{} n+uTypeFromTypeOpVar s@TyOpVarIn{} n | n > 0 = - let tvs = map (\ x -> TyVarIn True $ 'A' : show x) [1 .. n] in- mkUTypes tvs =<< tyApp s tvs+ let tvs = map (\ x -> TyVarIn True . pack $ 'A' : show x) + [1 .. n] in+ do ty <- tyApp s tvs+ mkUTypes tvs ty | otherwise = Left "uTypeFromTypeOpVar: must have a positive number of bound types." uTypeFromTypeOpVar _ _ = @@ -527,8 +569,10 @@ any universal types. -} mkSmall :: HOLType -> Either String HOLType-mkSmall (TyVarIn _ s) = Right $ TyVarIn True s-mkSmall (TyAppIn s tvs) = liftM (TyAppIn s) $ mapM mkSmall tvs+mkSmall (TyVarIn _ s) = + Right $ TyVarIn True s+mkSmall (TyAppIn op tvs) = + liftM (TyAppIn op) $ mapM mkSmall tvs mkSmall UTypeIn{} = Left "mkSmall" {-| @@ -545,9 +589,12 @@ quantified. -} destUTypes :: HOLType -> Maybe ([HOLType], HOLType)-destUTypes (UTypeIn tv tb) = Just $ destUTypesRec ([tv], tb)+destUTypes (UTypeIn tv tb) = + let (tvs, tb') = destUTypesRec ([tv], tb) in+ Just (tvs, tb') where destUTypesRec :: ([HOLType], HOLType) -> ([HOLType], HOLType)- destUTypesRec (acc, UTypeIn tv' tb') = destUTypesRec (acc++[tv'], tb')+ destUTypesRec (acc, UTypeIn tv' tb') = + destUTypesRec (acc++[tv'], tb') destUTypesRec res = res destUTypes _ = Nothing @@ -564,7 +611,8 @@ -} variantTyVar :: [HOLType] -> HOLType -> HOLType variantTyVar avoid tv@(TyVarIn small name)- | tv `elem` avoid = variantTyVar avoid . TyVarIn small $ name ++ "'"+ | tv `elem` avoid = + variantTyVar avoid (TyVarIn small $ name `snoc` '\'') | otherwise = tv variantTyVar _ ty = ty @@ -584,16 +632,13 @@ -- Documentation copied from HaskHOL.Core.Prims {-$ViewPatterns- The primitive data types of HaskHOL are implemented using view patterns in+ The primitive data types of HaskHOL are implemented using pattern synonyms in order to simulate private data types: * Internal constructors are hidden to prevent manual construction of terms. - * View constructors (those of 'HOLTypeView', 'HOLTermView', 'HOLThmView') are- exposed to enable pattern matching. -- * View patterns, as defined by instances of the 'view' function from the - @Viewable@ class, provide a conversion between the two sets of constructors.+ * Unidirectional pattern synonyms ('TyVar', etc.) are exposed to enable + pattern matching. -} {-$HOLTypes@@ -607,7 +652,7 @@ There are two principle changes to Harrison's implementation: 1. Type operators have been introduced, via the 'TypeOp' data type, to - facilitate a stateless logical kernel following from Freek Wiedijk's + facilitate a semi-stateless logical kernel following from Freek Wiedijk's Stateless HOL system. 2. Universal types and type operator variables have been introduced to move
src/HaskHOL/Core/Lib.hs view
@@ -1,7 +1,4 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, - StandaloneDeriving, TemplateHaskell #-}-+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables #-} {-| Module: HaskHOL.Core.Lib Copyright: (c) The University of Kansas 2013@@ -28,159 +25,200 @@ -} module HaskHOL.Core.Lib ( -- * Function Combinators- iComb -- :: a -> a- , kComb -- :: a -> b -> a- , cComb -- :: (a -> b -> c) -> b -> a -> c- , wComb -- :: (a -> a -> b) -> a -> b- , ffComb -- :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)- , ffCombM -- :: Monad m => (a -> m c) -> (b -> m d) -> (a, b) -> m (c, d)- , liftM1 -- :: Monad m => (a -> b -> m c) -> m a -> b -> m c+ iComb+ , kComb+ , cComb+ , wComb+ , ffComb+ , ffCombM+ , liftM1+ , on -- * Basic Operations on Pairs- , swap -- :: (a, b) -> (b, a)- , pairMap -- :: (a -> b) -> (a, a) -> (b, b)- , pairMapM -- :: Monad m => (a -> m b) -> (a, a) -> m (b, b)- , first -- :: (a -> c) -> (a, b) -> (c, b)- , firstM -- :: Monad m => (a -> m c) -> (a, b) -> m (c, b)- , second -- :: (b -> c) -> (a, b) -> (a, c)- , secondM -- :: Monad m => (b -> m c) -> (a, b) -> m (a, c)+ , swap+ , pairMap+ , pairMapM+ , first+ , firstM+ , second+ , secondM -- * Basic Operations on Lists- , tryHead -- :: [a] -> Maybe a- , tryTail -- :: [a] -> Maybe a- , tryInit -- :: [a] -> Maybe [a]- , butLast -- :: [a] -> Maybe [a]- , tryLast -- :: [a] -> Maybe a- , tryIndex -- :: [a] -> Int -> Maybe a- , el -- :: Int -> [a] -> Maybe a- , rev -- :: [a] -> [a]+ , tryHead+ , tryTail+ , tryInit+ , butLast+ , tryLast+ , tryIndex+ , el+ , rev -- * Basic Operations on Association Lists- , assoc -- :: Eq a => a -> [(a, b)] -> Maybe b- , revLookup -- :: Eq a => a -> [(b, a)] -> Maybe b- , revAssoc -- :: Eq a => a -> [(b, a)] -> Maybe b- , assocd -- :: Eq a => a -> [(a, b)] -> b -> b- , lookupd -- :: Eq a => a -> [(a, b)] -> b -> b- , revLookupd -- :: Eq a => a -> [(b, a)] -> b -> b- , revAssocd -- :: Eq a => a -> [(b, a)] -> b -> b+ , assoc+ , revLookup+ , revAssoc+ , assocd+ , lookupd+ , revLookupd+ , revAssocd -- * Methods for Error Handling- , can -- :: (Alternative m, Monad m) => (a -> m b) -> a -> m Bool- , canNot -- :: (Alternative m, Monad m) => (a -> m b) -> a -> m Bool- , check -- :: (a -> Bool) -> a -> Maybe a- , note -- :: a -> Maybe b -> Either a b- , hush -- :: Either a b -> Maybe b- , fromRight -- :: Either err a -> a- , fromRightM -- :: MonadPlus m => Either err a -> m a- , fromJustM -- :: MonadPlus m => Maybe a -> m a+ , can+ , canNot+ , check+ , note+ , hush+ , fromRight+ , fromRightM+ , fromJustM , LiftOption(..) , Note(..)+ , (#<<) + , (<#<)+ , (<#>)+ , (<#?>) -- * Methods for Function Repetition- , funpow -- :: Int -> (a -> a) -> a -> a- , funpowM -- :: Monad m => Int -> (a -> m a) -> a -> m a- , repeatM -- :: (Alternative M, Monad m) => (a -> m a) -> a -> m a- , map2 -- :: (a -> b -> c) -> [a] -> [b] -> Maybe c- , map2M -- :: (Monad m, MonadPlus m) => - -- (a -> b -> m c) -> [a] -> [b] -> m c- , doList -- :: Monad m => (a -> m b) -> [a] -> m ()- , allpairs -- :: (a -> b -> c) -> [a] -> [b] -> [c]+ , funpow + , funpowM+ , repeatM+ , map2+ , map2M+ , doList+ , allpairs -- * Methods for List Iteration- , itlist -- :: (a -> b -> b) -> [a] -> b -> b- , itlistM -- :: (F.Foldable t, Monad m) =>- -- (a -> b -> m b) -> t a -> b -> m b- , foldrM -- :: (F.Foldable t, Monad m) => - -- (a -> b -> m b) -> b -> t a -> m b- , revItlist -- :: (a -> b -> b) -> [a] -> b -> b- , foldlM -- :: (F.Foldable t, Monad m) => - -- (a -> b -> m b) -> a -> t b -> m a- , tryFoldr1 -- :: (a -> a -> a) -> [a] -> Maybe a- , endItlist -- :: (a -> a -> a) -> [a] -> Maybe a- , foldr1M -- :: (Monad m, MonadPlus m) => (a -> a -> m a) -> [a] -> m a- , foldr2 -- :: (a -> b -> c -> c) -> c -> [a] -> [b] -> Maybe c- , itlist2 -- :: (a -> b -> c -> c) -> [a] -> [b] -> c -> Maybe c- , foldr2M -- :: (Monad m, MonadPlus m) => - -- (a -> b -> c -> m c) -> c -> [a] -> [b] -> m c- , foldl2 -- :: (c -> a -> b -> c) -> c -> [a] -> [b] -> Maybe c- , revItlist2 -- :: (b -> b -> c -> c) -> [a] -> [b] -> c -> Maybe c- , foldl2M -- :: (Monad m, MonadPlus m) => - -- (c -> a -> b -> m c) -> c -> [b] -> m c+ , itlist+ , itlistM+ , foldrM+ , revItlist+ , foldlM+ , tryFoldr1+ , endItlist+ , foldr1M+ , foldr2+ , itlist2+ , foldr2M+ , foldl2 + , revItlist2+ , foldl2M -- * Methods for Sorting and Merging Lists- , sort -- :: Eq a => (a -> a -> Bool) -> [a] -> [a]- , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a]- , merge -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]- , mergesort -- :: forall a. (a -> a -> Bool) -> [a] -> [a]+ , sort+ , sortBy+ , merge+ , mergesort -- * Methods for Splitting and Stripping Binary Terms- , splitList -- :: (b -> Maybe (a, b)) -> b -> ([a], b)- , splitListM -- :: (Alternative m, Monad m) => - -- (b -> m (a, b)) -> b -> m ([a], b)- , revSplitList -- :: (a -> Maybe (a, a)) -> a -> (a, [a])- , revSplitListM -- :: (Alternative m, Monad m) => - -- (b -> m (b, b)) -> b -> m (b, [b])- , nsplit -- :: (a -> Maybe (a, a)) -> [b] -> a -> Maybe ([a], a)- , nsplitM -- :: Monad m => (b -> m (b, b)) -> [c] -> b -> m ([b], b)- , stripList -- :: (a -> Maybe (a, a)) -> a -> [a]- , stripListM -- :: (Alternative m, Monad m) => - -- (a -> m (a, a)) -> a -> m [a]+ , splitList+ , splitListM+ , revSplitList+ , revSplitListM+ , nsplit+ , nsplitM + , stripList + , stripListM -- * Methods for Searching and Manipulating Lists- , forall -- :: (a -> Bool) -> [a] -> Bool- , forall2 -- :: (a -> b -> Bool) -> [a] -> [b] -> Maybe Bool- , exists -- :: (a -> Bool) -> [a] -> Bool- , partition -- :: (a -> Bool) -> [a] -> ([a], [a])- , mapFilter -- :: (a -> Maybe b) -> [a] -> [b]- , mapFilterM -- :: (Alternative m, Monad m) => (a -> m b) -> [a] -> m [b]- , find -- :: (a -> Bool) -> [a] -> Maybe a- , findM -- :: (Monad m, MonadPlus m) => (a -> m Bool) -> [a] -> m a- , tryFind -- :: (Monad m, MonadPlus m) => (a -> m b) -> [a] -> m b- , flat -- :: [[a]] -> [a]- , dropWhileEnd -- :: (a -> Bool) -> [a] -> [a]- , remove -- :: (a -> Bool) -> [a] -> Maybe (a, [a])- , trySplitAt -- :: Int -> [a] -> Maybe ([a], [a])- , chopList -- :: Int -> [a] -> Maybe ([a], [a])- , elemIndex -- :: Eq a => a -> [a] -> Maybe Int- , index -- :: Eq a => a -> [a] -> Maybe Int- , stripPrefix -- :: Eq a => [a] -> [a] -> Maybe [a]- , uniq -- :: Eq a => [a] -> [a]- , shareOut -- :: [[a]] -> [b] -> Maybe [[b]]+ , forall + , forall2 + , exists + , partition + , mapFilter + , mapFilterM+ , find + , findM + , tryFind + , flat + , dropWhileEnd+ , remove + , trySplitAt + , chopList + , elemIndex+ , index+ , stripPrefix+ , uniq+ , shareOut -- * Set Operations on Lists- , mem -- :: Eq a => a -> [a] -> Bool- , insert -- :: Eq a => a -> [a] -> [a]- , insertMap -- :: Eq a => a -> b -> [(a, b)] -> [(a, b)]- , union -- :: Eq a => [a] -> [a] -> [a]- , unions -- :: Eq a => [[a]] -> [a]- , intersect -- :: Eq a => [a] -> [a] -> [a]- , delete -- :: Eq a => a -> [a] -> [a]- , (\\) -- :: Eq a => [a] -> [a] -> [a]- , subset -- :: Eq a => [a] -> [a] -> Bool- , setEq -- :: Eq a => [a] -> [a] -> Bool- , setify -- :: Eq a => [a] -> [a]- , nub -- :: Eq a => [a] -> [a]+ , mem + , insert+ , insertMap+ , union + , unions+ , intersect+ , delete+ , (\\)+ , subset+ , setEq+ , setify+ , nub -- * Set Operations Parameterized by Predicate- , mem' -- :: (a -> a -> Bool) -> a -> [a] -> Bool- , insert' -- :: (a -> a -> Bool) -> a -> [a] -> [a]- , union' -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]- , unions' -- :: (a -> a -> Bool) -> [[a]] -> [a]- , subtract' -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]- , group' -- :: (a -> a -> Bool) -> [a] -> [[a]]- , uniq' -- :: Eq a => (a -> a -> Bool) -> [a] -> [a]- , setify' -- :: Eq a => (a -> a -> Bool) -> (a -> a -> Bool) -> [a] -> [a]+ , mem'+ , insert'+ , union'+ , unions'+ , subtract'+ , group'+ , uniq'+ , setify' -- * Operations on \"Num\" Types- -- $NumAliases- , num0 -- :: Integer- , num1 -- :: Integer- , num2 -- :: Integer- , num10 -- :: Integer- , pow2 -- :: Integer -> Integer- , pow10 -- :: Integer -> Integer- , numdom -- :: Real a => a -> Rational- , numerator -- :: Rational -> Integer- , denominator -- :: Rational -> Integer- , gcdNum -- :: Integer -> Integer -> Integer- , lcmNum -- :: Integer -> Integer -> Integer- , numOfString -- :: (Eq a, Num a) => String -> Maybe a+ , (%)+ , numdom + , numerator + , denominator+ , numOfString+ -- * Polymorphic, Finite, Partial Functions Via Patricia Trees+ , Func+ , funcEmpty+ , isEmpty+ , funcMap+ , funcFoldl+ , funcFoldr+ , graph+ , dom+ , ran+ , applyd+ , apply+ , tryApplyd+ , defined+ , undefine+ , (|->)+ , combine+ , (|=>)+ , choose+ -- * Re-exported 'Map' primitives+ , Map+ , mapEmpty+ , mapInsert+ , mapUnion+ , mapDelete+ , mapLookup+ , mapElems+ , mapFromList+ , mapToList+ , mapMap+ , mapFoldrWithKey+ , mapRemove+ , mapToAscList+ -- * Re-exported 'Text' primitives+ , Text+ , append+ , cons+ , snoc+ , pack+ , unpack+ , textHead+ , textTail+ , textNull+ , textEmpty+ , textStrip+ , textShow+ -- * Re-exported 'AcidState' primitives+ , Update+ , Query+ , get+ , put+ , ask+ , makeAcidic -- * Classes for Common \"Language\" Operations -- $LangClasses , Lang(..) , LangSeq(..) -- * Miscellaneous Re-exported Libraries- , module HaskHOL.Core.Lib.Lift {-|- Re-exports 'deriveLift', 'deriveLiftMany', and 'Lift' to be used with- our extensible state mechanisms.+ , module HaskHOL.Core.Lib.Families {-|+ Re-exports a few type families used for basic, type-level boolean+ computation. -} , module Control.Applicative {-| Re-exports 'Applicative', 'Alternative', and the utility functions for@@ -201,16 +239,17 @@ Re-exports the entirety of the library. Used primarily to make interacting with primitive rules easier at later points in the system. -}- , module Data.Typeable {-|- Re-exports the 'Typeable' class name for use in deriving clauses.+ , module Data.Data {-|+ Re-exports the 'Data' and 'Typeable' class names for use in deriving + clauses. -}- , module Text.ParserCombinators.Parsec.Expr {-|- Re-exports the entirety of the library. Used primarily for its 'Assoc'- data type, but also contains a number of primitives used by the parser.+ , module Data.SafeCopy {-|+ Re-exports the entirety of the library for use with the 'HOL' monad's+ acid state primitives. -} ) where -import HaskHOL.Core.Lib.Lift+import HaskHOL.Core.Lib.Families -- Libraries re-exported in their entirety, except for applicative import Control.Applicative hiding (Const, WrappedMonad, WrappedArrow, ZipList)@@ -218,34 +257,45 @@ import Control.Monad import Data.Maybe import Data.Either-import Data.Typeable (Typeable)-import Text.ParserCombinators.Parsec.Expr+import Data.Data (Data, Typeable)+import Data.SafeCopy -- Libraries containing Re-exports import qualified Control.Arrow as A import qualified Data.Foldable as F+import qualified Data.Function as DF (on) import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as Map import qualified Data.Ratio as R+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Text.Show.Text as Text (Show, show) import qualified Data.Tuple as T+-- Acid State imports+import qualified Control.Monad.State as State (MonadState, get, put)+import qualified Control.Monad.Reader as Reader (MonadReader, ask)+import Data.Acid (Update, Query)+import qualified Data.Acid as Acid+import Language.Haskell.TH -- Libraries containing utility functions used, but not exported directly import Numeric (readInt, readHex, readDec) import Data.Char (digitToInt)+import Data.Bits+import Data.Hashable -- combinators -- | The I combinator. An alias for 'id'.-{-# INLINEABLE iComb #-} iComb :: a -> a iComb = id -- | The K combinator. An alias for 'const'.-{-# INLINEABLE kComb #-} kComb :: a -> b -> a kComb = const -- | The C combinator. An alias for 'flip'.-{-# INLINEABLE cComb #-} cComb :: (a -> b -> c) -> b -> a -> c cComb = flip @@ -253,12 +303,10 @@ The W combinator. Takes a function of arity 2 and applies a single argument to it twice. -}-{-# INLINEABLE wComb #-} wComb :: (a -> a -> b) -> a -> b wComb f x = f x x -- | The FF combinator. An alias for the arrow combinator 'A.***'. -{-# INLINEABLE ffComb #-} ffComb :: (a -> c) -> (b -> d) -> (a, b) -> (c, d) ffComb = (A.***) @@ -266,7 +314,6 @@ The monadic version of the FF combinator. An alias for the arrow combinator 'A.***' lifted for 'A.Kleisli' arrows. -}-{-# INLINEABLE ffCombM #-} ffCombM :: Monad m => (a -> m c) -> (b -> m d) -> (a, b) -> m (c, d) ffCombM f g = A.runKleisli $ A.Kleisli f A.*** A.Kleisli g @@ -275,24 +322,26 @@ > liftM1 f a b === flip f b =<< a -}-{-# INLINEABLE liftM1 #-} liftM1 :: Monad m => (a -> b -> m c) -> m a -> b -> m c liftM1 f a b = flip f b =<< a +{-|+ Re-export of the 'DF.on' combination from @Data.Function@.+-}+on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+on = DF.on+ -- pair basics -- | Swaps the order of a pair. A re-export of 'T.swap'.-{-# INLINEABLE swap #-} swap :: (a, b) -> (b, a) swap = T.swap -- | Applies a function to both elements of a pair using the 'A.***' operator.-{-# INLINEABLE pairMap #-} pairMap :: (a -> b) -> (a, a) -> (b, b) pairMap f = f A.*** f -- | The monadic version of 'pairMap'.-{-# INLINEABLE pairMapM #-} pairMapM :: Monad m => (a -> m b) -> (a, a) -> m (b, b) pairMapM f = f `ffCombM` f @@ -300,12 +349,10 @@ Applies a function only to the first element of a pair. A re-export of 'A.first'. -}-{-# INLINEABLE first #-} first :: (a -> c) -> (a, b) -> (c, b) first = A.first -- | A monadic version of 'first' lifted for 'A.Kleisli' arrows.-{-# INLINEABLE firstM #-} firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) firstM = A.runKleisli . A.first . A.Kleisli @@ -313,12 +360,10 @@ Applies a function only to the second element of a pair. A re-export of 'A.second'. -}-{-# INLINEABLE second #-} second :: (b -> c) -> (a, b) -> (a, c) second = A.second -- | A monadic version of 'second' lifted for 'A.Kleisli' arrows.-{-# INLINEABLE secondM #-} secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) secondM = A.runKleisli . A.second . A.Kleisli @@ -344,13 +389,12 @@ element of an empty list. -} tryInit :: [a] -> Maybe [a]-tryInit (_:[]) = Just []+tryInit [_] = Just [] tryInit (x:xs) = do xs' <- tryInit xs return (x:xs') tryInit _ = Nothing -- | An alias to 'tryInit' for HOL users more familiar with this name.-{-# INLINEABLE butLast #-} butLast :: [a] -> Maybe [a] butLast = tryInit @@ -359,7 +403,7 @@ element of an empty list. -} tryLast :: [a] -> Maybe a-tryLast (x:[]) = Just x+tryLast [x] = Just x tryLast (_:xs) = tryLast xs tryLast _ = Nothing @@ -376,18 +420,15 @@ An alias to 'tryIndex' for HOL users more familiar with this name. Note that the order of the arguments is flipped. -}-{-# INLINEABLE el #-} el :: Int -> [a] -> Maybe a el = flip tryIndex -- | An alias to 'reverse' for HOL users more familiar with this name.-{-# INLINEABLE rev #-} rev :: [a] -> [a] rev = reverse -- association lists -- | An alias to 'lookup' for HOL users more familiar with this name.-{-# INLINEABLE assoc #-} assoc :: Eq a => a -> [(a, b)] -> Maybe b assoc = lookup @@ -403,7 +444,6 @@ | otherwise = revLookup x as -- | An alias to 'revLookup' for HOL users who are more familiar with this name.-{-# INLINEABLE revAssoc #-} revAssoc :: Eq a => a -> [(b, a)] -> Maybe b revAssoc = revLookup @@ -412,7 +452,6 @@ lookupd x xs b = fromMaybe b $ lookup x xs -- | An alias to 'lookupd' for HOL users who are more familiar with this name.-{-# INLINEABLE assocd #-} assocd :: Eq a => a -> [(a, b)] -> b -> b assocd = lookupd @@ -425,7 +464,6 @@ {-| An alias to 'revLookupd' for HOL users who are more familiar with this name. -}-{-# INLINEABLE revAssocd #-} revAssocd :: Eq a => a -> [(b, a)] -> b -> b revAssocd = revLookupd @@ -480,20 +518,18 @@ A version of 'fromRight' that maps 'Left' values to 'mzero' rather than failing. -}-fromRightM :: MonadPlus m => Either err a -> m a+fromRightM :: (Monad m, Show err) => Either err a -> m a fromRightM (Right res) = return res-fromRightM _ = mzero+fromRightM (Left err) = fail $ show err {-| A version of 'fromJust' that maps 'Nothing' values to 'mzero' rather than failing. -}-fromJustM :: MonadPlus m => Maybe a -> m a+fromJustM :: Monad m => Maybe a -> m a fromJustM (Just res) = return res-fromJustM _ = mzero+fromJustM _ = fail "fromJust" -infixr 1 #<<-infixl 4 <#> {-| The 'LiftOption' class provides an infix operator to more cleanly apply the 'fromJustM' and 'fromRightM' methods to a value that will be passed to a@@ -506,24 +542,34 @@ -} liftO :: l a -> m a - -- | A version of '=<<' composed with 'liftO' for the right argument.- (#<<) :: (a -> m b) -> l a -> m b- l #<< r = l =<< liftO r+instance Monad m => LiftOption Maybe m where+ liftO = fromJustM - -- | A version of '<=<' composed with 'liftO' for the right argument.- (<#<) :: (b -> m c) -> (a -> l b) -> a -> m c- (<#<) l r x = l =<< liftO (r x)+instance (Show a, Monad m) => LiftOption (Either a) m where+ liftO = fromRightM - -- | A version of 'liftM1' composed with 'liftO' for the right argument.- (<#>) :: (a -> b -> m c) -> l a -> b -> m c- l <#> r = liftM1 l $ liftO r -instance MonadPlus m => LiftOption Maybe m where- liftO = fromJustM+infixr 1 #<<+-- | A version of '=<<' composed with 'liftO' for the right argument.+(#<<) :: LiftOption l m => (a -> m b) -> l a -> m b+l #<< r = l =<< liftO r -instance MonadPlus m => LiftOption (Either a) m where- liftO = fromRightM+infixr 1 <#< +-- | A version of '<=<' composed with 'liftO' for the right argument.+(<#<) :: LiftOption l m => (b -> m c) -> (a -> l b) -> a -> m c+(<#<) l r x = l =<< liftO (r x) +infixl 4 <#> +-- | A version of 'liftM1' composed with 'liftO' for the right argument.+(<#>) :: LiftOption l m => (a -> b -> m c) -> l a -> b -> m c+l <#> r = liftM1 l $ liftO r++infix 0 <#?>+-- | A version of '<?>' composed with 'liftO' for the job argument.+(<#?>) :: (LiftOption l m, Note m) => l a -> String -> m a+job <#?> err = liftO job <?> err++ infix 0 <?> {-| The 'Note' class provides an ad hoc way of tagging an error case with a@@ -623,7 +669,6 @@ An alias to 'foldr' for HOL users more familiar with this name. Note that the order of the list and base case arguments is flipped. -}-{-# INLINEABLE itlist #-} itlist :: (a -> b -> b) -> [a] -> b -> b itlist f = flip (foldr f) @@ -632,7 +677,6 @@ itlistM f = flip (F.foldrM f) -- | The monadic version of 'foldr'. A re-export of 'F.foldrM'.-{-# INLINEABLE foldrM #-} foldrM :: (F.Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b foldrM = F.foldrM @@ -641,12 +685,10 @@ order of the list and base case arguments is flipped, as is the order of the arguments to the function. -}-{-# INLINEABLE revItlist #-} revItlist :: (a -> b -> b) -> [a] -> b -> b revItlist f = flip (foldl $ flip f) -- | The monadic version of 'foldl'. A re-export of 'F.foldlM'.-{-# INLINEABLE foldlM #-} foldlM :: (F.Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a foldlM = F.foldlM @@ -656,11 +698,10 @@ -} tryFoldr1 :: (a -> a -> a) -> [a] -> Maybe a tryFoldr1 _ [] = Nothing-tryFoldr1 _ (x:[]) = Just x+tryFoldr1 _ [x] = Just x tryFoldr1 f (x:xs) = liftM (f x) $ tryFoldr1 f xs -- | An alias to 'tryFoldr1' for HOL users more familiar with this name.-{-# INLINEABLE endItlist #-} endItlist :: (a -> a -> a) -> [a] -> Maybe a endItlist = tryFoldr1 @@ -717,7 +758,6 @@ the order of the two list arguments and base case argument is flipped, as is the order of the arguments to the provided function. -}-{-# INLINEABLE revItlist2 #-} revItlist2 :: (a -> b -> c -> c) -> [a] -> [b] -> c -> Maybe c revItlist2 f xs ys b = foldl2 (\ z x y -> f x y z) b xs ys @@ -750,7 +790,6 @@ A more traditional sort using an 'Ordering' relationship between elements. A re-export of 'L.sortBy'. -}-{-# INLINEABLE sortBy #-} sortBy :: (a -> a -> Ordering) -> [a] -> [a] sortBy = L.sortBy @@ -775,9 +814,9 @@ mergesort _ [] = [] mergesort ord l = mergepairs [] $ map (: []) l where mergepairs :: [[a]] -> [[a]] -> [a]- mergepairs (x:[]) [] = x+ mergepairs [x] [] = x mergepairs xs [] = mergepairs [] xs- mergepairs xs (y:[]) = mergepairs (y:xs) []+ mergepairs xs [y] = mergepairs (y:xs) [] mergepairs xs (y1:y2:ys) = mergepairs (merge ord y1 y2 : xs) ys -- iterative term splitting and stripping via destructor@@ -811,19 +850,19 @@ @x1 \`f\` x2 \`f\` b@ calling this function with a destructor for @f@ will produce the result @(f, [x1, x2 \`f\` b])@. -}-revSplitList :: forall a. (a -> Maybe (a, a)) -> a -> (a, [a])+revSplitList :: forall a b. (a -> Maybe (a, b)) -> a -> (a, [b]) revSplitList f = recSplit []- where recSplit :: [a] -> a -> (a, [a])+ where recSplit :: [b] -> a -> (a, [b]) recSplit ls y = case f y of Just (l, r) -> recSplit (r:ls) l Nothing -> (y, ls) -- | The monadic version of 'revSplitList'.-revSplitListM :: forall m b. (Alternative m, Monad m) => - (b -> m (b, b)) -> b -> m (b, [b])+revSplitListM :: forall m a b. (Alternative m, Monad m) => + (a -> m (a, b)) -> a -> m (a, [b]) revSplitListM f = rsplist []- where rsplist :: [b] -> b -> m (b, [b])+ where rsplist :: [b] -> a -> m (a, [b]) rsplist ls y = (do (l, r) <- f y rsplist (r:ls) l)@@ -882,7 +921,6 @@ -- miscellaneous list methods -- | An alias to 'all' for HOL users who are more familiar with this name.-{-# INLINEABLE forall #-} forall :: (a -> Bool) -> [a] -> Bool forall = all @@ -894,19 +932,16 @@ forall2 f xs = liftM and . map2 f xs -- | An alias to 'any' for HOL users who are more familiar with this name.-{-# INLINEABLE exists #-} exists :: (a -> Bool) -> [a] -> Bool exists = any {-| Separates a list of elements using a predicate. A re-export of 'L.partition'. -}-{-# INLINEABLE partition #-} partition :: (a -> Bool) -> [a] -> ([a], [a]) partition = L.partition -- | An alias to 'mapMaybe' for HOL users more familiar with this name.-{-# INLINEABLE mapFilter #-} mapFilter :: (a -> Maybe b) -> [a] -> [b] mapFilter = mapMaybe @@ -923,7 +958,6 @@ <|> return xs' -- | A re-export of 'L.find'.-{-# INLINEABLE find #-} find :: (a -> Bool) -> [a] -> Maybe a find = L.find @@ -954,7 +988,6 @@ tryFind f (x:xs) = f x `mplus` tryFind f xs -- | An alias to 'concat' for HOL users who are more familiar with this name.-{-# INLINEABLE flat #-} flat :: [[a]] -> [a] flat = concat @@ -962,7 +995,6 @@ Drops elements from the end of a list while a predicate is true. A re-export of 'L.dropWhileEnd'. -}-{-# INLINEABLE dropWhileEnd #-} dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd = L.dropWhileEnd @@ -993,7 +1025,6 @@ return (x:m, l') -- | An alias to 'trySplitAt' for HOL users more familiar with this name-{-# INLINEABLE chopList #-} chopList :: Int -> [a] -> Maybe ([a], [a]) chopList = trySplitAt @@ -1001,12 +1032,10 @@ Returns the first index where an element appears in list. Fails with 'Nothing' if no such element is found. A re-export of 'L.elemIndex'. -}-{-# INLINEABLE elemIndex #-} elemIndex :: Eq a => a -> [a] -> Maybe Int elemIndex = L.elemIndex -- | An alias to 'elemIndex' for HOL users more familiar with this name.-{-# INLINEABLE index #-} index :: Eq a => a -> [a] -> Maybe Int index = elemIndex @@ -1014,7 +1043,6 @@ Drops the given prefix from a list. Fails with 'Nothing' if there is no such prefix. A re-export of 'L.stripPrefix'. -}-{-# INLINEABLE stripPrefix #-} stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] stripPrefix = L.stripPrefix @@ -1039,7 +1067,6 @@ -- set operations on lists -- | An alias to 'elem' for HOL users who are more familiar with this name.-{-# INLINEABLE mem #-} mem :: Eq a => a -> [a] -> Bool mem = elem @@ -1079,17 +1106,14 @@ unions = foldr union [] -- | Finds the intersection of two lists. A re-export of 'L.intersect'.-{-# INLINEABLE intersect #-} intersect :: Eq a => [a] -> [a] -> [a] intersect = L.intersect -- | Removes an item from a list. A re-export of 'L.delete'.-{-# INLINEABLE delete #-} delete :: Eq a => a -> [a] -> [a] delete = L.delete -- | Subtracts one list from the other. A re-export of 'L.\\'.-{-# INLINEABLE (\\) #-} (\\) :: Eq a => [a] -> [a] -> [a] (\\) = (L.\\) @@ -1102,14 +1126,12 @@ setEq l1 l2 = subset l1 l2 && subset l2 l1 -- | Converts a list to a set by removing duplicates. A re-export of 'L.nub'.-{-# INLINEABLE nub #-} nub :: Eq a => [a] -> [a] nub = L.nub --- | An alias to 'nub' for HOL users more familiar with this name.-{-# INLINEABLE setify #-}-setify :: Eq a => [a] -> [a]-setify = nub+-- | A version of 'nub' where the resultant list is sorted.+setify :: Ord a => [a] -> [a]+setify = L.sort . nub -- set operations parameterized by equality {-|@@ -1154,7 +1176,6 @@ Groups neighbors in a list together based on a predicate. A re-export of 'L.groupBy'. -}-{-# INLINEABLE group' #-} group' :: (a -> a -> Bool) -> [a] -> [[a]] group' = L.groupBy @@ -1172,83 +1193,30 @@ setify' :: Eq a => (a -> a -> Bool) -> (a -> a -> Bool) -> [a] -> [a] setify' le eq xs = uniq' eq $ sort le xs --- some useful functions on "num" types-{-$NumAliases-- The following are aliases to frequently used values and functions for- arbitrary-precision integers. Typically, they are used when converting to and- from numbers in the implementation language and the logic language. The- aliases clarify the intended use and saves us from having lots of explicit- type annotations to force 'Integer' values.--}--- | > 0 :: Integer-{-# INLINEABLE num0 #-}-num0 :: Integer-num0 = 0---- | > 1 :: Integer-{-# INLINEABLE num1 #-}-num1 :: Integer-num1 = 1---- | > 2 :: Integer-{-# INLINEABLE num2 #-}-num2 :: Integer-num2 = 2---- | > 10 :: Integer-{-# INLINEABLE num10 #-}-num10 :: Integer-num10 = 10---- | > x ^ (2 :: Integer)-{-# INLINEABLE pow2 #-}-pow2 :: Integer -> Integer-pow2 x = x ^ (2 :: Integer)---- | > x ^ (10 :: Integer)-{-# INLINEABLE pow10 #-}-pow10 :: Integer -> Integer-pow10 x = x ^ (10 :: Integer)+-- | Constructs a 'Rational' from two 'Integer's. A re-export of (R.%).+(%) :: Integer -> Integer -> Rational+(%) = (R.%) {-| Converts a real number to a rational representation. An alias to 'toRational' for HOL users more familiar with this name. -}-{-# INLINEABLE numdom #-}-numdom :: Real a => a -> Rational-numdom = toRational+numdom :: Rational -> (Integer, Integer)+numdom r = + (R.numerator r, R.denominator r) -- | Returns the numerator of a rational number. A re-export of 'R.numerator'.-{-# INLINEABLE numerator #-} numerator :: Rational -> Integer numerator = R.numerator {-| Returns the denominator of a rational number. A re-export of 'R.denominator'. -}-{-# INLINEABLE denominator #-} denominator :: Rational -> Integer denominator = R.denominator -{-| - Finds the least common denominator between two numbers. An alias to 'gcd' for- HOL users more familiar with this name.--}-{-# INLINEABLE gcdNum #-}-gcdNum :: Integer -> Integer -> Integer-gcdNum = gcd- {-|- Finds the least common multiplier between two numbers. An alias to 'lcm' for- HOL users more familiar with this name.--}-{-# INLINEABLE lcmNum #-}-lcmNum :: Integer -> Integer -> Integer-lcmNum = lcm--{-|- Converts a string representation of a number to an appropriate instance of+ Converts a 'String' representation of a number to an appropriate instance of the 'Num' class. Fails with 'Nothing' if the conversion cannot be performed. Note: The following prefixes are valid:@@ -1270,6 +1238,342 @@ ('0':'b':s') -> readInt 2 (`elem` "01") digitToInt s' _ -> readDec s +-- Polymorphic, finite, partial functions via Patricia trees+{-| 'Func' is a Patricia Tree representation of polymorphic, finite, partial + functions.+-}+data Func a b + = Empty+ | Leaf !Int ![(a, b)]+ | Branch !Int !Int !(Func a b) !(Func a b) deriving Eq++-- | An empty 'Func' tree.+funcEmpty :: Func a b+funcEmpty = Empty++-- | The predicate for empty 'Func' trees.+isEmpty :: Func a b -> Bool+isEmpty Empty = True+isEmpty _ = False++-- | A version of 'map' for 'Func' trees.+funcMap :: (b -> c) -> Func a b -> Func a c+funcMap _ Empty = Empty+funcMap f (Leaf h l) = Leaf h $ map (A.second f) l+funcMap f (Branch p b l r) = Branch p b (funcMap f l) $ funcMap f r++-- | A version of 'foldl' for 'Func' trees.+funcFoldl :: (c -> a -> b -> c) -> c -> Func a b -> c+funcFoldl _ a Empty = a+funcFoldl f a (Leaf _ l) =+ let (xs, ys) = unzip l in+ fromJust $ foldl2 f a xs ys+funcFoldl f a (Branch _ _ l r) = funcFoldl f (funcFoldl f a l) r++-- | A version of 'foldr' for 'Func' trees.+funcFoldr :: (a -> b -> c -> c) -> c -> Func a b -> c+funcFoldr _ a Empty = a+funcFoldr f a (Leaf _ l) =+ let (xs, ys) = unzip l in+ fromJust $ foldr2 f a xs ys+funcFoldr f a (Branch _ _ l r) = funcFoldr f (funcFoldr f a r) l++-- | Converts a 'Func' tree to a sorted association list.+graph :: (Ord a, Ord b) => Func a b -> [(a, b)]+graph f = setify $ funcFoldl (\ a x y -> ((x, y):a)) [] f+ +-- | Converts a 'Func' tree to a sorted list of domain elements.+dom :: Ord a => Func a b -> [a]+dom f = setify $ funcFoldl (\ a x _ -> x:a) [] f++-- | Converts a 'Func' tree to a sorted list of range elements.+ran :: Ord b => Func a b -> [b]+ran f = setify $ funcFoldl (\ a _ y -> y:a) [] f++-- | Application for 'Func' trees.+applyd :: forall a b. (Hashable a, Ord a) => Func a b -> (a -> Maybe b) -> a + -> Maybe b+applyd Empty d x = d x+applyd (Branch p b l r) d x+ | (k `xor` p) .&. (b - 1) == 0 =+ applyd (if k .&. b == 0 then l else r) d x+ | otherwise = d x+ where k = hash x+applyd (Leaf h l) d x+ | h == hash x = applydRec l+ | otherwise = d x+ where applydRec :: Ord a => [(a, b)] -> Maybe b+ applydRec [] = d x+ applydRec ((a, b):t)+ | x == a = Just b+ | x > a = applydRec t+ | otherwise = d x++-- | Application for 'Func' trees with using constant 'Nothing'.+apply :: (Hashable a, Ord a) => Func a b -> a -> Maybe b+apply f = applyd f $ const Nothing++-- | Application for 'Func' trees with a default value.+tryApplyd :: (Hashable a, Ord a) => Func a b -> a -> b -> b+tryApplyd f a d = fromJust $ applyd f (\ _ -> Just d) a++-- | Predicate for testing if a value is defined in a 'Func' tree.+defined ::(Hashable a, Ord a) => Func a b -> a -> Bool+defined f x = isJust $ apply f x++-- | Undefine a value in a 'Func' tree.+undefine :: forall a b. (Hashable a, Ord a, Eq b) => a -> Func a b -> Func a b+undefine _ Empty = Empty+undefine x t@(Branch p b l r)+ | hash x .&. b == 0 = + let l' = undefine x l in+ if l' == l then t+ else case l' of+ Empty -> r+ _ -> Branch p b l' r+ | otherwise =+ let r' = undefine x r in+ if r' == r then t+ else case r' of+ Empty -> l+ _ -> Branch p b l r'+undefine x t@(Leaf h l)+ | h == hash x =+ let l' = undefineRec l in+ if l' == l then t+ else if null l' then Empty+ else Leaf h l'+ | otherwise = t+ where undefineRec :: [(a, b)] -> [(a, b)]+ undefineRec [] = []+ undefineRec l'@(ab@(a, _):xs)+ | x == a = xs+ | x < a = l'+ | otherwise =+ let xs' = undefineRec xs in+ if xs' == xs then l' else ab:xs'++newBranch :: Int -> Func a b -> Int -> Func a b -> Func a b+newBranch p1 t1 p2 t2 =+ let zp = p1 `xor` p2+ b = zp .&. (-zp)+ p = p1 .&. (b - 1) in+ if p1 .&. b == 0 then Branch p b t1 t2+ else Branch p b t2 t1++-- | Insert or update an element in a 'Func' tree.+(|->) :: forall a b. (Hashable a, Ord a) => a -> b -> Func a b -> Func a b+(x |-> y) Empty = Leaf (hash x) [(x, y)]+(x |-> y) t@(Branch p b l r)+ | k .&. (b - 1) /= p =+ newBranch p t k $ Leaf k [(x, y)]+ | k .&. b == 0 = Branch p b ((x |-> y) l) r+ | otherwise = Branch p b l $ (x |-> y) r+ where k = hash x+(x |-> y) t@(Leaf h l)+ | h == k = Leaf h $ defineRec l+ | otherwise = + newBranch h t k $ Leaf k [(x, y)]+ where k = hash x+ + defineRec :: [(a, b)] -> [(a, b)]+ defineRec [] = [(x, y)]+ defineRec l'@(ab@(a, _):xs)+ | x == a = (x, y):xs+ | x < a = (x, y):l'+ | otherwise = ab:defineRec xs++-- | Combines two 'Func' trees.+combine :: forall a b. Ord a => (b -> b -> b) -> (b -> Bool) -> Func a b + -> Func a b -> Func a b +combine _ _ Empty t2 = t2+combine _ _ t1 Empty = t1+combine op z lf@(Leaf k _) br@(Branch p b l r)+ | k .&. (b - 1) == p =+ if k .&. b == 0+ then case combine op z lf l of+ Empty -> r+ l' -> Branch p b l' r+ else case combine op z lf r of+ Empty -> l+ r' -> Branch p b l r'+ | otherwise = newBranch k lf p br+combine op z br@(Branch p b l r) lf@(Leaf k _)+ | k .&. (b - 1) == p =+ if k .&. b == 0+ then case combine op z l lf of+ Empty -> r+ l' -> Branch p b l' r+ else case combine op z r lf of+ Empty -> l+ r' -> Branch p b l r'+ | otherwise = newBranch p br k lf+combine op z t1@(Branch p1 b1 l1 r1) t2@(Branch p2 b2 l2 r2)+ | b1 < b2 =+ if p2 .&. (b1 - 1) /= p1 then newBranch p1 t1 p2 t2+ else if p2 .&. b1 == 0+ then case combine op z l1 t2 of+ Empty -> r1+ l -> Branch p1 b1 l r1+ else case combine op z r1 t2 of+ Empty -> l1+ r -> Branch p1 b1 l1 r+ | b2 < b1 =+ if p1 .&. (b2 - 1) /= p2 then newBranch p1 t1 p2 t2+ else if p1 .&. b2 == 0+ then case combine op z t1 l2 of+ Empty -> r2+ l -> Branch p2 b2 l r2+ else case combine op z t1 r2 of+ Empty -> l2+ r -> Branch p2 b2 l2 r+ | p1 == p2 =+ case (combine op z l1 l2, combine op z r1 r2) of+ (Empty, r) -> r+ (l, Empty) -> l+ (l, r) -> Branch p1 b1 l r+ | otherwise = newBranch p1 t1 p2 t2+combine op z t1@(Leaf h1 l1) t2@(Leaf h2 l2)+ | h1 == h2 =+ let l = combineRec l1 l2 in+ if null l then Empty else Leaf h1 l+ | otherwise = newBranch h1 t1 h2 t2+ where combineRec :: [(a, b)] -> [(a, b)] -> [(a, b)]+ combineRec [] ys = ys+ combineRec xs [] = xs+ combineRec xs@(xy1@(x1, y1):xs') ys@(xy2@(x2, y2):ys')+ | x1 < x2 = xy1:combineRec xs' ys+ | x1 > x2 = xy2:combineRec xs ys'+ | otherwise =+ let y = op y1 y2+ l = combineRec xs' ys' in+ if z y then l else (x1, y):l++-- | Special case of '(|->)' applied to 'funcEmpty'.+(|=>) :: (Hashable a, Ord a) => a -> b -> Func a b+x |=> y = (x |-> y) funcEmpty++-- | Selects an arbitrary element from a 'Func' tree.+choose :: Func a b -> Maybe (a, b)+choose Empty = Nothing+choose (Leaf _ l) = tryHead l+choose (Branch _ _ t1 _) = choose t1++-- Maps+-- | A re-export of 'Map.empty'.+mapEmpty :: Map a b+mapEmpty = Map.empty++-- | A re-export of 'Map.insert'.+mapInsert :: Ord a => a -> b -> Map a b -> Map a b+mapInsert = Map.insert++-- | A re-export of 'Map.union'.+mapUnion :: Ord k => Map k a -> Map k a -> Map k a+mapUnion = Map.union++-- | A re-export of 'Map.delete'.+mapDelete :: Ord k => k -> Map k a -> Map k a+mapDelete = Map.delete++-- | A re-export of 'Map.lookup'.+mapLookup :: Ord a => a -> Map a b -> Maybe b+mapLookup = Map.lookup++-- | A re-export of 'Map.elems'.+mapElems :: Map k a -> [a]+mapElems = Map.elems++-- | A re-export of 'Map.fromList'.+mapFromList :: Ord a => [(a, b)] -> Map a b+mapFromList = Map.fromList++-- | A re-export of 'Map.toList'.+mapToList :: Ord a => Map a b -> [(a, b)]+mapToList = Map.toList++-- | A re-export of 'Map.map'.+mapMap :: (a -> b) -> Map k a -> Map k b+mapMap = Map.map++-- | A re-export of 'Map.foldrWithKey'.+mapFoldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+mapFoldrWithKey = Map.foldrWithKey++-- | A version of 'remove' for 'Map's based on 'Map.updateLookupWithKey'.+mapRemove :: Ord k => k -> Map k a -> Maybe (a, Map k a)+mapRemove x m = + let (child, map') = Map.updateLookupWithKey (\ _ _ -> Nothing) x m in+ case child of+ Nothing -> Nothing+ Just x' -> Just (x', map')++-- | A re-export of 'Map.toAscList'.+mapToAscList :: Map k a -> [(k, a)]+mapToAscList = Map.toAscList++-- | A re-export of 'Text.append'.+append :: Text -> Text -> Text+append = Text.append++-- | A re-export of 'Text.cons'.+cons :: Char -> Text -> Text+cons = Text.cons++-- | A re-export of 'Text.snoc'.+snoc :: Text -> Char -> Text+snoc = Text.snoc++-- | A re-export of 'Text.pack'.+pack :: String -> Text+pack = Text.pack++-- | A re-export of 'Text.unpack'.+unpack :: Text -> String+unpack = Text.unpack++-- | A re-export of 'Text.head'.+textHead :: Text -> Char+textHead = Text.head++-- | A re-export of 'Text.tail'.+textTail :: Text -> Text+textTail = Text.tail++-- | A re-export of 'Text.null'.+textNull :: Text -> Bool+textNull = Text.null++-- | A re-export of 'Text.empty'.+textEmpty :: Text+textEmpty = Text.empty++-- | A re-export of 'Text.strip'.+textStrip :: Text -> Text+textStrip = Text.strip++-- | A re-export of 'Text.show'.+textShow :: Text.Show a => a -> Text+textShow = Text.show++-- Acid State re-exports++-- | A re-export of 'State.get' from @Control.Monad.State@.+get :: State.MonadState s m => m s+get = State.get++-- | A re-export of 'State.put' from @Control.Monad.State@.+put :: State.MonadState s m => s -> m ()+put = State.put++-- | A re-export of 'Reader.ask' from @Control.Monad.Reader@.+ask :: Reader.MonadReader r m => m r+ask = Reader.ask++-- | A re-export of 'Acid.makeAcidic' from @Data.Acid@.+makeAcidic :: Name -> [Name] -> Q [Dec]+makeAcidic = Acid.makeAcidic+ -- language type classes {-$LangClasses The following two classes are used as an ad hoc mechanism for sharing@@ -1315,7 +1619,13 @@ operator. -} _TRY :: a -> a+ {-|+ A language combinator that annotates the wrapped operation with a provided+ 'String'. The language equivalent of 'note''.+ -}+ _NOTE :: String -> a -> a + {-| The 'LangSeq' class defines common language operations and combinators based on sequencing. See the note at the top of this section for more details as@@ -1334,9 +1644,3 @@ sequentially. -} _EVERY :: [a] -> a---- Not currently part of the Parsec library, so we define it here--- both orphan instances-deriving instance Eq Assoc--deriveLift ''Assoc
+ src/HaskHOL/Core/Lib/Families.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}+{-|+ Module: HaskHOL.Core.Lib.Families+ Copyright: (c) The University of Kansas 2013+ LICENSE: BSD3++ Maintainer: ecaustin@ittc.ku.edu+ Stability: unstable+ Portability: unknown++ This module defines type families for basic, type-level boolean computation.+ It is implemented separately given GHC's limitations on exporting type+ families with operators for names.+-}+module HaskHOL.Core.Lib.Families where++-- | Type family equality between types of the same kind.+type family (a :: k) == (b :: k) :: Bool++-- | Type family disjunction.+type family ((a :: Bool) || (b :: Bool)) :: Bool+type instance 'True || a = 'True+type instance a || 'True = 'True+type instance 'False || a = a+type instance a || 'False = a+++-- | Type family conjunction.+type family ((a :: Bool) && (b :: Bool)) :: Bool+type instance 'True && a = a+type instance 'False && a = 'False
− src/HaskHOL/Core/Lib/Lift.hs
@@ -1,158 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, MagicHash, OverlappingInstances,- TemplateHaskell, TypeSynonymInstances #-}--{-|- Module: HaskHOL.Core.Lib.Lift- Copyright: (c) Ian Lynagh 2006- LICENSE: BSD3-- Maintainer: ecaustin@ittc.ku.edu- Stability: unstable- Portability: unknown-- This module is a re-export of the th-lift library originally written by Ian- Lynagh and maintained by Mathieu Boespflug. A very minor change was made by- Evan Austin in order to facilitate derivation of lift instances for quantified- type constructors.-- The decision to include this source as part of the HaskHOL system, rather than- import the original library, was made to facilitate the above change and to- sever HaskHOL's only dependence on a non-Haskell Platform library.--}--{-- The original copyright is included in its entirety below, as required by BSD3:-- Copyright (c) Ian Lynagh.- All rights reserved.-- Redistribution and use in source and binary forms, with or without- modification, are permitted provided that the following conditions- are met:- 1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- 2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- 3. The names of the author may not be used to endorse or promote- products derived from this software without specific prior written- permission.-- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE- ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF- SUCH DAMAGE.--}--module HaskHOL.Core.Lib.Lift - ( deriveLift' -- :: Info -> Q [Dec]- , deriveLift -- :: Name -> Q [Dec]- , deriveLiftMany -- :: [Name] -> Q [Dec]- , module TH {-|- Re-exports 'Lift' for the purpose of writing type signatures external to- this module.- -}- ) where--import GHC.Exts-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import qualified Language.Haskell.TH.Syntax as TH (Lift)-import Control.Monad ((<=<))----- | Derive Lift instances for the given datatype.-deriveLift :: Name -> Q [Dec]-deriveLift = deriveLift' <=< reify---- | Derive Lift instances for many datatypes.-deriveLiftMany :: [Name] -> Q [Dec]-deriveLiftMany = deriveLiftMany' <=< mapM reify---- | Obtain Info values through a custom reification function. This is useful--- when generating instances for datatypes that have not yet been declared.-deriveLift' :: Info -> Q [Dec]-deriveLift' = fmap (:[]) . deriveLiftOne--deriveLiftMany' :: [Info] -> Q [Dec]-deriveLiftMany' = mapM deriveLiftOne--deriveLiftOne :: Info -> Q Dec-deriveLiftOne i =- case i of- TyConI (DataD dcx n vsk cons _) ->- liftInstance dcx n (map unTyVarBndr vsk) (map doCons cons)- TyConI (NewtypeD dcx n vsk con _) ->- liftInstance dcx n (map unTyVarBndr vsk) [doCons con]- _ -> fail ("deriveLift: unhandled: " ++ pprint i)- where liftInstance dcx n vs cases =- instanceD (ctxt dcx vs) (conT ''Lift `appT` typ n vs) [funD 'lift cases]- typ n = foldl appT (conT n) . map varT- ctxt dcx = fmap (dcx ++) . cxt . map liftPred- unTyVarBndr (PlainTV v) = v- unTyVarBndr (KindedTV v _) = v- liftPred n = classP ''Lift [varT n]--doCons :: Con -> Q Clause-doCons (NormalC c sts) = do- let ns = zipWith (\_ i -> 'x' : show i) sts [(0::Integer)..]- con = [| conE c |]- args = [ [| lift $(varE (mkName n)) |] | n <- ns ]- e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args- clause [conP c (map (varP . mkName) ns)] (normalB e) []-doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]-doCons (InfixC sty1 c sty2) = do- let con = [| conE c |]- left = [| lift $(varE (mkName "x0")) |]- right = [| lift $(varE (mkName "x1")) |]- e = [| infixApp $left $con $right |]- clause [infixP (varP (mkName "x0")) c (varP (mkName "x1"))] (normalB e) []--- ECA-doCons (ForallC _ _ con) = doCons con--instance Lift Name where- lift (Name occName nameFlavour) = [| Name occName nameFlavour |]--instance Lift OccName where- lift n = [| mkOccName $(lift $ occString n) |]--instance Lift PkgName where- lift n = [| mkPkgName $(lift $ pkgString n) |]--instance Lift ModName where- lift n = [| mkModName $(lift $ modString n) |]--instance Lift NameFlavour where- lift NameS = [| NameS |]- lift (NameQ moduleName) = [| NameQ moduleName |]- lift (NameU i) = [| case $( lift (I# i) ) of- I# i' -> NameU i' |]- lift (NameL i) = [| case $( lift (I# i) ) of- I# i' -> NameL i' |]- lift (NameG nameSpace pkgName moduleName)- = [| NameG nameSpace pkgName moduleName |]--instance Lift NameSpace where- lift VarName = [| VarName |]- lift DataName = [| DataName |]- lift TcClsName = [| TcClsName |]---- These instances should really go in the template-haskell package.--instance Lift () where- lift _ = [| () |]--instance Lift Rational where- lift x = return (LitE (RationalL x))----ECA-instance Lift String where- lift = liftString
src/HaskHOL/Core/Parser.hs view
@@ -16,61 +16,24 @@ "HaskHOL.Core.TermRep" module. -} module HaskHOL.Core.Parser- ( -- * Parser Data Types- PreTerm- , PreType- -- * Type Elaboration Flags- , FlagIgnoreConstVarstruct(..)- , FlagTyInvWarning(..)- , FlagTyOpInvWarning(..)- , FlagAddTyAppsAuto(..)- -- * Extensible Parser Operators- , parseAsBinder -- :: String -> HOL Theory thry ()- , parseAsTyBinder -- :: String -> HOL Theory thry ()- , parseAsPrefix -- :: String -> HOL Theory thry ()- , parseAsInfix -- :: (String, (Int, Assoc)) -> HOL Theory thry ()- , unparseAsBinder -- :: String -> HOL Theory thry ()- , unparseAsTyBinder -- :: String -> HOL Theory thry ()- , unparseAsPrefix -- :: String -> HOL Theory thry ()- , unparseAsInfix -- :: String -> HOL Theory thry ()- , binders -- :: HOLContext thry -> [String]- , tyBinders -- :: HOLContext thry -> [String]- , prefixes -- :: HOLContext thry -> [String]- , infixes -- :: HOLContext thry -> [(String, (Int, Assoc))]- , parsesAsBinder -- :: String -> HOLContext thry -> Bool- , parsesAsTyBinder -- :: String -> HOLContext thry -> Bool- , isPrefix -- :: String -> HOLContext thry -> Bool- , getInfixStatus -- :: String -> HOLContext thry -> - -- Maybe (Int, Assoc)- -- * Overloading and Interface Mapping- , makeOverloadable -- :: String -> HOLType -> HOL Theory thry ()- , removeInterface -- :: String -> HOL Theory thry ()- , reduceInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , overrideInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , overloadInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , prioritizeOverload -- :: HOLType -> HOL Theory thry ()- , getInterface -- :: HOLContext thry -> [(String, (String, HOLType))]- , getOverloads -- :: HOLContext thry -> [(String, HOLType)]- -- * Type Abbreviations- , newTypeAbbrev -- :: String -> HOLType -> HOL Theory thry ()- , removeTypeAbbrev -- :: String -> HOL Theory thry ()- , typeAbbrevs -- :: HOLContext thry -> [(String, HOLType)]- -- * Hidden Constant Mapping - , hideConstant -- :: String -> HOL Theory thry ()- , unhideConstant -- :: String -> HOL Theory thry ()- , getHidden -- :: HOLContext thry -> [String]- -- * Elaboration Functions- , tyElab -- :: PreType -> HOL cls thry HOLTerm- , elab -- :: PreTerm -> HOL cls thry HOLTerm+ ( -- * Elaboration Functions+ tyElab+ , elab -- * Parsing Functions- , holTypeParser -- :: String -> HOLContext thry -> Either ParseError PreType- , holTermParser -- :: String -> HOLContext thry -> Either ParseError PreTerm+ , runHOLParser+ , ptype+ , holTypeParser+ , pterm+ , holTermParser -- * Type/Term Representation Conversions , HOLTypeRep(..) , HOLTermRep(..)+ , HOLThmRep(..)+ -- * Primitive Parser types, utility functions, and extensions.+ , module HaskHOL.Core.Parser.Lib ) where -import HaskHOL.Core.State+import HaskHOL.Core.Lib import HaskHOL.Core.Parser.Lib import HaskHOL.Core.Parser.TypeParser@@ -78,15 +41,18 @@ import HaskHOL.Core.Parser.Elab import HaskHOL.Core.Parser.Rep -runHOLParser :: MyParser thry a -> String -> HOLContext thry -> +{-| Runs a custom parser when provided with an input 'String' and a + 'HOLContext'.+-}+runHOLParser :: MyParser thry a -> Text -> HOLContext thry -> Either ParseError a runHOLParser parser input ctxt =- runParser parser (ctxt, []) "" input+ runParser parser (ctxt, [], 0) "" input -- | Parser for 'HOLTerm's.-holTermParser :: String -> HOLContext thry -> Either ParseError PreTerm+holTermParser :: Text -> HOLContext thry -> Either ParseError PreTerm holTermParser = runHOLParser pterm -- | Parser for 'HOLType's.-holTypeParser :: String -> HOLContext thry -> Either ParseError PreType+holTypeParser :: Text -> HOLContext thry -> Either ParseError PreType holTypeParser = runHOLParser ptype
src/HaskHOL/Core/Parser.hs-boot view
@@ -1,9 +1,8 @@ module HaskHOL.Core.Parser where -import HaskHOL.Core.State--import HaskHOL.Core.Parser.Lib+import HaskHOL.Core.Lib+import HaskHOL.Core.Parser.Prims -holTermParser :: String -> HOLContext thry -> Either ParseError PreTerm+holTermParser :: Text -> HOLContext thry -> Either ParseError PreTerm -holTypeParser :: String -> HOLContext thry -> Either ParseError PreType+holTypeParser :: Text -> HOLContext thry -> Either ParseError PreType
src/HaskHOL/Core/Parser/Elab.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-| Module: HaskHOL.Core.Parser.Elab Copyright: (c) The University of Kansas 2013@@ -12,9 +13,9 @@ 'HOLType's and 'HOLTerm's accordingly. This conversion includes local type inference for terms. -}-module HaskHOL.Core.Parser.Elab - ( tyElab -- :: PreType -> HOL cls thry HOLTerm- , elab -- :: PreTerm -> HOL cls thry HOLTerm+module HaskHOL.Core.Parser.Elab+ ( tyElab+ , elab ) where import HaskHOL.Core.Lib@@ -22,21 +23,21 @@ import HaskHOL.Core.State import HaskHOL.Core.Basics -import HaskHOL.Core.Parser.Lib hiding ((<?>))+import HaskHOL.Core.Parser.Lib {- PEnv is an environment that carries an association between system type variables and their unifiable type. It is defined as a type synonym in case we ever need to change its implementation for performance reasons. -}-type PEnv = [(Int, PreType)]+type PEnv = [(Integer, PreType)] -- utility functions-destSTV :: PreType -> Maybe Int+destSTV :: PreType -> Maybe Integer destSTV (STyVar n) = Just n destSTV _ = Nothing -destUTy :: PreType -> Maybe String+destUTy :: PreType -> Maybe Text destUTy (UTyVar _ x _) = Just x destUTy _ = Nothing @@ -44,7 +45,7 @@ destPUTy (PUTy tv ty) = Just (tv, ty) destPUTy _ = Nothing -freeSTVS0 :: PreType -> [Int]+freeSTVS0 :: PreType -> [Integer] freeSTVS0 PTyCon{} = [] freeSTVS0 UTyVar{} = [] freeSTVS0 (STyVar n) = [n]@@ -64,7 +65,7 @@ variantUTyVar :: [PreType] -> PreType -> PreType variantUTyVar avoid tv@(UTyVar f name n)- | tv `elem` avoid = variantUTyVar avoid $ UTyVar f (name ++ "'") n+ | tv `elem` avoid = variantUTyVar avoid $ UTyVar f (name `snoc` '\'') n | otherwise = tv variantUTyVar _ tv = tv @@ -75,7 +76,7 @@ Used to construct a constant that has one or more instantiations provided for its type operator variables. -}-mkTIConst :: String -> HOLType -> HOLTypeEnv -> HOL cls thry HOLTerm+mkTIConst :: Text -> HOLType -> HOLTypeEnv -> HOL cls thry HOLTerm mkTIConst c ty subs = (do cty' <- liftM (typeSubst subs) $ getConstType c let (mat1Tys, opTys, opOps) = fromJust $ typeMatch cty' ty ([], [], [])@@ -88,7 +89,7 @@ <?> "mkTIConst" -- Constructs a PreTerm representation of a provided integer.-pmkNumeral :: Integer -> PreTerm+pmkNumeral :: Integral i => i -> PreTerm pmkNumeral = PComb numeral . pmkNumeralRec where numPTy :: PreType numPTy = PTyComb (PTyCon "num") []@@ -99,11 +100,11 @@ bit1 = PConst "BIT1" $ mkFunPTy numPTy numPTy t0 = PConst "_0" numPTy - pmkNumeralRec :: Integer -> PreTerm+ pmkNumeralRec :: Integral i => i -> PreTerm pmkNumeralRec 0 = t0 pmkNumeralRec n = - let op = if n `mod` 2 == num0 then bit0 else bit1 in- PComb op . pmkNumeralRec $ n `div` 1+ let op = if n `mod` 2 == 0 then bit0 else bit1 in+ PComb op . pmkNumeralRec $ n `div` 2 {- Checks if a unification for a system type variable is trivial, i.e. unifying@@ -113,7 +114,7 @@ Also used to check for cyclic occurances, i.e. a system type variable exists as a sub-term of the provided term. -}-istrivial :: PEnv -> Int -> PreType -> Maybe Bool+istrivial :: PEnv -> Integer -> PreType -> Maybe Bool istrivial _ _ PTyCon{} = Just False istrivial env x (STyVar y) | y == x = Just True@@ -132,15 +133,15 @@ else return False -- system type generation-newTypeVar :: HOL cls thry PreType-newTypeVar = return STyVar <*> tickTypeCounter+newTypeVar :: TypingState -> HOL cls thry PreType+newTypeVar ref = return STyVar <*> tickTypeCounter' ref -- Turn UType term into a non-UType by adding type applications-addTyApps :: PreTerm -> PreType -> HOL cls thry PreTerm-addTyApps tm ty@(PUTy tv tb) =- do ntv <- newTypeVar- addTyApps (TyPComb tm ty ntv) $ pretypeSubst [(ntv, tv)] tb-addTyApps tm _ = return tm+addTyApps :: TypingState -> PreTerm -> PreType -> HOL cls thry PreTerm+addTyApps ref tm ty@(PUTy tv tb) =+ do ntv <- newTypeVar ref+ addTyApps ref (TyPComb tm ty ntv) $ pretypeSubst [(ntv, tv)] tb+addTyApps _ tm _ = return tm -- Check where unification of ty with a UType is potentially possible unifiableWithUType :: PreType -> PEnv -> Bool@@ -151,12 +152,13 @@ isJust (destPUTy tys) || isJust (destSTV tys) -- Get a new instance of a constant's generic type modulo interface-getGenericType :: String -> HOL cls thry HOLType+getGenericType :: Text -> HOL cls thry HOLType getGenericType cname =- do ctxt <- get- case filter (\ (x, _) -> x == cname) $ getInterface ctxt of- ((_, (_, ty)):[]) -> return ty- (_:_:_) -> liftMaybe "getGenericType" . assoc cname $ getOverloads ctxt+ do iface <- getInterface+ case filter (\ (x, _) -> x == cname) iface of+ [(_, (_, ty))] -> return ty+ (_:_:_) -> do overs <- getOverloads+ liftMaybe "getGenericType" $ mapLookup cname overs _ -> getConstType cname {- @@ -209,9 +211,16 @@ data TypingRefs = TypingRefs { stvsTrans :: !Bool , stovsTrans :: !Bool- , smallSTVS :: ![Int]+ , smallSTVS :: ![Integer]+ , tyCounter :: !Integer } +tickTypeCounter' :: TypingState -> HOL cls thry Integer+tickTypeCounter' ref = + do n' <- liftM (succ . tyCounter) $ readHOLRef ref+ modifyHOLRef ref $ \ st -> st { tyCounter = n' }+ return n'+ -- Post typechecking elaboration tyElabRef :: TypingState -> PreType -> HOL cls thry HOLType tyElabRef _ (PTyCon s) = mkType s []@@ -221,7 +230,7 @@ "null arity" tyElabRef ref (PTyComb (STyVar n) args) = do modifyHOLRef ref $ \ st -> st { stovsTrans = True }- mkType ('?' : show n) =<< mapM (tyElabRef ref) args+ mkType ('?' `cons` textShow n) =<< mapM (tyElabRef ref) args tyElabRef ref (PTyComb (UTyVar _ v _) args) = mkType v =<< mapM (tyElabRef ref) args tyElabRef ref (PTyComb (PTyCon s) args) =@@ -230,8 +239,8 @@ fail "tyElab: unexpected first argument to type combination" tyElabRef ref (PUTy (UTyVar _ s 0) tbody) = do tbody' <- tyElabRef ref tbody- liftEither "tyElab: universal type" $- liftM1 mkUType (mkSmall $ mkVarType s) tbody'+ liftM1 mkUType (mkSmall $ mkVarType s) tbody' <#?> + "tyElab: universal type" tyElabRef ref (PUTy STyVar{} _) = do modifyHOLRef ref $ \ st -> st { stvsTrans = True } fail "tyElab: system type variable in universal type."@@ -251,13 +260,13 @@ fail "tyElab: invalid universal type construction." tyElabRef ref (STyVar n) = do modifyHOLRef ref $ \ st -> st { stvsTrans = True }- let tv = mkVarType $ '?' : show n+ let tv = mkVarType $ '?' `cons` textShow n st <- readHOLRef ref if n `elem` smallSTVS st- then liftEither "tyElab: small system type variable" $ mkSmall tv+ then mkSmall tv <#?> "tyElab: small system type variable" else return tv tyElabRef _ (UTyVar True v _) = - liftEither "tyElab: small user type variable" . mkSmall $ mkVarType v+ mkSmall (mkVarType v) <#?> "tyElab: small user type variable" tyElabRef _ (UTyVar False v _) = return $! mkVarType v tmElab :: TypingState -> PreTerm -> HOL cls thry HOLTerm@@ -304,18 +313,18 @@ tmElabRec (PAs tm _) = tmElabRec tm -- retypecheck-preTypeOf :: TypingState -> [(String, PreType)] -> PreTerm -> +preTypeOf :: TypingState -> [(Text, PreType)] -> PreTerm -> HOL cls thry PreTerm preTypeOf ref senv pretm = - do ty <- newTypeVar + do ty <- newTypeVar ref modifyHOLRef ref $ \ st -> st { smallSTVS = [] } (tm', _, env) <- typify ty (pretm, senv, []) <?> "typechecking: initial type assignment" env' <- resolveInterface tm' return env <?> "typechecking: overload resolution" solvePreterm env' tm'- where typify :: PreType -> (PreTerm, [(String, PreType)], PEnv) -> - HOL cls thry (PreTerm, [(String, PreType)], PEnv)+ where typify :: PreType -> (PreTerm, [(Text, PreType)], PEnv) -> + HOL cls thry (PreTerm, [(Text, PreType)], PEnv) typify ty (PVar s _, venv, uenv) = case lookup s venv of Just ty' -> @@ -323,25 +332,25 @@ let tys = if flag then solve uenv ty' else ty' if flag && isJust (destPUTy tys) && not (unifiableWithUType ty uenv)- then do tys' <- addTyApps (PVar s tys) tys+ then do tys' <- addTyApps ref (PVar s tys) tys typify ty (tys', venv, uenv) else do uenv' <- unify uenv (tys, ty) return (PVar s tys, [], uenv') Nothing -> - case numOfString s of+ case numOfString (unpack s) of Just s' -> - let t = pmkNumeral s' in+ let t = pmkNumeral (s' :: Integer) in do uenv' <- unify uenv (PTyComb (PTyCon "num") [], ty) return (t, [], uenv') Nothing -> (do s' <- getGenericType s- hidden <- gets getHidden+ hidden <- getHidden if s `notElem` hidden then do flag <- getBenignFlag FlagAddTyAppsAuto tys <- pretypeInstance s' if flag && isJust (destPUTy tys) && not (unifiableWithUType ty uenv)- then do ty' <- addTyApps (PVar s tys) tys+ then do ty' <- addTyApps ref (PVar s tys) tys typify ty (ty', venv, uenv) else do uenv' <- unify uenv (tys, ty) return (PConst s tys, [], uenv')@@ -349,7 +358,7 @@ <|> return (PVar s ty, [(s, ty)], uenv) typify ty (PInst tvis (PVar c _), _, uenv) = do c' <- getGenericType c <?> ("typify: TYINST can only be " ++ - "applied to a constant: " ++ c)+ "applied to a constant: " ++ show c) let cty = pretypeOfType c' let tvs = map snd tvis rtvs = filter (\ x -> case x of@@ -359,7 +368,7 @@ then let rtvNames = fromJust $ mapM destUTy rtvs (missing:_) = filter (`notElem` rtvNames) tvs in fail $ "typify: TYINST: type does not contain " ++ - "tyvar " ++ missing+ "tyvar " ++ show missing else let subs = fromJust $ mapM (\ tv -> do x <- destUTy tv x' <- revAssoc x tvis@@ -372,7 +381,7 @@ uenv' <- unify uenv (cty', ty) return (PInst tvis' (PConst c cty'), [], uenv') typify ty (PComb t (PApp ti), venv, uenv) =- do ntv <- newTypeVar+ do ntv <- newTypeVar ref (t', venv1, uenv1) <- typify ntv (t, venv, uenv) case solve uenv1 ntv of ty'@(PUTy ty1 ty2) -> @@ -382,7 +391,7 @@ _ -> fail $ "typify: Type application argument maybe not " ++ "of universal type: " ++ show t typify ty (PComb f x, venv, uenv) =- do ty'' <- newTypeVar+ do ty'' <- newTypeVar ref let ty' = mkFunPTy ty'' ty (f', venv1, uenv1) <- typify ty' (f, venv, uenv) (x', venv2, uenv2) <- typify (solve uenv1 ty'') @@ -392,7 +401,7 @@ do flag <- getBenignFlag FlagAddTyAppsAuto if flag && isJust (destPUTy pty) && not (unifiableWithUType ty uenv)- then do ty' <- addTyApps ptm pty+ then do ty' <- addTyApps ref ptm pty typify ty (ty', venv, uenv) else do uenv' <- unify uenv (ty, pty) typify ty (tm, venv, uenv')@@ -400,8 +409,8 @@ do (ty', ty'') <- case ty of PTyComb (PTyCon "fun") [ty', ty''] -> return (ty', ty'')- _ -> do ty1 <- newTypeVar- ty2 <- newTypeVar+ _ -> do ty1 <- newTypeVar ref+ ty2 <- newTypeVar ref return (ty1, ty2) uenv0 <- unify uenv (mkFunPTy ty' ty'', ty) (v', venv1, uenv1) <- do (v', venv1, uenv1) <- typify ty' @@ -417,7 +426,7 @@ (bod', venv2, uenv2) <- typify ty'' (bod, venv1 ++ venv, uenv1) return (PAbs v' bod', venv2, uenv2) typify ty (TyPAbs tv bod, venv, uenv) =- do ntv <- newTypeVar+ do ntv <- newTypeVar ref (bod', venv1, uenv1) <- typify ntv (bod, venv, uenv) uenv2 <- unify uenv1 (PUTy tv $ solve uenv1 ntv, ty) return (TyPAbs tv bod', venv1, uenv2)@@ -429,14 +438,14 @@ fail $ "typify: unexpected preterm at this stage: " ++ show ptm -- Give system type vars for all free type vars, except those in tys- replaceUtvsWithStvs :: [String] -> PreType -> HOL cls thry PreType+ replaceUtvsWithStvs :: [Text] -> PreType -> HOL cls thry PreType replaceUtvsWithStvs tys pty = do tyvs' <- mapM subsf $ utyvars pty return $! pretypeSubst tyvs' pty where subsf :: PreType -> HOL cls thry (PreType, PreType) subsf tv@(UTyVar f s _) = if s `elem` tys then return (tv, tv)- else do tv'@(STyVar n) <- newTypeVar+ else do tv'@(STyVar n) <- newTypeVar ref when f $ modifyHOLRef ref (\ st -> st { smallSTVS = n : smallSTVS st}) return (tv', tv)@@ -465,7 +474,7 @@ resolveInterface PVar{} cont env = cont env resolveInterface (PConst s ty) cont env =- do iface <- gets getInterface+ do iface <- getInterface let maps = filter (\ (s', _) -> s' == s) iface if null maps then cont env@@ -498,7 +507,7 @@ fail "solvePreterm: type ascription" solvePreterm env (PConst s ty) = let tys = solve env ty in- (do iface <- gets getInterface+ (do iface <- getInterface c' <- tryFind (\ (s', (c', ty')) -> if s == s' then do ty'' <- pretypeInstance ty'@@ -507,7 +516,7 @@ else mzero) iface pmkCV c' tys) <|> (return $! PConst s tys)- where pmkCV :: String -> PreType -> HOL cls thry PreTerm+ where pmkCV :: Text -> PreType -> HOL cls thry PreTerm pmkCV name pty = do cond <- can getConstType name return $! if cond then PConst name pty @@ -538,27 +547,29 @@ (STyVar x, t) -> handleSTVS x t (t, STyVar x) -> handleSTVS x t _ -> fail $ "unify: " ++ show ty1 ++ " WITH " ++ show ty2- where handleSTVS :: Int -> PreType -> HOL cls thry PEnv+ where handleSTVS :: Integer -> PreType -> HOL cls thry PEnv handleSTVS x t = case lookup x env of Just x' -> unify env (x', t)- _ -> if istrivial env x t == Just True- then return env- else do st <- readHOLRef ref- let t' = destSTV t- when (isJust t' && x `elem` smallSTVS st) $- modifyHOLRef ref $ \ s -> - s { smallSTVS = fromJust t' : smallSTVS s }- return $! insertMap x t env+ _ -> case istrivial env x t of+ Just True -> return env+ Just False ->+ do st <- readHOLRef ref+ let t' = destSTV t+ when (isJust t' && x `elem` smallSTVS st) $+ modifyHOLRef ref $ \ s -> + s { smallSTVS = fromJust t' : smallSTVS s }+ return $! insertMap x t env+ Nothing -> fail "handleSTVS" -- | Elaborator for 'PreType's. tyElab :: PreType -> HOL cls thry HOLType tyElab pty =- do ref <- newHOLRef $ TypingRefs False False []+ do ref <- newHOLRef $ TypingRefs False False [] 0 tyElabRef ref pty -- | Elaborator and type inference for 'PreTerm's. elab :: PreTerm -> HOL cls thry HOLTerm elab ptm = - do ref <- newHOLRef $ TypingRefs False False []+ do ref <- newHOLRef $ TypingRefs False False [] 0 tmElab ref =<< preTypeOf ref [] ptm
src/HaskHOL/Core/Parser/Lib.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, ViewPatterns #-}-+{-# LANGUAGE FlexibleContexts, PatternSynonyms, TypeFamilies #-} {-| Module: HaskHOL.Core.Parser.Lib Copyright: (c) The University of Kansas 2013@@ -31,74 +30,103 @@ ( -- * Parser Utilities and Types PreType(..) , PreTerm(..)- , dpty -- :: PreType- , pretypeOfType -- :: HOLType -> PreType+ , dpty+ , pretypeOfType , MyParser+ , ParseError -- | A re-export of 'ParseError'.+ , runParser -- |A re-export of 'runParser'.+ , langDef+ , lexer+ , mysymbol , myparens , mybraces , mybrackets , mycommaSep1 , mysemiSep+ , mysemiSep1 , myreserved , myidentifier , myinteger , myoperator , myreservedOp- , choiceOp+ , choiceSym+ , choiceId , mywhiteSpace+ , mymany+ , mymany1+ , mysepBy1+ , mytry -- * Type Elaboration Flags , FlagIgnoreConstVarstruct(..) , FlagTyInvWarning(..) , FlagTyOpInvWarning(..) , FlagAddTyAppsAuto(..)+ -- * Pretty Printer Flags+ , FlagRevInterface(..)+ , FlagPrintAllThm(..) -- * Extensible Parser Operators- , parseAsBinder -- :: String -> HOL Theory thry ()- , parseAsTyBinder -- :: String -> HOL Theory thry ()- , parseAsPrefix -- :: String -> HOL Theory thry ()- , parseAsInfix -- :: (String, (Int, Assoc)) -> HOL Theory thry ()- , unparseAsBinder -- :: String -> HOL Theory thry ()- , unparseAsTyBinder -- :: String -> HOL Theory thry ()- , unparseAsPrefix -- :: String -> HOL Theory thry ()- , unparseAsInfix -- :: String -> HOL Theory thry ()- , binders -- :: HOLContext thry -> [String]- , tyBinders -- :: HOLContext thry -> [String]- , prefixes -- :: HOLContext thry -> [String]- , infixes -- :: HOLContext thry -> [(String, (Int, Assoc))]- , parsesAsBinder -- :: String -> HOLContext thry -> Bool- , parsesAsTyBinder -- :: String -> HOLContext thry -> Bool- , isPrefix -- :: String -> HOLContext thry -> Bool- , getInfixStatus -- :: String -> HOLContext thry -> - -- Maybe (Int, Assoc)+ , HOLContext(..)+ , prepHOLContext+ , getTypeArityCtxt+ , parseAsBinder+ , parseAsTyBinder+ , parseAsPrefix+ , parseAsInfix+ , unparseAsBinder+ , unparseAsTyBinder+ , unparseAsPrefix+ , unparseAsInfix+ , parsesAsBinder+ , parsesAsTyBinder+ , isPrefix+ , getInfixStatus -- * Overloading and Interface Mapping- , makeOverloadable -- :: String -> HOLType -> HOL Theory thry ()- , removeInterface -- :: String -> HOL Theory thry ()- , reduceInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , overrideInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , overloadInterface -- :: String -> HOLTerm -> HOL Theory thry ()- , prioritizeOverload -- :: HOLType -> HOL Theory thry ()- , getInterface -- :: HOLContext thry -> [(String, (String, HOLType))]- , getOverloads -- :: HOLContext thry -> [(String, HOLType)]+ , makeOverloadable+ , removeInterface+ , reduceInterface+ , overrideInterface+ , overloadInterface+ , prioritizeOverload+ , getInterface+ , getOverloads -- * Type Abbreviations- , newTypeAbbrev -- :: String -> HOLType -> HOL Theory thry ()- , removeTypeAbbrev -- :: String -> HOL Theory thry ()- , typeAbbrevs -- :: HOLContext thry -> [(String, HOLType)]+ , newTypeAbbrev+ , removeTypeAbbrev+ , typeAbbrevs -- * Hidden Constant Mapping - , hideConstant -- :: String -> HOL Theory thry ()- , unhideConstant -- :: String -> HOL Theory thry ()- , getHidden -- :: HOLContext thry -> [String]- -- * Re-export Parsec for convenience reasons- , module Text.ParserCombinators.Parsec+ , hideConstant+ , unhideConstant+ , getHidden+ -- * Extensible Printer Operators+ , addUnspacedBinop + , addPrebrokenBinop+ , removeUnspacedBinop+ , removePrebrokenBinop+ , getUnspacedBinops+ , getPrebrokenBinops+ -- * Parser state manipulations+ , getState+ , setState+ , updateState ) where -import HaskHOL.Core.Lib+import HaskHOL.Core.Lib hiding ((<?>)) import HaskHOL.Core.Kernel import HaskHOL.Core.State import HaskHOL.Core.Basics+import HaskHOL.Core.Parser.Prims -import Text.ParserCombinators.Parsec hiding ((<|>))-import Text.ParserCombinators.Parsec.Token-import Text.ParserCombinators.Parsec.Language (emptyDef)+import Text.Parsec hiding (runParser, setState, getState, updateState+ ,ParseError, (<|>))+import qualified Text.Parsec as P+import Text.Parsec.Language+import Text.Parsec.Text+import Text.Parsec.Token +import Control.Monad.Identity++import {-# SOURCE #-} HaskHOL.Core.Parser.Rep+ -- new flags and extensions {-| Flag to say whether to treat a constant varstruct, i.e. @\\ const . bod@, as@@ -110,89 +138,319 @@ Flag indicating that the user should be warned if a type variable was invented during parsing. -}-newFlag "FlagTyInvWarning" True+newFlag "FlagTyInvWarning" False {-| Flag indicating that the user should be warned if a type operator variable was invented during parsing. -}-newFlag "FlagTyOpInvWarning" True+newFlag "FlagTyOpInvWarning" False {-| Flag to say whether implicit type applications are to be added during parsing. -} newFlag "FlagAddTyAppsAuto" True -newExtension "BinderOps" [| ["\\"] :: [String] |]+-- | Flag to indicate whether the interface should be reversed on printing.+newFlag "FlagRevInterface" True -newExtension "TyBinderOps" [| ["\\\\"] :: [String] |]+{-| + Flag to indicate if the entirety of a theorem should be printed, as opposed+ to just the conclusion term.+-}+newFlag "FlagPrintAllThm" True -newExtension "PrefixOps" [| [] :: [String] |]+data BinderOps = BinderOps ![Text] deriving Typeable -newExtension "InfixOps" - [| [("=", (12, AssocRight))] :: [(String, (Int, Assoc))] |]+deriveSafeCopy 0 'base ''BinderOps -newExtension "Interface" [| [] :: [(String, (String, HOLType))] |]+initBinderOps :: [Text]+initBinderOps = ["\\"] -newExtension "Overload" [| [] :: [(String, HOLType)] |]+insertBinder :: Text -> Update BinderOps ()+insertBinder op =+ do (BinderOps ops) <- get+ put (BinderOps (op:ops)) -newExtension "TypeAbbreviations" [| [] :: [(String, HOLType)] |]+removeBinder :: Text -> Update BinderOps ()+removeBinder op =+ do (BinderOps ops) <- get+ put (BinderOps (op `delete` ops)) -newExtension "Hidden" [| [] :: [String] |]+getBinders :: Query BinderOps [Text]+getBinders =+ do (BinderOps ops) <- ask+ return ops --- | Parsed, but pre-elaborated HOL types.-data PreType- = PTyCon String- | UTyVar Bool String Int- | STyVar Int- | PTyComb PreType [PreType]- | PUTy PreType PreType- deriving (Eq, Show)+makeAcidic ''BinderOps ['insertBinder, 'removeBinder, 'getBinders] --- | Parsed, but pre-elaborated HOL terms.-data PreTerm- = PVar String PreType- | PConst String PreType- | PComb PreTerm PreTerm- | PAbs PreTerm PreTerm- | PAs PreTerm PreType- | PInst [(PreType, String)] PreTerm- | PApp PreType- | TyPAbs PreType PreTerm- | TyPComb PreTerm PreType PreType- deriving Show +data TyBinderOps = TyBinderOps ![Text] deriving Typeable++deriveSafeCopy 0 'base ''TyBinderOps++initTyBinderOps :: [Text]+initTyBinderOps = ["\\\\"]++insertTyBinder :: Text -> Update TyBinderOps ()+insertTyBinder op =+ do (TyBinderOps ops) <- get+ put (TyBinderOps (op:ops))++removeTyBinder :: Text -> Update TyBinderOps ()+removeTyBinder op =+ do (TyBinderOps ops) <- get+ put (TyBinderOps (op `delete` ops))++getTyBinders :: Query TyBinderOps [Text]+getTyBinders =+ do (TyBinderOps ops) <- ask+ return ops++makeAcidic ''TyBinderOps ['insertTyBinder, 'removeTyBinder, 'getTyBinders]++data PrefixOps = PrefixOps ![Text] deriving Typeable++deriveSafeCopy 0 'base ''PrefixOps++insertPrefix :: Text -> Update PrefixOps ()+insertPrefix op =+ do (PrefixOps ops) <- get+ put (PrefixOps (op:ops))++removePrefix :: Text -> Update PrefixOps ()+removePrefix op =+ do (PrefixOps ops) <- get+ put (PrefixOps (op `delete` ops))++getPrefixes :: Query PrefixOps [Text]+getPrefixes =+ do (PrefixOps ops) <- ask+ return ops++makeAcidic ''PrefixOps ['insertPrefix, 'removePrefix, 'getPrefixes]++data InfixOps = InfixOps ![(Text, (Int, Text))] deriving Typeable++deriveSafeCopy 0 'base ''InfixOps++initInfixOps :: [(Text, (Int, Text))]+initInfixOps = [("=", (12, "right"))]++insertInfix :: (Text, (Int, Text)) -> Update InfixOps ()+insertInfix i@(n, _) =+ do (InfixOps is) <- get + let is' = case find (\ (n', _) -> n == n') is of+ Just _ -> is+ _ -> + sort (\ (s, (x, a)) (t, (y, b)) ->+ x < y || x == y && a > b || x == y && a == b && s < t)+ (i:is)+ put (InfixOps is')++removeInfix :: Text -> Update InfixOps ()+removeInfix op =+ do (InfixOps ops) <- get+ put (InfixOps (filter (\ (x, _) -> x /= op) ops))++getInfixes :: Query InfixOps [(Text, (Int, Text))]+getInfixes =+ do (InfixOps ops) <- ask+ return ops++makeAcidic ''InfixOps ['insertInfix, 'removeInfix, 'getInfixes]+++data Interface = Interface ![(Text, (Text, HOLType))] deriving Typeable++deriveSafeCopy 0 'base ''Interface++insertInterface :: (Text, (Text, HOLType)) -> Update Interface ()+insertInterface x =+ do (Interface xs) <- get+ put (Interface (x:xs))++deleteInterface :: (Text, (Text, HOLType)) -> Update Interface ()+deleteInterface x =+ do (Interface xs) <- get+ put (Interface (x `delete` xs))++filterInterface :: Text -> Update Interface ()+filterInterface s =+ do (Interface xs) <- get+ put (Interface (filter (\ (x, _) -> x /= s) xs))++getInterfaces :: Query Interface [(Text, (Text, HOLType))]+getInterfaces =+ do (Interface xs) <- ask+ return xs++makeAcidic ''Interface + ['insertInterface, 'deleteInterface, 'filterInterface, 'getInterfaces]+++data Overload = Overload !(Map Text HOLType) deriving Typeable++deriveSafeCopy 0 'base ''Overload++insertOverload :: Text -> HOLType -> Update Overload ()+insertOverload s ty =+ do (Overload xs) <- get+ put (Overload (mapInsert s ty xs))++getOverload :: Query Overload (Map Text HOLType)+getOverload =+ do (Overload xs) <- ask+ return xs++makeAcidic ''Overload ['insertOverload, 'getOverload]+++data TypeAbbreviations = TypeAbbreviations !(Map Text HOLType) + deriving Typeable++deriveSafeCopy 0 'base ''TypeAbbreviations++insertTypeAbbreviation :: Text -> HOLType -> Update TypeAbbreviations ()+insertTypeAbbreviation x ty =+ do (TypeAbbreviations xs) <- get+ put (TypeAbbreviations (mapInsert x ty xs))++removeTypeAbbreviation :: Text -> Update TypeAbbreviations ()+removeTypeAbbreviation x =+ do (TypeAbbreviations xs) <- get+ put (TypeAbbreviations (x `mapDelete` xs))++getTypeAbbreviations :: Query TypeAbbreviations (Map Text HOLType)+getTypeAbbreviations =+ do (TypeAbbreviations xs) <- ask+ return xs++makeAcidic ''TypeAbbreviations + ['insertTypeAbbreviation, 'removeTypeAbbreviation, 'getTypeAbbreviations]+++data Hidden = Hidden [Text] deriving Typeable++deriveSafeCopy 0 'base ''Hidden++insertHidden :: Text -> Update Hidden ()+insertHidden x =+ do (Hidden xs) <- get+ put (Hidden (x `insert` xs))++removeHidden :: Text -> Update Hidden ()+removeHidden x =+ do (Hidden xs) <- get+ put (Hidden (x `delete` xs))++getHiddens :: Query Hidden [Text]+getHiddens =+ do (Hidden xs) <- ask+ return xs++makeAcidic ''Hidden ['insertHidden, 'removeHidden, 'getHiddens]+++data UnspacedBinops = UnspacedBinops ![Text] deriving Typeable++deriveSafeCopy 0 'base ''UnspacedBinops++initUnspaced :: [Text]+initUnspaced = [",", "..", "$"]++insertUnspaced :: Text -> Update UnspacedBinops ()+insertUnspaced op =+ do (UnspacedBinops ops) <- get+ put (UnspacedBinops (op:ops))++removeUnspaced :: Text -> Update UnspacedBinops ()+removeUnspaced op =+ do (UnspacedBinops ops) <- get+ put (UnspacedBinops (ops \\ [op]))++getUnspaced :: Query UnspacedBinops [Text]+getUnspaced =+ do (UnspacedBinops ops) <- ask+ return ops++makeAcidic ''UnspacedBinops ['insertUnspaced, 'removeUnspaced, 'getUnspaced]+++data PrebrokenBinops = PrebrokenBinops ![Text] deriving Typeable++deriveSafeCopy 0 'base ''PrebrokenBinops++initPrebroken :: [Text]+initPrebroken = ["==>"]++insertPrebroken :: Text -> Update PrebrokenBinops ()+insertPrebroken op =+ do (PrebrokenBinops ops) <- get+ put (PrebrokenBinops (op:ops))++removePrebroken :: Text -> Update PrebrokenBinops ()+removePrebroken op =+ do (PrebrokenBinops ops) <- get+ put (PrebrokenBinops (ops \\ [op]))++getPrebroken :: Query PrebrokenBinops [Text]+getPrebroken =+ do (PrebrokenBinops ops) <- ask+ return ops++makeAcidic ''PrebrokenBinops ['insertPrebroken, 'removePrebroken, 'getPrebroken]+ -- | The default 'PreType' to be used as a blank for the type inference engine. dpty :: PreType-dpty = PTyComb (PTyCon "") []+dpty = PTyComb (PTyCon textEmpty) [] -- | Converts a 'HOLType' to 'PreType' pretypeOfType :: HOLType -> PreType-pretypeOfType (view -> TyVar f v) = UTyVar f v 0-pretypeOfType (view -> TyApp tyop args) =+pretypeOfType (TyVar f v) = UTyVar f v 0+pretypeOfType (TyApp tyop args) = let (s, n) = destTypeOp tyop tyop' = if n == -1 then UTyVar False s (length args) else PTyCon s in PTyComb tyop' $ map pretypeOfType args-pretypeOfType (view -> UType tv tb) = +pretypeOfType (UType tv tb) = PUTy (pretypeOfType tv) $ pretypeOfType tb-pretypeOfType _ = error "pretypeOfType: incomplete view pattern"+pretypeOfType _ = error "pretypeOfType: exhaustive warning." {-| - An alias to a stateful 'CharParser' that carries a 'HOLContext' and list of- known type operator variables with their arity. This second list is used- to guarantee that all instances of a type operator variable in a term have- the same arity.+ An alias to a stateful 'GenParser' that carries a 'HOLContext', a list of+ known type operator variables with their arity, and a counter The list of+ operators is used to guarantee that all instances of a type operator variable+ in a term have the same arity. The counter is used to generate fresh names+ in a term. -}-type MyParser thry a = CharParser (HOLContext thry, [(String, Int)]) a+type MyParser thry = GenParser (HOLContext thry, [(Text, Int)], Int) --- used internally by the numerous parser combinators seen below.-lexer :: TokenParser (HOLContext thry, [(String, Int)])-lexer = makeTokenParser- (emptyDef- { reservedNames = ["TYINST", "let", "and", "in", "if", "then", "else"]- , reservedOpNames = ["%", "_", "'", "->", "+", "#", "^", ":", ";"]- })+-- | The Parsec 'LanguageDef' for HaskHOL.+langDef :: GenLanguageDef Text st Identity+langDef = LanguageDef+ { commentStart = ""+ , commentEnd = ""+ , commentLine = ""+ , nestedComments = True+ , identStart = alphaNum <|> char '_'+ , identLetter = alphaNum <|> oneOf "_'"+ , opStart = oneOf ",:!#$%&*+./<=>?@\\^|-~"+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , reservedNames = [ "TYINST", "let", "and", "in", "if", "then", "else"+ , "match", "when", "function" ]+ , reservedOpNames = ["(", ")", "[", "]", "{", "}"+ , "%", "_", "'", "->", ".", ":", ";", "|"]+ , caseSensitive = True+ } +-- | The Parsec token parser for HaskHOL.+lexer :: GenTokenParser Text (HOLContext thry, [(Text, Int)], Int) Identity+lexer = makeTokenParser langDef++-- | A version of 'symbol' for our language.+mysymbol :: String -> MyParser thry Text+mysymbol = liftM pack . symbol lexer+ -- | A version of 'parens' for our language. myparens :: MyParser thry a -> MyParser thry a myparens = parens lexer@@ -213,141 +471,178 @@ mysemiSep :: MyParser thry a -> MyParser thry [a] mysemiSep = semiSep lexer +-- | A version of 'semiSep1' for our language.+mysemiSep1 :: MyParser thry a -> MyParser thry [a]+mysemiSep1 = semiSep1 lexer+ -- | A version of 'reserved' for our language. myreserved :: String -> MyParser thry () myreserved = reserved lexer -- | A version of 'identifier' for our language.-myidentifier :: MyParser thry String-myidentifier = identifier lexer+myidentifier :: MyParser thry Text+myidentifier = liftM pack $ identifier lexer -- | A version of 'integer' for our language. myinteger :: MyParser thry Integer myinteger = integer lexer -- | A version of 'operator' for our language.-myoperator :: MyParser thry String-myoperator = operator lexer+myoperator :: MyParser thry Text+myoperator = liftM pack $ operator lexer -- | A version of 'reservedOp' for our language. myreservedOp :: String -> MyParser thry () myreservedOp = reservedOp lexer +-- | Selects the first matching symbol.+choiceSym :: [String] -> MyParser thry Text+choiceSym ops = choice $ map mysymbol ops+ -- | Selects the first matching reserved operator.-choiceOp :: [String] -> MyParser thry String-choiceOp ops = - choice $ map (\ name -> do myreservedOp name- return name) ops+choiceId :: [Text] -> MyParser thry Text+choiceId ops = choice $ map + (\ s -> try $ do s' <- myidentifier <|> myoperator+ if s' == s+ then return s+ else fail "choiceId") ops -- | A version of 'whiteSpace' for our language. mywhiteSpace :: MyParser thry () mywhiteSpace = whiteSpace lexer +-- | A re-export of 'P.many'.+mymany :: MyParser thry a -> MyParser thry [a]+mymany = P.many++-- | A re-export of 'P.many1'.+mymany1 :: MyParser thry a -> MyParser thry [a]+mymany1 = P.many1++-- | A re-export of 'P.sepBy1'.+mysepBy1 :: MyParser thry a -> MyParser thry b -> MyParser thry [a]+mysepBy1 = P.sepBy1++-- | A re-export of 'P.try'.+mytry :: MyParser thry a -> MyParser thry a+mytry = P.try+ -- State Extensions+prepHOLContext :: HOL cls thry (HOLContext thry)+prepHOLContext =+ do acid1 <- openLocalStateHOL (InfixOps initInfixOps)+ is <- queryHOL acid1 GetInfixes+ closeAcidStateHOL acid1+ acid2 <- openLocalStateHOL (PrefixOps [])+ ps <- queryHOL acid2 GetPrefixes+ closeAcidStateHOL acid2+ acid3 <- openLocalStateHOL (BinderOps initBinderOps)+ bs <- queryHOL acid3 GetBinders+ closeAcidStateHOL acid3+ acid4 <- openLocalStateHOL (TyBinderOps initTyBinderOps)+ tbs <- queryHOL acid4 GetTyBinders+ closeAcidStateHOL acid4+ ts <- types+ tas <- typeAbbrevs+ iface <- getInterface+ cond1 <- getBenignFlag FlagPrintAllThm+ cond2 <- getBenignFlag FlagRevInterface+ us <- getUnspacedBinops+ pbs <- getPrebrokenBinops+ return $! HOLContext is ps bs tbs ts tas iface cond1 cond2 us pbs++ -- Operators--- | Specifies a 'String' to be recognized as a term binder by the parser.-parseAsBinder :: String -> HOL Theory thry ()+-- A version of 'getTypeArity' for parser contexts.+getTypeArityCtxt :: HOLContext thry -> Text -> Maybe Int+getTypeArityCtxt ctxt name =+ liftM (snd . destTypeOp) . mapLookup name $ typesCtxt ctxt++-- | Specifies a 'Text' to be recognized as a term binder by the parser.+parseAsBinder :: Text -> HOL Theory thry () parseAsBinder op =- modifyExt (\ (BinderOps ops) -> BinderOps $ op `insert` ops)+ do acid <- openLocalStateHOL (BinderOps initBinderOps)+ updateHOL acid (InsertBinder op)+ createCheckpointAndCloseHOL acid --- | Specifies a 'String' to be recognized as a type binder by the parser.-parseAsTyBinder :: String -> HOL Theory thry ()+-- | Specifies a 'Text' to be recognized as a type binder by the parser.+parseAsTyBinder :: Text -> HOL Theory thry () parseAsTyBinder op =- modifyExt (\ (TyBinderOps ops) -> TyBinderOps $ op `insert` ops)+ do acid <- openLocalStateHOL (TyBinderOps initTyBinderOps)+ updateHOL acid (InsertTyBinder op)+ createCheckpointAndCloseHOL acid --- | Specifies a 'String' to be recognized as a prefix operator by the parser.-parseAsPrefix :: String -> HOL Theory thry ()+-- | Specifies a 'Text' to be recognized as a prefix operator by the parser.+parseAsPrefix :: Text -> HOL Theory thry () parseAsPrefix op =- modifyExt (\ (PrefixOps ops) -> PrefixOps $ op `insert` ops)+ do acid <- openLocalStateHOL (PrefixOps [])+ updateHOL acid (InsertPrefix op)+ createCheckpointAndCloseHOL acid {-| - Specifies a 'String' to be recognized as an infix operator by the parser with+ Specifies a 'Text' to be recognized as an infix operator by the parser with a given precedence level and associativity. -}-parseAsInfix :: (String, (Int, Assoc)) -> HOL Theory thry ()+parseAsInfix :: (Text, (Int, Text)) -> HOL Theory thry () parseAsInfix op =- modifyExt (\ (InfixOps ops) -> InfixOps $ op `insertInfix` ops)- where insertInfix :: (String, (Int, Assoc)) -> [(String, (Int, Assoc))] ->- [(String, (Int, Assoc))]- insertInfix i@(n, _) is =- case find (\ (n', _) -> n == n') is of- Just _ -> is- _ -> sortBy (\ (_, (x, _)) (_, (y, _)) -> y `compare` x) $ i:is+ do acid <- openLocalStateHOL (InfixOps initInfixOps)+ updateHOL acid (InsertInfix op)+ createCheckpointAndCloseHOL acid --- | Specifies a 'String' for the parser to stop recognizing as a term binder.-unparseAsBinder :: String -> HOL Theory thry ()+-- | Specifies a 'Text' for the parser to stop recognizing as a term binder.+unparseAsBinder :: Text -> HOL Theory thry () unparseAsBinder op =- modifyExt (\ (BinderOps ops) -> BinderOps $ op `delete` ops)+ do acid <- openLocalStateHOL (BinderOps initBinderOps)+ updateHOL acid (RemoveBinder op)+ createCheckpointAndCloseHOL acid --- | Specifies a 'String' for the parser to stop recognizing as a type binder.-unparseAsTyBinder :: String -> HOL Theory thry ()+-- | Specifies a 'Text' for the parser to stop recognizing as a type binder.+unparseAsTyBinder :: Text -> HOL Theory thry () unparseAsTyBinder op =- modifyExt (\ (TyBinderOps ops) -> TyBinderOps $ op `delete` ops)+ do acid <- openLocalStateHOL (TyBinderOps initTyBinderOps)+ updateHOL acid (RemoveTyBinder op)+ createCheckpointAndCloseHOL acid {-| - Specifies a 'String' for the parser to stop recognizing as a prefix operator.+ Specifies a 'Text' for the parser to stop recognizing as a prefix operator. -}-unparseAsPrefix :: String -> HOL Theory thry ()+unparseAsPrefix :: Text -> HOL Theory thry () unparseAsPrefix op =- modifyExt (\ (PrefixOps ops) -> PrefixOps $ op `delete` ops)+ do acid <- openLocalStateHOL (PrefixOps [])+ updateHOL acid (RemovePrefix op)+ createCheckpointAndCloseHOL acid {-| - Specifies a 'String' for the parser to stop recognizing as an infix operator.+ Specifies a 'Text' for the parser to stop recognizing as an infix operator. -}-unparseAsInfix :: String -> HOL Theory thry ()+unparseAsInfix :: Text -> HOL Theory thry () unparseAsInfix op =- modifyExt (\ (InfixOps ops) -> - InfixOps $ filter (\ (x, _) -> x == op) ops)---- | Returns all 'String's recognized as term binders by the parser.-binders :: HOLContext thry -> [String]-binders ctxt =- let (BinderOps ops) = getExtCtxt ctxt in- ops---- | Returns all 'String's recognized as type binders by the parser.-tyBinders :: HOLContext thry -> [String]-tyBinders ctxt =- let (TyBinderOps ops) = getExtCtxt ctxt in- ops---- | Returns all 'String's recognized as prefix operators by the parser.-prefixes :: HOLContext thry -> [String]-prefixes ctxt =- let (PrefixOps ops) = getExtCtxt ctxt in- ops--{-| - Returns all 'String's recognized as infix operators by the parser along with- their precedence and associativity pairs.--} -infixes :: HOLContext thry -> [(String, (Int, Assoc))]-infixes ctxt =- let (InfixOps ops) = getExtCtxt ctxt in- ops+ do acid <- openLocalStateHOL (InfixOps initInfixOps)+ updateHOL acid (RemoveInfix op)+ createCheckpointAndCloseHOL acid --- | Predicate for 'String's recognized as term binders by the parser.-parsesAsBinder :: String -> HOLContext thry -> Bool+-- | Predicate for 'Text's recognized as term binders by the parser.+parsesAsBinder :: Text -> HOLContext thry -> Bool parsesAsBinder op = elem op . binders --- | Predicate for 'String's recognized as term binders by the parser.-parsesAsTyBinder :: String -> HOLContext thry -> Bool+-- | Predicate for 'Text's recognized as term binders by the parser.+parsesAsTyBinder :: Text -> HOLContext thry -> Bool parsesAsTyBinder op = elem op . tyBinders --- | Predicate for 'String's recognized as prefix operators by the parser.-isPrefix :: String -> HOLContext thry -> Bool+-- | Predicate for 'Text's recognized as prefix operators by the parser.+isPrefix :: Text -> HOLContext thry -> Bool isPrefix op = elem op . prefixes {-| - Predicate for 'String's recognized as infix operators by the parser. Returns+ Predicate for 'Text's recognized as infix operators by the parser. Returns a precidence and associativity pair guarded by 'Maybe'. -}-getInfixStatus :: String -> HOLContext thry -> Maybe (Int, Assoc)+getInfixStatus :: Text -> HOLContext thry -> Maybe (Int, Text) getInfixStatus op = lookup op . infixes -- Interface {-|- Specifies a 'String' that can act as an overloadable identifier within the+ Specifies a 'Text' that can act as an overloadable identifier within the parser. The provided type is the most general type that instances of this symbol may have. Throws a 'HOLException' if the given symbol has already been declared as overloadable with a different type.@@ -356,35 +651,40 @@ that were previously introduced via 'overrideInterface' in order to guarantee that all overloads are matchable with their most general type. -}-makeOverloadable :: String -> HOLType -> HOL Theory thry ()+makeOverloadable :: Text -> HOLType -> HOL Theory thry () makeOverloadable s gty =- do (Overload overs) <- getExt- case lookup s overs of+ do overs <- getOverloads+ case mapLookup s overs of Just ty | gty == ty -> return () | otherwise -> fail "makeOverloadable: differs from existing skeleton"- _ -> do putExt $ Overload ((s, gty):overs)- modifyExt (\ (Interface iface) -> - Interface $ filter (\ (x, _) -> x /= s) iface)+ _ -> do acid1 <- openLocalStateHOL (Overload mapEmpty)+ updateHOL acid1 (InsertOverload s gty)+ createCheckpointAndCloseHOL acid1+ acid2 <- openLocalStateHOL (Interface [])+ updateHOL acid2 (FilterInterface s)+ createCheckpointAndCloseHOL acid2 -- | Removes all instances of an overloaded symbol from the interface.-removeInterface :: String -> HOL Theory thry ()+removeInterface :: Text -> HOL Theory thry () removeInterface sym =- modifyExt (\ (Interface iface) -> Interface $ - filter (\ (x, _) -> x /= sym) iface)+ do acid <- openLocalStateHOL (Interface [])+ updateHOL acid (FilterInterface sym)+ createCheckpointAndCloseHOL acid {-| Removes a specific instance of an overloaded symbol from the interface. Throws a 'HOLException' if the provided term is not a constant or varible term representing an instance of the overloaded symbol. -}-reduceInterface :: String -> HOLTerm -> HOL Theory thry ()+reduceInterface :: Text -> HOLTerm -> HOL Theory thry () reduceInterface sym tm = do namty <- liftMaybe "reduceInterface: term not a constant or variable" $ destConst tm <|> destVar tm- modifyExt (\ (Interface iface) -> Interface $ - (sym, namty) `delete` iface)+ acid <- openLocalStateHOL (Interface [])+ updateHOL acid (DeleteInterface (sym, namty))+ createCheckpointAndCloseHOL acid {-| Removes all existing overloads for a given symbol and replaces them with a@@ -398,15 +698,16 @@ the provided term must have a type that is matchable with the symbol's most general type. -}-overrideInterface :: String -> HOLTerm -> HOL Theory thry ()+overrideInterface :: Text -> HOLTerm -> HOL Theory thry () overrideInterface sym tm = do namty <- liftMaybe "overrideInterface: term not a constant or variable" $ destConst tm <|> destVar tm- let m = modifyExt (\ (Interface iface) -> - let iface' = filter (\ (x, _) -> x /= sym) iface in- Interface $ (sym, namty) : iface')- (Overload overs) <- getExt- case sym `lookup` overs of+ let m = do acid <- openLocalStateHOL (Interface [])+ updateHOL acid (FilterInterface sym)+ updateHOL acid (InsertInterface (sym, namty))+ createCheckpointAndCloseHOL acid+ overs <- getOverloads+ case sym `mapLookup` overs of Just gty -> if isNothing $ typeMatch gty (snd namty) ([], [], []) then fail $ "overrideInterface: " ++ "not an instance of type skeleton"@@ -430,18 +731,20 @@ of the interface list, effectively prioritizing it. This behavior is utilized by 'prioritizeOverload'. -}-overloadInterface :: String -> HOLTerm -> HOL Theory thry ()+overloadInterface :: Text -> HOLTerm -> HOL Theory thry () overloadInterface sym tm =- do (Overload overs) <- getExt- gty <- liftMaybe ("overloadInstace: symbol " ++ sym ++ - " is not overloadable.") $ lookup sym overs+ do overs <- getOverloads+ gty <- liftMaybe ("overloadInstace: symbol " ++ show sym ++ + " is not overloadable.") $ mapLookup sym overs namty <- liftMaybe "overloadInstance: term not a constant or variable" $ destConst tm <|> destVar tm if isNothing $ typeMatch gty (snd namty) ([], [], []) then fail "overloadInstance: not an instance of type skeleton"- else modifyExt (\ (Interface iface) -> - let iface' = (sym, namty) `delete` iface in- Interface $ (sym, namty) : iface')+ else do acid <- openLocalStateHOL (Interface [])+ let i = (sym, namty)+ updateHOL acid (DeleteInterface i)+ updateHOL acid (InsertInterface i)+ createCheckpointAndCloseHOL acid {-| Specifies a type to prioritize when the interface is used to overload a @@ -451,76 +754,190 @@ -} prioritizeOverload :: HOLType -> HOL Theory thry () prioritizeOverload ty =- do (Overload overs) <- getExt+ do overs <- getOverloads mapM_ (\ (s, gty) -> - (do (Interface iface) <- getExt+ (do iface <- getInterface let (n, t') = fromJust $ tryFind (\ (s', x@(_, t)) -> if s' /= s then Nothing- else do (tys, _, _) <- typeMatch gty t- ([], [], [])- _ <- ty `revLookup` tys+ else do (ts, _, _) <- typeMatch gty t+ ([], [], [])+ _ <- ty `revLookup` ts return x) iface overloadInterface s $ mkVar n t')- <|> return ()) overs+ <|> return ()) $ mapToList overs -- | Returns the list of all currently defined interface overloads.-getInterface :: HOLContext thry -> [(String, (String, HOLType))]-getInterface ctxt =- let (Interface iface) = getExtCtxt ctxt in iface+getInterface :: HOL cls thry [(Text, (Text, HOLType))]+getInterface =+ do acid <- openLocalStateHOL (Interface [])+ iface <- queryHOL acid GetInterfaces+ closeAcidStateHOL acid+ return iface {-| Returns the list of all overloadable symbols paired with their most generic types. -}-getOverloads :: HOLContext thry -> [(String, HOLType)]-getOverloads ctxt =- let (Overload overs) = getExtCtxt ctxt in overs+getOverloads :: HOL cls thry (Map Text HOLType)+getOverloads =+ do acid <- openLocalStateHOL (Overload mapEmpty)+ ovrlds <- queryHOL acid GetOverload+ closeAcidStateHOL acid+ return ovrlds -- Type Abbreviations {-| - Specifies a 'String' to act as an abbreviation for a given type in the parser.+ Specifies a 'Text' to act as an abbreviation for a given type in the parser. Upon recognizing the abbreviation the parser will replace it with the 'PreType' value for it's associated 'HOLType' such that the elaborator can infer the correct type for polymorphic abbreviations. -}-newTypeAbbrev :: String -> HOLType -> HOL Theory thry ()-newTypeAbbrev s ty =- modifyExt (\ (TypeAbbreviations abvs) -> - TypeAbbreviations $ insertMap s ty abvs)+newTypeAbbrev :: HOLTypeRep ty Theory thry => Text -> ty -> HOL Theory thry ()+newTypeAbbrev s pty =+ do ty <- toHTy pty+ acid <- openLocalStateHOL (TypeAbbreviations mapEmpty)+ updateHOL acid (InsertTypeAbbreviation s ty)+ createCheckpointAndCloseHOL acid {-| - Specifies a 'String' for the parser to stop recognizing as a type + Specifies a 'Text' for the parser to stop recognizing as a type abbreviation. -}-removeTypeAbbrev :: String -> HOL Theory thry ()+removeTypeAbbrev :: Text -> HOL Theory thry () removeTypeAbbrev s =- modifyExt (\ (TypeAbbreviations abvs) ->- TypeAbbreviations $ filter (\ (s', _) -> s' /= s) abvs)+ do acid <- openLocalStateHOL (TypeAbbreviations mapEmpty)+ updateHOL acid (RemoveTypeAbbreviation s)+ createCheckpointAndCloseHOL acid {-| - Returns all 'String's currently acting as type abbreviations in the parser+ Returns all 'Text's currently acting as type abbreviations in the parser paired with their associated types. -}-typeAbbrevs :: HOLContext thry -> [(String, HOLType)]-typeAbbrevs ctxt =- let (TypeAbbreviations abvs) = getExtCtxt ctxt in abvs+typeAbbrevs :: HOL cls thry (Map Text HOLType)+typeAbbrevs =+ do acid <- openLocalStateHOL (TypeAbbreviations mapEmpty)+ abvs <- queryHOL acid GetTypeAbbreviations+ closeAcidStateHOL acid+ return abvs -- Hidden Constant Mapping--- | Specifies a 'String' for the parser to stop recognizing as a constant.-hideConstant :: String -> HOL Theory thry ()-hideConstant c = modifyExt (\ (Hidden hcs) -> Hidden $ c `insert` hcs)+-- | Specifies a 'Text' for the parser to stop recognizing as a constant.+hideConstant :: Text -> HOL Theory thry ()+hideConstant c =+ do acid <- openLocalStateHOL (Hidden [])+ updateHOL acid (InsertHidden c)+ createCheckpointAndCloseHOL acid --- | Specifies a 'String' for the parser to resume recognizing as a constant.-unhideConstant :: String -> HOL Theory thry ()-unhideConstant c = modifyExt (\ (Hidden hcs) -> Hidden $ c `delete` hcs)+-- | Specifies a 'Text' for the parser to resume recognizing as a constant.+unhideConstant :: Text -> HOL Theory thry ()+unhideConstant c =+ do acid <- openLocalStateHOL (Hidden [])+ updateHOL acid (RemoveHidden c)+ createCheckpointAndCloseHOL acid --- | Returns all 'String's currently acting as constants hidden from the parser.-getHidden :: HOLContext thry -> [String]-getHidden ctxt = - let (Hidden hidden) = getExtCtxt ctxt in hidden+-- | Returns all 'Text's currently acting as constants hidden from the parser.+getHidden :: HOL cls thry [Text]+getHidden =+ do acid <- openLocalStateHOL (Hidden [])+ hids <- queryHOL acid GetHiddens+ closeAcidStateHOL acid+ return hids -deriveLiftMany [ ''BinderOps, ''TyBinderOps - , ''PrefixOps, ''InfixOps- , ''Interface, ''Overload - , ''TypeAbbreviations, ''Hidden ]+{-| + Specifies a symbol to be recognized as an unspaced, binary operator by the+ printer. Applications involving these operators will be built with the '<>'+ combinator as opposed to '<+>'.++ Note that technically this method should be considered benign, however, for+ simplicity of implementation it is defined using 'modifyExt' and thus must be+ tagged a 'Theory' computation.+-}+addUnspacedBinop :: Text -> HOL Theory thry ()+addUnspacedBinop op =+ do acid <- openLocalStateHOL (UnspacedBinops initUnspaced)+ updateHOL acid (InsertUnspaced op)+ createCheckpointAndCloseHOL acid++{-| + Specifies a symbol to be recognized as a prebroken, binary operator by the+ printer. Applications involving these operators will have their right-hand+ side argument printed on the next line using the 'hang' combinator.++ Note that technically this method should be considered benign, however, for+ simplicity of implementation it is defined using 'modifyExt' and thus must be+ tagged a 'Theory' computation.+-}+addPrebrokenBinop :: Text -> HOL Theory thry ()+addPrebrokenBinop op =+ do acid <- openLocalStateHOL (PrebrokenBinops initPrebroken)+ updateHOL acid (InsertPrebroken op)+ createCheckpointAndCloseHOL acid++{-| + Specifies a symbol to stop being recognized as an unspaced, binary operator + by the printer.++ Note that technically this method should be considered benign, however, for+ simplicity of implementation it is defined using 'modifyExt' and thus must be+ tagged a 'Theory' computation.+-}+removeUnspacedBinop :: Text -> HOL Theory thry ()+removeUnspacedBinop op =+ do acid <- openLocalStateHOL (UnspacedBinops initUnspaced)+ updateHOL acid (RemoveUnspaced op)+ createCheckpointAndCloseHOL acid++{-| + Specifies a symbol to stop being recognized as an prebroken, binary operator + by the printer.++ Note that technically this method should be considered benign, however, for+ simplicity of implementation it is defined using 'modifyExt' and thus must be+ tagged a 'Theory' computation.+-}+removePrebrokenBinop :: Text -> HOL Theory thry ()+removePrebrokenBinop op =+ do acid <- openLocalStateHOL (PrebrokenBinops initPrebroken)+ updateHOL acid (RemovePrebroken op)+ createCheckpointAndCloseHOL acid++{-| + Returns the list of all symbols current recognized as unspaced, binary+ operators by the printer.+-}+getUnspacedBinops :: HOL cls thry [Text]+getUnspacedBinops =+ do acid <- openLocalStateHOL (UnspacedBinops initUnspaced)+ ops <- queryHOL acid GetUnspaced+ closeAcidStateHOL acid+ return ops++{-| + Returns the list of all symbols current recognized as prebroken, binary+ operators by the printer.+-}+getPrebrokenBinops :: HOL cls thry [Text]+getPrebrokenBinops =+ do acid <- openLocalStateHOL (PrebrokenBinops initUnspaced)+ ops <- queryHOL acid GetPrebroken+ closeAcidStateHOL acid+ return ops++-- Re-exports+-- | A re-export of 'P.runParser'.+runParser :: GenParser st a -> st -> P.SourceName -> Text + -> Either ParseError a+runParser = P.runParser++-- | A re-export of 'P.getState'.+getState :: Monad m => P.ParsecT s u m u+getState = P.getState++-- | A re-export of 'P.setState'.+setState :: Monad m => u -> P.ParsecT s u m ()+setState = P.setState++-- | A re-export of 'P.updateState'.+updateState :: Monad m => (u -> u) -> P.ParsecT s u m ()+updateState = P.updateState
+ src/HaskHOL/Core/Parser/Prims.hs view
@@ -0,0 +1,50 @@+module HaskHOL.Core.Parser.Prims+ ( PreType(..)+ , PreTerm(..)+ , ParseError+ , HOLContext(..)+ ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel++import qualified Text.Parsec as P++-- | Parsed, but pre-elaborated HOL types.+data PreType+ = PTyCon !Text+ | UTyVar !Bool !Text !Int+ | STyVar !Integer+ | PTyComb !PreType ![PreType]+ | PUTy !PreType !PreType+ deriving (Eq, Show)++-- | Parsed, but pre-elaborated HOL terms.+data PreTerm+ = PVar !Text !PreType+ | PConst !Text !PreType+ | PComb !PreTerm !PreTerm+ | PAbs !PreTerm !PreTerm+ | PAs !PreTerm !PreType+ | PInst ![(PreType, Text)] !PreTerm+ | PApp !PreType+ | TyPAbs !PreType !PreTerm+ | TyPComb !PreTerm !PreType !PreType+ deriving (Eq, Show)++-- | A re-export of 'P.ParseError'.+type ParseError = P.ParseError++data HOLContext thry = HOLContext + { infixes :: ![(Text, (Int, Text))]+ , prefixes :: ![Text]+ , binders :: ![Text]+ , tyBinders :: ![Text]+ , typesCtxt :: !(Map Text TypeOp)+ , typeAbbrevsCtxt :: !(Map Text HOLType)+ , getInterfaceCtxt :: ![(Text, (Text, HOLType))]+ , flagPrintAllThm :: !Bool+ , flagRevInterface :: !Bool+ , unspacedBinops :: ![Text]+ , prebrokenBinops :: ![Text]+ }
src/HaskHOL/Core/Parser/Rep.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, - TypeSynonymInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances, IncoherentInstances, MultiParamTypeClasses, + TypeSynonymInstances, TypeFamilies #-} {-| Module: HaskHOL.Core.Parser.Rep@@ -13,69 +13,138 @@ This module defines conversions for alternative type and term representations via the 'HOLTermRep' and 'HOLTypeRep' classes. - The most commonly used alternative representations are strings and protected+ The most commonly used alternative representations are 'Text' and protected terms/types as produced by the "HaskHOL.Core.Ext" module. -}-module HaskHOL.Core.Parser.Rep- ( HOLTypeRep(..)- , HOLTermRep(..)- ) where+module HaskHOL.Core.Parser.Rep where +import HaskHOL.Core.Lib import HaskHOL.Core.Kernel import HaskHOL.Core.State +import HaskHOL.Core.Ext.Protected+ import HaskHOL.Core.Parser.Lib import HaskHOL.Core.Parser.Elab import {-# SOURCE #-} HaskHOL.Core.Parser (holTermParser, holTypeParser) +import Data.String++-- Types {-| The 'HOLTypeRep' class provides a conversion from an alternative representation of types to 'HOLType' within the 'HOL' monad. The first parameter is the type of the alternative representation. - The second parameter is the tag for the last checkpoint of the - current working theory. This enables us to have a conversion from - representations that are theory dependent without running into type - matchability issues.+ The second parameter is the classification of the monad computation. This+ is used to assert type equality when converting between monadic + representations.++ The third parameter is the tag for the last checkpoint of the + current working theory. This enables us to safely have conversions between + representations that are theory dependent. -}-class HOLTypeRep a thry | a -> thry where+class HOLTypeRep a cls thry where -- | Conversion from alternative type @a@ to 'HOLType'. toHTy :: a -> HOL cls thry HOLType -instance HOLTypeRep String a where+instance (IsString a, a ~ Text) => HOLTypeRep a cls thry where toHTy x = - do ctxt <- get+ do ctxt <- prepHOLContext tyElab =<< liftEither "toHTy" (holTypeParser x ctxt) -instance HOLTypeRep PreType a where+instance thry1 ~ thry2 => HOLTypeRep (PType thry1) cls thry2 where+ toHTy = serve++instance HOLTypeRep PreType cls thry where toHTy = tyElab -instance HOLTypeRep HOLType a where+instance HOLTypeRep HOLType cls thry where toHTy = return +instance HOLTypeRep (Maybe HOLType) cls thry where+ toHTy Nothing = fail "toHTy: Nothing"+ toHTy (Just ty) = return ty++instance Show a => HOLTypeRep (Either a HOLType) cls thry where+ toHTy (Left err) = fail $ show err+ toHTy (Right ty) = return ty++instance (cls ~ cls1, thry ~ thry1) => + HOLTypeRep (HOL cls1 thry1 HOLType) cls thry where+ toHTy = id++-- Terms {-| The 'HOLTermRep' class provides a conversion from an alternative representation of terms to 'HOLTerm' within the 'HOL' monad. - The first parameter is the type of the alternative representation.- - The second parameter is the tag for the last checkpoint of the - current working theory. This enables us to have a conversion from - representations that are theory dependent, i.e. 'PTerm', without running into- type matchability issues.+ The second parameter is the classification of the monad computation. This+ is used to assert type equality when converting between monadic + representations.++ The third parameter is the tag for the last checkpoint of the + current working theory. This enables us to safely have conversions between + representations that are theory dependent. -}-class HOLTermRep a thry | a -> thry where+class HOLTermRep a cls thry where -- | Conversion from alternative type @a@ to 'HOLTerm'. toHTm :: a -> HOL cls thry HOLTerm -instance HOLTermRep String a where+instance thry1 ~ thry2 => HOLTermRep (PTerm thry1) cls thry2 where+ toHTm = serve++instance (IsString a, a~Text) => HOLTermRep a cls thry where toHTm x = - do ctxt <- get+ do ctxt <- prepHOLContext elab =<< liftEither "toHTm" (holTermParser x ctxt) -instance HOLTermRep PreTerm a where+instance HOLTermRep PreTerm cls thry where toHTm = elab -instance HOLTermRep HOLTerm a where+instance HOLTermRep HOLTerm cls thry where toHTm = return++instance HOLTermRep (Maybe HOLTerm) cls thry where+ toHTm Nothing = fail "toHTm: Nothing"+ toHTm (Just tm) = return tm++instance Show a => HOLTermRep (Either a HOLTerm) cls thry where+ toHTm (Left err) = fail $ show err+ toHTm (Right tm) = return tm++instance (cls ~ cls1, thry ~ thry1) => + HOLTermRep (HOL cls1 thry1 HOLTerm) cls thry where+ toHTm = id++-- Theorems+{-|+ The 'HOLThmRep' class provides a conversion from an alternative + representation of theorems to 'HOLThm' within the 'HOL' monad.++ The second parameter is the classification of the monad computation. This+ is used to assert type equality when converting between monadic + representations.++ The third parameter is the tag for the last checkpoint of the + current working theory. This enables us to safely have conversions between + representations that are theory dependent.+-}+class HOLThmRep a cls thry where+ -- | Conversion from alternative type @a@ to 'HOLThm'.+ toHThm :: a -> HOL cls thry HOLThm++instance thry1 ~ thry2 => HOLThmRep (PThm thry1) cls thry2 where+ toHThm = serve++instance HOLThmRep HOLThm cls thry where+ toHThm = return++instance Show a => HOLThmRep (Either a HOLThm) cls thry where+ toHThm (Left err) = fail $ show err+ toHThm (Right thm) = return thm++instance (cls ~ cls1, thry ~ thry1) => + HOLThmRep (HOL cls1 thry1 HOLThm) cls thry where+ toHThm = id
+ src/HaskHOL/Core/Parser/Rep.hs-boot view
@@ -0,0 +1,8 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module HaskHOL.Core.Parser.Rep where++import HaskHOL.Core.Kernel+import HaskHOL.Core.State.Monad++class HOLTypeRep a cls thry where+ toHTy :: a -> HOL cls thry HOLType
src/HaskHOL/Core/Parser/TermParser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-| Module: HaskHOL.Core.Parser.TermParser Copyright: (c) The University of Kansas 2013@@ -31,8 +32,15 @@ ATOMIC_PRETERM :: ( PRETERM ) | [: type] | [ PRETERM; .. ; PRETERM ] - | if PRETERM then PRETERM else PRETERM - | identifier + | if PRETERM then PRETERM else PRETERM + | match PRETERM with CLAUSES+ | function CLAUSES + | identifier ++ CLAUSES :: PATTERN -> PRETERM | .. | PATTERN -> PRETERM++ PATTERN :: PRETERM when PRETERM+ | PRETERM @ Note that arbitrary atomic preterms, typed or untyped, are allowed as @@ -51,8 +59,7 @@ ( pterm ) where -import HaskHOL.Core.Lib hiding (many)-import HaskHOL.Core.State+import HaskHOL.Core.Lib import HaskHOL.Core.Parser.Lib import HaskHOL.Core.Parser.TypeParser@@ -60,77 +67,94 @@ -- | Parser for HOL terms. pterm :: MyParser thry PreTerm pterm = - do mywhiteSpace- ctxt <- getState- buildExpressionParser (partitionOps ctxt) pappl+ (do mywhiteSpace+ (ctxt, _, _) <- getState+ expressionParser (infixes ctxt) ptyped)+ <|> (do s <- myidentifier <|> myoperator+ return $! PVar s dpty) +ptyped :: MyParser thry PreTerm+ptyped = pas =<< pappl+ pappl :: MyParser thry PreTerm pappl = - try (do prefs <- pprefixes- if null prefs- then fail "pappl: no prefix found"- else do bod <- pappl- return $! foldr PComb bod prefs)- <|> (do tms <- many1 pbinder- let tm = mkPComb tms- pas tm <|> return tm)+ (do p <- pprefix+ tm <- pappl+ return $! PComb (PVar p dpty) tm)+ <|> do (tm:tms) <- mymany1 pbinder+ return $! foldr (flip PComb) tm (reverse tms) +pprefix :: MyParser thry Text+pprefix =+ do (ctxt, _, _) <- getState+ choiceId $ prefixes ctxt+ pbinder :: MyParser thry PreTerm pbinder = (do myreserved "let"- tms <- pterm `sepBy1` myreserved "and"+ tms <- pterm `mysepBy1` myreserved "and" myreserved "in" bod <- pterm case mkLet tms bod of Nothing -> fail "pterm: invalid let construction" Just tm -> return tm)- <|> do (ctxt, _) <- getState- bind <- choiceOp $ binders ctxt- (do vars <- many1 pvar- myreservedOp "."- bod <- pterm- return $! mkBinders bind vars bod)- <|> (return $! PVar bind dpty)- <|> do (ctxt, _) <- getState- bind <- choiceOp $ tyBinders ctxt- (do vars <- many1 psmall- myreservedOp "."- bod <- pterm- return $! mkTyBinders bind vars bod)- <|> (return $! PVar bind dpty)- <|> ptyped+ <|> (do (ctxt, _, _) <- getState+ bind <- choiceId $ binders ctxt+ (do vars <- mymany1 pvar+ myreservedOp "."+ bod <- pterm+ return $! mkBinders bind vars bod)+ <|> (return $! PVar bind dpty))+ <|> (do (ctxt, _, _) <- getState+ bind <- choiceId $ tyBinders ctxt+ (do vars <- mymany1 psmall+ myreservedOp "."+ bod <- pterm+ return $! mkTyBinders bind vars bod)+ <|> (return $! PVar bind dpty))+ <|> pinst where -ptyped :: MyParser thry PreTerm-ptyped = +pinst :: MyParser thry PreTerm+pinst = (do myreserved "TYINST"- vars <- many1 pinst+ vars <- mymany1 pinst' tm <- patomic return $! PInst vars tm) <|> patomic- where pinst :: MyParser thry (PreType, String)- pinst = myparens $ do myreservedOp "_"- x <- myidentifier- myreservedOp ":"- ty <- ptype- return (ty, x)+ where pinst' :: MyParser thry (PreType, Text)+ pinst' = myparens $ do myreservedOp "_"+ x <- myidentifier+ myreservedOp ":"+ ty <- ptype+ return (ty, x) - pvar :: MyParser thry PreTerm-pvar =- do tm <- patomic- pas tm <|> return tm+pvar = pas =<< patomic pas :: PreTerm -> MyParser thry PreTerm-pas ptm =- do myreservedOp ":"- ty <- ptype- return $! PAs ptm ty+pas tm =+ (do myreservedOp ":"+ ty <- ptype+ return $! PAs tm ty) <|> return tm patomic :: MyParser thry PreTerm patomic = - myparens (pterm <|> (do x <- myoperator- return $! PVar x dpty))+ myparens ((do myreservedOp ":"+ ty <- ptype+ return $! PAs (PVar "UNIV" dpty) + (PTyComb (PTyCon "fun") + [ty, PTyComb (PTyCon "bool") []]))+ <|> mytry pterm+ <|> (do s <- myidentifier <|> myoperator+ return (PVar s dpty)))+ <|> (do myreserved "if"+ c <- pterm+ myreserved "then"+ t <- pterm+ myreserved "else"+ e <- pterm+ return $! PComb (PComb (PComb (PVar "COND" dpty) c) t) e) <|> mybrackets ((do myreservedOp ":" ty <- ptype@@ -138,51 +162,78 @@ <|> (do tms <- mysemiSep pterm return (foldr (\ x y -> PVar "CONS" dpty `PComb` x `PComb` y)- (PVar "NILS" dpty) tms)))- {- <|> mybraces- ((do tms <- mycommaSep pterm- return $! foldr (\ x y -> PComb (PComb (PVar "INSERT" dpty) x) y)- (PVar "EMPTY" dpty) tms)- <|> (do tms <- mypipeSep pterm- if length tms == 2- then -- setabs- else if length tms == 3- then -- setcompr))- -}- <|> (do myreserved "if"- c <- pterm- myreserved "then"- t <- pterm- myreserved "else"+ (PVar "NIL" dpty) tms)))+{-+ <|> mybraces+ ((do tms <- mycommaSep pterm+ return $! foldr (\ x y -> PComb (PComb (PVar "INSERT" dpty) x) y)+ (PVar "EMPTY" dpty) tms)+ <|> (do tms <- pterm `sepBy1` myreservedOp "|"+ case tms of+ (l:r:[]) -> pmkSetAbs l r+ (f:v:b:[]) -> pmkSetCompr f (pfrees vs []) b+ _ -> fail "patomic: bad set construction."))+-}+ <|> (do myreserved "match" e <- pterm- return $! PComb (PComb (PComb (PVar "COND" dpty) c) t) e)- <|> (do x <- myidentifier- return $! PVar x dpty)+ myreserved "with"+ c <- pclauses+ return $! PComb (PComb (PVar "_MATCH" dpty) e) c)+ <|> (do myreserved "function"+ c <- pclauses+ return $! PComb (PVar "_FUNCTION" dpty) c) + <|> mytry (do x <- myidentifier <|> myoperator+ (ctxt, _, _) <- getState+ if x `notElem` prefixes ctxt &&+ x `notElem` map fst (infixes ctxt) &&+ x `notElem` binders ctxt+ then return $! PVar x dpty+ else fail "patomic") -pprefixes :: MyParser thry [PreTerm]-pprefixes =- do (ctxt, _) <- getState- pref <- myoperator- let prefOps = sortBy (\ x y -> compare (length y) (length x)) $ - prefixes ctxt- return $! splitPref pref prefOps []- where splitPref :: String -> [String] -> [PreTerm] -> [PreTerm]- splitPref _ [] acc = acc- splitPref ops prefs@(p:ps) acc =- case stripPrefix p ops of- Nothing -> splitPref ops ps acc- Just ops' -> - let acc' = acc ++ [PVar p dpty] in- if null ops' then acc'- else splitPref ops' prefs acc'- +pclauses :: MyParser thry PreTerm+pclauses =+ do c <- pclause `mysepBy1` myreservedOp "|"+ return $! foldr1 (\ s t -> PComb (PComb (PVar "_SEQPATTERN" dpty) s) t) c+ where pclause :: MyParser thry PreTerm+ pclause = do (pat:guards) <- pterm `mysepBy1` myreserved "when"+ myreservedOp "->"+ res <- pterm+ mkPattern pat guards res -- helper functions-mkPComb :: [PreTerm] -> PreTerm-mkPComb (tm:[]) = tm-mkPComb (tm:tms) = foldr (flip PComb) tm (reverse tms)-mkPComb _ = error "parser: mkPComb used without many1 parser combinator"+pgenVar :: MyParser thry PreTerm+pgenVar = + do (ctxt, ops, n) <- getState+ setState (ctxt, ops, succ n)+ return $! PVar (pack $ "_GENPVAR_" ++ show n) dpty +pfrees :: PreTerm -> [PreTerm] -> MyParser thry [PreTerm]+pfrees ptm@(PVar v pty) acc+ | textNull v && pty == dpty = return acc+ | otherwise = + do (ctxt, _, _) <- getState+ case getTypeArityCtxt ctxt v of+ Just _ -> return acc+ Nothing ->+ case numOfString (unpack v) :: (Maybe Integer) of+ Just _ -> return acc+ Nothing -> + case lookup v $ getInterfaceCtxt ctxt of+ Just _ -> return acc+ Nothing -> return $! ptm `insert` acc+pfrees PConst{} acc = return acc+pfrees (PComb p1 p2) acc = pfrees p1 =<< pfrees p2 acc+pfrees (PAbs p1 p2) acc =+ do p1s <- pfrees p1 []+ p2s <- pfrees p2 acc+ return $! p2s \\ p1s+pfrees (PAs p _) acc = pfrees p acc+pfrees (PInst _ p) acc = pfrees p acc+pfrees PApp{} acc = return acc+pfrees (TyPAbs _ p) acc = pfrees p acc+pfrees (TyPComb p _ _) acc = pfrees p acc++ pdestEq :: PreTerm -> Maybe (PreTerm, PreTerm) pdestEq (PComb (PComb (PVar "=" _) l) r) = Just (l, r) pdestEq (PComb (PComb (PVar "<=>" _) l) r) = Just (l, r)@@ -197,29 +248,76 @@ ab = foldr PAbs letend vars letstart = PComb (PVar "LET" dpty) ab -mkBinder :: String -> PreTerm -> PreTerm -> PreTerm+mkBinder :: Text -> PreTerm -> PreTerm -> PreTerm mkBinder "\\" v bod = PAbs v bod mkBinder n v bod = PComb (PVar n dpty) $ PAbs v bod -mkBinders :: String -> [PreTerm] -> PreTerm -> PreTerm+mkBinders :: Text -> [PreTerm] -> PreTerm -> PreTerm mkBinders bind vars bod = foldr (mkBinder bind) bod vars -mkTyBinder :: String -> PreType -> PreTerm -> PreTerm+mkTyBinder :: Text -> PreType -> PreTerm -> PreTerm mkTyBinder "\\\\" v bod = TyPAbs v bod mkTyBinder n v bod = PComb (PVar n dpty) $ TyPAbs v bod -mkTyBinders :: String -> [PreType] -> PreTerm -> PreTerm+mkTyBinders :: Text -> [PreType] -> PreTerm -> PreTerm mkTyBinders bind vars bod = foldr (mkTyBinder bind) bod vars --- build op table for expression parser from context--- Note: prefix operators are handled separately in pprefixes-partitionOps :: (HOLContext thry, [(String, Int)]) ->- OperatorTable Char (HOLContext thry, [(String, Int)]) PreTerm-partitionOps (ctxt, _) = map (map mkOp) . - group' (\ (_, (x, _)) (_, (y, _)) -> x == y) $ - infixes ctxt- where mkOp :: (String, (Int, Assoc)) -> - Operator Char (HOLContext thry, [(String, Int)]) PreTerm- mkOp (name, (_, a)) = - Infix (do myreservedOp name- return (\ x y -> PComb (PComb (PVar name dpty) x) y)) a+mkPattern :: PreTerm -> [PreTerm] -> PreTerm -> MyParser thry PreTerm+mkPattern pat guards res =+ do x <- pgenVar+ y <- pgenVar+ vs <- pfrees pat []+ let bod = if null guards + then PComb (PComb (PVar "_UNGUARDED_PATTERN" dpty) $ + mkGEQ pat x) $ mkGEQ res y+ else PComb (PComb (PComb (PVar "_GUARDED_PATTERN" dpty) $+ mkGEQ pat x) $ head guards) $ mkGEQ res y+ return . PAbs x . PAbs y $ foldr mkExists bod vs+ where mkGEQ :: PreTerm -> PreTerm -> PreTerm+ mkGEQ l = PComb (PComb (PVar "GEQ" dpty) l)++ mkExists :: PreTerm -> PreTerm -> PreTerm+ mkExists v ptm = PComb (PVar "?" dpty) $ PAbs v ptm+ ++-- build expression parser from infix operators in context+expressionParser :: [(Text, (Int, Text))] -> MyParser thry PreTerm+ -> MyParser thry PreTerm+expressionParser [] prs = prs+expressionParser infxs@((_, (p, at)):_) prs =+ let (topins, rest) = partition (\ (_, pat') -> pat' == (p, at)) infxs+ parse' = if at == "right" then pRightBinary else pLeftBinary in+ parse' (expressionParser rest prs)+ (choiceId (map fst topins))+ (\ op x y -> PComb (PComb (PVar op dpty) x) y)++sepPair :: MyParser thry Text -> MyParser thry PreTerm + -> MyParser thry [(Text, PreTerm)]+sepPair sep prs =+ mymany (do l <- sep+ r <- prs+ return (l, r))++pRightBinary :: MyParser thry PreTerm -> MyParser thry Text+ -> (Text -> PreTerm -> PreTerm -> PreTerm) + -> MyParser thry PreTerm+pRightBinary prs sep cns =+ do x <- prs+ opxs <- sepPair sep prs+ if null opxs+ then return x+ else let (ops, xs) = unzip opxs in+ case foldr2 cns (last xs) ops (x:init xs) of+ Just res -> return res+ _ -> fail "pRightBinary"++pLeftBinary :: MyParser thry PreTerm -> MyParser thry Text+ -> (Text -> PreTerm -> PreTerm -> PreTerm) + -> MyParser thry PreTerm+pLeftBinary prs sep cns =+ do x <- prs+ opxs <- sepPair sep prs+ let (ops, xs) = unzip opxs in+ case foldr2 (\ op l r -> cns op r l) x (reverse ops) (reverse xs) of+ Just res -> return res+ _ -> fail "pLeftBinary"
src/HaskHOL/Core/Parser/TypeParser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-| Module: HaskHOL.Core.Parser.TypeParser Copyright: (c) The University of Kansas 2013@@ -50,7 +51,6 @@ ) where import HaskHOL.Core.Lib-import HaskHOL.Core.State import HaskHOL.Core.Parser.Lib @@ -76,13 +76,13 @@ Left is fresh. Right is existing. -}- let x' = '_':x- (_, opvars) <- getState+ let x' = '_' `cons` x+ (_, opvars, _) <- getState case lookup x' opvars of Nothing -> return . Left $ UTyVar False x' 0 Just n -> return . Right $ UTyVar False x' n -pbinty :: String -> String -> MyParser thry PreType -> MyParser thry PreType -> +pbinty :: String -> Text -> MyParser thry PreType -> MyParser thry PreType -> MyParser thry PreType pbinty op name pty1 pty2 = do ty1 <- pty1@@ -94,7 +94,7 @@ putype :: MyParser thry PreType putype = do myreservedOp "%"- tvs <- many1 psmall+ tvs <- mymany1 psmall myreservedOp "." ty <- ptype return $! foldr PUTy ty tvs@@ -116,7 +116,7 @@ Left (UTyVar _ s _) -> -- fresh ty op var so add it to state let n = length tys in- do updateState $ second ((:) (s, n))+ do updateState (\ (x, ops, y) -> (x, (s, n):ops, y)) let c' = UTyVar False s n return $! PTyComb c' tys Right c'@(UTyVar _ _ n) ->@@ -127,7 +127,7 @@ _ -> fail $ "type parser: unrecognized case for type operator " ++ "variable") <|> ((do x <- myidentifier- (ctxt, _) <- getState+ (ctxt, _, _) <- getState case getTypeArityCtxt ctxt x of Nothing -> fail $ "type parser: unsupported type " ++ "variable application"@@ -136,21 +136,32 @@ then return $! PTyComb (PTyCon x) tys else fail "type parser: bad arity for type application") <|> (case tys of- (ty:[]) -> return ty+ [ty] -> return ty _ -> fail "type parser: unexpected list of types"))- <|> try (do tys <- many1 psmall- c <- popvar- case c of- Left (UTyVar _ s _) ->- let n = length tys in- do updateState $ second ((:) (s, n))- return $! PTyComb (UTyVar False s n) tys- Right c'@(UTyVar _ _ n) ->- if n == length tys- then return $! PTyComb c' tys- else fail "type parser: bad type operator application."- _ -> fail "type parser: unrecognized case for type operator.")- <|> patomty+ <|> mytry (do tys <- mymany1 psmall+ c <- popvar+ case c of+ Left (UTyVar _ s _) ->+ let n = length tys in+ do updateState (\ (x, ops, y) -> (x, (s, n):ops, y))+ return $! PTyComb (UTyVar False s n) tys+ Right c'@(UTyVar _ _ n) ->+ if n == length tys+ then return $! PTyComb c' tys+ else fail "type parser: bad type operator application."+ _ -> fail "type parser: unrecognized case for type operator.")+ <|> (do ty <- patomty+ mytry (do x <- myidentifier+ (ctxt, _, _) <- getState+ case getTypeArityCtxt ctxt x of+ Nothing -> fail $ "type parser: unrecognized constant" + ++ " in unary application."+ Just n ->+ if n == 1+ then return $! PTyComb (PTyCon x) [ty]+ else fail $ "type parser: bad arity for unary type" + ++ " application")+ <|> return ty) patomty :: MyParser thry PreType patomty = @@ -159,15 +170,15 @@ case c of Left c'@(UTyVar _ s 0) -> -- fresh ty-op of zero arity- do updateState $ second ((:) (s, 0))+ do updateState (\ (x, ops, y) -> (x, (s, 0):ops, y)) return $! PTyComb c' [] Right c'@(UTyVar _ _ 0) -> return $! PTyComb c' [] _ -> fail $ "type parser: type operator variable of non-zero " ++ "arity outside of application")- <|> (do x <- myidentifier <|> liftM show myinteger- (ctxt, _) <- getState- case x `lookup` typeAbbrevs ctxt of+ <|> (do x <- myidentifier+ (ctxt, _, _) <- getState+ case x `mapLookup` typeAbbrevsCtxt ctxt of Just ty -> return $! pretypeOfType ty Nothing -> case getTypeArityCtxt ctxt x of Nothing -> return $! UTyVar False x 0
src/HaskHOL/Core/Printer.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,- OverlappingInstances, TemplateHaskell, UndecidableInstances, - ViewPatterns #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternSynonyms, + TypeFamilies #-} {-| Module: HaskHOL.Core.Printer@@ -27,26 +26,16 @@ them. -} module HaskHOL.Core.Printer- ( -- * Pretty Printer Flags- FlagRevInterface(..)- , FlagPrintAllThm(..)- -- * Extensible Printer Operators- , addUnspacedBinop -- :: String -> HOL Theory thry ()- , addPrebrokenBinop -- :: String -> HOL Theory thry ()- , removeUnspacedBinop -- :: String -> HOL Theory thry ()- , removePrebrokenBinop -- :: String -> HOL Theory thry ()- , getUnspacedBinops -- :: HOLContext thry -> [String]- , getPrebrokenBinops -- :: HOLContext thry -> [String]- -- * Pretty Printers- , ppType -- :: HOLType -> String- , ppTerm -- :: HOLContext thry -> HOLTerm -> String- , ppThm -- :: HOLContext thry -> HOLThm -> String+ ( -- * Pretty Printers+ ppType+ , ppTerm+ , ppThm -- * Printing in the 'HOL' Monad , ShowHOL(..)- , printHOL -- :: ShowHOL a => a -> HOL cls thry ()+ , printHOL ) where -import HaskHOL.Core.Lib hiding (empty, lefts, rights)+import HaskHOL.Core.Lib hiding (empty, lefts, rights, base) import HaskHOL.Core.Kernel import HaskHOL.Core.State import HaskHOL.Core.Basics@@ -59,92 +48,12 @@ -} import Text.PrettyPrint --- new flags and extensions--- | Flag to indicate whether the interface should be reversed on printing.-newFlag "FlagRevInterface" True--{-| - Flag to indicate if the entirety of a theorem should be printed, as opposed- to just the conclusion term.--}-newFlag "FlagPrintAllThm" True--newExtension "UnspacedBinops" [| [",", "..", "$"] :: [String] |]--newExtension "PrebrokenBinops" [| ["==>"] :: [String] |]--{-| - Specifies a symbol to be recognized as an unspaced, binary operator by the- printer. Applications involving these operators will be built with the '<>'- combinator as opposed to '<+>'.-- Note that technically this method should be considered benign, however, for- simplicity of implementation it is defined using 'modifyExt' and thus must be- tagged a 'Theory' computation.--}-addUnspacedBinop :: String -> HOL Theory thry ()-addUnspacedBinop op =- modifyExt (\ (UnspacedBinops ops) -> UnspacedBinops $ op `insert` ops)--{-| - Specifies a symbol to be recognized as a prebroken, binary operator by the- printer. Applications involving these operators will have their right-hand- side argument printed on the next line using the 'hang' combinator.-- Note that technically this method should be considered benign, however, for- simplicity of implementation it is defined using 'modifyExt' and thus must be- tagged a 'Theory' computation.--}-addPrebrokenBinop :: String -> HOL Theory thry ()-addPrebrokenBinop op =- modifyExt (\ (PrebrokenBinops ops) -> PrebrokenBinops $ op `insert` ops)--{-| - Specifies a symbol to stop being recognized as an unspaced, binary operator - by the printer.-- Note that technically this method should be considered benign, however, for- simplicity of implementation it is defined using 'modifyExt' and thus must be- tagged a 'Theory' computation.--}-removeUnspacedBinop :: String -> HOL Theory thry ()-removeUnspacedBinop op =- modifyExt (\ (UnspacedBinops ops) -> UnspacedBinops $ ops \\ [op])--{-| - Specifies a symbol to stop being recognized as an prebroken, binary operator - by the printer.-- Note that technically this method should be considered benign, however, for- simplicity of implementation it is defined using 'modifyExt' and thus must be- tagged a 'Theory' computation.--}-removePrebrokenBinop :: String -> HOL Theory thry ()-removePrebrokenBinop op =- modifyExt (\ (PrebrokenBinops ops) -> PrebrokenBinops $ ops \\ [op])--{-| - Returns the list of all symbols current recognized as unspaced, binary- operators by the printer.--}-getUnspacedBinops :: HOLContext thry -> [String]-getUnspacedBinops ctxt =- let (UnspacedBinops ops) = getExtCtxt ctxt in ops--{-| - Returns the list of all symbols current recognized as prebroken, binary- operators by the printer.--}-getPrebrokenBinops :: HOLContext thry -> [String]-getPrebrokenBinops ctxt =- let (PrebrokenBinops ops) = getExtCtxt ctxt in ops- -- | Pretty printer for 'HOLType's. ppType :: HOLType -> String ppType = render . ppTypeRec 0 where ppTypeRec :: Int -> HOLType -> Doc- ppTypeRec _ (view -> TyVar False x) = text x- ppTypeRec _ (view -> TyVar True x) = text $ '\'' : x+ ppTypeRec _ (TyVar False x) = text $ unpack x+ ppTypeRec _ (TyVar True x) = text $ '\'' : unpack x ppTypeRec prec ty = case destUTypes ty of Just (tvs, bod) -> @@ -155,19 +64,19 @@ Nothing -> case do (op, tys) <- destType ty let (name, ar) = destTypeOp op- name' = if ar < 0 then '_':name else name- return (name', tys) of+ name' = if ar < 0 then '_' `cons` name else name+ return (unpack name', tys) of Just (op, []) -> text op- Just ("fun", ty1:ty2:[]) ->+ Just ("fun", [ty1,ty2]) -> ppTypeApp "->" (prec > 0) [ ppTypeRec 1 ty1 , ppTypeRec 0 ty2]- Just ("sum", ty1:ty2:[]) -> + Just ("sum", [ty1,ty2]) -> ppTypeApp "+" (prec > 2) [ ppTypeRec 3 ty1 , ppTypeRec 2 ty2]- Just ("prod", ty1:ty2:[]) -> + Just ("prod", [ty1,ty2]) -> ppTypeApp "#" (prec > 4) [ ppTypeRec 5 ty1 , ppTypeRec 4 ty2]- Just ("cart", ty1:ty2:[]) -> + Just ("cart", [ty1,ty2]) -> ppTypeApp "^" (prec > 6) [ ppTypeRec 6 ty1 , ppTypeRec 7 ty2] Just (bin, args) -> @@ -186,6 +95,10 @@ ppTerm ctxt = render . ppTermRec 0 where ppTermRec :: Int -> HOLTerm -> Doc ppTermRec prec tm =+-- numeral case+ case destNumeral tm of+ Just x -> integer x+ Nothing -> -- List case case destList tm of Just tms -> brackets $ ppTermSeq ";" 0 tms@@ -201,7 +114,7 @@ case destLet tm of Just (eq:eqs, bod) -> let ppLet x = case uncurry primMkEq x of- Right x' -> ppTermRec 0 x'+ Just x' -> ppTermRec 0 x' _ -> text "<*bad let binding*>" base = hang (text "let" <+> @@ -210,153 +123,155 @@ text "in") 2 $ ppTermRec 0 bod in if prec == 0 then base else parens base _ ->- let (hop, args) = stripComb tm in+-- General abstraction case -- needs work+ if isGAbs tm+ then let (vs, bod) = stripGAbs tm+ base = char '\\' <+> sep (map (ppTermRec 999) vs) <+>+ char '.' <+> ppTermRec 0 bod in+ if prec == 0 then base else parens base+ else let (hop, args) = stripComb tm in -- Base term abstraction case- if isAbs hop && null args - then ppBinder prec "\\" False hop+ if isAbs hop && null args + then ppBinder prec "\\" False hop -- Base type abstraction case- else - if isTyAbs hop && null args- then ppBinder prec "\\\\" True hop+ else + if isTyAbs hop && null args+ then ppBinder prec "\\\\" True hop -- Reverse interface for other cases- else let s0 = case view hop of- Var x _ -> x- Const x _ _ -> x- _ -> ""- ty0 = typeOf hop- s = reverseInterface s0 ty0 in--- General abstraction case- if s == "GABS"- then case destGAbs tm of- Nothing -> text "ppTerm: printer error - GAbs case"- Just (vs, bod) ->- let base = char '\\' <+> ppTermRec 999 vs <+> - char '.' <+> ppTermRec 0 bod in- if prec == 0 then base else parens base+ else let s0 = case hop of+ Var x _ -> x+ Const x _ -> x+ _ -> textEmpty+ ty0 = typeOf hop+ s = reverseInterface s0 ty0 + ss = unpack s in -- Conditional case- else - if s == "COND" && length args == 3- then let (c:t:e:_) = args- base = text "if" <+> ppTermRec 0 c <+> - text "then" <+> ppTermRec 0 t <+> - text "else" <+> ppTermRec 0 e in- if prec == 0 then base else parens base+ if s == "COND" && length args == 3+ then let (c:t:e:_) = args+ base = text "if" <+> ppTermRec 0 c <+> + text "then" <+> ppTermRec 0 t <+> + text "else" <+> ppTermRec 0 e in+ if prec == 0 then base else parens base -- Prefix operator case - else - if s `elem` prefix && - length args == 1- then let base = text s <+> ppTermRec 999 (head args) in- if prec == 1000 then parens base else base+ else + if s `elem` prefix && + length args == 1+ then let base = text ss <+> ppTermRec 999 (head args) in+ if prec == 1000 then parens base else base -- Non-lambda term binder case- else - if s `elem` binds && - length args == 1 && - isGAbs (head args)- then ppBinder prec s False tm+ else + if s `elem` binds && + length args == 1 && + isGAbs (head args)+ then ppBinder prec s False tm -- Non-lambda type binder case- else- if s `elem` tybinds && - length args == 1 &&- isTyAbs (head args)- then ppBinder prec s True tm+ else+ if s `elem` tybinds && + length args == 1 &&+ isTyAbs (head args)+ then ppBinder prec s True tm -- Infix operator case- else - let getRight = s `lookup` rights- getLeft = s `lookup` lefts in- if (isJust getRight || isJust getLeft) &&- length args == 2- then let (barg:bargs) = - if isJust getRight- then let (tms, tmt) = - splitList (destBinaryTm hop) tm in- tms ++ [tmt]- else let (tmt, tms) = - revSplitList (destBinaryTm hop) tm in- tmt:tms - newprec = fromMaybe 0 (getRight <|> getLeft)- wrapper = if newprec <= prec then parens else id- sepr = - if s `elem` getUnspacedBinops ctxt - then (\ x y -> cat [x, y]) - else (\ x y -> sep [x, y])- hanger = - if s `elem` getPrebrokenBinops ctxt- then (\ x y -> x `sepr` (text s <+> y))- else (\ x y -> (x <+> text s) `sepr` y) in- wrapper $ - foldr (\ x acc -> acc `hanger` - ppTermRec newprec x)- (ppTermRec newprec barg) $ reverse bargs+ else + let getRight = s `lookup` rights+ getLeft = s `lookup` lefts in+ if (isJust getRight || isJust getLeft) &&+ length args == 2+ then let (barg:bargs) = + if isJust getRight+ then let (tms, tmt) = + splitList (destBinaryTm hop) tm in+ tms ++ [tmt]+ else + let (tmt, tms) = + revSplitList (destBinaryTm hop) tm in+ tmt:tms + newprec = fromMaybe 0 (getRight <|> getLeft)+ wrapper = + if newprec <= prec then parens else id+ sepr = + if s `elem` unspacedBinops ctxt+ then (\ x y -> cat [x, y]) + else (\ x y -> sep [x, y])+ hanger = + if s `elem` prebrokenBinops ctxt+ then (\ x y -> x `sepr` (text ss <+> y))+ else (\ x y -> (x <+> text ss) `sepr` y) in+ wrapper $ + foldr (\ x acc -> acc `hanger` + ppTermRec newprec x)+ (ppTermRec newprec barg) $ reverse bargs -- Base constant or variable case- else - if null args && (isConst hop || isVar hop)- then if s `elem` binds || - s `elem` tybinds ||- isJust (s `lookup` rights) || - isJust (s `lookup` lefts) ||- s `elem` prefix- then parens $ text s- else text s+ else + if null args && (isConst hop || isVar hop)+ then if s `elem` binds || + s `elem` tybinds ||+ isJust (s `lookup` rights) || + isJust (s `lookup` lefts) ||+ s `elem` prefix+ then parens $ text ss+ else text ss -- Base combination case - else case destComb tm of- Just (l, r) ->- let base = ppTermRec 999 l <+> ppTermRec 1000 r in- if prec == 1000 then parens base else base- _ -> text "ppTerm: printer error - unrecognized term"+ else case destComb tm of+ Just (l, r) ->+ let base = + ppTermRec 999 l <+> ppTermRec 1000 r in+ if prec == 1000 then parens base else base+ _ -> text $ "ppTerm: printer error - " +++ "unrecognized term" - grabInfix :: Assoc -> [(String, (Int, Assoc))] -> [(String, Int)]+ grabInfix :: Text -> [(Text, (Int, Text))] -> [(Text, Int)] grabInfix a = mapMaybe (\ (x, (n, a')) -> if a == a' then Just (x, n) else Nothing)- binds :: [String]+ binds :: [Text] binds = binders ctxt - tybinds :: [String]+ tybinds :: [Text] tybinds = tyBinders ctxt - prefix :: [String]+ prefix :: [Text] prefix = prefixes ctxt - lefts :: [(String, Int)]- lefts = grabInfix AssocLeft $ infixes ctxt+ lefts :: [(Text, Int)]+ lefts = grabInfix "left" $ infixes ctxt - rights :: [(String, Int)]- rights = grabInfix AssocRight $ infixes ctxt+ rights :: [(Text, Int)]+ rights = grabInfix "right" $ infixes ctxt ppTermSeq :: String -> Int -> [HOLTerm] -> Doc ppTermSeq sepr prec = ppTermSeqRec where ppTermSeqRec [] = empty- ppTermSeqRec (x:[]) = ppTermRec prec x+ ppTermSeqRec [x] = ppTermRec prec x ppTermSeqRec (x:xs) = ppTermRec prec x <+> text sepr <+> ppTermSeqRec xs - ppBinder :: Int -> String -> Bool -> HOLTerm -> Doc+ ppBinder :: Int -> Text -> Bool -> HOLTerm -> Doc ppBinder prec prep f tm = let (vs, bod) = if f then stripTy ([], tm) else stripTm ([], tm)- base = let bvs = text prep <> - foldr (\ x acc -> acc <+> text x) empty vs <>- char '.'+ base = let bvs = text (unpack prep) <> + foldr (\ x acc -> acc <+> text (unpack x)) + empty vs <> char '.' indent = min (1 + length (render bvs)) 5 in cat [ bvs , nest indent $ ppTermRec prec bod ] in if prec == 0 then base else parens base- where stripTm :: ([String], HOLTerm) -> ([String], HOLTerm)- stripTm (acc, view -> Abs (view -> Var bv _) bod) = + where stripTm :: ([Text], HOLTerm) -> ([Text], HOLTerm)+ stripTm (acc, Abs (Var bv _) bod) = stripTm (bv:acc, bod)- stripTm pat@(acc, view -> Comb (view -> Const s _ _) - (view -> Abs (view -> Var bv _) bod))+ stripTm pat@(acc, Comb (Const s _) + (Abs (Var bv _) bod)) | s == prep = stripTm (bv:acc, bod) | otherwise = pat stripTm pat = pat - stripTy :: ([String], HOLTerm) -> ([String], HOLTerm)- stripTy (acc, view -> TyAbs (view -> TyVar _ bv) bod) =- stripTy (('\'':bv):acc, bod)- stripTy pat@(acc, view -> Comb (view -> Const s _ _)- (view -> TyAbs (view -> TyVar _ bv) bod))- | s == prep = stripTy (('\'':bv):acc, bod)+ stripTy :: ([Text], HOLTerm) -> ([Text], HOLTerm)+ stripTy (acc, TyAbs (TyVar _ bv) bod) =+ stripTy (('\'' `cons` bv):acc, bod)+ stripTy pat@(acc, Comb (Const s _)+ (TyAbs (TyVar _ bv) bod))+ | s == prep = stripTy (('\'' `cons` bv):acc, bod) | otherwise = pat stripTy pat = pat @@ -365,103 +280,93 @@ do (il, r) <- destComb tm (i, l) <- destComb il if i == c- then do i' <- destConst i- c' <- destConst c+ then do i' <- destConst i <|> destVar i+ c' <- destConst c <|> destVar c if uncurry reverseInterface i' == uncurry reverseInterface c' then Just (l, r) else Nothing else Nothing - reverseInterface :: String -> HOLType -> String+ reverseInterface :: Text -> HOLType -> Text reverseInterface s0 ty0- | not (getBenignFlagCtxt FlagRevInterface ctxt) = s0+ | not (flagRevInterface ctxt) = s0 | otherwise = fromMaybe s0 . liftM fst . find (\ (_, (s', ty)) -> s' == s0 && isJust (typeMatch ty ty0 ([], [], []))) $- getInterface ctxt+ getInterfaceCtxt ctxt -- Printer for Theorems -- | Pretty printer for 'HOLTheorem's. ppThm :: HOLContext thry -> HOLThm -> String-ppThm ctxt (view -> Thm asl c) = render ppThmRec+ppThm ctxt (Thm asl c) = render ppThmRec where ppThmRec :: Doc ppThmRec = let c' = text $ ppTerm ctxt c asl' | null asl = [empty]- | not (getBenignFlagCtxt FlagPrintAllThm ctxt) = [text "..."]+ | not (flagPrintAllThm ctxt) = [text "..."] | otherwise = showHOLListRec comma $ map (ppTerm ctxt) asl in sep (asl' ++ [text "|-" <+> c'])+ppThm _ _ = error "ppThm: exhaustive warning." {-| The @ShowHOL@ class is functionally equivalent to 'show' lifted to the 'HOL' monad. It is used to retrieve the current working theory to be used with the context sensitive pretty printers for 'HOLTerm's and 'HOLType's. -}-class ShowHOL a thry where+class ShowHOL a where {-| A version of 'show' lifted to the 'HOL' monad for context sensitive pretty printers. -} showHOL :: a -> HOL cls thry String- -instance ShowHOL String thry where- showHOL = return--instance ShowHOL a thry => ShowHOL [a] thry where- showHOL = liftM (showHOLList brackets comma) . mapM showHOL+ showHOLList :: [a] -> HOL cls thry String+ showHOLList = liftM (showHOLList' brackets comma) . mapM showHOL -instance (ShowHOL a thry, ShowHOL b thry) => ShowHOL (a, b) thry where- showHOL (a, b) = liftM (showHOLList parens comma) . sequence $ +instance ShowHOL a => ShowHOL [a] where+ showHOL = showHOLList+ +instance (ShowHOL a, ShowHOL b) => ShowHOL (a, b) where+ showHOL (a, b) = liftM (showHOLList' parens comma) . sequence $ [showHOL a, showHOL b] -instance (ShowHOL a thry, ShowHOL b thry, ShowHOL c thry) => - ShowHOL (a, b, c) thry where- showHOL (a, b, c) = liftM (showHOLList parens comma) . sequence $ +instance (ShowHOL a, ShowHOL b, ShowHOL c) => + ShowHOL (a, b, c) where+ showHOL (a, b, c) = liftM (showHOLList' parens comma) . sequence $ [showHOL a, showHOL b, showHOL c] -instance (ShowHOL a thry, ShowHOL b thry, ShowHOL c thry, ShowHOL d thry) => - ShowHOL (a, b, c, d) thry where- showHOL (a, b, c, d) = liftM (showHOLList parens comma) . sequence $ +instance (ShowHOL a, ShowHOL b, ShowHOL c, ShowHOL d) => + ShowHOL (a, b, c, d) where+ showHOL (a, b, c, d) = liftM (showHOLList' parens comma) . sequence $ [showHOL a, showHOL b, showHOL c, showHOL d] -- Prints a list of strings provided a wrapper function and seperator document.-showHOLList :: (Doc -> Doc) -> Doc -> [String] -> String-showHOLList wrap sepr = render . wrap . sep . showHOLListRec sepr+showHOLList' :: (Doc -> Doc) -> Doc -> [String] -> String+showHOLList' wrap sepr = render . wrap . sep . showHOLListRec sepr -- Useful to have at top level for ppThm. showHOLListRec :: Doc -> [String] -> [Doc] showHOLListRec _ [] = [empty]-showHOLListRec _ (x:[]) = [text x]+showHOLListRec _ [x] = [text x] showHOLListRec sepr (x:xs) = (text x <> sepr <> space) : showHOLListRec sepr xs -- orphan instances-instance ShowHOL Assoc thry where- showHOL (AssocNone) = return "None" - showHOL (AssocLeft) = return "Left"- showHOL (AssocRight) = return "Right"--instance ShowHOL TypeOp thry where- showHOL = return . show--instance ShowHOL HOLType thry where+instance ShowHOL HOLType where showHOL ty = return $ ':' : ppType ty -instance ShowHOL HOLTerm thry where- showHOL tm = do ctxt <- get+instance ShowHOL HOLTerm where+ showHOL tm = do ctxt <- prepHOLContext return $! ppTerm ctxt tm -instance ShowHOL HOLThm thry where- showHOL thm = do ctxt <- get+instance ShowHOL HOLThm where+ showHOL thm = do ctxt <- prepHOLContext return $! ppThm ctxt thm {-| Prints a HOL object with a new line. A composition of 'putStrLnHOL' and 'showHOL'. -}-printHOL :: ShowHOL a thry => a -> HOL cls thry ()+printHOL :: ShowHOL a => a -> HOL cls thry () printHOL = putStrLnHOL <=< showHOL--deriveLiftMany [''UnspacedBinops, ''PrebrokenBinops]
src/HaskHOL/Core/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, ViewPatterns #-}+{-# LANGUAGE PatternSynonyms, TypeFamilies #-} {-| Module: HaskHOL.Core.State@@ -21,33 +21,33 @@ -} module HaskHOL.Core.State ( -- * Stateful Type Primitives- types -- :: HOL cls thry [(String, TypeOp)]- , getTypeArityCtxt -- :: HOLContext thry -> String -> Maybe Int- , getTypeArity -- :: String -> HOL cls thry Int- , newType -- :: String -> Int -> HOL Theory thry ()- , mkType -- :: String -> [HOLType] -> HOL cls thry HOLType- , mkFunTy -- :: HOLType -> HOLType -> HOL cls thry HOLType+ types+ , tyDefinitions+ , getTypeArity+ , newType+ , mkType+ , mkFunTy -- * Stateful Term Primitives- , constants -- :: HOL cls thry [(String, HOLTerm)]- , getConstType -- :: String -> HOL cls thry HOLType- , newConstant -- :: String -> HOLType -> HOL Theory thry ()- , mkConst -- :: TypeSubst l r => - -- String -> [(l, r)] -> HOL cls thry HOLTerm- , mkConstFull -- :: String -> SubstTrip -> HOL cls thry HOLTerm- , mkEq -- :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+ , constants+ , getConstType+ , newConstant+ , mkConst+ , mkConstFull+ , mkEq -- * Stateful Theory Extension Primitives- , axioms -- :: HOL cls thry [(String, HOLThm)]- , getAxiom -- :: String -> HOL cls thry HOLThm- , newAxiom -- :: String -> HOLTerm -> HOL Theory thry HOLThm- , definitions -- :: HOL cls thry [HOLThm]- , newBasicDefinition -- :: HOLTerm -> HOL Theory thry HOLThm- , newBasicTypeDefinition -- :: String -> String -> String -> HOLThm -> - -- HOL Theory thry (HOLThm, HOLThm)+ , axioms+ , newAxiom+ , getAxiom+ , definitions+ , newBasicDefinition+ , getBasicDefinition+ , newBasicTypeDefinition+ , getBasicTypeDefinition -- * Primitive Debugging System , FlagDebug(..)- , warn -- :: Bool -> String -> HOL cls thry ()- , printDebugLn -- :: String -> HOL cls thry a -> HOL cls thry a- , printDebug -- :: String -> HOL cls thry a -> HOL cls thry a+ , warn+ , printDebugLn+ , printDebug -- * Monad Re-Export , module HaskHOL.Core.State.Monad ) where@@ -60,76 +60,173 @@ -- | Flag states whether or not to print debug statements. newFlag "FlagDebug" True -newExtension "TypeConstants" - [| [("bool", tyOpBool), ("fun", tyOpFun)] :: [(String, TypeOp)] |] -newExtension "TermConstants" [| [("=", tmEq tyA)] :: [(String, HOLTerm)] |]+data TypeConstants = TypeConstants !(Map Text TypeOp) deriving Typeable -newExtension "TheAxioms" [| [] :: [(String, HOLThm)] |]+deriveSafeCopy 0 'base ''TypeConstants -{- - Extensible state type for term definitions introduced via - newBasicDefinition.--}-newExtension "TheCoreDefinitions" [| [] :: [HOLThm] |]+insertTypeConstant :: Text -> TypeOp -> Update TypeConstants ()+insertTypeConstant ty op =+ do TypeConstants m <- get+ put (TypeConstants (mapInsert ty op m)) +getTypeConstants :: Query TypeConstants (Map Text TypeOp)+getTypeConstants =+ do TypeConstants m <- ask+ return m++makeAcidic ''TypeConstants + ['insertTypeConstant, 'getTypeConstants]++initTypeConstants :: Map Text TypeOp+initTypeConstants = mapFromList [("bool", tyOpBool), ("fun", tyOpFun)]+++data TypeDefinitions = TypeDefinitions !(Map Text (HOLThm, HOLThm)) + deriving Typeable++deriveSafeCopy 0 'base ''TypeDefinitions++insertTypeDefinition :: Text -> (HOLThm, HOLThm) -> Update TypeDefinitions ()+insertTypeDefinition ty defs =+ do TypeDefinitions m <- get+ put (TypeDefinitions (mapInsert ty defs m))++getTypeDefinitions :: Query TypeDefinitions (Map Text (HOLThm, HOLThm))+getTypeDefinitions =+ do TypeDefinitions m <- ask+ return m++getTypeDefinition :: Text -> Query TypeDefinitions (Maybe (HOLThm, HOLThm))+getTypeDefinition lbl =+ do (TypeDefinitions m) <- ask+ return $! mapLookup lbl m ++makeAcidic ''TypeDefinitions + ['insertTypeDefinition, 'getTypeDefinitions, 'getTypeDefinition]+++data TermConstants = TermConstants !(Map Text HOLTerm) deriving Typeable++deriveSafeCopy 0 'base ''TermConstants++insertTermConstant :: Text -> HOLTerm -> Update TermConstants ()+insertTermConstant tm op =+ do TermConstants m <- get+ put (TermConstants (mapInsert tm op m))++getTermConstants :: Query TermConstants (Map Text HOLTerm)+getTermConstants =+ do TermConstants m <- ask+ return m++makeAcidic ''TermConstants + ['insertTermConstant, 'getTermConstants]++initTermConstants :: Map Text HOLTerm+initTermConstants = mapFromList [("=", tmEq tyA)]++data TheAxioms = TheAxioms !(Map Text HOLThm) deriving Typeable++deriveSafeCopy 0 'base ''TheAxioms++insertAxiom :: Text -> HOLThm -> Update TheAxioms ()+insertAxiom lbl thm =+ do TheAxioms m <- get+ put (TheAxioms (mapInsert lbl thm m))++getAxioms :: Query TheAxioms (Map Text HOLThm)+getAxioms =+ do TheAxioms m <- ask+ return m++getAxiom' :: Text -> Query TheAxioms (Maybe HOLThm)+getAxiom' lbl =+ do TheAxioms m <- ask+ return $! mapLookup lbl m++makeAcidic ''TheAxioms ['insertAxiom, 'getAxioms, 'getAxiom']+++data TheCoreDefinitions = + TheCoreDefinitions !(Map Text HOLThm) deriving Typeable++deriveSafeCopy 0 'base ''TheCoreDefinitions++insertCoreDefinition :: Text -> HOLThm -> Update TheCoreDefinitions ()+insertCoreDefinition lbl thm =+ do TheCoreDefinitions defs <- get+ put (TheCoreDefinitions (mapInsert lbl thm defs))++getCoreDefinitions :: Query TheCoreDefinitions [HOLThm]+getCoreDefinitions =+ do TheCoreDefinitions defs <- ask+ return $! mapElems defs++getCoreDefinition :: Text -> Query TheCoreDefinitions (Maybe HOLThm)+getCoreDefinition name =+ do (TheCoreDefinitions defs) <- ask+ return $! name `mapLookup` defs++makeAcidic ''TheCoreDefinitions + ['insertCoreDefinition, 'getCoreDefinitions, 'getCoreDefinition]++ -- Stateful HOL Light Type Primitives {-|- Retrieves the list of type constants from the current working theory. The- list contains pairs of strings recognized by the parser and the associated+ Retrieves the 'Map' of type constants from the current working theory. The+ mapping pairs strings recognized by the parser with the associated type operator value, i.e. > ("bool", tyOpBool) -}-types :: HOL cls thry [(String, TypeOp)]+types :: HOL cls thry (Map Text TypeOp) types =- do (TypeConstants tys) <- getExt- return tys---- needed for parser-{-| - Retrieves the arity of a given type constant. Fails with 'Nothing' if the- provided type constant name is not defined in the provided context.+ do acid <- openLocalStateHOL (TypeConstants initTypeConstants)+ m <- queryHOL acid GetTypeConstants+ closeAcidStateHOL acid+ return m - Note that this function takes a 'HOLContext' argument such that it can be- used outside of 'HOL' computations; for example, in the parser.--}-getTypeArityCtxt :: HOLContext thry -> String -> Maybe Int-getTypeArityCtxt ctx name =- let (TypeConstants tys) = getExtCtxt ctx in- do tyOp <- lookup name tys- return . snd $ destTypeOp tyOp+-- | Retrieves the 'Map' of type definitions from the current working theory.+tyDefinitions :: HOL cls thry (Map Text (HOLThm, HOLThm))+tyDefinitions =+ do acid <- openLocalStateHOL (TypeDefinitions mapEmpty)+ m <- queryHOL acid GetTypeDefinitions+ closeAcidStateHOL acid+ return m {-|- A version of 'getTypeArityCtxt' that operates over the current working theory- of a 'HOL' computation. Throws a 'HOLException' if the provided type constant+ Returns the arity associated with a type constant.+ Throws a 'HOLException' if the provided type constant name is not defined. -}-getTypeArity :: String -> HOL cls thry Int+getTypeArity :: Text -> HOL cls thry Int getTypeArity name =- do ctxt <- get- liftMaybe ("getTypeArity: type " ++ name ++ " has not been defined.") $- getTypeArityCtxt ctxt name+ do tys <- types+ liftMaybe ("getTypeArity: type " ++ show name ++ + " has not been defined.") .+ liftM (snd . destTypeOp) $ mapLookup name tys {- Primitive type constant construction function. Used by newType and newBasicTypeDefinition. Not exposed to the user. -}-newType' :: String -> TypeOp -> HOL Theory thry ()+newType' :: Text -> TypeOp -> HOL Theory thry () newType' name tyop = do failWhen (can getTypeArity name) $- "newType: type " ++ name ++ " has already been declared."- modifyExt $ \ (TypeConstants consts) -> - TypeConstants $ (name, tyop) : consts+ "newType: type " ++ show name ++ " has already been declared."+ acid <- openLocalStateHOL (TypeConstants initTypeConstants)+ updateHOL acid (InsertTypeConstant name tyop)+ createCheckpointAndCloseHOL acid {-| Constructs a new primitve type constant of a given name and arity. Also adds this new type to the current working theory. Throws a 'HOLException' when a type of the same name has already been declared. -}-newType :: String -> Int -> HOL Theory thry ()+newType :: Text -> Int -> HOL Theory thry () newType name arity = - newType' name $ newPrimTypeOp name arity+ newType' name $ newPrimitiveTypeOp name arity {-| Constructs a type application given an operator name and a list of argument@@ -141,26 +238,26 @@ * A type operator is applied to zero arguments. -}-mkType :: String -> [HOLType] -> HOL cls thry HOLType+mkType :: Text -> [HOLType] -> HOL cls thry HOLType mkType name args =- do (TypeConstants consts) <- getExt- case lookup name consts of- Just tyOp -> liftEither "mkType: type constructor application failed" $- tyApp tyOp args+ do consts <- types+ case mapLookup name consts of+ Just tyOp -> tyApp tyOp args <#?> + "mkType: type constructor application failed" Nothing -> {- This seemed to be the easiest way to supress superfluous warnings when parsing type operators. -}- do name' <- case name of- '_':x -> return x- _ -> printDebugLn - ("warning - mkType: type " ++ name ++ " has " ++- "not been defined. Defaulting to type " ++ - "operator variable.") $ - return name+ do name' <- if textHead name == '_'+ then return $! textTail name+ else printDebugLn + ("warning - mkType: type " ++ show name ++ + " has not been defined. Defaulting to type " ++ + "operator variable.") $ + return name failWhen (return $ null args) "mkType: type operator applied to zero args."- liftEither "mkType: type operator variable application failed" $ - tyApp (mkTypeOpVar name') args+ tyApp (mkTypeOpVar name') args <#?> + "mkType: type operator variable application failed" {-| Constructs a function type safely using 'mkType'. Should never fail provided@@ -171,47 +268,53 @@ -- State for Constants {-|- Retrieves the list of term constants from the current working theory. The- list contains pairs of strings recognized by the parser and the associated+ Retrieves the 'Map' of term constants from the current working theory. The+ mapping pairs strings recognized by the parser and the associated term constant value, i.e. > ("=", tmEq tyA) -}-constants :: HOL cls thry [(String, HOLTerm)]+constants :: HOL cls thry (Map Text HOLTerm) constants =- do (TermConstants consts) <- getExt- return consts+ do acid <- openLocalStateHOL (TermConstants initTermConstants)+ m <- queryHOL acid GetTermConstants+ closeAcidStateHOL acid+ return m {-| Retrieves the type of a given term constant. Throws a 'HOLException' if the provided term constant name is not defined. -}-getConstType :: String -> HOL cls thry HOLType+getConstType :: Text -> HOL cls thry HOLType getConstType name =- do (TermConstants consts) <- getExt- tm <- liftMaybe "getConstType: not a constant name" $- lookup name consts- return $! typeOf tm+ do consts <- constants+ liftMaybe "getConstType: not a constant name" .+ liftM typeOf $ mapLookup name consts {- Primitive term constant construction function. Used by newConstant, newBasicDefinition, and newBasicTypeDefinition. -}-newConstant' :: String -> HOLTerm -> HOL Theory thry ()+newConstant' :: Text -> HOLTerm -> HOL Theory thry () newConstant' name c = do failWhen (can getConstType name) $- "newConstant: constant " ++ name ++ " has already been declared."- modifyExt $ \ (TermConstants consts) -> - TermConstants $ (name, c) : consts+ "newConstant: constant " ++ show name ++ " has already been declared."+ acid <- openLocalStateHOL (TermConstants initTermConstants)+ updateHOL acid (InsertTermConstant name c)+ createCheckpointAndCloseHOL acid {-| Constructs a new primitive term constant of a given name and type. Also adds this new term to the current working theory. Throws a 'HOLException' when a term of the same name has already been declared. -}-newConstant :: String -> HOLType -> HOL Theory thry ()+newConstant :: Text -> HOLType -> HOL Theory thry () newConstant name ty =- newConstant' name $ newPrimConst name ty+ do cond <- can getConstType name+ if cond+ then printDebugLn ("newConstant: ignoring redefintion of " ++ + show name) $ return ()+ else newConstant' name $ newPrimitiveConst name ty {-| Constructs a specific instance of a term constant when provided with its name@@ -222,11 +325,11 @@ * The provided name is not a currently defined constant. -}-mkConst :: TypeSubst l r => String -> [(l, r)] -> HOL cls thry HOLTerm+mkConst :: TypeSubst l r => Text -> [(l, r)] -> HOL cls thry HOLTerm mkConst name tyenv =- do (TermConstants consts) <- getExt+ do consts <- constants tm <- liftMaybe "mkConst: not a constant name" $ - lookup name consts+ mapLookup name consts liftMaybe "mkConst: instantiation failed" $ instConst tm tyenv @@ -234,11 +337,11 @@ A version of 'mkConst' that accepts a triplet of type substitition environments. Frequently used with the 'typeMatch' function. -}-mkConstFull :: String -> SubstTrip -> HOL cls thry HOLTerm+mkConstFull :: Text -> SubstTrip -> HOL cls thry HOLTerm mkConstFull name pat =- do (TermConstants consts) <- getExt+ do consts <- constants tm <- liftMaybe "mkConstFull: not a constant name" $- lookup name consts+ mapLookup name consts liftMaybe "mkConstFull: instantiation failed" $ instConstFull tm pat @@ -251,10 +354,9 @@ mkEq l r = let ty = typeOf l in do eq <- mkConst "=" [(tyA, ty)]- liftEither "mkEq" $- liftM1 mkComb (mkComb eq l) r+ liftM1 mkComb (mkComb eq l) r <#?> "mkEq" --- State for Axioms +-- State for Axioms {-| Retrieves the list of axioms from the current working theory. The list@@ -262,20 +364,12 @@ compile time operations have a tag with which they can use to extract axioms from saved theories. See 'extractAxiom' for more details. -}-axioms :: HOL cls thry [(String, HOLThm)]-axioms = - do (TheAxioms thms) <- getExt- return thms--{-| - Retrieves a specific axiom by name. Throws a 'HOLException' if there is no- axiom with the provided name in the current working theory.--}-getAxiom :: String -> HOL cls thry HOLThm-getAxiom lbl =- do (TheAxioms thms) <- getExt- liftMaybe "getAxiom: axiom name not found" $- lookup lbl thms+axioms :: HOL cls thry (Map Text HOLThm)+axioms = + do acid <- openLocalStateHOL (TheAxioms mapEmpty)+ m <- queryHOL acid GetAxioms+ closeAcidStateHOL acid+ return m {-| Constructs a new axiom of a given name and conclusion term. Also adds this@@ -286,15 +380,31 @@ * An axiom with the provided name has already been declared. -}-newAxiom :: String -> HOLTerm -> HOL Theory thry HOLThm-newAxiom name tm- | typeOf tm /= tyBool = fail "newAxiom: Not a proposition."- | otherwise =- do failWhen (can getAxiom name) $ "newAxiom: axiom with name " ++ - name ++ " has already been declared."- let th = axiomThm tm - modifyExt $ \ (TheAxioms axs) -> TheAxioms $ (name, th) : axs- return th+newAxiom :: Text -> HOLTerm -> HOL Theory thry HOLThm+newAxiom name tm =+ do acid <- openLocalStateHOL (TheAxioms mapEmpty)+ qth <- queryHOL acid (GetAxiom' name)+ closeAcidStateHOL acid+ case qth of+ Just th -> + return th+ Nothing+ | typeOf tm /= tyBool -> + fail "newAxiom: Not a proposition."+ | otherwise ->+ let th = axiomThm tm in+ do acid' <- openLocalStateHOL (TheAxioms mapEmpty)+ updateHOL acid' (InsertAxiom name th)+ createCheckpointAndCloseHOL acid'+ return th+ + -- | Retrieves an axiom by label from the theory context.+getAxiom :: Text -> HOL cls thry HOLThm+getAxiom lbl =+ do acid <- openLocalStateHOL (TheAxioms mapEmpty)+ qth <- queryHOL acid (GetAxiom' lbl)+ closeAcidStateHOL acid+ liftMaybe ("getAxiom: axiom " ++ show lbl ++ " not found.") qth -- State for Definitions {-|@@ -303,22 +413,44 @@ -} definitions :: HOL cls thry [HOLThm] definitions =- do (TheCoreDefinitions defs) <- getExt- return defs+ do acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty)+ m <- queryHOL acid GetCoreDefinitions+ closeAcidStateHOL acid+ return m {-| Introduces a definition of the form @c = t@ into the current working theory. Throws a 'HOLException' when the definitional term is ill-formed. See 'newDefinedConst' for more details. -}-newBasicDefinition :: HOLTerm -> HOL Theory thry HOLThm-newBasicDefinition tm =- do (c@(view -> Const name _ _), dth) <- liftEither "newBasicDefinition" $- newDefinedConst tm- newConstant' name c- modifyExt $ \ (TheCoreDefinitions defs) -> - TheCoreDefinitions $ dth : defs- return dth+newBasicDefinition :: Text -> HOLTerm -> HOL Theory thry HOLThm+newBasicDefinition lbl tm =+ getBasicDefinition lbl+ <|> case destEq tm of+ Just (Const _ _, _) ->+ fail "newBasicDefinition: constant already defined."+ Just (Var name _, _)+ | name /= lbl ->+ fail $ "newBasicDefinition: provided label does not " +++ "match provided term."+ | otherwise ->+ do (c@(Const x _), dth) <- liftEither "newBasicDefinition" $ + newDefinedConst tm+ newConstant' x c+ acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty)+ updateHOL acid (InsertCoreDefinition lbl dth)+ createCheckpointAndCloseHOL acid+ return dth+ _ -> fail "newBasicDefinition: provided term not an equation."+ +-- | Retrieves a basic term definition by label from the theory context.+getBasicDefinition :: Text -> HOL cls thry HOLThm+getBasicDefinition lbl =+ do acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty)+ qth <- queryHOL acid (GetCoreDefinition lbl)+ closeAcidStateHOL acid+ liftMaybe ("getBasicDefinition: definition for " ++ show lbl +++ " not found.") qth {-| Introduces a new type constant, and two associated term constants, into the @@ -342,21 +474,33 @@ See 'newDefinedTypeOp' for more details. -}-newBasicTypeDefinition :: String -> String -> String -> HOLThm -> +newBasicTypeDefinition :: Text -> Text -> Text -> HOLThm -> HOL Theory thry (HOLThm, HOLThm) newBasicTypeDefinition tyname absname repname dth = do failWhen (return or <*> mapM (can getConstType) [absname, repname]) $- "newBasicTypeDefinition: Constant(s) " ++ absname ++ ", " ++ repname ++- " already in use."+ "newBasicTypeDefinition: Constant(s) " ++ show absname ++ ", " ++ + show repname ++ " already in use." (atyop, a, r, dth1, dth2) <- liftEither "newBasicTypeDefinition" $ newDefinedTypeOp tyname absname repname dth failWhen (canNot (newType' tyname) atyop) $- "newBasicTypeDefinition: Type " ++ tyname ++ " already defined."+ "newBasicTypeDefinition: Type " ++ show tyname ++ " already defined." newConstant' absname a newConstant' repname r+ acid <- openLocalStateHOL (TypeDefinitions mapEmpty)+ updateHOL acid (InsertTypeDefinition tyname (dth1, dth2))+ createCheckpointAndCloseHOL acid return (dth1, dth2) +-- | Retrieves a basic type definition by label from the theory context.+getBasicTypeDefinition :: Text -> HOL cls thry (HOLThm, HOLThm)+getBasicTypeDefinition lbl =+ do acid <- openLocalStateHOL (TypeDefinitions mapEmpty)+ qth <- queryHOL acid (GetTypeDefinition lbl)+ closeAcidStateHOL acid+ liftMaybe ("getBasicTypeDefinition: definition for " ++ show lbl +++ " not found.") qth + -- Primitive Debugging Functions {-| Prints the provided string, with a new line, when the given boolean value is@@ -385,6 +529,3 @@ if debug then fn str >> x else x--deriveLiftMany [ ''TypeConstants, ''TermConstants- , ''TheAxioms, ''TheCoreDefinitions ]
src/HaskHOL/Core/State/Monad.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ExistentialQuantification, - MultiParamTypeClasses, ScopedTypeVariables, TemplateHaskell #-}-+{-# LANGUAGE ConstraintKinds, DataKinds, EmptyDataDecls, ScopedTypeVariables, + TypeFamilies, TypeOperators, UndecidableInstances #-} {-| Module: HaskHOL.Core.State.Monad Copyright: (c) The University of Kansas 2013@@ -11,85 +10,176 @@ Portability: unknown This module exports the primitive types and combinators for the 'HOL' - computational monad. At a high level this monad is a flattened stack of a- 'State' monad transformer and a limited 'IO' monad.+ computational monad. At a high level this monad is a newtype wrapper for a+ limited 'IO' monad. For higher level monadic combinators see the "HaskHOL.Core.State" and "HaskHOL.Core.Basics" modules. -} module HaskHOL.Core.State.Monad- ( -- * The HOL Monad+ ( -- * The 'HOL' Monad HOL , Theory , Proof- , runHOLCtxt -- :: HOLContext thry -> IO (a, HOLContext thry) - , evalHOLCtxt -- :: HOL cls thry a -> HOLContext thry -> IO a- , execHOLCtxt -- :: HOL cls thry a -> HOLContext thry -> - -- IO (HOLContext thry)- -- * State Methods- , get -- :: HOL cls thry (HOLContext thry)- , gets -- :: (HOLContext thry -> a) -> HOL cls thry a+ , runHOLProof+ , runHOL+ -- * Theory Contexts+ , TheoryPath+ , mkTheoryPath+ , destTheoryPath+ , BaseThry(..)+ , ExtThry(..)+ , CtxtName(..)+ , PolyTheory+ , BaseCtxt+ , ctxtBase -- * Text Output Methods- , putStrHOL -- :: String -> HOL cls thry ()- , putStrLnHOL -- :: String -> HOL cls thry ()+ , putStrHOL+ , putStrLnHOL -- * Exception Handling Methods , HOLException(..)- , throwHOL -- :: Exception e => e -> HOL cls thry a- , catchHOL -- :: Exception e => HOL cls thry a -> (e -> HOL cls thry a) - -- -> HOL cls thry a- , liftMaybe -- :: String -> Maybe a -> HOL cls thry a- , liftEither -- :: Show err => String -> Either err a -> HOL cls thry a+ , throwHOL+ , catchHOL+ , noteHOL+ , liftMaybe+ , liftEither+ , finallyHOL -- * Local Reference Methods , HOLRef- , newHOLRef -- :: a -> HOL cls thry (HOLRef a)- , readHOLRef -- :: IORef a -> HOL cls thry a- , writeHOLRef -- :: IORef a -> a -> HOL cls thry ()- , modifyHOLRef -- :: IORef a -> (a -> a) -> HOL cls thry ()+ , newHOLRef+ , readHOLRef+ , writeHOLRef+ , modifyHOLRef+ -- * Acid State Primitives+ , openLocalStateHOL+ , openLocalStateHOLBase+ , closeAcidStateHOL+ , createCheckpointAndCloseHOL+ , cleanArchives+ , updateHOL+ , updateHOLUnsafe+ , queryHOL -- * Benign Flag Methods- , BenignFlag(..) , setBenignFlag , unsetBenignFlag- , getBenignFlagCtxt , getBenignFlag+ , newFlag -- * Methods Related to Fresh Name Generation- , tickTermCounter -- :: HOL cls thry Int- , tickTypeCounter -- :: HOL cls thry Int- -- * Extensible State Methods- -- $ExtState- , ExtClass(..)- , ExtState- , putExt -- :: ExtClass a => a -> HOL Theory thry ()- , getExtCtxt -- :: forall a thry. ExtClass a => HOLContext thry -> Maybe a- , getExt -- :: forall cls thry a. ExtClass a => HOL cls thry a- , modifyExt -- :: ExtClass a => (a -> a) -> HOL Theory thry ()- -- * Implementation of Theory Contexts- , HOLContext- , ctxtBase -- :: HOLContext BaseThry- , ExtThry(..)- , BaseThry(..)- , BaseCtxt- -- * Template Haskell Assistance for Flags/Extensions- , newFlag -- :: String -> Bool -> Q [Dec]- , newExtension -- :: String -> ExpQ -> Q [Dec]+ , tickTermCounter+ , tickTypeCounter+ -- * Proof Caching+ , cacheProof+ , cacheProofs+ , checkpointProofs+ , cleanArchiveProofs -- * Re-export for Extensible Exceptions , Exception ) where -import HaskHOL.Core.Lib+import HaskHOL.Core.Lib hiding (combine)+import HaskHOL.Core.Kernel.Prims +-- HOL Monad imports+import Data.Typeable import Control.Exception (Exception) import qualified Control.Exception as E- import Data.IORef- -import Data.Typeable (cast, typeOf)+import GHC.Prim (Constraint)+import qualified Data.HashMap.Strict as Hash+import Data.Hashable+import Data.Acid hiding (makeAcidic, Query, Update)++-- TH imports import Language.Haskell.TH-import Language.Haskell.TH.Syntax (Lift(..))+import Language.Haskell.TH.Syntax (lift) +-- Path Handling imports+import Prelude hiding (FilePath)+import Paths_haskhol_core+import Shelly hiding (put, get)+import System.FilePath (combine) +-- Messy Template Haskell stuff+-- Proofs+data Proofs = Proofs !(Hash.HashMap String HOLThm) deriving Typeable++instance (SafeCopy a, SafeCopy b, Hashable a, Eq a) => + SafeCopy (Hash.HashMap a b) where+ getCopy = contain $ fmap Hash.fromList safeGet+ putCopy = contain . safePut . Hash.toList++deriveSafeCopy 0 'base ''Proofs++insertProof :: String -> HOLThm -> Update Proofs ()+insertProof lbl thm =+ do (Proofs m) <- get+ put (Proofs (Hash.insert lbl thm m))++getProof :: String -> Query Proofs (Maybe HOLThm)+getProof lbl =+ do (Proofs m) <- ask+ return $! Hash.lookup lbl m++makeAcidic ''Proofs ['insertProof, 'getProof]+--+-- Types+data TyCounter = TyCounter !Integer deriving Typeable++deriveSafeCopy 0 'base ''TyCounter++updateTyCounter :: Update TyCounter Integer+updateTyCounter =+ do TyCounter n <- get+ let n' = succ n+ put (TyCounter n')+ return n'++queryTyCounter :: Query TyCounter Integer+queryTyCounter =+ do TyCounter n <- ask+ return n++makeAcidic ''TyCounter ['updateTyCounter, 'queryTyCounter]+--+-- Terms+data TmCounter = TmCounter !Integer deriving Typeable++deriveSafeCopy 0 'base ''TmCounter++updateTmCounter :: Update TmCounter Integer+updateTmCounter =+ do TmCounter n <- get+ let n' = succ n+ put (TmCounter n')+ return n'++queryTmCounter :: Query TmCounter Integer+queryTmCounter =+ do TmCounter n <- ask+ return n++makeAcidic ''TmCounter ['updateTmCounter, 'queryTmCounter]+--+-- Flags+data BenignFlags = BenignFlags !(Map String Bool) deriving Typeable++deriveSafeCopy 0 'base ''BenignFlags++insertFlag :: String -> Bool -> Update BenignFlags ()+insertFlag ty flag = + do BenignFlags m <- get+ put (BenignFlags (mapInsert ty flag m))++lookupFlag :: String -> Query BenignFlags (Maybe Bool)+lookupFlag ty =+ do BenignFlags m <- ask+ return (mapLookup ty m)+makeAcidic ''BenignFlags ['insertFlag, 'lookupFlag]+--+--+ -- Monad -- HOL method types- {-| The 'HOL' monad structures computations in the HaskHOL system at the stateful layer and above. The type parameters are used as such:@@ -101,7 +191,8 @@ by one of two empty data types, 'Theory' and 'Proof'. * @thry@ - Carries a tag indicating the most recent checkpoint of the current- working theory, i.e. the last library loaded. Again, it is phantom+ working theory, i.e. the last library loaded. Again, it is a+ phantom type variable that is inhabited by an empty data type. A unique tag is created for each library by linerearly extending the tag starting from a base value. For example, the tag @@ -109,29 +200,22 @@ theory consisting of the base and equality logic theories. Note that typically this value is left polymorphic and is- constrained by a class related to a library. For example, the+ constrained by a type class related to a library. For example, the following type indicates a computation that can only be ran by using a theory context value that has the equality logic library loaded: @EqualCtxt thry => HOL cls thry a@ * @a@ - The return type of a 'HOL' computation. - Note that the 'HOL' monad is effectively a flattened stack of a limited- 'IO' monad and a 'State' monad. We say limited as we restrict the possible- IO-like computations to the ones shown in this module, rather than allowing+ Note that the 'HOL' monad is essentially a newtype wrapper to a limited+ 'IO' monad. We say limited as we restrict the possible+ IO-like computations to the ones exported in this module, rather than allowing arbitrary computations through a mechanism like 'MonadIO'. This prevents a number of soundness issues.-- For more information regarding the contents of a theory context see the- documentation for 'HOLContext'. -}- newtype HOL cls thry a = - HOL { {-| - Evaluates a 'HOL' computation with a provided theory context.- Returns the result paired with an updated theory context.- -}- runHOLCtxt :: HOLContext thry -> IO (a, HOLContext thry) + HOL { -- not exposed to the user+ runHOLUnsafe :: AcidState Proofs -> String -> IO a } -- | The classification tag for theory extension computations.@@ -139,16 +223,50 @@ -- | The classification tag for proof computations. data Proof +-- used internally by runHOLProof and runHOL+runHOLUnsafe' :: HOL cls thry a -> String -> IO a+runHOLUnsafe' m fp =+ do dir <- getDataDir + acid <- openLocalStateFrom (dir `combine` "Proofs") (Proofs Hash.empty)+ runHOLUnsafe m acid fp `E.finally` closeAcidState acid++{-| + Runs a 'HOL' 'Proof' computation using a provided 'TheoryPath' with access to+ the proof cache. Other state values, e.g. type and term constants, may be + accessed but not modified.+-}+runHOLProof :: HOL Proof thry a -> TheoryPath thry -> IO a+runHOLProof m (TheoryPath fp) = runHOLUnsafe' m fp++{-| + Evaluates a 'HOL' computation by copying the contents of a provided + 'TheoryPath' to a new directory where destructive updates will occur.+ This is used primarily by 'extendTheory', but is also useful for testing + 'Theory' computations in temporary directories.+-}+runHOL :: HOL cls thry a -> TheoryPath thry -> String -> IO a+runHOL m (TheoryPath old) new =+ do dir <- getDataDir+ let old' = mkFilePath $ dir `combine` old+ new' = mkFilePath $ dir `combine` new+ shelly $ do unlessM (test_d old') . fail $ + "runHOL: acid-state directory, " +++ old ++ ", does not exist."+ whenM (test_d new') . echo . pack $+ "runHOL: acid-state directory, " +++ new ++ ", already exists. Overwriting."+ rm_rf new'+ cp_r old' new'+ runHOLUnsafe' m new+ instance Functor (HOL cls thry) where fmap = liftM instance Monad (HOL cls thry) where- return x = HOL $ \ s -> - return (x, s)- {-# INLINEABLE (>>=) #-}- m >>= k = HOL $ \ s ->- do (b, s') <- runHOLCtxt m s- runHOLCtxt (k b) s'+ return x = HOL $ \ _ _ -> return x+ m >>= k = HOL $ \ acid st -> + do b <- runHOLUnsafe m acid st+ runHOLUnsafe (k b) acid st fail = throwHOL . HOLException instance MonadPlus (HOL cls thry) where@@ -166,61 +284,102 @@ instance Note (HOL cls thry) where job <?> str = job <|> throwHOL (HOLException str) --- | A version of 'runHOLCtxt' that returns only the resultant value.-evalHOLCtxt :: HOL cls thry a -> HOLContext thry -> IO a-evalHOLCtxt m ctxt = return fst <*> runHOLCtxt m ctxt --- | A version of 'runHOLCtxt' that returns only the theory context.-execHOLCtxt :: HOL cls thry a -> HOLContext thry -> IO (HOLContext thry)-execHOLCtxt m ctxt = return snd <*> runHOLCtxt m ctxt+-- Theory Contexts+{-| + A @newtype@ wrapper for the filepath to a theory context that uses a phantom+ type variable to capture the theory context type. See 'HOL' for more + information.+-}+newtype TheoryPath thry = TheoryPath String -{- - We define our own versions of state functions instead of deriving MonadState - so that we can control where they are exported. Note that put is not expose- to the user.+{-| Constructs a 'TheoryPath' for a provided theory context type using + 'ctxtName'. -}-put :: HOLContext thry -> HOL cls thry ()-put s = HOL $ \ _ -> return ((), s)+mkTheoryPath :: forall thry. CtxtName thry => TheoryPath thry+mkTheoryPath = TheoryPath $ ctxtName (undefined :: thry) +-- | Destructs a 'TheoryPath', returning its internal 'String'.+destTheoryPath :: TheoryPath thry -> String+destTheoryPath (TheoryPath x) = x++-- converts TheoryPath strings to FilePaths for shelly+mkFilePath :: String -> FilePath+mkFilePath = fromText . pack+++-- | The 'BaseThry' type is the type of the initial working theory.+data BaseThry = BaseThry {-| - Equivalent to 'Control.Monad.State.get' for the 'HOL' monad. Note that we- define our own version of this function, rather than define an instance of- 'MonadState' so that we can control where the morphisms are exported.+ The 'ExtThry' type is the type of a linear theory extension, i.e. a cons-like+ operation for theory types. See the module "HaskHOL.Lib.Equal.Context" for+ an example of how to correctly define theory types and contexts for a library.+-}+data ExtThry a b = ExtThry a b - This is done in the name of soundness given that a user can inject an unsound- theory context into a proof using a @put@ morphism. This is analogous to the- issue behind defining an instance of 'MonadIO' given 'liftIO' can be used to- inject arbitrary computations into the 'HOL' monad, including ones containing- unsound contexts.+{-|+ The 'CtxtName' class associates a 'String' representation of context names+ with context types. It's used internally for most Template Haskell primitives+ defined in @HaskHOL.Core.Ext@ and its submodules. -}-get :: HOL cls thry (HOLContext thry)-get = HOL $ \ s -> return (s, s)+class CtxtName a where+ -- | Returns the name of a context type.+ ctxtName :: a -> String {-| - A version of 'get' that applies a function to the state before returning the- result.+ The 'PolyTheory' type family is used to build a polymorphic theory context + constraint from a monomorphic theory context type. For example: ++ > type instance PolyTheory BoolType b = BaseCtxt b++ Note: This will be automated and appropriately hidden in the future, but for+ now it must be manually defined.+ Be extra careful not to define incorrect instances as they can be used to+ bypass the safety mechanisms of 'cacheProof' and 'cacheProofs'. -}-gets :: (HOLContext thry -> a) -> HOL cls thry a-gets f = liftM f get+type family PolyTheory a b :: Constraint --- See the above notes. Not exported to the user.-modify :: (HOLContext thry -> HOLContext thry) -> HOL cls thry ()-modify = put <=< gets+instance CtxtName BaseThry where+ ctxtName _ = "BaseCtxt" +instance CtxtName a => CtxtName (ExtThry a b) where+ ctxtName _ = ctxtName (undefined::a)++{-|+ The 'BaseCtxt' class is the context name associated with the 'BaseThry' type,+ i.e. the constraint to be used to guarantee that the stateful kernel has been+ loaded. This should always be true.+-}+type family BaseCtxt a :: Constraint where+ BaseCtxt BaseThry = ()+ BaseCtxt (ExtThry a b) = BaseCtxt b++-- type family stuff for base contexts+type instance PolyTheory BaseThry b = BaseCtxt b++type instance BaseThry == BaseThry = 'True+type instance ExtThry a b == ExtThry a' b' = (a == a') && (b == b')++-- | The 'TheoryPath' for the base theory context.+ctxtBase :: TheoryPath BaseThry+ctxtBase = mkTheoryPath++ -- define own versions of IO functions so they can be used external to kernel+ -- | A version of 'putStr' lifted to the 'HOL' monad. putStrHOL :: String -> HOL cls thry ()-putStrHOL str = HOL $ \ s -> putStr str >> return ((), s)+putStrHOL x = HOL $ \ _ _ -> putStr x -- | A version of 'putStrLn' lifted to the 'HOL' monad. putStrLnHOL :: String -> HOL cls thry ()-putStrLnHOL str = HOL $ \ s -> putStrLn str >> return ((), s)+putStrLnHOL x = HOL $ \ _ _ -> putStrLn x -- Errors- -- the basic HOL exception type -- | The data type for generic errors in HaskHOL. Carries a 'String' message.-newtype HOLException = HOLException String deriving (Show, Typeable)+newtype HOLException = HOLException String deriving Typeable+instance Show HOLException where show (HOLException str) = str instance Exception HOLException {-| @@ -241,7 +400,7 @@ > fail "empty - HOL" -} throwHOL :: Exception e => e -> HOL cls thry a-throwHOL e = HOL $ \ _ -> E.throwIO e+throwHOL x = HOL $ \ _ _ -> E.throwIO x {-| A version of 'E.catch' lifted to the 'HOL' monad.@@ -252,19 +411,28 @@ -} catchHOL :: Exception e => HOL cls thry a -> (e -> HOL cls thry a) -> HOL cls thry a-catchHOL job errcase = HOL $ \ s ->- runHOLCtxt job s `E.catch` \ e -> runHOLCtxt (errcase e) s+catchHOL job errcase = HOL $ \ acid st -> + runHOLUnsafe job acid st `E.catch` \ e -> runHOLUnsafe (errcase e) acid st -- Used to define mplus and (<|>) for the HOL monad. Not exposed to the user. (<||>) :: HOL cls thry a -> HOL cls thry a -> HOL cls thry a-job <||> alt = HOL $ \ s ->- runHOLCtxt job s `E.catch` \ (_ :: E.SomeException) -> runHOLCtxt alt s+job <||> alt = HOL $ \ acid st -> + runHOLUnsafe job acid st `E.catch` + \ (_ :: E.SomeException) -> runHOLUnsafe alt acid st +-- | A version of 'note' specific to 'HOL' computations.+noteHOL :: String -> HOL cls thry a -> HOL cls thry a+noteHOL str m = HOL $ \ acid st ->+ runHOLUnsafe m acid st `E.catch` \ (e :: E.SomeException) ->+ case E.fromException e of+ Just (HOLException str2) -> + E.throwIO . HOLException $ str ++ ": " ++ str2+ _ -> E.throwIO . HOLException $ str ++ ": " ++ show e+ {-| Lifts a 'Maybe' value into the 'HOL' monad mapping 'Just's to 'return's and 'Nothing's to 'fail's with the provided 'String'. -}-{-# INLINEABLE liftMaybe #-} liftMaybe :: String -> Maybe a -> HOL cls thry a liftMaybe _ (Just x) = return x liftMaybe str _ = fail str @@ -277,11 +445,15 @@ class such that 'show' can be used to construct a string to be used with 'fail'. -}-{-# INLINEABLE liftEither #-} liftEither :: Show err => String -> Either err a -> HOL cls thry a liftEither _ (Right res) = return res-liftEither str1 (Left str2) = fail $ str1 ++ " - " ++ show str2+liftEither str1 (Left str2) = fail $ str1 ++ ": " ++ show str2 +-- | A version of 'E.finally' lifted to the 'HOL' monad.+finallyHOL :: HOL cls thry a -> HOL cls thry b -> HOL cls thry a+finallyHOL a b = HOL $ \ acid st ->+ runHOLUnsafe a acid st `E.finally` runHOLUnsafe b acid st+ -- Local vars -- | A type synonym for 'IORef'. type HOLRef = IORef@@ -291,65 +463,112 @@ to 'newIORef' lifted to the 'HOL' monad. -} newHOLRef :: a -> HOL cls thry (HOLRef a)-newHOLRef x = HOL $ \ s ->- do ref <- newIORef x- return (ref, s)+newHOLRef ref = HOL $ \ _ _ -> newIORef ref {-| Reads a 'HOLRef' returning the stored value. Functionally equivalent to 'readIORef' lifted to the 'HOL' monad. -} readHOLRef :: IORef a -> HOL cls thry a-readHOLRef ref = HOL $ \ s ->- do res <- readIORef ref- return (res, s)+readHOLRef ref = HOL $ \ _ _ -> readIORef ref {-| Writes a value to a 'HOLRef'. Functionally equivalent to 'writeHOLRef' lifted to the 'HOL' monad. -} writeHOLRef :: IORef a -> a -> HOL cls thry ()-writeHOLRef ref x = HOL $ \ s -> writeIORef ref x >> return ((), s)+writeHOLRef ref x = HOL $ \ _ _ -> writeIORef ref x {-| Applies a given function to a 'HOLRef', modifying the stored value. Functionally equivalent to 'modifyHOLRef' lifted to the 'HOL' monad. -} modifyHOLRef :: IORef a -> (a -> a) -> HOL cls thry ()-modifyHOLRef ref f = HOL $ \ s -> modifyIORef ref f >> return ((), s)+modifyHOLRef ref f = HOL $ \ _ _ -> modifyIORef ref f +-- acid primitives --- Context-{-|- The 'ExtClass' type class is the heart of HaskHOL's extensible state- mechanism. It serves a number of purposes:+-- used internally by openLocalStateHOL and openLocalStateHOLBase+openLocalState' :: (Typeable st, IsAcidic st) + => st -> String -> IO (AcidState st)+openLocalState' ast suf =+ do dir <- getDataDir+ let dir' = dir `combine` suf `combine` show (typeOf ast)+ openLocalStateFrom dir' ast - * It provides the polymorphic type for heterogenous structures of type - 'ExtState'. - * It introduces the 'Typeable' constraint that enables the mechanism for- selecting specific state extensions based on their type. See 'getExt' for- more details.+{-| + Creates an 'AcidState' value from a 'HOL' computation's theory context using+ a default value.+ This is a wrapper to 'openLocalStateFrom' using @HaskHOL.Core@'s + shared data directory appended with the 'ctxtName' of the theory context.+-}+openLocalStateHOL :: (Typeable st, IsAcidic st) => st + -> HOL cls thry (AcidState st)+openLocalStateHOL ast = HOL $ \ _ st -> openLocalState' ast st - * It defines an initial value for state extensions to use if they have not - been introduced to the context by a computation yet.+{-| + A version of 'openLocalStateHOL' that uses just @HaskHOL.Core@'s shared data+ directory.+-}+openLocalStateHOLBase :: (Typeable st, IsAcidic st) => st + -> HOL cls thry (AcidState st)+openLocalStateHOLBase ast = HOL $ \ _ _ -> openLocalState' ast "" - For more information see the documentation for 'HOLContext', 'getExtCtxt', and- 'putExt'.+-- | A wrapper to 'closeAcidState' for the 'HOL' monad.+closeAcidStateHOL :: (SafeCopy st, Typeable st) => AcidState st + -> HOL cls thry ()+closeAcidStateHOL ast = HOL $ \ _ _ -> closeAcidState ast++{-| + A version of 'closeAcidStateHOL' that calls 'createCheckpoint' and + 'createArchive' first. -}+createCheckpointAndCloseHOL :: (SafeCopy st, Typeable st) => AcidState st + -> HOL cls thry ()+createCheckpointAndCloseHOL ast = HOL $ \ _ _ ->+ do createCheckpoint ast+ createArchive ast+ closeAcidState ast++{-| + The 'cleanArchives' method removes all of the "Archive" sub-directories + in a theory context that were created by 'createCheckpointAndCloseHOL'. -}-class (Lift a, Typeable a) => ExtClass a where- {-| - The intial value for an extensible state type. The value returned when- attempting to retrieve a type that is not yet defined in the context.- -}- initValue :: a+cleanArchives :: HOL cls thry ()+cleanArchives = HOL $ \ _ st ->+ do dir <- getDataDir+ let dir' = mkFilePath $ dir `combine` st+ shelly $ do archvs <- findWhen (\ x -> return $! x == "Archive") dir'+ mapM_ rm_rf archvs +{-|+ A wrapper to 'update' for the 'HOL' monad. Note that the classification of+ the provided 'HOL' computation is unrestricted, such that it can be used in + 'Proof' computations to update benign state values.++ If you want the state modification to be captured by the type, make sure to+ use 'updateHOL' instead.+-}+updateHOLUnsafe :: UpdateEvent event => AcidState (EventState event) -> event + -> HOL cls thry (EventResult event)+updateHOLUnsafe ast e = HOL $ \ _ _ -> update ast e+ {-| - Used to build heterogenous structures that hold state extensions. See- 'ExtClass' for more details.+ A version of 'updateHOLUnsafe' that restricts the classification of the + provided 'HOL' computation to be of a 'Theory' type. -}-data ExtState = forall a. ExtClass a => ExtState a+updateHOL :: UpdateEvent event => AcidState (EventState event) -> event + -> HOL Theory thry (EventResult event)+updateHOL = updateHOLUnsafe +-- | A wrapper to 'query' for the 'HOL' monad.+queryHOL :: QueryEvent event => AcidState (EventState event) -> event + -> HOL cls thry (EventResult event)+queryHOL ast e = HOL $ \ _ _ -> query ast e+++-- Flag Methods+ {-| HOL systems typically use a large number of boolean flags in order to direct system behavior, i.e. debug flags, warning flags, parser/printer flags, etc.@@ -366,7 +585,7 @@ The 'BenignFlag' class works very similarly to the 'ExtClass' class with the obvious exception that initial values are restricted to boolean values. - See 'HOLContext', 'getBenignFlagCtxt', and 'setBenignFlag' for more details.+ See 'getBenignFlagCtxt' and 'setBenignFlag' for more details. -} class Typeable a => BenignFlag a where {-| @@ -375,51 +594,26 @@ -} initFlagValue :: a -> Bool -{-|- The state type for the 'HOL' monad. A newtype wrapper to the following quad:-- * An association 'List' of @('String', 'Bool')@ pairs that models HaskHOL's- extensible benign flag system. The first field is a 'String' representation- of the type of a benign flag and the second field is that flag's current- value.-- * An 'Int' counter that is used for fresh name generation for type variables.-- * An 'Int' counter that is used for fresh name generation for term variables.-- * An association 'List' of @('String', 'ExtState')@ pairs that models - HaskHOL's extensible state. The first field is a 'String' representation of - the type of a state extension and the second field is a wrapping of that - type that has an instance of the 'ExtClass' class.-- See 'putExt' and 'getExtCtxt' for more details on how to interact with the- extensible state and see 'setBenignFlag' and 'getBenignFlag' for more details- on how to interact with benign flags.--}-newtype HOLContext thry = - HCtxt ([(String, Bool)], Int, Int, [(String, ExtState)]) - deriving Typeable---- manually derived to avoid needing lift instance for phantoms-instance Lift (HOLContext thry) where- lift (HCtxt x) = conE 'HCtxt `appE` lift x+-- Benign Flag methods -instance Show (HOLContext thry) where- show (HCtxt (_, _, _, xs)) = show $ map fst xs+-- Converts a flag's type to the string representation of its full name+tyToIndex :: forall a. Typeable a => a -> String+tyToIndex _ =+ let con = typeRepTyCon $ typeOf (undefined::a) in+ tyConPackage con ++ tyConModule con ++ tyConName con --- Benign Flag methods -- used internally by set/unsetBenignFlag modBenignFlag :: BenignFlag a => Bool -> a -> HOL cls thry () modBenignFlag val flag =- modify (\ (HCtxt (flags, tm, ty, m)) ->- HCtxt (insertMap (show $ typeOf flag) val flags, tm, ty, m))+ do acid <- openLocalStateHOL (BenignFlags mapEmpty)+ updateHOLUnsafe acid (InsertFlag (tyToIndex flag) val)+ closeAcidStateHOL acid {-| Adds a new, or modifies an existing, benign flag to be 'True'. Benign flags - in the context are stored as a list of @('String', 'Bool')@ pairs. The first - field in this pair is a term-level reificatino of a benign flag's type, - produced via a composition of 'show' and 'typeOf'. The second field is simply- the current boolean value of the flag.+ in the context are stored as a 'Map' of 'Bool' values with 'String' keys.+ The key is a term-level reificatino of a benign flag's type, + produced via a composition of 'show' and 'typeOf'. Numerous usage examples can be found in both the "HaskHOL.Core.Parser.Lib" and "HaskHOL.Core.Printer" modules where flags are used to direct the behavior@@ -432,17 +626,13 @@ does need to provide a witness to the flag type. As such, it can either be a nullary, punned data declaration, i.e. @data X = X@, or an empty data declaration with a type annotated instance of 'undefined' acting as the- ness, i.e. @undefined :: X@.+ witness, i.e. @undefined :: X@. Example: > setBenignFlag FlagDebug would set the debugging flag equal to 'True'.-- Alternatively, the 'newFlag' splice can be used to automatically construct a - new extension given a name and initial value. See that function's - documentation for more information. -} setBenignFlag :: BenignFlag a => a -> HOL cls thry () setBenignFlag = modBenignFlag True@@ -452,10 +642,7 @@ unsetBenignFlag = modBenignFlag False {-|- Retrieves the value of a benign flag from a theory context. This function is- typically used external to 'HOL' computations, such as in the parser and - printer.-+ Retrieves the value of a benign flag from a theory context. Note that retrieval of the value requires a witness to the desired flag's type, i.e. @@ -468,151 +655,36 @@ In the event that the flag is not found then the 'initFlagValue' for that type is returned. Thus, this function never fails. -}-getBenignFlagCtxt :: forall a thry. BenignFlag a => - a -> HOLContext thry -> Bool-getBenignFlagCtxt flag (HCtxt (flags, _, _, _)) =- fromMaybe (initFlagValue flag) $ - lookup (show $ typeOf flag) flags--{-|- A version of 'getBenignFlagCtxt' that can be used with theory contexts passed- implicitly as part of a 'HOL' computation.- - Never fails.--} getBenignFlag :: BenignFlag a => a -> HOL cls thry Bool-getBenignFlag = gets . getBenignFlagCtxt+getBenignFlag flag =+ do acid <- openLocalStateHOL (BenignFlags mapEmpty)+ val <- queryHOL acid (LookupFlag (tyToIndex flag))+ closeAcidStateHOL acid+ return $! fromMaybe (initFlagValue flag) val -- Fresh Name Generation+ {-| Increments the term counter stored in the context, returning the new value.- Can be used to guarantee the freshness of term names within a single - computation. -}-tickTermCounter :: HOL cls thry Int+tickTermCounter :: HOL cls thry Integer tickTermCounter =- do (HCtxt (f, tm, ty, s)) <- get- let tm' = succ tm- put $ HCtxt (f, tm', ty, s)- return tm'+ do acid <- openLocalStateHOL (TmCounter 0)+ n <- updateHOLUnsafe acid UpdateTmCounter+ closeAcidStateHOL acid+ return n {-| Increments the type counter stored in the context, returning the new value.- Can be used to gurantee the freshness of type names within a single- computation. -}-tickTypeCounter :: HOL cls thry Int+tickTypeCounter :: HOL cls thry Integer tickTypeCounter =- do (HCtxt (f, tm, ty, s)) <- get- let ty' = succ ty- put $ HCtxt (f, tm, ty', s)- return ty'---- Context: Extensible State-{- $ExtState- HaskHOL's extensible state mechanism is based closely on the implementation - of extensible state found in XMonad.-- In the event that the relevant documentation from 'ExtClass', 'putExt', and- 'getExtCtxt' is confusing or not sufficient, it may be helpful to review the- documentation contained in the "XMonad.Util.ExtensibleState" module.--}--{-|- Adds a new, or modifies an existing, state extension. State extensions in the- context are stored as a list of @('String', 'ExtState')@ pairs. The first - field in this pair is a term-level reification of a state extension's type, - produced via a composition of 'show' and 'typeOf'. The second field is simply- a wrapping of the extension's value with 'ExtState' to facilitate - heterogeneous structures.-- Numerous usage examples can be found in the "HaskHOL.Core.Parser.Lib" module- where extensible state is used to store the list of operators, as well as- other information, required by the parser.-- Note that since the retrieval and storage of state extensions are driven by - types, it is in the best interest of library implementors to guarantee that- the type of their extensions are unique. The easiest way to do this is to- create a @newtype@ wrapper for your extension and hide the internal- constructor to prevent unintended modification. Again, see - "HaskHOL.Core.Parser.Lib" for usage examples.-- Alternatively, the 'newExtension' splice can be used to automatically- construct a new extension given a name and initial value. See that function's- documentation for more information.--}-putExt :: ExtClass a => a -> HOL Theory thry ()-putExt val = - modify (\ (HCtxt (b, tm, ty, m)) -> - HCtxt (b, tm, ty, insertMap (show . typeOf $ val) (ExtState val) m))--{-|- Retrives a state extension from a theory context. This function is typically - used external to 'HOL' computations, such as in the parser, where- a theory context is passed explicitly as a value.-- Note that the selection of the extension is driven by the return type of this - function. Thus when binding the result of this function, the type must be - fixed either via explicit type annotation or through the presence of a unique - constructor.-- In order to provide the correct result type, this function relies on the- type-safe 'cast' operation. In the event that either this cast fails or the - state extension is not found then the 'initValue' for that type is returned.- Thus, this function never fails.--}-getExtCtxt :: forall a thry. ExtClass a => HOLContext thry -> a-getExtCtxt (HCtxt (_, _, _, ctxt)) =- fromMaybe initValue $- do (ExtState val) <- lookup (show $ typeOf (undefined :: a)) ctxt- cast val- -{-|- A version of 'getExtCtxt' that can be used with theory contexts passed- implicitly as part of a 'HOL' computation.-- Never fails.--} -getExt :: ExtClass a => HOL cls thry a-getExt = gets getExtCtxt- -{-| - Modifies the value of a state extension. Functionally equivalent to the- composition -- > \ f -> putExt . f =<< getExt--}-modifyExt :: ExtClass a => (a -> a) -> HOL Theory thry ()-modifyExt f = putExt . f =<< getExt---- Initial Context--- | The 'BaseThry' type is the type of the initial working theory.-data BaseThry = BaseThry deriving Typeable-{-| - The 'ExtThry' type is the type of a linear theory extension, i.e. a cons-like- operation for theory types. See the module "HaskHOL.Lib.Equal.Context" for- an example of how to correctly define theory types and contexts for a library.--}-data ExtThry a b = ExtThry a b deriving Typeable+ do acid <- openLocalStateHOL (TyCounter 0)+ n <- updateHOLUnsafe acid UpdateTyCounter+ closeAcidStateHOL acid+ return n {-|- The 'BaseCtxt' class is the context name associated with the 'BaseThry' type,- i.e. the constraint to be used to guarantee that the stateful kernel has been- loaded. This should always be true.--}-class BaseCtxt a-instance BaseCtxt BaseThry-instance BaseCtxt b => BaseCtxt (ExtThry a b)--{-| - The initial working theory value: debugging is on, the counters are at zero - and the extensible state is empty.--}-ctxtBase :: HOLContext BaseThry-ctxtBase = HCtxt ([], 0, 0, [])---- Some TH wizardry-{-| The 'newFlag' splice can be used to automatically construct a new benign flag given a name and an initial flag value. @@ -635,39 +707,105 @@ [FunD 'initFlagValue [Clause [WildP] (NormalB val') []]] return [ty, cls] +-- Proof Caching+ {-|- The 'newExtension' splice can be used to automatically construct a new state- extension given a name and a quoted, type annotated, initial value. The type- annotation is required as many initial values, such as an empty list, are too- polymorphic to infer the correct type on its own.+ The 'cacheProof' method stores or retrieves a theorem from the proof+ cache. For example: - Example:+ > thmTRUTH :: BoolCtxt thry => HOL cls thry HOLThm+ > thmTRUTH = cacheProof "thmTRUTH" ctxtBool $+ > do tm <- toHTm [str| \p:bool. p |]+ > tdef <- defT+ > liftO . liftM1 primEQ_MP (ruleSYM tdef) $ primREFL tm - > newExtension "TheCoreDefinitions" [| [] :: [HOLThm] |]+ Note that 'cacheProof' takes three arguments: - will construct the following Haskell code:+ * The label for the theorem. Note that these labels must be unique, such that+ an attempt to store a theorem with a duplicate label will instead retrieve+ the existing theorem. In the event that the existing theorem requires a+ theory context that is not satisfied by the provided context, the+ appropriate error will be thrown. - > newtype TheCoreDefinitions = TheCoreDefinitions [HOLThm] deriving Typeable- > instance ExtClass TheCoreDefinitions where- > initValue = TheCoreDefinitions []+ * The theory context required to successfully evaluate the proof of the+ theorem. Note that this context only needs to satisfy the ascribed type+ constraint, not "match" it. For example, one could define a set of contexts+ that are identical modulo overload priorities. Selecting from this set on a+ case by case basis can be used to eliminate a large number of type + annotations. - Note that, due to limitations with the current version of Template Haskell,- 'Lift' instances should be derived external to this splice via 'deriveLift' or- 'deriveLiftMany'.+ * The proof computation itself. Regardless of how the proof is provided as+ an argument, be sure that it's type matches that of the type ascribed to+ the call to 'cacheProof'. -}-newExtension :: String -> ExpQ -> Q [Dec]-newExtension ext val =- do val' <- val- case val' of- SigE e eTy -> - let name = mkName ext- ty = NewtypeD [] name [] - (NormalC name [(NotStrict, eTy)]) [''Typeable]- extCls = InstanceD [] (ConT ''ExtClass `AppT` ConT name)- [ValD (VarP 'initValue) (NormalB $- ConE name `AppE` e) []] in- return [ty, extCls]- _ -> fail "newExtension: provided value must be annotated with a type."+cacheProof :: PolyTheory thry thry' => String -> TheoryPath thry + -> HOL Proof thry HOLThm + -> HOL cls thry' HOLThm+cacheProof lbl (TheoryPath fp) prf = HOL $ \ acid _ ->+ do qth <- query acid (GetProof lbl)+ case qth of+ Just th -> + return th+ Nothing ->+ do putStrLn ("proving: " ++ lbl)+ th <- runHOLUnsafe prf acid fp+ putStrLn (lbl ++ " proved.")+ update acid (InsertProof lbl th)+ return th --- lift derivations-deriveLift ''ExtState+{-|+ This is a version of 'cacheProof' that handles proof computations that return+ multiple theorems. Essentially, it maps 'cacheProof' over+ the list of labels, where each resultant computation retrieves only a single+ theorem, but can store them all.+ + The decision to return a list of computations was inherited from a previous + implementation technique. It can result in some messy code when you want to+ provide top-level names for each computation, but works fairly well otherwise.+-}+cacheProofs :: forall cls thry thry'. PolyTheory thry thry' => [String] + -> TheoryPath thry + -> HOL Proof thry [HOLThm] + -> [HOL cls thry' HOLThm]+cacheProofs lbls (TheoryPath fp) prf = map cacheProofs' lbls+ where cacheProofs' :: String -> HOL cls thry' HOLThm+ cacheProofs' lbl = HOL $ \ acid _ ->+ do qth <- query acid (GetProof lbl)+ case qth of+ Just th -> + return th+ Nothing -> + do qths <- liftM catMaybes $ + mapM (query acid . GetProof) lbls+ unless (null qths) . fail $+ "cacheProofs: some provided labels clas with " +++ "existing theorems."+ putStrLn ("proving: " ++ unwords lbls)+ ths <- runHOLUnsafe prf acid fp+ putStrLn (unwords lbls ++ " proved.")+ when (length lbls /= length ths) . fail $+ "cacheProofs: number of labels does not match " +++ "number of theorems."+ mapM_ (\ (x, y) -> update acid (InsertProof x y)) $ + zip lbls ths+ let n = fromJust $ elemIndex lbl lbls+ th = ths !! n+ return th++{-| + Similar to 'createCheckpointAndCloseHOL', this method creates a checkpoint+ and archive for the proofs cache specifically.+-}+checkpointProofs :: HOL cls thry ()+checkpointProofs = HOL $ \ acid _ ->+ do createCheckpoint acid+ createArchive acid++{-| + A version of 'cleanArchives' for the proofs cache specifically.+-}+cleanArchiveProofs :: HOL cls thry ()+cleanArchiveProofs = HOL $ \ _ _ ->+ do dir <- liftM mkFilePath getDataDir+ let dir' = dir </> ("Proofs" :: FilePath) </> ("Archive" :: FilePath)+ shelly $ rm_rf dir'