packages feed

haskhol-core (empty) → 1.0.0

raw patch · 26 files changed

+8836/−0 lines, 26 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, parsec, pretty, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2013, University of Kansas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++  * 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskhol-core.cabal view
@@ -0,0 +1,59 @@+name:          haskhol-core+version:       1.0.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>. +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+build-type:    Simple+stability:     experimental+Homepage:      haskhol.org+ +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++    exposed-modules:+      HaskHOL.Core+      HaskHOL.Core.Basics+      HaskHOL.Core.Lib     +      HaskHOL.Core.Lib.Lift+      HaskHOL.Core.Kernel  +      HaskHOL.Core.Kernel.Terms+      HaskHOL.Core.Kernel.Types +      HaskHOL.Core.State   +      HaskHOL.Core.State.Monad+      HaskHOL.Core.Parser  +      HaskHOL.Core.Printer+      HaskHOL.Core.Ext	++    exposed: True+    buildable: True+    hs-source-dirs: src++    other-modules:+      HaskHOL.Core.Basics.Nets+      HaskHOL.Core.Ext.Protected    +      HaskHOL.Core.Ext.QQ+      HaskHOL.Core.Kernel.Prims+      HaskHOL.Core.Parser.Elab+      HaskHOL.Core.Parser.Lib  +      HaskHOL.Core.Parser.Rep +      HaskHOL.Core.Parser.TermParser   +      HaskHOL.Core.Parser.TypeParser      +             +    ghc-prof-options: -prof -fprof-auto+    ghc-options: -Wall++source-repository head+  type: git +  location: git://github.com/ecaustin/haskhol-core.git
+ src/HaskHOL/Core.hs view
@@ -0,0 +1,130 @@+{-|+  Module:    HaskHOL.Core+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module is the one to import for users looking to include the entirety of+  the core of the HaskHOL proof system.  It re-exports all of the core +  sub-modules in addition to a number of overloaded functions that work with+  'HOLTermRep' and 'HOLTypeRep' representations for convenience reasons.+-}+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 ()+      -- * Library and Utility Functions+    , module HaskHOL.Core.Lib+      -- * Logical Kernel+    , module HaskHOL.Core.Kernel+      -- * Stateful Primitives+    , module HaskHOL.Core.State+      -- * Basic Derived Type and Term Functions+    , module HaskHOL.Core.Basics+      -- * HaskHOL Parsers+    , module HaskHOL.Core.Parser+      -- * HaskHOL Pretty Printers+    , module HaskHOL.Core.Printer+      -- * HaskHOL Core Extensions+    , module HaskHOL.Core.Ext+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State hiding ( newConstant, newAxiom, newBasicDefinition )+import HaskHOL.Core.Basics+import HaskHOL.Core.Parser hiding ( makeOverloadable, reduceInterface +                                  , overrideInterface, overloadInterface+                                  , prioritizeOverload, newTypeAbbrev )+import HaskHOL.Core.Printer+import HaskHOL.Core.Ext++import qualified HaskHOL.Core.State as S ( newConstant, newAxiom+                                         , newBasicDefinition )+import qualified HaskHOL.Core.Parser as P ( makeOverloadable, reduceInterface +                                          , overrideInterface, overloadInterface+                                          , prioritizeOverload, newTypeAbbrev )+-- 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 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 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+++-- from parser+{-|+  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 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 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 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 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 = 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 s = P.newTypeAbbrev s <=< toHTy
+ src/HaskHOL/Core/Basics.hs view
@@ -0,0 +1,1005 @@+{-# LANGUAGE ViewPatterns #-}++{-|+  Module:    HaskHOL.Core.Basics+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines common utility functions that depend on data types+  introduced by HaskHOL. See the "HaskHOL.Core.Lib" module for utility functions+  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+      -- * Common Type Functions+    , occursIn   -- :: HOLType -> HOLType -> Bool+    , tysubst    -- :: HOLTypeEnv -> HOLType -> Either String HOLType+    , alphaUtype -- :: HOLType -> HOLType -> Either String HOLType+      -- * 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+      -- * Common Theorem Functions+    , typeVarsInThm -- :: HOLThm -> [HOLType]+    , thmFrees      -- :: HOLThm -> [HOLTerm]+      -- * 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)+      -- * 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+      -- * 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]+      -- * 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)+      -- * 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)+      -- * 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+      -- * Term Nets+    , module HaskHOL.Core.Basics.Nets+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State+import HaskHOL.Core.Basics.Nets++-- Term 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 n ty =+    do count <- tickTermCounter+       return $! mkVar (n ++ show count) ty++-- | A version of 'genVarWithName' that defaults to the prefix \"_\".+genVar :: HOLType -> HOL cls thry HOLTerm+genVar = genVarWithName "_"++-- functions for manipulating types+{-| +  Checks to see if the first type occurs in the second type.  Note that the+  predicate is also satisfied if the two types are equal.+-}+occursIn :: HOLType -> HOLType -> Bool+occursIn ty bigTy+  | ty == bigTy = True+  | otherwise = case view bigTy of+                  TyApp _ args -> any (occursIn ty) args+                  _ -> False+++{-| +  Basic type substitution that ignores type operators and prunes the +  substitution environment of bound variables rather than handle renaming.+  Works for all types, variable and non-variable alike.  Fails with 'Left' when +  the substitution would result in an invalid type construction.++  Note that the order of the elements of the substitution pairs matches other +  environments in the systems, such that for the pair @(A, B)@ @B@ will be +  substituted for all instances of @A@.+-}+tysubst :: HOLTypeEnv -> HOLType -> Either String HOLType+tysubst env ty =+  note "tysubst" (lookup ty env) +  <|> case view 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"++{-|+  Alpha conversion for universal types.  Renames a bound type variable to match+  the name of a provided type variable.  Fails with 'Left' in the following+  cases:++  * First type is not a small type variable.++  * Second type is not a universal type.++  * 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)+    | 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{}) = +  Left "alphaUtype: first type not a small type variable."+alphaUtype _ _ = Left "alphaUtype: second type not a universal type."++-- functions for manipulating terms+{-| +  Predicate to check if the first term is free in the second modulo+  alpha-equivalence.+-}+freeIn :: HOLTerm -> HOLTerm -> Bool+freeIn tm1 tm2 =+  (tm1 `aConv` tm2) ||+  (case view 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)++{-| +  Basic term substitution.  Throws a 'HOLException' when the substitution would +  result in an invalid term construction.++  Note that the order of the elements of the substitution pairs matches other +  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 ilist tm =+    let (xs, ts) = unzip ilist in+      do gs <- mapM (genVar . typeOf) xs+         tm' <- liftEither "subst" $ ssubst (zip xs gs) tm+         if tm' == tm+            then return tm+            else return $! 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+                Comb f x -> +                  liftM1 mkComb (ssubst env f) =<< ssubst env x+                Abs bv bod -> +                  mkAbs bv =<< +                    ssubst (filter (not . varFreeIn bv . fst) env) bod+                TyAbs ty bod ->+                  mkTyAbs ty =<< +                    ssubst (filter (\ (_, x) -> ty `notElem` +                                                typeVarsInTerm x) env) bod+                TyComb bod ty ->+                  liftM1 mkTyComb (ssubst env bod) ty+                _ -> Right t++{-|+  Alpha conversion for term abstractions.  Renames a bound variable to match+  the name of a provided variable.  Fails with 'Left' in the following cases:++  * First term is not a variable.++  * Second term is not an abstraction.++  * The types of the variable and bound variable do no agree.++  * 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)+    | 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) <?> +                    "alpha: construction of abstraction failed."+alpha _ (view -> Abs{}) = Left "alpha: first term not a variable."+alpha _ _ = Left "alpha: second term not an abstraction."++{-|+  Alpha conversion for type abstractions.  Renames a bound type variable to+  match the name of a provided type variable.  Fails with 'Left' in the +  following cases:++  * The provided type is not a small type variable.++  * The provided term is not a type abstraction.++  * 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)+    | 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{}) = +    Left "alphaTyabs: type not a small type variable."+alphaTyabs _ _ = +    Left "alphaTyabs: term not a type abstraction."++-- searching for terms+{-| +  Searches a term for a subterm that satisfies a given predicate.  Fails with+  'Nothing' if no such term is found.+-}+findTerm :: (HOLTerm -> Bool) -> HOLTerm -> Maybe HOLTerm+findTerm p tm+    | p tm = Just tm+    | otherwise =+        case view 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++-- | 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 =+            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'+                _ -> tl'++-- Director strings down a term+{-|+  Searches a term for a subterm that satisfies a given predicate, returning+  a string that indicates the path to that subterm:++  * @\'b\'@ - Take the body of an abstraction.+  +  * @\'t\'@ - Take the body of a type abstraction.+  +  * @\'l\'@ - Take the left path in a term combination.+  +  * @\'r\'@ - Take the right path in a term combination.+  +  * @\'c\'@ - Take the body in a type combination.++  Fails with 'Nothing' if there is no satisfying subterm.+-}+findPath :: (HOLTerm -> Bool) -> HOLTerm -> Maybe String+findPath p tm+    | p tm = Just []+    | otherwise =+        case view tm of+          Abs _ bod -> liftM ((:) 'b') $ findPath p bod+          TyAbs _ bod -> liftM ((:) 't') $ findPath p bod+          Comb l r -> liftM ((:) 'r') (findPath p r) <|>+                      liftM ((:) 'l') (findPath p l)+          TyComb bod _ -> liftM ((:) 'c') $ findPath p bod+          _ -> Nothing++{-|+  Returns the subterm found by following a 'String' path as produced by +  'findPath'.  Fails with 'Nothing' if the provided term does not a suitable +  subterm for the given path.+-}+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 _ _ = Nothing++-- theorem manipulators+-- | Returns the list of all free type variables in a theorem.+typeVarsInThm :: HOLThm -> [HOLType]+typeVarsInThm (view -> Thm asl c) =+    foldr (union . typeVarsInTerm) (typeVarsInTerm c) asl++-- | Returns the list of all free term variables in a theorem.+thmFrees :: HOLThm -> [HOLTerm]+thmFrees (view -> Thm asl c) = +    foldr (union . frees) (frees c) asl++-- more syntax+{-|+  Constructs a complex combination that represents the application of a +  function to a list of arguments.  Fails with 'Left' if any internal call to +  'mkComb' fails.+-}+listMkComb :: HOLTerm -> [HOLTerm] -> Either String HOLTerm+listMkComb = foldlM mkComb++{-|+  Constructs a complex abstraction that represents a term with multiple+  bound variables.  Fails with 'Left' if any internal call to 'mkAbs' fails.+-}+listMkAbs :: [HOLTerm] -> HOLTerm -> Either String HOLTerm+listMkAbs = flip (foldrM mkAbs)++-- Useful function to create stylized arguments using numbers+{-|+  Constructs a list of term variables of a given prefix.  Names are adjusted+  as necessary with 'variant' to avoid clashing with the provided list of term+  variables.  The number and types of the resultant variables is directed by +  the provided list of types, i.e.++  > mkArgs "x" avoids [ty1, ... tyn] === [x1:ty1, ..., xn:tyn] where {x1, ..., xn} are not elements of avoids+-}+mkArgs :: String -> [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]+        mkRec _ _ _ [] = []+        mkRec n x avs (y:ys) =+          let v' = variant avs $ mkVar (x ++ show n) y+              vs = mkRec (n + 1) x (v':avs) ys in+            (v':vs)++{-| +  Returns the left term of a combination.  Fails with 'Nothing' if the provided+  term is not a combination.+-}+rator :: HOLTerm -> Maybe HOLTerm+rator (view -> Comb l _) = Just l+rator _ = Nothing++{-|+  Returns the right term of a combination.  Fails with 'Nothing' if the provided+  term is not a combination.+-}+rand :: HOLTerm -> Maybe HOLTerm+rand (view -> Comb _ r) = Just r+rand _ = Nothing++{-|+  Returns the bound term of an abstraction.  Fails with 'Nothing' if the+  provided term is not an abstraction.+-}+bndvar :: HOLTerm -> Maybe HOLTerm+bndvar (view -> Abs bv _) = Just bv+bndvar _ = Nothing++{-|+  Returns the body term of an abstraction.  Fails with 'Nothing' if the+  provided term is not an abstraction.+-}+body :: HOLTerm -> Maybe HOLTerm+body (view -> Abs _ bod) = Just bod+body _ = Nothing++{-|+  Returns the bound type of a type abstraction.  Fails with 'Nothing' if the+  provided term is not a type abstraction.+-}+bndvarTyabs :: HOLTerm -> Maybe HOLType+bndvarTyabs (view -> TyAbs bv _) = Just bv+bndvarTyabs _ = Nothing++{-|+  Returns the body term of a type abstraction.  Fails with 'Nothing' if the+  provided term is not a type abstraction.+-}+bodyTyabs :: HOLTerm -> Maybe HOLTerm+bodyTyabs (view -> TyAbs _ bod) = Just bod+bodyTyabs _ = Nothing++{-|+  Destructs a complex combination returning its function term and its list of+  argument terms.+-}+stripComb :: HOLTerm -> (HOLTerm, [HOLTerm])+stripComb = revSplitList destComb++{-|+  Destructs a complex abstraction returning its list of bound variables and its+  body term.+-}+stripAbs :: HOLTerm -> ([HOLTerm], HOLTerm)+stripAbs = splitList destAbs++-- type matching+{-|+  Computes a tiplet of substitution environments that can be used to make two+  types match.  The triplet argument can be used to constrain the match, or+  its three environments can be left empty to find the most general match.+  Fails with 'Nothing' in the event that a match cannot be found that satisfies+  the provided constraint.+-}+typeMatch :: HOLType -> HOLType -> SubstTrip -> Maybe SubstTrip+typeMatch vty cty sofar =+    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))+            | v `elem` env = Just acc+            | otherwise =+                case lookup v sfar of+                  Just c'+                    | 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) =+            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))+            | vop == cop = foldr2M typeMatchRec acc vargs cargs+            | isTypeOpVar vop && isTypeOpVar cop =+                do copTy <- hush . uTypeFromTypeOpVar cop $ length cargs+                   case lookup vop opTys of+                     Just cop'+                         | cop' == copTy -> +                             foldr2M typeMatchRec acc vargs cargs+                         | otherwise -> Nothing+                     Nothing -> +                         foldr2M typeMatchRec +                           (env, (sfar, (vop, copTy):opTys, opOps)) vargs cargs +            | isTypeOpVar vop =+                case lookup vop opOps of+                  Just cop'+                    | cop' == cop -> foldr2M typeMatchRec acc vargs cargs+                    | otherwise -> Nothing+                  Nothing -> +                      foldr2M typeMatchRec +                        (env, (sfar, opTys, (vop, cop):opOps)) vargs cargs+            | otherwise = Nothing+        typeMatchRec _ _ _ = Nothing++-- matching version of mkConst+{-|+  Constructs an instance of a constant of the provided name and type.  Relies+  internally on 'typeMatch' in order to provide a match between the most general+  type of the constant and the provided type.  Throws a 'HOLException' in the+  following cases:++  * The provided string is not the name of a defined constant.++  * Type matching fails.+-}+mkMConst :: String -> HOLType -> HOL cls thry HOLTerm+mkMConst name ty = +  do uty <- getConstType name <?> "mkMConst: not a constant name"+     (mkConstFull name . fromJust $ typeMatch uty ty ([], [], [])) <?>+       "mkMConst: generic type cannot be instantiated"++{-|+  A version of 'mkComb' that instantiates the type variables in the left hand+  argument.  Relies internally on 'typeMatch' in order to provide a match+  between the domain type of the function and the type of the argument.  Fails+  with 'Nothing' if instantiation is impossible.+-}+mkIComb :: HOLTerm -> HOLTerm -> Maybe HOLTerm+mkIComb tm1 tm2 =+    do (ty, _) <- destFunTy $ typeOf tm1+       mat <- typeMatch ty (typeOf tm2) ([], [], [])+       hush $ mkComb (instFull mat tm1) tm2++{-|+  An iterative version of 'mkIComb' that builds a complex combination given a+  constant name and a list of arguments, attempting to find a correct+  instantiation at every step.  Throws a 'HOLException' in the following cases:++  * The provided name is not a currently defiend constant.++  * Any internal call to mkIComb fails.+-}+listMkIComb :: String -> [HOLTerm] -> HOL cls thry HOLTerm+listMkIComb cname args =+    do cnst <- mkConst cname ([]::HOLTypeEnv) <?> +                 "listMkIComb: not a constant name"+       liftMaybe "listMkIComb: type cannot be instantiated" $+         foldlM mkIComb cnst args+                                          +-- syntax for binary operators+{-| +  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 _ _ = 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 _ _ = False++{-|+  Destructs a binary application returning its left and right arguments.  Fails +  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)+    | s == s' = Just (l, r)+    | otherwise = Nothing+destBinary _ _ = Nothing++-- | 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)+    | op' == op = Just (l, r)+    | otherwise = Nothing+destBinop _ _ = Nothing++{-|+  Constructs a binary application given a constant name and two argument terms.+  Note that no instantiation is performed, thus the constant must be monomorphic+  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 s l r = +  (do c <- mkConst s ([]::HOLTypeEnv)+      fromRightM $ mkComb (fromRight $ mkComb c l) r)+  <?> "mkBinary: " ++ s++{-| +  A version of 'mkBinary' that accepts the operator as a pre-constructed term.+-}+mkBinop :: HOLTerm -> HOLTerm -> HOLTerm -> Either String HOLTerm+mkBinop op tm1 tm2 =+  liftM1 mkComb (mkComb op tm1) tm2 <?> "mkBinop"++{-| +  Iteratively builds a complex combination using 'mkBinop', i.e.+ +  > listMkBinop (/\) [T, F, T] === T /\ F /\ T+-} +listMkBinop :: HOLTerm -> [HOLTerm] -> Either String HOLTerm+listMkBinop = foldr1M . mkBinop++{-|+  The inverse of 'listMkBinop'.  Destructs a complex combination built with+  a binary operator into its list of arguments.+-}+binops :: HOLTerm -> HOLTerm -> [HOLTerm]+binops = stripList . destBinop++-- syntax for complex abstractions+-- | Predicate for generalized abstractions.  See 'mkGAbs' for more details.+isGAbs :: HOLTerm -> Bool+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 _ _ = 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 _ _ = False++{-| +  Destructor for generalized abstractions.  Fails with 'Nothing' if the provided+  term is not an abstraction or generalized abstraction.  See 'mkGAbs' for more +  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)+  where destGeq :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+        destGeq = destBinary "GEQ"+destGAbs _ = Nothing++{-|+  Destructs an abstraction of specified binder name into its bound variable and+  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))+    | s == s' = Just (bv, t)+    | otherwise = Nothing+destBinder _ _ = Nothing++{-|+  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))+    | s == s' = Just (bv, t)+    | otherwise = Nothing+destTyBinder _ _ = Nothing++{-|+  Constructor for generalized abstractions.  Generalized abstractions extend+  term abstractions to the more general of notion of a function mapping some+  structure to some term.  This allows us to bind patterns more complicated+  than a variable, i.e. binding pairs++  > \ (x:num, y:num) -> x + y++  or lists++  > \ CONS x xs -> x++  Note that in the case where the pattern to bind is simply a variable 'mkGAbs'+  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 tm2 = +    let fvs = frees tm1 in+      (do fTy <- mkFunTy (typeOf tm1) $ typeOf tm2+          let f = variant (frees tm1++frees tm2) $ mkVar "f" fTy+          bodIn <- listMkForall fvs =<< mkGEq (fromRight $ mkComb f tm1) tm2+          bndr <- mkConst "GABS" [(tyA, fTy)]+          fromRightM $ mkComb bndr =<< mkAbs f bodIn)+      <?> "mkGAbs"+  where mkGEq :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+        mkGEq t1 t2 = +          do p <- mkConst "GEQ" [(tyA, typeOf t1)]+             fromRightM $ mkBinop p t1 t2++{-|+  Constructs an abstraction given a binder name and two argument terms.  Throws+  a 'HOLException' if any of the internal calls to 'mkConst', 'mkAbs', or +  'mkComb' fail.++  Note that the given string can actually be any constant name of type +  @(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 op v tm = +    (do c <- mkConst op [(tyA, typeOf v)]+        fromRightM $ mkComb c =<< mkAbs v tm)+    <?> "mkBinder: " ++ op++{-|+  Constructs a type abstraction given a type binder name, a type variable to+  find, and a body term.  Throws a 'HOLException' if any of the internal calls+  to 'mkConst', 'mkTyAbs', or 'mkComb' fail.++  Note that the given string can actually be any constant name of type+  @(% '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 op v tm =+  (do c <- mkConst op ([]::HOLTypeEnv)+      fromRightM $ mkComb c =<< mkTyAbs v tm)+  <?> "mkTyBinder: " ++ op++-- | A specific version of 'listMkAbs' for general abstractions.+listMkGAbs :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm+listMkGAbs = flip (foldrM mkGAbs)++-- | A specific version of 'stripAbs' for general abstractions.+stripGAbs :: HOLTerm -> ([HOLTerm], HOLTerm)+stripGAbs = splitList destGAbs++-- common special cases of binary ops+-- | Predicate for boolean conjunctions.+isConj :: HOLTerm -> Bool+isConj = isBinary "/\\"++-- | Predicate for boolean implications.+isImp :: HOLTerm -> Bool+isImp = isBinary "==>"++-- | Predicate for universal term quantification.+isForall :: HOLTerm -> Bool+isForall = isBinder "!"++-- | Predicate for existential term quantification.+isExists :: HOLTerm -> Bool+isExists = isBinder "?"++-- | Predicate for boolean disjunctions.+isDisj :: HOLTerm -> Bool+isDisj = isBinary "\\/"++-- | Predicate for boolean negations.+isNeg :: HOLTerm -> Bool+isNeg (view -> Comb (view -> Const "~" _ _) _) = True+isNeg _ = False++-- | Predicate for unique, existential quantification.+isUExists :: HOLTerm -> Bool+isUExists = isBinder "?!"++-- | Predicate for term-level universal type quantification.+isTyAll :: HOLTerm -> Bool+isTyAll = isTyBinder "!!"++-- | Predicate for term-level existential type quantification.+isTyEx :: HOLTerm -> Bool+isTyEx = isTyBinder "??"++-- | Destructor for boolean conjunctions.+destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destConj = destBinary "/\\"++-- | Destructor for boolean implications.+destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destImp = destBinary "==>"++-- | Destructor for universal term quantification.+destForall :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destForall = destBinder "!"++-- | Destructor for existential term quantification.+destExists :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destExists = destBinder "?"++-- | Destructor for boolean disjunctions.+destDisj :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destDisj = destBinary "\\/"++-- | Destructor for boolean negations.+destNeg :: HOLTerm -> Maybe HOLTerm+destNeg (view -> Comb (view -> Const "~" _ _) p) = Just p+destNeg _ = Nothing++-- | Destructor for unique, existential quantification.+destUExists :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destUExists = destBinder "?!"++-- | Destructor for term-level universal type quantification.+destTyAll :: HOLTerm -> Maybe (HOLType, HOLTerm)+destTyAll = destTyBinder "!!"++-- | Destructor for term-level existential type quantification.+destTyEx :: HOLTerm -> Maybe (HOLType, HOLTerm)+destTyEx = destTyBinder "??"++{-|+  Constructor for boolean conjunctions.  Throws a 'HOLException' if the internal+  call to 'mkBinary' fails.+-}+mkConj :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkConj = mkBinary "/\\"++{-|+  Constructor for boolean implications.  Throws a 'HOLException' if the internal+  call to 'mkBinary' fails.+-}+mkImp :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkImp = mkBinary "==>"++{-| +  Constructor for universal term quantification.  Throws a 'HOLException' if the+  internal call to 'mkBinder' fails.+-}+mkForall :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkForall = mkBinder "!"++{-| +  Constructor for existential term quantification.  Throws a 'HOLException' if +  the internal call to 'mkBinder' fails.+-}+mkExists :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkExists = mkBinder "?"++{-|+  Constructor for boolean disjunctions.  Throws a 'HOLException' if the internal+  call to 'mkBinary' fails.+-}+mkDisj :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkDisj = mkBinary "\\/"++{-|+  Constructor for boolean negations.  Throws a 'HOLException' if any of the +  internal calls to 'mkConst' or 'mkComb' fail.+-}+mkNeg :: HOLTerm -> HOL cls thry HOLTerm+mkNeg tm = +    (do c <- mkConst "~" ([]::HOLTypeEnv)+        fromRightM $ mkComb c tm)+    <?> "mkNeg"++{-| +  Constructor for unique, existential term quantification.  Throws a +  'HOLException' if the internal call to 'mkBinder' fails.+-}+mkUExists :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkUExists = mkBinder "?!"++{-|+  Constructor for term-level universal type quantification.  Throws a +  'HOLException' if the internal call to 'mkTyBinder' fails.+-}+mkTyAll :: HOLType -> HOLTerm -> HOL cls thry HOLTerm+mkTyAll = mkTyBinder "!!"++{-|+  Constructor for term-level existential type quantification.  Throws a +  'HOLException' if the internal call to 'mkTyBinder' fails.+-}+mkTyEx :: HOLType -> HOLTerm -> HOL cls thry HOLTerm+mkTyEx = mkTyBinder "??"++-- | Constructs a complex conjunction from a given list of propositions.+listMkConj :: [HOLTerm] -> HOL cls thry HOLTerm+listMkConj = foldr1M mkConj++-- | A specific version of 'listMkAbs' for universal term quantification.+listMkForall :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm+listMkForall = flip (foldrM mkForall)++-- | A specific version of 'listMkAbs' for existential term quantification.+listMkExists :: [HOLTerm] -> HOLTerm -> HOL cls thry HOLTerm+listMkExists vs bod = foldrM mkExists bod vs++-- | Constructs a complex disjunction from a given list of propositions.+listMkDisj :: [HOLTerm] -> HOL cls thry HOLTerm+listMkDisj = foldr1M mkDisj++-- | Returns the list of propositions in a complex conjunction.+conjuncts :: HOLTerm -> [HOLTerm]+conjuncts = stripList destConj++-- | Returns the list of propositions in a complex disjunction.+disjuncts :: HOLTerm -> [HOLTerm]+disjuncts = stripList destDisj++-- | A specific version of 'stripAbs' for universal term quantification.+stripForall :: HOLTerm -> ([HOLTerm], HOLTerm)+stripForall = splitList destForall++-- | A specific version of 'stripAbs' for existential term quantification.+stripExists :: HOLTerm -> ([HOLTerm], HOLTerm)+stripExists = splitList destExists++{-| +  A specific version of 'stripAbs' for term-level universal type quantification.+-}+stripTyAll :: HOLTerm -> ([HOLType], HOLTerm)+stripTyAll = splitList destTyAll++{-| +  A specific version of 'stripAbs' for term-level existential type +  quantification.+-}+stripTyEx :: HOLTerm -> ([HOLType], HOLTerm)+stripTyEx = splitList destTyEx++-- syntax for other terms+-- | Predicate for list @CONS@.+isCons :: HOLTerm -> Bool+isCons = isBinary "CONS"++-- | Predicate for list terms.+isList :: HOLTerm -> Bool+isList = isJust . destList++-- | Predicate for let binding terms.+isLet :: HOLTerm -> Bool+isLet = isJust . destLet++-- | Destructor for list @CONS@.+destCons :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destCons = destBinary "CONS"++{-|+  Destructor for list terms.  Returns a list of the elements in the term.  Fails+  with 'Nothing' if internall the term is not of the form++  > x1 `CONS` .... xn `CONS` NIL+-}+destList :: HOLTerm -> Maybe [HOLTerm]+destList tm =+    let (tms, nil) = splitList destCons tm in+      case view nil of+        (Const "NIL" _ _) -> Just tms+        _ -> Nothing++{-|+  Destructs a let binding term into a list of its name and value pairs and its+  body term.  Fails with 'Nothing' if internally the term is not of the form++  > LET (x1, v1) ... (xn, vn) LET_END+-}+destLet :: HOLTerm -> Maybe ([(HOLTerm, HOLTerm)], HOLTerm)+destLet tm =+  case stripComb tm of+    (view -> 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)+          _ -> Nothing+    _ -> Nothing++{-|+  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') =+          liftM (2 *) $ destNum r'+        destNum (view -> Comb (view -> Const "BIT1" _ _) r') =+          liftM (\ x -> 1 + 2 * x) $ destNum r'+        destNum _ = Nothing+destNumeral _ = Nothing
+ src/HaskHOL/Core/Basics.hs-boot view
@@ -0,0 +1,8 @@+module HaskHOL.Core.Basics where+ +import HaskHOL.Core.Kernel+import HaskHOL.Core.State++genVar :: HOLType -> HOL cls thry HOLTerm++stripComb :: HOLTerm -> (HOLTerm, [HOLTerm])
+ src/HaskHOL/Core/Basics/Nets.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE TemplateHaskell #-}++{-|+  Module:    HaskHOL.Core.Basics.Nets+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines term nets, an efficient tree structure used for fast +  lookups of values that match a given "pattern" term.  Typically term nets are+  used to store a collection of conversions or tactics to be used for rewriting.+  By associating these operations with the pattern that they are valid for, the+  rewrite process can quickly prune computations that will obviously fail.++  For more information see the "nets" module from John Harrison's HOL Light.+-}+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+       ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State+import {-# SOURCE #-} HaskHOL.Core.Basics (genVar, stripComb)++-- ordered, unique insertion for sets as lists+setInsert :: Ord a => a -> [a] -> [a]+setInsert a xs = fromMaybe xs $ sinsert a xs+  where sinsert :: Ord a => a -> [a] -> Maybe [a]+        sinsert x [] = Just [x]+        sinsert x l@(h:t)+            | h == x = Nothing+            | x < h = Just (x:l)+            | otherwise = do t' <- sinsert x t+                             return (h:t')++-- ordered, unique merging of two sets+setMerge :: Ord a => [a] -> [a] -> [a]+setMerge [] l2 = l2+setMerge l1 [] = l1+setMerge l1@(h1:t1) l2@(h2:t2)+    | h1 == h2 = h1 : setMerge t1 t2+    | h1 < h2 = h1 : setMerge t1 l2+    | otherwise = h2 : setMerge l1 t2++-- 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+     | LNet Int         -- term abstraction+     | LTyAbs           -- type abstraction+     | LTyComb          -- type combination+     deriving (Eq, Show)+       +{-|+  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+  the following guidelines:++  * Flattening of combinations favors the left hand side such that the head of +    an application is looked at first.++  * If the head of an application is variable, the whole term is considered +    variable.++  * Type abstractions and type combinations are effectively treated as local +    constants, though they do have their own node lable representations to avoid+    any potential issues with user provided variable lists for 'enter'.++  * Matching is conservative, such that all matching values will be returned, +    but some non-matching values may be returned.  For example, a pattern term +    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++-- | The empty 'Net'.+netEmpty :: Net a+netEmpty = NetNode [] []++{-+  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 lconsts tm = +    let (op, args) = stripComb tm in+      case view op of+        (Const x _ _) -> return (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, [])+        _ -> 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 _ (b, [], NetNode edges tips) = +    return . 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++{-| +  Inserts a new element, paired with a pattern term, into a provided net.  The +  first argument is a list of variables that should be treated as local +  constants, such that only patterns with those variables at the exact same +  position will match.  See the documentation for 'Net' for more details.++  Never fails.+-}+netEnter :: Ord a => [HOLTerm] -> (HOLTerm, a) -> Net a -> HOL cls thry (Net a)+netEnter lconsts (tm, b) net = netUpdate lconsts (b, [tm], net)++{-+  Generates a node label from a provided pattern term.  Differs from+  labelToStore in that no list of local constants to consider is given.+-}+labelForLookup :: HOLTerm -> (TermLabel, [HOLTerm])+labelForLookup tm =+    let (op, args) = stripComb tm in+      case view op of+        (Const x _ _ ) -> (CNet x (length args), args)+        (Abs _ bod) -> (LNet (length args), bod:args)+        (TyAbs _ t) -> (LTyAbs, [t])+        (TyComb t _) -> (LTyComb, [t])+        (Var x _) -> (LCNet x (length args), args)+        _ -> error "labelForLookup: stripComb broken"++{-+  Traverses a Net following the labels generated from pattern terms via+  labelForLookup.  Returns a list of all values that satisfy the generated+  pattern.+-}+follow :: ([HOLTerm], Net a) -> [a]+follow ([], NetNode _ tips) = tips+follow (tm:rtms, NetNode edges _) = +    let (label, ntms) = labelForLookup tm+        collection = case lookup label edges of+                       Just child -> follow (ntms++rtms, child)+                       Nothing -> [] in+      if label == VNet then collection+      else case lookup VNet edges of+             Just vn -> collection ++ follow (rtms, vn)+             Nothing -> collection++{-|+  Returns the list of all values stored in a term net that satisfy a provided+  pattern term.  See the documentation for 'Net' for more details.+-}+netLookup :: HOLTerm -> Net a -> [a]+netLookup tm net = follow ([tm], net)++{-|+  Merges two term nets together.  The values for the two nets are merged,+  maintaining order and uniqueness, with the term labels adjusted appropriately.+  The algorithm to do so is courtesy of Don Syme via John Harrison's+  implementation in HOL Light.+-}+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]
+ src/HaskHOL/Core/Ext.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE TemplateHaskell #-}++{-|+  Module:    HaskHOL.Core.Ext+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module exports HaskHOL's non-trivial extensions to the underlying HOL+  system, i.e. the compile time operations.  These operations are split into+  three categories:++  * Methods related to the Protect and Serve Mechanism for sealing and unsealing+    data against a provided theory context.++  * Methods related to quasi-quoting of 'HOLTerm's.  ++  * Methods related to compile time extension and caching of theory contexts.+-}+module HaskHOL.Core.Ext+    ( -- * Protected Data Methods+       -- $Protect+      module HaskHOL.Core.Ext.Protected+      -- * Quasi-Quoter Methods+       -- $QQ+    , module HaskHOL.Core.Ext.QQ+      -- * Theory Extension Methods+    , extendCtxt -- :: Typeable thry => HOLContext thry -> +                 --    HOL cls thry () -> Name -> String -> Q [Dec]+      -- * Template Haskell Re-Exports+    , module Language.Haskell.TH {-|+        Re-exports 'Q', 'Dec', and 'Exp' for the purpose of writing type+        signatures external to this module.+      -}+    , module Language.Haskell.TH.Quote {-|+        Re-exports 'QuasiQuoter' for the purpose of writing type signatures+        external to this module.+      -}+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel hiding (typeOf)+import HaskHOL.Core.State++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++{-|+  Extends a theory by evaluating a provided computation, returning a list of+  declarations containing:++  * 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.++  For example:++  > extendCtxt ctxtBase loadBoolLib "bool"++  will produce the following code++  > data BoolThry deriving Typeable+  > 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+  >+  > 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+        -- upper case label for everything else+        upLbl = toUpper (head lbl) : tail lbl+        -- type of old theory+        oldThry = buildOldThry . head . typeRepArgs $ typeOf ctx+        -- general use type variables+        aName = mkName "a"+        aVar = VarT aName+        bVar = VarT $ mkName "b"+-- build data types+        dataName = mkName $ upLbl ++ "Thry"+        dataType = ConT dataName+        dataDec = DataD [] dataName [] [] [''Typeable]+        tyName = mkName $ upLbl ++ "Type"+        newThry = extThry `AppT` dataType `AppT` 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)) []+-- 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+-- build QuasiQuoter+        qqName = mkName lowLbl+        qqTySig = SigD qqName $ ConT ''QuasiQuoter+        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' ++-- Documentation copied from sub-modules++{-$Protect+  The basic goal behind the Protect and Serve mechanism is to recapture some of+  the efficiency lost as a result of moving from an impure, interpretted host +  language to a pure, compiled one.  We do this by forcing the evaluation of +  large computations, usually proofs, such that they are only run once. To+  maintain soundness of our proof system, we must track what information+  was used to force the computation and guarantee that information is present+  in all cases where this new value is to be used.  This is the purpose of the+  @Protected@ class and the 'liftProtectedExp' and 'liftProtected' methods.+-}++{-$QQ+  Quasi-quoting provides a way to parse 'HOLTerm's at compile time safely.+  Just as with proofs, we seal these terms against the theory context used to+  parse them with 'protect' and 'serve' to preserve soundness.  See the+  documentation for 'base' for a brief discussion on when quasi-quoting should+  be used vs. 'toHTm'.+-}
+ src/HaskHOL/Core/Ext/Protected.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances, +             FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables,+             TemplateHaskell, TypeFamilies, TypeSynonymInstances, +             UndecidableInstances, ViewPatterns #-}++{-|+  Module:    HaskHOL.Core.Ext.Protected+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines a mechanism for sealing and unsealing values against a+  given context.  Additionally, a number of compile time operations are+  provided that leverage this technique as an example of how it can be used.++  The basic goal behind the content of this module is to recapture some of the+  efficiency lost as a result of moving from an impure, interpretted host +  language to a pure, compiled one.  We do this by forcing the evaluation of +  large computations, usually proofs, such that they are only run once. To+  maintain soundness of our proof system, we must track what information+  was used to force the computation and guarantee that information is present+  in all cases where this new value is to be used.  This is the purpose of the+  @Protected@ class and the 'liftProtectedExp' and 'liftProtected' methods.+-}+module HaskHOL.Core.Ext.Protected+    ( Protected(protect, serve)+    , PData+    , 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]+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel hiding (typeOf)+import HaskHOL.Core.State+import HaskHOL.Core.Parser++import Data.Typeable (typeOf, typeRepArgs)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift(..))++-- protected values+{-|+  The Protected class is the associated type class that facilitates our+  protect/serve protection mechanism.++  It defines:++  * A data wrapper for our protected type.++  * Conversions to/from this new type, protect and serve.++  * Some boilerplate code to enable template haskell lifting.+-}+class Lift a => Protected a where+    data PData a thry+    -- | Protects a value by sealing it against a provided context.+    protect :: HOLContext thry -> a -> PData a thry+    {-| +      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+    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+    protLift (PThm thm) = conE 'PThm `appE` lift thm+-- | Type synonym for protected 'HOLThm's.+type PThm thry = PData HOLThm thry++instance Protected HOLTerm where+    data PData HOLTerm thry = PTm HOLTerm+    protect _ = PTm+    serve (PTm tm) = return tm+    liftTy _ = ''HOLTerm+    protLift (PTm tm) = conE 'PTm `appE` lift tm+-- | Type synonym for protected 'HOLTerm's.+type PTerm thry = PData HOLTerm thry++instance Protected HOLType where+    data PData HOLType thry = PTy HOLType+    protect _ = PTy+    serve (PTy ty) = return ty+    liftTy _ = ''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 HOLTypeRep (PType thry) thry where+    toHTy = serve+++{-+  Builds the theory contrainst for a lifted, protected value.  +  For example:+  +  > buildThryType (x::PData a Bool)++  builds the context++  > forall thry. BoolCtxt thry => PData a thry+-}+buildThryType :: forall a thry. (Protected a, Typeable thry) => +                                PData a thry -> 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++{-| +  Lifts a protected data value as an expression using an ascribed type.+  For example:++  > liftProtectedExp (x::PData a Bool)++  produces the following spliceable expression++  > [| x :: forall thry. BoolCtxt thry => PData a Bool |]+-}+liftProtectedExp :: (Protected a, Typeable thry) => +                    PData a thry -> Q Exp+liftProtectedExp pdata =+  do pdata' <- protLift pdata+     let ty = buildThryType pdata+     return $! SigE pdata' ty++{-| +  Lifts a protected data value as a declaration of a given name with an ascribed+  type signature.+  For example:++  > liftProtected "protX" (x::PData a Bool)++  produces the following list of spliceable declarations++  > [ [d| protX :: forall thry. BoolCtxt thry => PData a Bool |]+  > , [d| protX = x |] ]++  See 'extractAxiom' for a basic example of how this function may be used.+-}+liftProtected :: (Protected a, Typeable thry) => +                 String -> PData a thry -> Q [Dec]+liftProtected lbl pdata =+  do pdata' <- protLift pdata+     let ty = buildThryType pdata+         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
@@ -0,0 +1,93 @@+{-|+  Module:    HaskHOL.Core.Ext.QQ+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines a mechanism for compile time quasi-quoting of 'HOLTerm's.+  The 'baseQuoter' method constructs a theory specific quasi-quoter that parses+  'HOLTerm's at the expression level using 'toHTm'.  An example, 'base' is +  provided to demonstrate how this process works.++  Additionally, a specialized quasi-quoter for 'String's is provided that+  escapes special characters and trims white-space.  This can be helpful when+  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+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.State+import HaskHOL.Core.Parser+import HaskHOL.Core.Ext.Protected++{-+  We require some Template Haskell primitives that shouldn't be exposed outside+  of this module, i.e. runIO+-}+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+  a 'String' as a term, protecting and lifting the result.++  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)+          nothing _ = fail "quoting here not supported"++{-| +  An instance of 'baseQuoter' for the core theory context, 'ctxtBase'.+  Example:++  > [base| 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 |]+  >    ...++  will parse the term exactly once, only checking the @thry@ tag of the+  computation for each evaluation.  Conversely,++  > do tm <- toHTm "x = y"+  >    ...++  will parse the term for every evaluation of that computation.  Generally, the+  use of 'toHTm' is reserved for run time parsing and in larger computations+  that themselves are evaluated at copmile time to minimize the amount of work+  Template Haskell has to do.+-}+base :: QuasiQuoter+base = baseQuoter ctxtBase++{-|+  This is a specialized quasi-quoter for 'String'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+          nothing _ = fail "quoting here not supported"
+ src/HaskHOL/Core/Kernel.hs view
@@ -0,0 +1,549 @@+{-|+  Module:    HaskHOL.Core.Kernel+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  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.++  * The primitive, stateless theory extension functions.++  For clarity, all of these items have been seperated based on their influential+  system: HOL Light, Stateless HOL, and HOL2P.++  Note that, per the stateless approach, any stateful, but still primitive,+  functions related to theorems or theory extension have been relocated to the +  "HaskHOL.Core.State" module.+-}+module HaskHOL.Core.Kernel+    ( -- * A View of HOL Types, Terms, and Theorems+       -- ** A Quick Note on View Patterns+        -- $ViewPatterns+      view -- :: a -> b+       -- ** Destructors and Accessors for Theorems+    , HOLThm+    , HOLThmView(..)+    , destThm -- :: HOLThm -> ([HOLTerm], HOLTerm)+    , hyp     -- :: HOLThm -> [HOLTerm]+    , concl   -- :: HOLThm -> HOLTerm+      -- * 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+      -- * 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+      -- * 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)+      -- * Primitive Re-Exports+    , module HaskHOL.Core.Kernel.Types+    , module HaskHOL.Core.Kernel.Terms+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel.Prims+import HaskHOL.Core.Kernel.Types+import HaskHOL.Core.Kernel.Terms++{-+  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++{- +  Unions two lists of terms, ordering the result modulo alpha-equivalence.  Not+  exposed to the user.+-}+termUnion :: [HOLTerm] -> [HOLTerm] -> [HOLTerm]+termUnion [] l2 = l2+termUnion l1 [] = l1+termUnion l1@(h1:t1) l2@(h2:t2) = +    case alphaOrder h1 h2 of+      EQ -> h1 : termUnion t1 t2+      LT -> h1 : termUnion t1 l2+      _  -> h2 : termUnion l1 t2++{- +  Removes a term from a term list, ordering the result modulo alpha-equivalence.+  Not exposed to the user.+-}+termRemove :: HOLTerm -> [HOLTerm] -> [HOLTerm]+termRemove _ [] = []+termRemove t l@(s:ss) =+    case alphaOrder t s of+      GT -> s : termRemove t ss+      EQ -> ss+      _  -> l++{- +  Maps a function over a list of terms, termUnion-ing the result at each step.+  Roughly equivalent to a composition of nub and map that orders the result+  modulo alpha-equivalence.  Not exposed to the user+-}+termImage :: (HOLTerm -> HOLTerm) -> [HOLTerm] -> [HOLTerm]+termImage _ [] = []+termImage f (h:t) = termUnion [f h] $ termImage f t++{-+   HOL Light Theorem Primitives+-}+{-| +  Destructs a theorem, returning its list of assumption terms and conclusion+  term.+-}+destThm :: HOLThm -> ([HOLTerm], HOLTerm)+destThm (ThmIn a c) = (a, c)++-- | Accessor for the hypotheses, or assumption terms, of a theorem.+hyp :: HOLThm -> [HOLTerm]+hyp (ThmIn a _) = a++-- | Accessor for the conclusion term of a theorem.+concl :: HOLThm -> HOLTerm+concl (ThmIn _ c) = c++{-+   HOL Light Primitive Inference Rules+-}++-- Basic Equality Rules++{-|@+     t    +-----------+ |- t = t+@++  Never fails.+-}+primREFL :: HOLTerm -> HOLThm+primREFL t = ThmIn [] $ safeMkEq t t++{-|@+ A1 |- t1 = t2   A2 |- t2 = t3+-------------------------------+       A1 U A2 |- t1 = t3     +@++  Fails with 'Left' in the following cases:+  +  * The middle terms are not alpha-equivalent.+  +  * 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))+    | m1 `aConv` m2 =+        Right . ThmIn (termUnion a1 a2) $ CombIn eql r+    | otherwise = Left "primTRANS: middle terms don't agree"	+primTRANS _ _ = Left "primTRANS: not both equations"++-- Basic Congruence Rules++{-|@+ A1 |- f = g   A2 |- x = y+---------------------------+    A1 U A2 |- f x = g y+@++  Fails with 'Left' in the following cases:+  +  * One, or both, of the theorem conclusions is not an equation.+  +  * The first theorem conclusion is not an equation of function terms.+  +  * 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)) =+    case typeOf l1 of+      (TyAppIn (TyPrim "fun" _) (ty:_:_))+          | typeOf l2 `tyAConv` ty ->+              Right . +                ThmIn (termUnion a1 a2) . 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"++{-|@+          A |- t1 = t2+-------------------------------+ A |- (\\ x . t1) = (\\ x . t2)+@++  Fails with 'Left' in the following cases:+  +  * The term to bind is free in the assumption list of the theorem.+  +  * 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"	+    | otherwise = +        Right . ThmIn a . safeMkEq (AbsIn v l) $ AbsIn v r+primABS _ _ = Left "primABS: not an equation"++-- Beta Reduction+{-|@+        (\\ x . t[x]) x+-------------------------------+     |- (\\ x . t) x = t[x]+@++  Fails with 'Left' in the following cases:+  +  * The term is not a valid application.+  +  * The reduction is not a trivial one, i.e. the argument term is not equivalent+    to the bound variable.+-}+primBETA :: HOLTerm -> Either String HOLThm+primBETA tm@(CombIn (AbsIn bv bod) arg)+    | arg == bv = Right . ThmIn [] $ safeMkEq tm bod+    | otherwise = Left "primBETA_PRIM: not a trivial beta reduction"+primBETA _ = Left "primBETA_PRIM: not a valid application"++-- Deduction Rules+{-|@+     t+-----------+   t |- t+@++  Fails with 'Nothing' if the term is not a proposition.+-}+primASSUME :: HOLTerm -> Maybe HOLThm+primASSUME tm+    | typeOf tm == tyBool = Just $ ThmIn [tm] tm+    | otherwise = Nothing++{-|@+ A1 |- t1 = t2   A2 |- t1+----------------------------+      A1 U A2 |- t2+@++  Fails with 'Left' in the following cases:++  * The conclusion of the first theorem is not an equation.++  * The conclusion term of the second theorem and the left hand side of the +    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+    | 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+@++  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++-- Instantiation Rules+{-|@+ [(ty1, tv1), ..., (tyn, tvn)]   A |- t              +----------------------------------------+   A[ty1, ..., tyn/tv1, ..., tvn]+    |- t[ty1, ..., tyn/tv1, ..., tvn]+@++  Never fails.+-}+primINST_TYPE :: Inst a b => [(a, b)] -> HOLThm -> HOLThm+primINST_TYPE tyenv (ThmIn a t) = +    let instFun = inst tyenv in+      ThmIn (termImage instFun a) $ 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) =+    let instFun = instFull tyenv in+      ThmIn (termImage instFun a) $ instFun t++{-|@+ [(t1, x1), ..., (tn, xn)]   A |- t          +------------------------------------+   A[t1, ..., tn/x1, ..., xn]+    |- t[t1, ..., tn/x1, ..., xn]   +@++  Never fails.+-}+primINST :: HOLTermEnv -> HOLThm -> HOLThm+primINST env (ThmIn a t) = +    let instFun = varSubst env in+      ThmIn (termImage instFun a) $ instFun t++{-+   HOL2P Primitive Inference Rules+-}++-- Type Congruence rules++{-|@+          A |- t1 = t2+-------------------------------+ A |- (\\\\ x . t1) = (\\\\ x . t2)+@++  Fails with 'Left' in the following cases:++  * The type to bind is not a small type variable. ++  * The conclusion of the theorem is not an equation.++  * The type to bind is free in the assumption list of the theorem. +  +  * 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 =+        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+    | otherwise =+        Left "primTYABS: type variable is free in assumptions"+primTYABS (TyVarIn True _) _ = +    Left "primTYABS: conclusion not an equation"+primTYABS _ _ =+    Left "primTYABS: first argument not a small type variable"++{-|@+          A |- t1 = t2+-------------------------------+ A |- t1 [: ty1] = t2 [: ty2]+@++  Fails with 'Left' in the following cases:++  * The conclusion of the theorem is not an equation of terms of universal type.++  * The type arguments are not alpha-equivalent.++  * 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))+    | ty1 `tyAConv` ty2 = +        case typeOf l of+          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+          _ -> Left "primTYAPP2: terms not of universal type"+    | otherwise = +        Left "primTYAPP2: type arguments not alpha-convertible"+primTYAPP2 _ _ _ = Left "primTYAPP2: conclusion not an equation"+    +{-|@+        A |- t1 = t2+----------------------------+ A |- t1 [: ty] = t2 [: ty]+@++  Fails with 'Nothing' if the conclusion of the theorem is not an equation.++  Note that 'primTYAPP' is equivalent to 'primTYAPP2' when the same type is+  applied to both sides, i.e. ++  @ 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++-- Type Beta Reduction++{-|@+     (\\\\ ty . t[ty]) [: ty]    +---------------------------------+ |- (\\\\ ty . t[ty]) [: ty] = t+@++  Fails with 'Left' in the following cases:++  * The term is not a valid type application.++  * The reduction is not a trivial one, i.e. the argument type is not equivalent+    to the bound type variable.+-}+primTYBETA :: HOLTerm -> Either String HOLThm+primTYBETA tm@(TyCombIn (TyAbsIn tv bod) argt)+    | argt == tv = Right . ThmIn [] $ safeMkEq tm bod+    | otherwise = Left "primTYBETA: not a trivial type beta reduction"+primTYBETA _ = Left "primTYBETA: not a valid type application"++{-+   Stateless HOL Theory Extension Primitives+   Note that the following primitives are in HaskHOL.Core.State as per+   Stateless HOL:+   axioms, newAxiom, newBasicDefinition, newBasicTypeDefinition+-}++{-|+  Creates a new axiom theorem.  ++  Note that, as discussed in the documentation for 'HOLThm', the introduction of+  axioms is not tracked until the stateful layer of the system is introduced so +  be careful using this function.+-}+axiomThm :: HOLTerm -> HOLThm	+axiomThm = ThmIn []++{-|@+   c = t  +-----------+ |- c = t+@++  Creates a new defined constant given a term that equates a variable of the+  desired constant name and type to its desired definition.  The return value +  is a pair of the new constant and its definitional theorem.  ++  Note that internally the constant is tagged with its definitional term via the+  @Defined@ 'ConstTag'.++  Fails with 'Left' in the following cases:++  * The provided term is not an equation.++  * The provided term is not closed.++  * There are free type variables present in the definition that are not also in+    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) =+        Left "newDefinedConst: not closed"+    | not (subset (typeVarsInTerm r) (tyVars ty)) =+        Left "newDefinedConst: type vars not refelcted in const"+    | otherwise =        +        let c = ConstIn cname ty $ Defined tm+            dth = ThmIn [] $ safeMkEq c r in+          Right (c, dth)+newDefinedConst _ = Left "newDefinedConst: not an equation"++{-|@+                           |- p x:rep+-----------------------------------------------------------------+ (|- mk:rep->ty (dest:ty->rep a) = a, |- P r \<=\> dest(mk r) = r)+@++  Creates a new defined type constant that is defined as an inhabited subset+  of an existing type constant.  The return value is a pentuple that +  collectively provides a bijection between the new type and the old type.++  The following four items are taken as input:++  * The name of the new type constant - @ty@ in the above sequent.++  * The name of the new term constant that will be used to make an instance of +    the new type - @mk@ in the above sequent.++  * The name of the new term constant that will be used to destruct an instance+    of the new type - @dest@ in the above sequent.++  * A theorem proving that the desired subset is non-empty.  The conclusion of+    this theorem must take the form @p x@ where @p@ is the predicate that+    defines the subset and @x@ is a witness to inhabitation.++  The following items are returned as part of the resultant pentuple:++  * The new defined type operator.  These type operators carry their name,+    arity, and definitional theorem.  The arity, in this case, is inferred from+    the number of free type variables found in the predicate of the definitional+    theorem.++  * The new term constants, @mk@ and @dest@, as described above.  Note that +    constants constructed in this manner are tagged with special instances of +    'ConstTag', @MkAbstract@ and @DestAbstract@ accordingly, that carry the +    name, arity, and definitional theorem of their related type constant.++  * The two theorems proving the bijection, as shown in the sequent above.+-}+newDefinedTypeOp :: String -> String -> String -> HOLThm -> +                    Either String (TypeOp, HOLTerm, HOLTerm, HOLThm, HOLThm)+newDefinedTypeOp tyname absname repname dth'@(ThmIn [] (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)+            arity = length tys+            atyop = TyDefined tyname arity dth'+            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+          Right (atyop, absCon, repCon,+                 ThmIn [] (safeMkEq (CombIn absCon (CombIn repCon atm)) atm),+                 ThmIn [] (safeMkEq (CombIn p rtm) $ +                             safeMkEq (CombIn repCon (CombIn absCon rtm)) 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+  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.+-}
+ src/HaskHOL/Core/Kernel/Prims.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, +             TemplateHaskell #-}++{-|+  Module:    HaskHOL.Core.Kernel.Prims+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines the primitive data types for HaskHOL: +  'HOLType', 'HOLTerm', and 'HOLThm'.++   Note:  This module is intended to be hidden by cabal to prevent manual, and +   possibly unsound, construction of the primitive data types.  ++   To include the contents of this module with the appropriate restrictions in +   place, along with the entirey of the core system, import the "HaskHOL.Core"+   module.  Alternatively, the following modules also export individual+   primitive types with their associated restrictions:+   * "HaskHOL.Core.Types"  - Exports types+   * "HaskHOL.Core.Terms"  - Exports terms+   * "HaskHOL.Core.Kernel" - Exports theorems+-}++module HaskHOL.Core.Kernel.Prims+    ( -- * HOL types+      HOLType(..)+    , HOLTypeView(..)+    , TypeOp(..)+    , HOLTypeEnv+    , SubstTrip+      -- * HOL terms+    , HOLTerm(..)+    , HOLTermView(..)+    , ConstTag(..)+    , HOLTermEnv+      -- * HOL theorems+    , HOLThm(..)+    , HOLThmView(..)+      -- * The View pattern class+    , Viewable(..)+    ) where++import HaskHOL.Core.Lib++{-+  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.+-}++{-+  The following data types combined provide the definition of HOL types in +  HaskHOL.++  The primary data type, 'HOLType', follows closely from the +  simply typed lambda calculus approach used in John Harrison's HOL Light +  system. ++  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 +      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'.+-}+data HOLType+    = TyVarIn !Bool !String+    | TyAppIn !TypeOp ![HOLType]+    | UTypeIn !HOLType !HOLType+    deriving (Eq, Ord, Typeable) ++-- | 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++{-|+  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'+-}+data TypeOp +    = TyOpVar !String+    | TyPrim !String !Int+    | TyDefined !String !Int !HOLThm+    deriving (Eq, Ord, Typeable)++{-+  In order to keep HaskHOL's type system decidable, we follow the same +  \"smallness\" constraint used by HOL2P: type variables that are constrained +  to be small cannot be replaced with types that contain either universal types+  or unconstrained type variables.  This constraint, in addition to the+  restriction that universal types can only bind small type variables, prevents+  the system from performing a substitution that would result in a higher rank+  type than the system is capable of dealing with.  This effectively limits the+  type system to 2nd order polymorphism.++  Voelker elected to rely on syntactic distinction to differentiate between the+  many kinds of type variables (small, unconstrained, and operator); depending +  on how it was to be used, the name of a variable was prepended with a special +  symbol.  Internal to HaskHOL, we elected to replace these syntactic +  distinctions with structural ones such that the following hold true:++  * @TyVarIn True \"x\"@ represents the small type variable @\'x@+ +  * @TyVarIn False \"x\"@ represents the unconstrainted type variable @x@+ +  * @TyOpVar "x"@ represents the type operator variable @_x@++  Note that external to HaskHOL, during I/O of terms, both the parser and+  pretty-printer still rely on the syntactic distinctions introduced by+  Voelker.+-} ++-- | Type synonym for the commonly used, list-based, type environment.+type HOLTypeEnv = [(HOLType, HOLType)]++{-| +  Type synonym for the commonly used triplet of substitution environments.+  See 'TypeSubst' for more information.+-}+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++{-+  The following data types combined provide the definition of HOL terms in +  HaskHOL.++  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.++  Most notably this includes:+  (1) The introduction of tags for constants to carry information formerly+      contained in the state.++  2.  Additional constructors have been added to 'HOLTerm' to facilitate+      term-level, type abstractions and applications.+-}++{-|+  The 'HOLTerm' data type defines the internal constructors for HOL terms in+  HaskHOL.  For more details, see the documentation for its view pattern data+  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)++-- | 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+   +{-| +  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'.+-}+data ConstTag+    = Prim+    | Defined !HOLTerm+    | MkAbstract !String !Int !HOLThm+    | DestAbstract !String !Int !HOLThm+    deriving (Eq, Ord, Typeable)++-- | Type synonym for the commonly used, list-based, term environment.+type HOLTermEnv = [(HOLTerm, HOLTerm)]++{- +  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.+-}+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++{-| +  The 'HOLThm' data type defines HOL Theorems in HaskHOL.  A theorem is defined+  simply as a list of assumption terms and a conclusion term.++  Note that this representation, in combination with a stateless +  approach, means that the introduction of axioms is not tracked in the kernel.+  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'.++      * For theorems - Converts from 'HOLThm' to 'HOLThmView'.+    -}+    view :: a -> b++{- +  Deepseq instances for the primitive data types.  These are included as they +  are commonly used by a number of benchmarking libraries.+-}+instance NFData HOLType where+    rnf (TyVarIn b s) = rnf b `seq` rnf s+    rnf (TyAppIn s tys) = rnf s `seq` rnf tys+    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++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 (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++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])
+ src/HaskHOL/Core/Kernel/Terms.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+  Module:    HaskHOL.Core.Kernel.Terms+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module exports a safe view of HOL terms for HaskHOL.  It also defines+  the primitive functions related to terms.  For clarity, these functions have+  been seperated based on their influential system: HOL Light, Stateless HOL,+  and HOL2P.++  Note that, per the stateless approach, any stateful, but still primitive,+  functions related to terms have been relocated to the "HaskHOL.Core.State"+  module.+-}+module HaskHOL.Core.Kernel.Terms+    ( -- * A View of HOL Terms+       -- ** A Quick Note on View Patterns+        -- $ViewPatterns+       -- ** A High-Level Overview of HOL Terms+        -- $HOLTerms+      HOLTerm+    , HOLTermView(..)+    , ConstTag+    , HOLTermEnv+      -- * HOL Light Term Primitives+       -- ** Alpha-Equivalence of Terms+    , alphaOrder -- :: HOLTerm -> HOLTerm -> Ordering+    , aConv      -- :: HOLTerm -> HOLTerm -> Bool+       -- ** 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)+       -- ** 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]+       -- ** Term Substitution and Instantiation+    , varSubst      -- :: HOLTermEnv -> HOLTerm -> HOLTerm+    , 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+       -- ** 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]+      -- * Stateless HOL Term Primitives+       -- ** Constructors for Constant Tags+    , newPrimConst -- :: String -> HOLType -> HOLTerm+       -- ** Type Operator Variable Extractors+    , typeOpVarsInTerm  -- :: HOLTerm -> [TypeOp]+    , typeOpVarsInTerms -- :: [HOLTerm] -> [TypeOp]+      -- * 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)+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel.Prims+import HaskHOL.Core.Kernel.Types++{- +   HOL Light Term Primitives+   Note that the following primitives are in HaskHOL.Core.State as per +   Stateless HOL:+   constants, getConstType, newConstant, mkConst, mkEq+-}+-- | 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++        ordav :: HOLTermEnv -> 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++        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++-- | Tests if two terms are alpha-equivalent+aConv :: HOLTerm -> HOLTerm -> Bool+aConv tm1 tm2 = alphaOrder tm1 tm2 == EQ++-- | Predicate for term variables.+isVar :: HOLTerm -> Bool+isVar VarIn{} = True+isVar _ = False++-- | Predicate for term constants.+isConst :: HOLTerm -> Bool+isConst ConstIn{} = True+isConst _ = False++-- | Predicate for term abstractions.+isAbs :: HOLTerm -> Bool+isAbs AbsIn{} = True+isAbs _ = False++-- | Predicate for term combinations.+isComb :: HOLTerm -> Bool+isComb CombIn{} = True+isComb _ = False++-- | Constructs a term variable of a given name and type.+mkVar :: String -> HOLType -> HOLTerm+mkVar = VarIn++{-| +  Constructs a term abstraction of a given bound term and body term.  Fails with+  'Left' if the bound term is not a variable.+-}+mkAbs :: HOLTerm -> HOLTerm -> Either String HOLTerm+mkAbs bv@VarIn{} bod = Right $ AbsIn bv bod+mkAbs _ _ = Left "mkAbs"++{-|+  Constructs a combination of two given terms.  Fails with 'Left' in the+  following cases:++  * The first term does not have a function type.++  * The types of the two terms does not agree.+-}+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+          else Left "mkComb: argument type mismatch."+      _ -> Left "mkComb: argument not of function type."++{-| +  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 (VarIn s ty) = Just (s, ty)+destVar _ = Nothing++{-|+  Destructs a term constant, returning its name and type.  Note that no constant+  tag information is returned.  Fails with 'Nothing' if the provided term is+  not a constant.+-}+destConst :: HOLTerm -> Maybe (String, HOLType)+destConst (ConstIn s ty _) = Just (s, ty)+destConst _ = Nothing++{-|+  Destructs a term combination, returning its function and argument terms.  +  Fails with 'Nothing' if the provided term is not a combination.+-}+destComb :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destComb (CombIn f x) = Just (f, x)+destComb _ = Nothing++{-|+  Destructs a term abstraction, returning its bound term and body term. Fails+  with 'Nothing' if the provided term is not an abstraction.+-}+destAbs :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destAbs (AbsIn v b) = Just (v, b)+destAbs _ = Nothing++-- | 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++-- | Returns a list of all free, term variables in a list of terms.+catFrees :: [HOLTerm] -> [HOLTerm]+catFrees = foldr (union . frees) []++-- | 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++-- | Checks if a variable or constant term is free in a given term.+varFreeIn :: HOLTerm -> HOLTerm -> Bool+varFreeIn v (AbsIn bv bod) = v /= bv && varFreeIn v bod+varFreeIn v (CombIn s t) = varFreeIn v s || varFreeIn v t+varFreeIn v (TyAbsIn _ t) = varFreeIn v t+varFreeIn v (TyCombIn t _) = varFreeIn v t+varFreeIn v tm = v == tm++{-| +  Returns a list of all free, type variables in a term, not including +  type operator variables.+-}+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++{-|+  Returns a list of all free, type variables in a list of terms, not including+  type operator variables.+-}+typeVarsInTerms :: [HOLTerm] -> [HOLType]+typeVarsInTerms =+    foldr (\ tm tvs -> typeVarsInTerm tm `union` tvs) []++{-| +  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:+  +  * The second element is substituted for the first, i.e. the substitution pair+    @(A, \\ x.x)@ indicates that the lambda term @\\x.x@ should be substituted +    for the term variable @A@.+-}+varSubst :: HOLTermEnv -> HOLTerm -> HOLTerm+varSubst [] term = term+varSubst theta term =+    varSubstRec (filter validPair theta) term+  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 env (CombIn s t) =+              CombIn (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++{-|+  The @Inst@ class provides the framework for type instantiation in HaskHOL.+  Note that in the simplest cases, instantiation is simply a type substitution+  for the types of term variables and constants.  Therefore, instantiation is +  constrained by the 'TypeSubst' class.++  The move to a polymorphic type system further complicates things as types can+  now be bound at the term level, requiring renaming for type instantiation.+  Since we have three different possible substitution environment types, we have+  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 +    where a type abstraction binds a type variable present in @r@ and @x@ is+    present in the body of the type abstraction.++  * For @(_::'TypeOp', _::'TypeOp')@ substitution pairs we can safely ignore +    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 +    where a type abstraction binds a type variable present in @r@ and @x@ is +    present in the body of the type abstraction.++  Just as we did for the 'TypeSubst' class, we hide the internals of @Inst@ to+  prevent unsound re-definition.  The correct functions to call for+  type instantiation are 'inst' and 'instFull'.+-}+class TypeSubst a b => Inst a b where+    {-| +      Handles the specific case of instantiating a type abstraction term.  This+      method is not exposed to the user.  Call the 'inst' or 'instFull' function+      instead.+    -}+    instTyAbs :: HOLTermEnv -> [(a, b)] -> HOLTerm -> Either HOLTerm HOLTerm++instance Inst HOLType HOLType where+    instTyAbs env tyenv tm@(TyAbsIn tv t) = +        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'+               -- 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+    instTyAbs _ _ tm = Right tm++instance Inst TypeOp TypeOp where+    instTyAbs env tyenv (TyAbsIn tv t) = +        liftM (TyAbsIn tv) $ instRec env tyenv t+    instTyAbs _ _ tm = Right tm++instance Inst TypeOp HOLType where+    instTyAbs env tyenv (TyAbsIn tv t) =+        if any (\ (x, ty) -> tv `elem` tyVars ty && +                             x `elem` typeOpVarsInTerm t) tyenv+        -- avoid capture by renaming type variable+        then let tvbs = typeOpVarsInTerm t+                 tvpatts = map fst tyenv+                 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+    instTyAbs _ _ tm = Right tm++{-|+  Type instantiation for terms.  Accepts the same types of substitution+  environments as discussed in the documentation for the 'TypeSubst' class, +  with invalid substitution pairs being pruned internally by 'typeSubst' as +  necessary.  ++  For more information on why the 'Inst' class constraint is necessary and how +  renaming of bound types is performed, see that classes documentation.+-}+inst :: Inst a b => [(a, b)] -> HOLTerm -> HOLTerm+inst [] tm = tm+inst theta tm = +    case instRec [] theta tm of+      Right res -> res+      Left _ -> tm++-- Used internally by inst and instTyAbs both.  Not exposed to the user.+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+      if lookupd tm' env tm == tm then Right tm' +      else Left tm' -- Clash+instRec _ tyenv (ConstIn c ty tag) =+    let ty' = typeSubst tyenv ty in+      Right $ ConstIn c ty' tag+instRec env tyenv (CombIn f x) =+    return CombIn <*> instRec env tyenv f <*> instRec env tyenv x+instRec env tyenv (AbsIn y@(VarIn _ ty) t) =+    do y' <- instRec [] tyenv y+       case instRec ((y', y):env) tyenv t of+         Right t' -> Right $ AbsIn 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+                       _ -> 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++{-| +  A version of 'inst' that accepts a triplet of type substitution environments.+-}+instFull :: SubstTrip -> HOLTerm -> HOLTerm+instFull (tyenv, tyOps, opOps) = inst opOps . inst tyOps . inst tyenv++{-|+  A simplified version of 'inst' that works only for term constants.  Fails with+  'Nothing' if the provided term is not a constant.  Used internally by +  '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 _ _ = Nothing++{-| +  A version of 'instConst' that accepts a triplet of type substitition +  environments.+-}+instConstFull :: HOLTerm -> SubstTrip -> Maybe HOLTerm+instConstFull (ConstIn name uty tag) tyenv = +    Just $ ConstIn name (typeSubstFull tyenv uty) 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++-- | Predicate for equations, i.e. terms of the form @l = r@.+isEq :: HOLTerm -> Bool+isEq (CombIn (CombIn (ConstIn "=" _ Prim) _) _) = 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 l r+    | typeOf l `tyAConv` typeOf r =+        Right $ CombIn (CombIn (tmEq $ typeOf l) l) r+    | otherwise = Left "primMkEq"++{-|+  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) =+    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.+-}+variant :: [HOLTerm] -> HOLTerm -> HOLTerm+variant avoid v@(VarIn s ty)+    | any (varFreeIn v) avoid = variant avoid $ VarIn (s++"'") ty+    | otherwise = v+variant _ tm = tm++{-|+  Renames a list of term variables to avoid sharing a name with any of a given+  list of term variables.  As each term variable is processed it is added to+  the list of avoids such that the resultant list of term variables are all+  uniquely named.+-}+variants :: [HOLTerm] -> [HOLTerm] -> [HOLTerm]+variants _ [] = []+variants avoid (v:vs) = +    let vh = variant avoid v in+      vh : variants (vh:avoid) vs++{- +   Stateless HOL Term Primitives+-}++{-|  +  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.+-} +newPrimConst :: String -> HOLType -> HOLTerm+newPrimConst name ty = ConstIn name ty Prim++-- | 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++-- | Returns the list of all type operator variables in a list of terms.+typeOpVarsInTerms :: [HOLTerm] -> [TypeOp]+typeOpVarsInTerms =+    foldr (\ tm topvs -> typeOpVarsInTerm tm `union` topvs) []++{- +   HOL2P Term Primitives+-}+-- | Predicate for type abstraction terms.+isTyAbs :: HOLTerm -> Bool+isTyAbs TyAbsIn{} = True+isTyAbs _ = False++-- | Predicate for type combination terms.+isTyComb :: HOLTerm -> Bool+isTyComb TyCombIn{} = True+isTyComb _ = False++{-|+  Constructs a type abstraction term given a bound type and a body term.  Fails+  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 _ _ = Left "mkTyAbs: first argument not a small type variable."++{-|+  Constructs a type combination term given a body term and a type argument to +  apply.  Fails with 'Left' in the following cases:++  * The type argument is not a small type.++  * The type of the body term is not a universal type.+-}+mkTyComb :: HOLTerm -> HOLType -> Either String HOLTerm+mkTyComb tm ty+    | isSmall ty =+        case typeOf tm of+          UTypeIn{} -> Right $ TyCombIn tm ty+          _ -> Left "mkTyComb: term must have universal type."+    | otherwise =+        Left "mkTyComb: type argument not small."++{-| +  Destructs a type abstraction, returning its bound type and body term.  Fails+  with 'Nothing' if the provided term is not a type abstraction.+-}+destTyAbs :: HOLTerm -> Maybe (HOLType, HOLTerm)+destTyAbs (TyAbsIn tv bod) = Just (tv, bod)+destTyAbs _ = Nothing++{-|+  Destructs a type combination, returning its body term and type argument.+  Fails with 'Nothing' if the provided term is not a type combination.+-}+destTyComb :: HOLTerm -> Maybe (HOLTerm, HOLType)+destTyComb (TyCombIn tm ty) = Just (tm, ty)+destTyComb _ = Nothing++-- Documentation copied from HaskHOL.Core.Prims++{-$ViewPatterns+  The primitive data types of HaskHOL are implemented using view patterns 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.+-}++{-$HOLTerms+  The following data types combined provide the definition of HOL terms in +  HaskHOL.++  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.++  Most notably this includes:+  (1) The introduction of tags for constants to carry information formerly+      contained in the state.++  2.  Additional constructors have been added to 'HOLTerm' to facilitate+      term-level, type abstractions and applications.+-}
+ src/HaskHOL/Core/Kernel/Types.hs view
@@ -0,0 +1,643 @@+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+  Module:    HaskHOL.Core.Kernel.Types+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module exports a safe view of HOL types for HaskHOL.  It also defines+  the primitive functions related to types.  For clarity, these functions have+  been seperated based on their influential system: HOL Light, Stateless HOL,+  and HOL2P.++  Note that, per the stateless approach, any stateful, but still primitive,+  functions related to types have been relocated to the "HaskHOL.Core.State"+  module.+-}+module HaskHOL.Core.Kernel.Types+    ( -- * A View of HOL Types+       -- ** A Quick Note on View Patterns+        -- $ViewPatterns+       -- ** A High-Level Overview of HOL Types+        -- $HOLTypes+      HOLType+    , HOLTypeView(..)+       -- ** A Quick Note on Type Variable Distinction+        -- $TypeDistinction+    , TypeOp+    , HOLTypeEnv+    , SubstTrip+      -- * HOL Light Type Primitives+       -- ** Alpha-Equivalence of Types+    , tyAlphaOrder -- :: HOLType -> HOLType -> Ordering+    , tyAConv      -- :: HOLType -> HOLType -> Bool+       -- ** 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])+       -- ** Type Variable Extractors+    , tyVars    -- :: HOLType -> [HOLType]+    , catTyVars -- :: [HOLType] -> [HOLType]+       -- ** Type Substitution+    , TypeSubst+    , typeSubst     --  :: TypeSubst a b => [(a, b)] -> HOLType -> HOLType+    , typeSubstFull --  :: SubstTrip -> HOLType -> HOLType+       -- ** Commonly Used Types and Functions+    , tyBool    -- :: HOLType+    , tyA       -- :: HOLType+    , tyB       -- :: HOLType+    , destFunTy -- :: HOLType -> Maybe (HOLType, HOLType)+    , typeOf    -- :: HOLTerm -> HOLType+      -- * 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)+       -- ** Commonly Used Type Operators+    , tyOpBool -- :: TypeOp+    , tyOpFun  -- :: TypeOp+    , tyApp    -- :: TypeOp -> [HOLType] -> Either String HOLType+       -- ** Type Operator Variable Extractors+    , typeOpVars    -- :: HOLType -> [TypeOp]+    , catTypeOpVars -- :: [HOLType] -> [TypeOp]+      -- * 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)+       -- ** Commonly Used Functions+    , containsUType -- :: HOLType -> Bool+    , variantTyVar  -- :: [HOLType] -> HOLType -> HOLType+    , variantTyVars -- :: [HOLType] -> [HOLType] -> HOLType+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel.Prims++{- +   HOL Light Type Primitives+   Note that the following primitives are in HaskHOL.Core.State as per +   Stateless HOL:+   types, getTypeArityCtxt, getTypeArity, newType, mkType, mkFunTy+-}+-- | 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++        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++        tyordas :: HOLTypeEnv -> [HOLType] -> [HOLType] -> Ordering+        tyordas _ [] [] = EQ+        tyordas _ [] _ = LT+        tyordas _ _ [] = GT+        tyordas env (x:xs) (y:ys) =+            case tyorda env x y of+              EQ -> tyordas env xs ys+              res -> res++-- | Tests if two types are alpha-equivalent.+tyAConv :: HOLType -> HOLType -> Bool+tyAConv ty1 ty2 = tyAlphaOrder ty1 ty2 == EQ++-- | Predicate for type variables.+isVarType :: HOLType -> Bool+isVarType TyVarIn{} = True+isVarType _ = False++-- | Predicate for type applications+isType :: HOLType -> Bool+isType TyAppIn{} = True+isType _ = False++{-| +  Constructs a type variable of a given name.  Note that the resultant type +  variable is unconstrained.+-}+mkVarType :: String -> 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 (TyVarIn _ s) = Just s+destVarType _ = Nothing++{-| +  Destructs a type application, returning its operator name and its list of type+  arguments.  Fails with 'Nothing' if called on a type that is not an +  application.+-}+destType :: HOLType -> Maybe (TypeOp, [HOLType])+destType (TyAppIn op args) = Just (op, args)+destType _ = Nothing++{-| +  Returns the list of all free, type variables in a type, not including type+  operator variables.+-}+tyVars :: HOLType -> [HOLType]+tyVars tv@TyVarIn{} = [tv]+tyVars (TyAppIn _ args) = catTyVars args+tyVars (UTypeIn tv ty) = tyVars ty \\ [tv]++{-| +  Returns the list of all type variables in a list of types, not including type+  operator variables.+-}+catTyVars :: [HOLType] -> [HOLType]+catTyVars = foldr (union . tyVars) []++{-|+  The @TypeSubst@ class provides the framework for type substitution in HaskHOL.+  Note that, with the introduction of universal types and type operator+  variables, we now have three kinds of substitution to handle:++  * Substitution of types for type variables, satisfying type variable +    constraints.++  * Instantiation of type operators with universal types.++  * Substitution of type operators for type operator variables.++  Rather than have three separate functions exposed to the user, we elected to+  provide a polymorphic type substitution function that will accept any+  well-formed, homogenous substitution environment.++  Note that the internals of @TypeSubst@ are hidden to prevent unsound+  re-definition.  The relevant type substitution function is re-exported as+  'typeSubst'.  We also provide a function, 'typeSubstFull', that+  accepts a triplet of all possible substitution environments that can be+  conveniently used in combination with 'typeMatch'.++  See the ITP2013 paper, "Stateless Higher-Order Logic with Quantified Types,"+  for more details.+-}+class TypeSubst a b where+    -- | Tests if a pair is a valid element in a substitution environment.+    validSubst :: (a, b) -> Bool+    {-| +      Perfoms a type substitution as described above using the provided +      environment.+    -}+    typeSubst' :: [(a, b)] -> HOLType -> HOLType++instance TypeSubst HOLType HOLType where+    validSubst (TyVarIn False _, _) = True+    validSubst (TyVarIn{}, ty) = isSmall ty+    validSubst _ = False+    typeSubst' = typeTypeSubst++instance TypeSubst TypeOp TypeOp where+    validSubst (_, TyOpVar{}) = False+    validSubst (TyOpVar{}, _) = True+    validSubst _ = False+    typeSubst' = typeOpSubst++instance TypeSubst TypeOp HOLType where+    validSubst (TyOpVar{}, UTypeIn{}) = True+    validSubst _ = False+    typeSubst' = typeOpInst++{-|+  Re-exports the internal type substitution function of the 'TypeSubst' class+  to prevent unsound re-definition.  Invalid substitution pairs are pruned from+  the environment such that substitution never fails.++  Note that the order of elements in a substitution pair follows the convention+  of most Haskell libraries, rather than the traditional HOL convention:+  +  * The second element is substituted for the first, i.e. the substitution pair+    @(tyA, tyBool)@ indicates that the boolean type should be substituted for+    the type variable @A@.+-}+{-# INLINEABLE typeSubst #-}+typeSubst :: TypeSubst a b => [(a, b)] -> HOLType -> HOLType+typeSubst = typeSubst'++{-| +  A version of 'typeSubst' that accepts a triplet of type substitution +  environments.+-}+typeSubstFull :: SubstTrip -> HOLType -> HOLType+typeSubstFull (tyenv, tyOps, opOps) =+    typeOpSubst opOps . typeOpInst tyOps . typeSubst' tyenv++-- Type subst for (HOLType, HOLType) pairs.+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+        typeSubstRec tyins (TyAppIn op args) =+            TyAppIn op $ map (typeSubstRec tyins) args+        typeSubstRec tyins ty@(UTypeIn tv tbody) =+            let tyins' = filter (\ (x, _) -> x /= tv) tyins in+              if null tyins' then 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'+                   then let tvbs = tyVars tbody+                            tvpatts = map fst tyins'+                            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              +                                +-- | Alias to the primitive boolean type.+{-# INLINEABLE tyBool #-}+tyBool :: HOLType+tyBool = TyAppIn tyOpBool []++-- Used for error cases in type checking only.  Not exported.+{-# INLINEABLE tyBottom #-}+tyBottom :: HOLType+tyBottom = TyAppIn tyOpBottom []++-- | Alias to the unconstrained type variable @A@.+{-# INLINEABLE tyA #-}+tyA :: HOLType+tyA = TyVarIn False "A"++-- | Alias to the unconstrained type variable @B@.+{-# INLINEABLE tyB #-}+tyB :: HOLType+tyB = TyVarIn 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 _ = Nothing++{-|+  Returns the type of term.  Fails with a special type, @tyBottom@, if the type+  is poorly constructed; this keeps the function total without requiring the+  use of an additional guard type like 'Maybe'.++  In practice, this type will never be seen provided the kernel is not modified+  to expose the internal constructors for terms.+-}+typeOf :: HOLTerm -> HOLType+typeOf (VarIn _ ty) = ty+typeOf (ConstIn _ ty _) = ty+typeOf (CombIn x _) =+    case destType $ typeOf x of+      Just (_, _ : ty : _) -> ty+      _ -> tyBottom+typeOf (AbsIn (VarIn _ ty) tm) =+    TyAppIn tyOpFun [ty, typeOf tm]+typeOf AbsIn{} = tyBottom+typeOf (TyAbsIn tv tb) = UTypeIn tv $ typeOf tb+typeOf (TyCombIn t ty) =+    case typeOf t of+      (UTypeIn tv tbody) -> typeSubst [(tv, ty)] tbody+      _ -> tyBottom++{-+   Stateless HOL Type Primitives+-}+-- | Predicate for type operator variables.+isTypeOpVar :: TypeOp -> Bool+isTypeOpVar TyOpVar{} = 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++{-|+  Constructs a type operator variable of a given name.  Note that type+  operator arities are not stored, only inferred from the context where the+  operator is used.++  The parser makes an attempt to guarantee that all instances of a type operator+  in a term have the same arity.  The same protection is not provided for terms+  that are manually constructed.+-}+mkTypeOpVar :: String -> TypeOp+mkTypeOpVar = TyOpVar++{-| +  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)++-- | Alias to the primitive boolean type operator.+{-# INLINEABLE tyOpBool #-}+tyOpBool :: TypeOp+tyOpBool = TyPrim "bool" 0+-- Used for error cases in type checking only.  Not exported.+{-# INLINEABLE tyOpBottom #-}+tyOpBottom :: TypeOp+tyOpBottom = TyPrim "_|_" 0+-- | Alias to the primitive function type operator.+{-# INLINEABLE tyOpFun #-}+tyOpFun :: TypeOp+tyOpFun = TyPrim "fun" 2++{-|+  Constructs a type application from a provided type operator and list of type+  arguments.  Fails with 'Left' in the following cases:++  * A type operator variable is applied to zero arguments.++  * A type operator's arity disagrees with the length of the argument list.+-}+tyApp :: TypeOp -> [HOLType] -> Either String HOLType+tyApp tyOp@TyOpVar{} [] = +    Left $ "tyApp: " ++ show tyOp ++ ": TyOpVar applied to zero args."+tyApp tyOp@TyOpVar{} args = Right $ TyAppIn tyOp args+tyApp tyOp args =+    let (_, arity) = destTypeOp tyOp in+      if arity == length args +      then Right $ TyAppIn tyOp args+      else Left $ "tyApp: " ++ show tyOp ++ ": wrong number of arguments."++-- | 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 _ = []++-- | Returns the list of all type operator variables in a list of types.+catTypeOpVars :: [HOLType] -> [TypeOp]+catTypeOpVars = foldr (union . typeOpVars) []++-- substitution of type operator variables for other type operators.+-- Note that replacement with another type operator variable is allowed+typeOpSubst :: [(TypeOp, TypeOp)] -> HOLType -> HOLType+typeOpSubst [] t = t+typeOpSubst tyopenv t =+    tyOpSubstRec (filter validSubst tyopenv) t+  where tyOpSubstRec :: [(TypeOp, TypeOp)] -> HOLType -> 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'+        tyOpSubstRec tyopins (UTypeIn tv tbody) =+            UTypeIn tv $ tyOpSubstRec tyopins tbody+        tyOpSubstRec _ ty = 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+  where arityOf :: HOLType -> Maybe Int+        arityOf ty = return (length . fst) <*> destUTypes ty      ++        tyOpInstRec :: [(TypeOp, HOLType)] -> HOLType -> 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+        tyOpInstRec tyopins (UTypeIn tv tbody) =+            if any (\ (x, ty) -> tv `elem` tyVars ty && +                                 x `elem` typeOpVars tbody) tyopins+            -- test for name capture, renaming instances of tv if necessary +            then let tvbs = typeOpVars tbody+                     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+                  +                +{- +   HOL2P Type Primitives+-}++-- | Predicate for universal types.+isUType :: HOLType -> Bool+isUType UTypeIn{} = True+isUType _ = False++{-|+  Predicate for small types.  Returns 'True' if all type variables in the type+  are constrained to be small and the type contains no universal types; returns +  'False' otherwise. +-}+isSmall :: HOLType -> Bool+isSmall (TyVarIn small _) = small+isSmall (TyAppIn _ args) = all isSmall args+isSmall UTypeIn{} = False++{-|+  Constructs a universal type of a given bound type and body type.  Fails with+  '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 _ _ = 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)++{-|+  Constructs a compound universal type from a type operator variable and a given+  number of bound variables, i.e. +  +  > uTypeFromTypeOpVar _T n === % 'A1 ... 'An. ('A1, ..., 'An)_T  ++  Fails with 'Left' in the following cases:++  * @n<=0@ which would result in the application of a type operator to an+    empty list of type arguments.++  * The type operator argument is not a variable. +-}+uTypeFromTypeOpVar :: TypeOp -> Int -> Either String HOLType+uTypeFromTypeOpVar s@TyOpVar{} n+    | n > 0 = +        let tvs = map (\ x -> TyVarIn True $ 'A' : show x) [1 .. n] in+          mkUTypes tvs =<< tyApp s tvs+    | otherwise = +        Left "uTypeFromTypeOpVar: must have a positive number of bound types."+uTypeFromTypeOpVar _ _ = +    Left "uTypeFromTypeOpVar: type operator not a variable."++{-|+  Constructs a small type from a given type by constraining all of the type+  variables in the type to be small.  Fails with 'Left' if the type contains+  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 UTypeIn{} = Left "mkSmall"++{-| +  Destructs a universal type, returning its bound type and body type.  Fails+  with 'Nothing' if the provided type is not universally quantified.+-}+destUType :: HOLType -> Maybe (HOLType, HOLType)+destUType (UTypeIn tv ty) = Just (tv, ty)+destUType _ = Nothing++{-|+  Destructs a compound universal type, returning the list of bound variables+  and the final body type.  Fails if the provided type is not universally+  quantified.+-} +destUTypes :: HOLType -> Maybe ([HOLType], HOLType)+destUTypes (UTypeIn tv tb) = Just $ destUTypesRec ([tv], tb)+  where destUTypesRec :: ([HOLType], HOLType) -> ([HOLType], HOLType)+        destUTypesRec (acc, UTypeIn tv' tb') = destUTypesRec (acc++[tv'], tb')+        destUTypesRec res = res+destUTypes _ = Nothing++-- | Predicate to test if a type contains a universal type at any level.+containsUType :: HOLType -> Bool+containsUType TyVarIn{} = False+containsUType (TyAppIn _ args) = any containsUType args+containsUType UTypeIn{} = True++{-|+  Renames a type variable to avoid sharing a name with any of a given list of+  type variables.  Note that this function is both smallness presserving and+  respecting.  Returns the original type if it's not a type variable.+-}+variantTyVar :: [HOLType] -> HOLType -> HOLType+variantTyVar avoid tv@(TyVarIn small name)+    | tv `elem` avoid = variantTyVar avoid . TyVarIn small $ name ++ "'"+    | otherwise = tv+variantTyVar _ ty = ty++{-|+  Renames a list of type variables to avoid sharing a name with any of a given+  list of type variables.  As each type variable is processed it is added to the+  list of avoids such that the resultant list of type variables are all uniquely+  named.+-}+variantTyVars :: [HOLType] -> [HOLType] -> [HOLType]+variantTyVars _ [] = []+variantTyVars avoid (tv:tvs) =+    let tv' = variantTyVar avoid tv in+      tv : variantTyVars (tv':avoid) tvs+++-- Documentation copied from HaskHOL.Core.Prims++{-$ViewPatterns+  The primitive data types of HaskHOL are implemented using view patterns 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.+-}++{-$HOLTypes+  The following data types combined provide the definition of HOL types in +  HaskHOL.++  The primary data type, 'HOLType', follows closely from the +  simply typed lambda calculus approach used in John Harrison's HOL Light +  system. ++  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 +      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.+-}++{-$TypeDistinction+  In order to keep HaskHOL's type system decidable, we follow the same +  \"smallness\" constraint used by HOL2P: type variables that are constrained +  to be small cannot be replaced with types that contain either universal types+  or unconstrained type variables.  This constraint, in addition to the+  restriction that universal types can only bind small type variables, prevents+  the system from performing a substitution that would result in a higher rank+  type than the system is capable of dealing with.  This effectively limits the+  type system to 2nd order polymorphism.++  Voelker elected to rely on syntactic distinction to differentiate between the+  many kinds of type variables (small, unconstrained, and operator); depending +  on how it was to be used, the name of a variable was prepended with a special +  symbol.  Internal to HaskHOL, we elected to replace these syntactic +  distinctions with structural ones such that the following hold true:++  * @TyVarIn True \"x\"@ represents the small type variable \"\'x\"++  * @TyVarIn False \"x\"@ represents the unconstrainted type variable \"x\"++  * @TyOpVar \"x\"@ represents the type operator variable \"_x\"++  Note that external to HaskHOL, during I/O of terms, both the parser and+  pretty-printer still rely on the syntactic distinctions introduced by+  Voelker.+-}
+ src/HaskHOL/Core/Lib.hs view
@@ -0,0 +1,1342 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, +             StandaloneDeriving, TemplateHaskell #-}++{-|+  Module:    HaskHOL.Core.Lib+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines or re-exports common utility functions, type classes, +  and auxilliary data types used in HaskHOL.  The following conventions hold +  true:+  * Where possible, we favor re-exporting common functions rather than+    redefining them. +  * We favor re-exporting individual functions rather entire modules to reduce+    the number of items in our utility library.+  * We default to the names of functions commonly used by Haskell libraries,+    however, if there's a different name for a function in HOL systems we+    include an alias for it.  For example, 'iComb' and 'id'.++  Note that none of the functions in this module depend on data types +  introduced by HaskHOL.  Utility functions that do have such a dependence are +  found in the "HaskHOL.Core.Basics" module.+-}+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+      -- * 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)+      -- * 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]+      -- * 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+      -- * 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+    , 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]+      -- * 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+      -- * 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]+      -- * 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]+      -- * 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]]+      -- * 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]+      -- * 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]+      -- * 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+      -- * 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 Control.Applicative {-| +        Re-exports 'Applicative', 'Alternative', and the utility functions for+        use with the 'HOL' monad.+      -}+    , module Control.DeepSeq {-|+        Re-exports the entirety of the library, but currently only 'NFData' is+        used.  Necessary for using the "Criterion" benchmarking library.+      -}+    , module Control.Monad {-|+        Re-exports the entirety of the library for use with the 'HOL' monad.+      -}+    , module Data.Maybe {-|+        Re-exports the entirety of the library.  Used primarily to make+        interacting with primitive rules easier at later points in the system.+      -}+    , module Data.Either {-|+        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 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.+      -}+    ) where++import HaskHOL.Core.Lib.Lift++-- Libraries re-exported in their entirety, except for applicative+import Control.Applicative hiding (Const, WrappedMonad, WrappedArrow, ZipList)+import Control.DeepSeq+import Control.Monad+import Data.Maybe+import Data.Either+import Data.Typeable (Typeable)+import Text.ParserCombinators.Parsec.Expr++-- Libraries containing Re-exports+import qualified Control.Arrow as A+import qualified Data.Foldable as F+import qualified Data.List as L+import qualified Data.Ratio as R+import qualified Data.Tuple as T++-- Libraries containing utility functions used, but not exported directly+import Numeric (readInt, readHex, readDec)+import Data.Char (digitToInt)++-- 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++{-| +  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.***)++{-| +  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++{-|+  Promotes a function to a monad, but only for its first argument, i.e.+  +  > 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++-- 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++{-|+  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++{-| +  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++-- list basics+{-| +  A safe version of 'head'.  Fails with 'Nothing' when trying to take the head+  of an empty list.+-}+tryHead :: [a] -> Maybe a+tryHead (x:_) = Just x+tryHead _ = Nothing++{-| +  A safe version of 'tail'.  Fails with 'Nothing' when trying to take the tail+  of an empty list.+-}+tryTail :: [a] -> Maybe [a]+tryTail (_:t) = Just t+tryTail _ = Nothing++{-|+  A safe version of 'init'.  Fails with 'Nothing' when trying to drop the last+  element of an empty list.+-}+tryInit :: [a] -> Maybe [a]+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++{-| +  A safe version of 'last'.  Fails with 'Nothing' when trying to take the last+  element of an empty list.+-}+tryLast :: [a] -> Maybe a+tryLast (x:[]) = Just x+tryLast (_:xs) = tryLast xs+tryLast _ = Nothing++{-| +  A safe version of 'index'.  Fails with 'Nothing' if the selected index does+  not exist.+-}+tryIndex :: [a] -> Int -> Maybe a+tryIndex xs n+    | n >= 0 = tryHead $ drop n xs+    | otherwise = Nothing++{-|+  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++{-| +  A version of 'lookup' where the search is performed against the second element+  of the pair instead of the first.  Still fails with 'Nothing' if the desired+  value is not found.+-}+revLookup :: Eq a => a -> [(b, a)] -> Maybe b+revLookup _ [] = Nothing+revLookup x ((f, s):as)+  | x == s = Just f+  | 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++-- | A version of 'lookup' that defaults to a provided value rather than fail.+lookupd :: Eq a => a -> [(a, b)] -> b -> b+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++{-| +  A version of 'revLookup' that defaults to a provided value rather than fail.+-}+revLookupd :: Eq a => a -> [(b, a)] -> b -> b+revLookupd x xs b = fromMaybe b $ revLookup x xs++{-| +  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++-- error handling and checking+{-| +  Returns a boolean value indicating whether a monadic computation succeeds or+  fails.  The '<|>' operator is used for branching.+-}+can :: (Alternative m, Monad m) => (a -> m b) -> a -> m Bool+can f x = (f x >> return True) <|> return False++{-| +  The opposite of 'can'.  Functionally equivalent to ++  > \ f -> liftM not . can f+-}+canNot :: (Alternative m, Monad m) => (a -> m b) -> a -> m Bool+canNot f x = (f x >> return False) <|> return True++{-| +  Checks if a predicate succeeds for a provided value, returning that value+  guarded by a 'Maybe' type if so.+-} +check :: (a -> Bool) -> a -> Maybe a+check p x+  | p x = Just x+  | otherwise = Nothing++-- | Takes a default error value to convert a 'Maybe' type to an 'Either' type.+note :: a -> Maybe b -> Either a b+note l Nothing = Left l+note _ (Just r) = Right r++{-| +  Suppresses the error value of an 'Either' type to convert it to a 'Maybe' +  type.+-}+hush :: Either a b -> Maybe b+hush (Left _) = Nothing+hush (Right r) = Just r++{-|+  An analogue of 'fromJust' for the 'Either' type.  Fails with 'error' when+  provided a 'Left' value, so take care only to use it in cases where you know +  you are working with a 'Right' value or are catching exceptions. +-}+fromRight :: Either err a -> a+fromRight (Right res) = res+fromRight _ = error "fromRight"++{-|+  A version of 'fromRight' that maps 'Left' values to 'mzero' rather than+  failing.+-}+fromRightM :: MonadPlus m => Either err a -> m a+fromRightM (Right res) = return res+fromRightM _ = mzero++{-|+  A version of 'fromJust' that maps 'Nothing' values to 'mzero' rather than+  failing.+-}+fromJustM :: MonadPlus m => Maybe a -> m a+fromJustM (Just res) = return res+fromJustM _ = mzero++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+  monadic computation.+-}+class Monad m => LiftOption l m where+    {-| +      Used to lift an option value, i.e. 'Maybe' or 'Either', so that it can be+      passed as an argument to a monadic computation.+    -}+    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++    -- | 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)++    -- | 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++instance MonadPlus m => LiftOption (Either a) m where+    liftO = fromRightM++infix 0 <?>+{-| +  The 'Note' class provides an ad hoc way of tagging an error case with a+  string.+-}+class (Alternative m, Monad m) => Note m where+  {-| +    Used to annotate more precise error messages.  Replaces the '<|>' operator +    in cases such as  +    +    > ... <|> fail "..."+  -}+  (<?>) :: m a -> String -> m a++  {-|+    Replaces the common pattern ++    > m >>= \ cond -> if cond then fail "..."+    +    The default case is defined in terms of 'empty' and '<?>'.+  -}+  failWhen :: m Bool -> String -> m ()+  failWhen m str =+      do cond <- m+         when cond empty <?> str++instance Note (Either String) where+  job <?> str = job <|> Left str++-- repetition of a functions+{-| +  Repeatedly applies a function to an argument @n@ times.  Rather than fail,+  the original argument is returned when @n<=0@.+-}+funpow :: Int -> (a -> a) -> a -> a+funpow n f x+    | n <= 0 = x+    | otherwise = funpow (n - 1) f (f x)++-- | The monadic version of 'funpow'.+funpowM :: Monad m => Int -> (a -> m a) -> a -> m a+funpowM n f x+    | n <= 0 = return x+    | otherwise = funpowM (n - 1) f =<< f x++{-| +  Repeatedly applies a monadic computation to an argument until there is a +  failure.  The '<|>' operator is used for branching.+-}+repeatM :: (Alternative m, Monad m) => (a -> m a) -> a -> m a+repeatM f x = (repeatM f =<< f x) <|> return x+++{-| +  A safe version of a list map for functions of arity 2.  Fails with 'Nothing'+  if the two lists are of different lengths.+-}+map2 :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]+map2 _ [] [] = Just []+map2 f (x:xs) (y:ys) =+  do zs <- map2 f xs ys+     return $! f x y : zs+map2 _ _ _ = Nothing++{-| +  The monadic version of 'map2'.  Fails with 'mzero' if the two lists are of+  different lengths.+-}+map2M :: (Monad m, MonadPlus m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+map2M _ [] [] = return []+map2M f (x:xs) (y:ys) =+  do h <- f x y+     t <- map2M f xs ys+     return (h : t)+map2M _ _ _ = mzero++{-|+  Map a monadic function over a list, ignoring the results.  A re-export of +  'mapM_'.+-}+doList :: Monad m => (a -> m b) -> [a] -> m ()+doList = mapM_++-- all pairs arrising from applying a function over two lists+{-|+  Produces a list containing the results of applying a function to all possible +  combinations of arguments from two lists.  Rather than failing if the lists+  are of different lengths, iteration is shortcutted to end when the left most+  list is null.+-}+allpairs :: (a -> b -> c) -> [a] -> [b] -> [c]+allpairs _ [] _ = []+allpairs f (h:t) l2 = foldr (\ x a -> f h x : a) (allpairs f t l2) l2++-- list iteration+{-| +  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)++-- | The monadic version of 'itlist'.+itlistM :: (F.Foldable t, Monad m) => (a -> b -> m b) -> t a -> b -> m b+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++{-|+  An alias to 'foldl' for HOL users more familiar with this name.  Note that the+  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++{-| +  A safe version of 'foldr1'.  Fails with 'Nothing' if an empty list is provided+  as an argument.+-}+tryFoldr1 :: (a -> a -> a) -> [a] -> Maybe a+tryFoldr1 _ [] = Nothing+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++{-| +  The monadic version of 'foldr1'.  Fails with 'mzero' if an empty list is+  provided as an argument.+-}+foldr1M :: (Monad m, MonadPlus m) => (a -> a -> m a) -> [a] -> m a+foldr1M _ [] = mzero+foldr1M _ [x] = return x+foldr1M f (h:t) = f h =<< foldr1M f t++{-| +  A safe version of a right, list fold for functions of arity 2.  Fails with+  'Nothing' if the two lists are of different lengths.+-}+foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> Maybe c+foldr2 _ b [] [] = Just b+foldr2 f b (x:xs) (y:ys) =+    do b' <- foldr2 f b xs ys+       return $! f x y b'+foldr2 _ _ _ _ = Nothing++{-|+  An alias to 'foldr2' for HOL users more familiar with this name.  Note that+  the order of the two list arguments and the base case argument is flipped.+-}+{-# INLINE itlist2 #-}+itlist2 :: (a -> b -> c -> c) -> [a] -> [b] -> c -> Maybe c+itlist2 f xs ys b = foldr2 f b xs ys++{-|+  The monadic version of 'foldr2'.  Fails with 'mzero' if the two lists are+  of different lengths.+-}+foldr2M :: (Monad m, MonadPlus m) => +           (a -> b -> c -> m c) -> c -> [a] -> [b] -> m c+foldr2M _ b [] [] = return b+foldr2M f b (h1:t1) (h2:t2) = f h1 h2 =<< foldr2M f b t1 t2+foldr2M _ _ _ _ = mzero++{-|+  A safe version of a left, list fold for functions of arity 2.  Fails with+  'Nothing' if the two lists are of different lengths.+-}+foldl2 :: (c -> a -> b -> c) -> c -> [a] -> [b] -> Maybe c+foldl2 _ b [] [] = Just b+foldl2 f b (x:xs) (y:ys) =+  foldl2 f (f b x y) xs ys +foldl2 _ _ _ _ = Nothing++{-|+  An alias to 'foldl2' for HOL users more familiar with this name.  Note that+  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++{-|+  The monadic version of 'foldl2'.  Fails with 'mzero' if the two lists are+  of different lengths.+-}+foldl2M :: (Monad m, MonadPlus m) => +           (c -> a -> b -> m c) -> c -> [a] -> [b] -> m c+foldl2M _ b [] [] = return b+foldl2M f b (h1:t1) (h2:t2) =+    do b' <- f b h1 h2+       foldl2M f b' t1 t2+foldl2M _ _ _ _ = mzero++-- sorting and merging of lists++{-|+  Sorts a list using a partitioning predicate to build an implied ordering.+  If @p@ is the predicate and @x \`p\` y@ and @not (y \`p\` x)@ are true then +  @x@ will be in front of @y@ in the sorted list.+-}+sort :: Eq a => (a -> a -> Bool) -> [a] -> [a]+sort _ [] = []+sort f (piv:rest) =+    let (r, l) = partition (f piv) rest in+      sort f l ++ (piv : sort f r)++{-| +  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++{-|+  Merges two lists using a partitioning predicate to build an implied ordering.+  See 'sort' for more information on how the predicate affects the order of the+  resultant list.+-}+merge :: (a -> a -> Bool) -> [a] -> [a] -> [a]+merge _ [] l2 = l2+merge _ l1 [] = l1+merge ord l1@(x:xs) l2@(y:ys)+  | ord x y = x : merge ord xs l2+  | otherwise = y : merge ord l1 ys++{-|+  Sorts a list using a partitioning predicate to build an implied ordering;+  uses 'merge' internally.  See 'sort' for more information on how the predicate+  affects the order of the resultant list.+-}+mergesort :: forall a. (a -> a -> Bool) -> [a] -> [a]+mergesort _ [] = []+mergesort ord l = mergepairs [] $ map (: []) l+  where mergepairs :: [[a]] -> [[a]] -> [a]+        mergepairs (x:[]) [] = x+        mergepairs xs [] = mergepairs [] 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+{-|+  Repeatedly applies a binary destructor function to a term until failure.+  +  Application is forward, or left-associative, such that for a term of the form+  @x1 \`f\` x2 \`f\` b@ calling this function with a destructor for @f@ will+  produce the result @([x1, x2], b)@.+-}+splitList :: (b -> Maybe (a, b)) -> b -> ([a], b)+splitList f x = +    case f x of+      Just (l, r) -> +          let (ls, res) = splitList f r in+            (l:ls, res)+      Nothing -> ([], x)++-- | The monadic version of 'splitList'.+splitListM :: (Alternative m, Monad m) => (b -> m (a, b)) -> b -> m ([a], b)+splitListM f x = +    (do (l, r) <- f x+        (ls, res) <- splitListM f r+        return (l:ls, res))+    <|> return ([], x)++{-|+  Repeatedly applies a binary destructor function to a term until failure.+  +  Application is reverse, or right-associative, such that for a term of the form+  @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 f = recSplit []+  where recSplit :: [a] -> a -> (a, [a])+        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 f = rsplist []+  where rsplist :: [b] -> b -> m (b, [b])+        rsplist ls y = +            (do (l, r) <- f y+                rsplist (r:ls) l)+            <|> return (y, ls)+                            +{-|+  Repeatedly applies a binary destructor function to a term for every element+  in a provided list.+  +  Application is reverse, or right-associative, such that for a term of the form+  @f x1 (f x2 ...(f xn b))@ calling this function with a destructor for @f@ and+  a list @l@ will produce the result @([x1 .. xk], f x(k+1) ...(f xn b))@ where +  @k@ is the length of list @l@.+-}+nsplit :: (a -> Maybe (a, a)) -> [b] -> a -> Maybe ([a], a)+nsplit _ [] x = return ([], x)+nsplit dest (_:cs) x =+    do (l, r) <- dest x+       (ll, y) <- nsplit dest cs r+       return (l:ll, y)++-- | The monadic version of 'nsplit'.+nsplitM :: Monad m => (b -> m (b, b)) -> [c] -> b -> m ([b], b)+nsplitM _ [] x = return ([], x)+nsplitM dest (_:n) x = +    do (l, r) <- dest x+       (ll, y) <- nsplitM dest n r+       return (l:ll, y)++{-|+  Repeatedly applies a binary destructor function to a term until failure.+  +  Application is forward, or left-associative, such that for a term of the form+  @x1 \`f\` x2 \`f\` x3@ calling this function with a destructor for @f@ will+  produce the result @[x1, x2, x3]@.+-}+stripList :: forall a. (a -> Maybe (a, a)) -> a -> [a]+stripList dest x = strip x []+  where strip :: a -> [a] -> [a]+        strip x' acc =+            case dest x' of+              Just (l, r) -> strip l $ strip r acc+              Nothing -> x' : acc++-- | The monadic version of 'stripList'.+stripListM :: forall m a. (Alternative m, Monad m) => +                          (a -> m (a, a)) -> a -> m [a]+stripListM dest x = strip x []+  where strip :: a -> [a] -> m [a]+        strip x' acc =+          (do (l, r) <- dest x'+              strip l =<< strip r acc)+          <|> return (x' : acc)+++-- 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++{-| +  A version of 'all' for predicates of arity 2.  Iterates down two lists+  simultaneously with 'map2', using 'and' to combine the results.+-}+forall2 :: (a -> b -> Bool) -> [a] -> [b] -> Maybe Bool+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++{-| +  The monadic version of 'mapFilter'.  The '(<|>)' operator is used for +  branching.+-}+mapFilterM :: (Alternative m, Monad m) => (a -> m b) -> [a] -> m [b]+mapFilterM _ [] = return []+mapFilterM f (x:xs) =+    do xs' <- mapFilterM f xs+       (do x' <- f x+           return (x':xs'))+         <|> return xs'++-- | A re-export of 'L.find'.+{-# INLINEABLE find #-}+find :: (a -> Bool) -> [a] -> Maybe a+find = L.find++{-| +  The monadic version of 'find'.  Fails if the monadic predicate does.  Also +  fails with 'mzero' if an empty list is provided.+-}+findM :: (Monad m, MonadPlus m) => (a -> m Bool) -> [a] -> m a+findM _ [] = mzero+findM f (x:xs) =+    do b <- f x+       if b+          then return x+          else findM f xs++{-|+  An alternative monadic version of 'find' where the predicate is a monadic+  computation not necessarily of a boolean return type.  Returns the result of+  the first successful application of the predicate to an element of the list.+  Fails with 'mzero' if called on an empty list.  ++  Note that 'mplus' is used for branching instead of '<|>' to minimize the +  constraint type; for the vast majority of monads these two functions should be+  identical anyway.+-}+tryFind :: (Monad m, MonadPlus m) => (a -> m b) -> [a] -> m b+tryFind _ [] = mzero+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++{-| +  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++{-| +  Separates the first element of a list that satisfies a predicate.  Fails with+  'Nothing' if no such element is found.+-}+remove :: (a -> Bool) -> [a] -> Maybe (a, [a])+remove _ [] = Nothing+remove p (h:t)+  | p h = Just (h, t)+  | otherwise =+      do (y, n) <- remove p t+         return (y, h:n)++{-|+  A safe version of 'splitAt'.   Fails with 'Nothing' if a split is attempted+  at an index that doesn't exist.+-}+trySplitAt :: Int -> [a] -> Maybe ([a], [a])+trySplitAt n l+    | n < 0 = Nothing+    | n == 0 = Just ([], l)+    | otherwise = +        case l of+          [] -> Nothing+          (x:xs) -> do (m, l') <- trySplitAt (n - 1) xs+                       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++{-|+  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++{-|+  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++-- | Removes adjacent, equal elements from a list.+uniq :: Eq a => [a] -> [a]+uniq (x:y:t) =+  let t' = uniq t in+    if x == y then t' else x : t'+uniq l = l++{-| +  Partitions a list into a list of lists matching the structure of the first +  argument. For example:+  @shareOut [[1, 2], [3], [4, 5]] \"abcde\" === [\"ab\", \"c\", \"de\"]@+-}+shareOut :: [[a]] -> [b] -> Maybe [[b]]+shareOut [] _ = Just []+shareOut (p:ps) bs = +    do (l, r) <- chopList (length p) bs+       ls <- shareOut ps r+       return (l : ls)++-- 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++{-|  +  Inserts an item into a list if it would be a unique element.++  Important note:  This insert is unordered, unlike the 'L.insert' in the+  "Data.List" module.+-}+insert :: Eq a => a -> [a] -> [a]+insert x l+    | x `elem` l = l+    | otherwise = x : l++{-|+  Inserts, or updates, a key value pair in an association list.++  Note that this insert is unordered, but uniqueness preserving.+-}+insertMap :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+insertMap key v [] = [(key, v)]+insertMap key v (x@(key', _):xs)+    | key == key' = (key, v) : xs+    | otherwise = x : insertMap key v xs++{-|+  Unions two list maintaining uniqueness of elements.++  Important note:  This union is unordered, unlike the 'L.union' in the+  "Data.List" module.+-}+union :: Eq a => [a] -> [a] -> [a]+union l1 l2 = foldr insert l2 l1++-- | Unions a list of lists using 'union'.+unions :: Eq a => [[a]] -> [a]+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.\\)++-- | Tests if the first list is a subset of the second.+subset :: Eq a => [a] -> [a] -> Bool+subset xs ys = all (`elem` ys) xs++-- | A test for set equality using 'subset'.+setEq :: Eq a => [a] -> [a] -> Bool+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++-- set operations parameterized by equality+{-|+  A version of 'mem' where the membership test is an explicit predicate, rather+  than a strict equality test.+-}+mem' :: (a -> a -> Bool) -> a -> [a] -> Bool+mem' _ _ [] = False+mem' eq a (x:xs) = eq a x || mem' eq a xs++{-|+  A version of 'insert' where the uniqueness test is an explicit predicate, +  rather than a strict equality test.+-}+insert' :: (a -> a -> Bool) -> a -> [a] -> [a]+insert' eq x xs+  | mem' eq x xs = xs+  | otherwise = x : xs++{-|+  A version of 'union' where the uniqueness test is an explicit predicate, +  rather than a strict equality test.+-}+union' :: (a -> a -> Bool) -> [a] -> [a] -> [a]+union' eq xs ys = foldr (insert' eq) ys xs++{-|+  A version of 'unions' where the uniqueness test is an explicit predicate, +  rather than a strict equality test.+-}+unions' :: (a -> a -> Bool) -> [[a]] -> [a]+unions' eq = foldr (union' eq) []++{-|+  A version of 'subtract' where the uniqueness test is an explicit predicate, +  rather than a strict equality test.+-}+subtract' :: (a -> a -> Bool) -> [a] -> [a] -> [a]+subtract' eq xs ys = filter (\ x -> not $ mem' eq x ys) xs++{-|+  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++-- | A version of 'uniq' that eliminates elements based on a provided predicate.+uniq' :: Eq a => (a -> a -> Bool) -> [a] -> [a]+uniq' eq l@(x:t@(y:_)) =+    let t' = uniq' eq t in+      if x `eq` y then t'+      else if t' == t then l else x:t'+uniq' _ l = l++{-| +  A version of 'setify' that eliminates elements based on a provided predicate.+-}+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)++{-| +  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++-- | 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+  the 'Num' class.  Fails with 'Nothing' if the conversion cannot be performed.++  Note:  The following prefixes are valid:++  * @0x@ - number read as a hexidecimal value++  * @0b@ - number read as a binary value++  * Any other prefix causes the number to be read as a decimal value+-}+numOfString :: forall a. (Eq a, Num a) => String -> Maybe a+numOfString s =+    case res of+      [(x, "")] -> Just x+      _ -> Nothing+   where res :: [(a, String)]+         res = case s of+                 ('0':'x':s') -> readHex s'+                 ('0':'b':s') -> readInt 2 (`elem` "01") digitToInt s'+                 _ -> readDec s++-- language type classes+{-$LangClasses+  The following two classes are used as an ad hoc mechanism for sharing+  \"language\" operations between different types.  For example, both tactics+  and conversions share a number of the same operations.  Rather than having +  multiple functions, such as @thenTac@ and @thenConv@, we've found it easier to+  have a single, polymorphic function to use, '_THEN'.++  The sequencing operations are seperated in their own class, 'LangSeq', because+  their tactic instances have a reliance on the boolean logic theory.  Rather +  than unecessarily propogate this prerequisite for all members of the 'Lang' +  class, we elected to separate them.+-}+{-| +  The 'Lang' class defines common language operations and combinators not based+  on sequencing.+-}+class Lang a where+    {-| +      A primitive language operation that always fails.  Typically this is+      written using 'throw'.+    -}+    _FAIL :: String -> a+    -- | An instance of '_FAIL' with a fixed failure string.+    _NO :: a+    -- | A primitive language operation that always succeeds.+    _ALL :: a+    {-| +      A language combinator for branching based on failure.  The language+      equivalent of the '<|>' operator.+    -}+    _ORELSE :: a -> a -> a+    -- | A language combinator that performs the first operation in a list.+    _FIRST :: [a] -> a+    {-| +      A language combinator that fails if the wrapped operation doesn't invoke+      some change, i.e. a tactic fails to change the goal state.+    -}+    _CHANGED :: a -> a+    {-| +      A language combinator that prevents the wrapped operation from having an+      effect if it fails.  The language equivalent of the backtracking 'try' +      operator.+    -}+    _TRY :: 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+  to why these are separated on their own.+-}+class LangSeq a where+    -- | A language combinator that sequences operations.+    _THEN :: a -> a -> a+    {-| +      A language combinator that repeatedly applies a language operation until +      failure.+    -}+    _REPEAT :: a -> a+    {-| +      A language combinator that performs every operation in a list  +      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/Lift.hs view
@@ -0,0 +1,158 @@+{-# 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
@@ -0,0 +1,92 @@+{-|+  Module:    HaskHOL.Core.Parser+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines the parsers for 'HOLType's and 'HOLTerm's.++  It also re-exports the related benign flags, theory extension mechanisms, +  and type/term elaborators.++  For examples of the parsers and elaborators in use see the +  "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+      -- * Parsing Functions+    , holTypeParser -- :: String -> HOLContext thry -> Either ParseError PreType+    , holTermParser -- :: String -> HOLContext thry -> Either ParseError PreTerm+      -- * Type/Term Representation Conversions+    , HOLTypeRep(..)+    , HOLTermRep(..)+    ) where++import HaskHOL.Core.State++import HaskHOL.Core.Parser.Lib+import HaskHOL.Core.Parser.TypeParser+import HaskHOL.Core.Parser.TermParser+import HaskHOL.Core.Parser.Elab+import HaskHOL.Core.Parser.Rep++runHOLParser :: MyParser thry a -> String -> HOLContext thry -> +                Either ParseError a+runHOLParser parser input ctxt =+    runParser parser (ctxt, []) "" input++-- | Parser for 'HOLTerm's.+holTermParser :: String -> HOLContext thry -> Either ParseError PreTerm+holTermParser = runHOLParser pterm++-- | Parser for 'HOLType's.+holTypeParser :: String -> HOLContext thry -> Either ParseError PreType+holTypeParser = runHOLParser ptype
+ src/HaskHOL/Core/Parser.hs-boot view
@@ -0,0 +1,9 @@+module HaskHOL.Core.Parser where++import HaskHOL.Core.State++import HaskHOL.Core.Parser.Lib++holTermParser :: String -> HOLContext thry -> Either ParseError PreTerm++holTypeParser :: String -> HOLContext thry -> Either ParseError PreType
+ src/HaskHOL/Core/Parser/Elab.hs view
@@ -0,0 +1,564 @@+{-|+  Module:    HaskHOL.Core.Parser.Elab+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines the elaborators for types and terms.  These elaborators+  convert 'PreType's and 'PreTerm's, as produced by the parsers, into +  '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+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State+import HaskHOL.Core.Basics++import HaskHOL.Core.Parser.Lib hiding ((<?>))++{- +  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)]++-- utility functions+destSTV :: PreType -> Maybe Int+destSTV (STyVar n) = Just n+destSTV _ = Nothing++destUTy :: PreType -> Maybe String+destUTy (UTyVar _ x _) = Just x+destUTy _ = Nothing++destPUTy :: PreType -> Maybe (PreType, PreType)+destPUTy (PUTy tv ty) = Just (tv, ty)+destPUTy _ = Nothing++freeSTVS0 :: PreType -> [Int]+freeSTVS0 PTyCon{} = []+freeSTVS0 UTyVar{} = []+freeSTVS0 (STyVar n) = [n]+freeSTVS0 (PTyComb _ args) =+    foldr (\ x y -> freeSTVS0 x `union` y) [] args+freeSTVS0 (PUTy _ tbody) = freeSTVS0 tbody++utyvars :: PreType -> [PreType]+utyvars PTyCon{} = []+utyvars tv@UTyVar{} = [tv]+utyvars STyVar{} = []+utyvars (PTyComb t args) = foldr (union . utyvars) [] $ t : args+utyvars (PUTy tv tbody) = utyvars tbody \\ [tv]++catUTyVars :: [PreType] -> [PreType]+catUTyVars = foldr (union . utyvars) []++variantUTyVar :: [PreType] -> PreType -> PreType+variantUTyVar avoid tv@(UTyVar f name n)+    | tv `elem` avoid = variantUTyVar avoid $ UTyVar f (name ++ "'") n+    | otherwise = tv+variantUTyVar _ tv = tv++mkFunPTy :: PreType -> PreType -> PreType+mkFunPTy pty1 pty2 = PTyComb (PTyCon "fun") [pty1, pty2]++{- +  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 c ty subs =+    (do cty' <- liftM (typeSubst subs) $ getConstType c+        let (mat1Tys, opTys, opOps) = fromJust $ typeMatch cty' ty ([], [], [])+            tys' = map (second $ typeSubst mat1Tys) subs ++ mat1Tys+            mat2 = (tys', opTys, opOps)+        con <- mkConstFull c mat2+        if typeOf con == ty+           then return con+           else mzero)+    <?> "mkTIConst"++-- Constructs a PreTerm representation of a provided integer.+pmkNumeral :: Integer -> PreTerm+pmkNumeral = PComb numeral . pmkNumeralRec +  where numPTy :: PreType+        numPTy = PTyComb (PTyCon "num") []+        +        numeral, bit0, bit1, t0 :: PreTerm+        numeral = PConst "NUMERAL" $ mkFunPTy numPTy numPTy+        bit0 = PConst "BIT0" $ mkFunPTy numPTy numPTy+        bit1 = PConst "BIT1" $ mkFunPTy numPTy numPTy+        t0 = PConst "_0" numPTy++        pmkNumeralRec :: Integer -> PreTerm+        pmkNumeralRec 0 = t0+        pmkNumeralRec n = +            let op = if n `mod` 2 == num0 then bit0 else bit1 in+              PComb op . pmkNumeralRec $ n `div` 1++{- +  Checks if a unification for a system type variable is trivial, i.e. unifying+  with itself or a unification between two system type variables already stored+  in the environment.++  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 _ _ PTyCon{} = Just False+istrivial env x (STyVar y)+    | y == x = Just True+    | otherwise = +        (istrivial env x =<< lookup y env) <|> return False+istrivial _ _ UTyVar{} = Just False+istrivial env x (PTyComb f args) =+    do ys' <- mapM (istrivial env x) $ f : args+       if or ys'+          then Nothing+          else return False+istrivial env x (PUTy _ tbody) =+    do tbody' <- istrivial env x tbody+       if tbody'+          then Nothing+          else return False++-- system type generation+newTypeVar :: HOL cls thry PreType+newTypeVar = return STyVar <*> tickTypeCounter++-- 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++-- Check where unification of ty with a UType is potentially possible+unifiableWithUType :: PreType -> PEnv -> Bool+unifiableWithUType ty env+    | ty == dpty = False+    | otherwise = +          let tys = solve env ty in+            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 cname =+    do ctxt <- get+       case filter (\ (x, _) -> x == cname) $ getInterface ctxt of+         ((_, (_, ty)):[]) -> return ty+         (_:_:_) -> liftMaybe "getGenericType" . assoc cname $ getOverloads ctxt+         _ -> getConstType cname++{- +  Pretype substitution based on HOLType substitution.+  Note that the PTyCon case is comparatively simpler given the extra work done +  in the parser.+-}+pretypeSubst :: [(PreType, PreType)] -> PreType -> PreType+pretypeSubst _ ty@PTyCon{} = ty+pretypeSubst tyenv ty@UTyVar{} = revAssocd ty tyenv ty+pretypeSubst _ ty@STyVar{} = ty+pretypeSubst tyenv ty@(PTyComb tyop args) =+    let tyop' = pretypeSubst tyenv tyop +        args' = map (pretypeSubst tyenv) args in+      if tyop == tyop' && args == args' then ty+      else case tyop' of+             PUTy{} -> let (rtvs, rtbody) = splitList destPUTy tyop' in+                         pretypeSubst (zip args' rtvs) rtbody+             _ -> PTyComb tyop' args'+pretypeSubst tyenv ty@(PUTy tv tbody) =+    let tyenv' = filter (\ (_, x) -> x /= tv) tyenv in+      if null tyenv' then ty+      else if any (\ (t, x) -> tv `elem` utyvars t && +                               x `elem` utyvars tbody) tyenv'+           then let tvbody = utyvars tbody+                    tvpatts = map snd tyenv'+                    tvrepls = catUTyVars . map (\ x -> revAssocd x tyenv' x) $ +                                intersect tvbody tvpatts +                    tv' = variantUTyVar ((tvbody \\ tvpatts) `union` tvrepls) tv in+                  PUTy tv' $ pretypeSubst ((tv', tv):tyenv') tbody+           else PUTy tv $ pretypeSubst tyenv' tbody++-- Apply type unifications+solve :: PEnv -> PreType -> PreType+solve _ pty@PTyCon{} = pty +solve _ pty@UTyVar{} = pty+solve env pty@(STyVar i) =+    fromMaybe pty . liftM (solve env) $ lookup i env+solve env (PTyComb f args) = +    PTyComb (solve env f) $ map (solve env) args+solve env (PUTy tv tbod) =+    PUTy tv $ solve env tbod+                            +-- Final type checker for preterms+{- +  Local reference that tracks if we invent system type (operator) variables.+  Also used to track the smallness constraints of system type variables.+-}+type TypingState = HOLRef TypingRefs+data TypingRefs = TypingRefs+    { stvsTrans :: !Bool+    , stovsTrans :: !Bool+    , smallSTVS :: ![Int]+    }++-- Post typechecking elaboration+tyElabRef :: TypingState -> PreType -> HOL cls thry HOLType+tyElabRef _ (PTyCon s) = mkType s []+tyElabRef ref (PTyComb STyVar{} []) =+    do modifyHOLRef ref $ \ st -> st { stvsTrans = True }+       fail $ "tyElab: system type variable present in type application of " +++              "null arity"+tyElabRef ref (PTyComb (STyVar n) args) =+    do modifyHOLRef ref $ \ st -> st { stovsTrans = True }+       mkType ('?' : show n) =<< mapM (tyElabRef ref) args+tyElabRef ref (PTyComb (UTyVar _ v _) args) =+    mkType v =<< mapM (tyElabRef ref) args+tyElabRef ref (PTyComb (PTyCon s) args) =+    mkType s =<< mapM (tyElabRef ref) args+tyElabRef _ PTyComb{} =+    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'+tyElabRef ref (PUTy STyVar{} _) =+    do modifyHOLRef ref $ \ st -> st { stvsTrans = True }+       fail "tyElab: system type variable in universal type."+-- Alternative way to handle this if we don't want to make it an error, +-- per HOL2P:+{-+tyElabRef ref (PUTy tv@(STyVar n) tbody) =+    do modifyHOLRef ref $ \ st -> st { stvsTrans = True }+       warn True "tyElab: system type variable in universal type."+       let tv' = '?' : show n+       tbody' <- tyElabRef ref $ pretypeSubst [(UTyVar True tv' 0, tv)] tbody+       liftMaybe "tyElab: universal type - system type variable case" $+         do tv'' <- mkSmall $ mkVarType tv'+            mkUType tv'' tbody'+-}+tyElabRef _ PUTy{} =+    fail "tyElab: invalid universal type construction."+tyElabRef ref (STyVar n) =+    do modifyHOLRef ref $ \ st -> st { stvsTrans = True }+       let tv = mkVarType $ '?' : show n+       st <- readHOLRef ref+       if n `elem` smallSTVS st+          then liftEither "tyElab: small system type variable" $ mkSmall tv+          else return tv+tyElabRef _ (UTyVar True v _) = +    liftEither "tyElab: small user type variable" . mkSmall $ mkVarType v+tyElabRef _ (UTyVar False v _) = return $! mkVarType v++tmElab :: TypingState -> PreTerm -> HOL cls thry HOLTerm+tmElab ref ptm =+    do modifyHOLRef ref $ \ st -> st { stvsTrans = False, stovsTrans = False }+       tm <- tmElabRec ptm+       st <- readHOLRef ref+       flag1 <- getBenignFlag FlagTyInvWarning+       flag2 <- getBenignFlag FlagTyOpInvWarning+       warn (stvsTrans st && flag1) +         "warning: inventing type variables"+       warn (stovsTrans st && flag2) +         "warning: inventing type operator variables"+       return tm+  where tmElabRec :: PreTerm -> HOL cls thry HOLTerm+        tmElabRec PApp{} =+            fail $ "tmElab: type application present outside of type " +++                   "combination term"+        tmElabRec (PVar s pty) = +            liftM (mkVar s) $ tyElabRef ref pty+        tmElabRec (PConst s pty) = +            mkMConst s =<< tyElabRef ref pty+        tmElabRec (PInst tvis (PConst c pty)) =+            do tvis' <- mapM (\ (ty, x) -> do ty' <- tyElabRef ref ty+                                              return (mkVarType x, ty')) tvis+               pty' <- tyElabRef ref pty+               mkTIConst c pty' tvis'+        tmElabRec PInst{} =+            fail "tmElab: body of TYINST not a constant."+        tmElabRec (PComb l r) =+            do (l', r') <- pairMapM tmElabRec (l, r)+               liftEither "tmElab" $ mkComb l' r'+        tmElabRec (PAbs v bod) =+            do (v', bod') <- pairMapM tmElabRec (v, bod)+               mkGAbs v' bod'+        tmElabRec (TyPAbs tv t) =+            do tv' <- tyElabRef ref tv+               t' <- tmElabRec t+               liftEither "tmElab" $ mkTyAbs tv' t'+        tmElabRec (TyPComb t _ ti) =+            do t' <- tmElabRec t+               ti' <- tyElabRef ref ti+               liftEither "tmElab" $ mkTyComb t' ti'+        tmElabRec (PAs tm _) = tmElabRec tm++-- retypecheck+preTypeOf :: TypingState -> [(String, PreType)] -> PreTerm -> +             HOL cls thry PreTerm+preTypeOf ref senv pretm = +    do ty <- newTypeVar +       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)+        typify ty (PVar s _, venv, uenv) =+            case lookup s venv of+              Just ty' -> +                do flag <- getBenignFlag FlagAddTyAppsAuto+                   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+                              typify ty (tys', venv, uenv)+                      else do uenv' <- unify uenv (tys, ty)+                              return (PVar s tys, [], uenv')+              Nothing -> +                case numOfString s of+                  Just s' -> +                    let t = pmkNumeral s' in+                      do uenv' <- unify uenv (PTyComb (PTyCon "num") [], ty)+                         return (t, [], uenv')+                  Nothing ->+                    (do s' <- getGenericType s+                        hidden <- gets 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+                                              typify ty (ty', venv, uenv)+                                      else do uenv' <- unify uenv (tys, ty)+                                              return (PConst s tys, [], uenv')+                           else mzero)+                    <|> 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)+               let cty = pretypeOfType c'+               let tvs = map snd tvis+                   rtvs = filter (\ x -> case x of+                                             UTyVar _ x' _ -> x' `elem` tvs+                                             _ -> False) $ utyvars cty+               if length rtvs < length tvs+                  then let rtvNames = fromJust $ mapM destUTy rtvs+                           (missing:_) = filter (`notElem` rtvNames) tvs in+                         fail $ "typify: TYINST: type does not contain " ++ +                                "tyvar " ++ missing+                  else let subs = fromJust $ mapM (\ tv -> +                                                   do x <- destUTy tv+                                                      x' <- revAssoc x tvis+                                                      return (x', tv)) rtvs+                           tvis' = fromJust $ mapM (\ (t, tv) ->+                                                    do x <- destUTy tv+                                                       return (t, x)) subs in+                         do ctyrep <- replaceUtvsWithStvs tvs cty+                            let cty' = pretypeSubst subs ctyrep+                            uenv' <- unify uenv (cty', ty)+                            return (PInst tvis' (PConst c cty'), [], uenv')+        typify ty (PComb t (PApp ti), venv, uenv) =+            do ntv <- newTypeVar+               (t', venv1, uenv1) <- typify ntv (t, venv, uenv)+               case solve uenv1 ntv of+                 ty'@(PUTy ty1 ty2) -> +                     do uenv1' <-  unify uenv1 +                                     (ty, pretypeSubst [(ti, ty1)] ty2)+                        return (TyPComb t' ty' ti, venv1, uenv1')+                 _ -> fail $ "typify: Type application argument maybe not " +++                             "of universal type: " ++ show t+        typify ty (PComb f x, venv, uenv) =+            do ty'' <- newTypeVar+               let ty' = mkFunPTy ty'' ty+               (f', venv1, uenv1) <- typify ty' (f, venv, uenv)+               (x', venv2, uenv2) <- typify (solve uenv1 ty'') +                                       (x, venv1 ++ venv, uenv1)+               return (PComb f' x', venv1 ++ venv2, uenv2)+        typify ty (ptm@(PAs tm pty), venv, uenv) =+            do flag <- getBenignFlag FlagAddTyAppsAuto+               if flag && isJust (destPUTy pty) && +                  not (unifiableWithUType ty uenv)+                  then do ty' <- addTyApps ptm pty+                          typify ty (ty', venv, uenv)+                  else do uenv' <- unify uenv (ty, pty)+                          typify ty (tm, venv, uenv')+        typify ty (PAbs v bod, venv, uenv) =+            do (ty', ty'') <- case ty of+                                  PTyComb (PTyCon "fun") [ty', ty''] -> +                                      return (ty', ty'')+                                  _ -> do ty1 <- newTypeVar+                                          ty2 <- newTypeVar+                                          return (ty1, ty2)+               uenv0 <- unify uenv (mkFunPTy ty' ty'', ty)+               (v', venv1, uenv1) <- do (v', venv1, uenv1) <- typify ty' +                                                                (v, [], uenv0)+                                        flag <- getBenignFlag +                                                  FlagIgnoreConstVarstruct+                                        case v' of+                                          PConst s _ -> return $! +                                            if flag+                                            then (PVar s ty', [(s, ty')], uenv0)+                                            else (v', venv1, uenv1)+                                          _ -> return (v', venv1, uenv1)+               (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+               (bod', venv1, uenv1) <- typify ntv (bod, venv, uenv)+               uenv2 <- unify uenv1 (PUTy tv $ solve uenv1 ntv, ty)+               return (TyPAbs tv bod', venv1, uenv2)+        typify ty (TyPComb t (PUTy ty1 ty2) ti, venv, uenv) =+            do uenv0 <- unify uenv (pretypeSubst [(ti, ty1)] ty2, ty)+               (t', venv1, uenv1) <- typify (PUTy ty1 ty2) (t, venv, uenv0)+               return (TyPComb t' (PUTy ty1 ty2) ti, venv1, uenv1)+        typify _ (ptm, _, _) =+            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 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+                            when f $ modifyHOLRef ref +                              (\ st -> st { smallSTVS = n : smallSTVS st})+                            return (tv', tv)+                subsf _ = fail "replaceUtvsWithStvs"++        pretypeInstance :: HOLType -> HOL cls thry PreType+        pretypeInstance = replaceUtvsWithStvs [] . pretypeOfType++-- Type constraint specialization by resolving overloadings+        resolveInterface :: PreTerm -> (PEnv -> HOL cls thry PEnv) -> PEnv -> +                            HOL cls thry PEnv+        resolveInterface PApp{} _ _ =+            fail "resolveInterface: type application"+        resolveInterface (PComb f x) cont env =+            resolveInterface f (resolveInterface x cont) env+        resolveInterface (PAbs v bod) cont env =+            resolveInterface v (resolveInterface bod cont) env+        resolveInterface (TyPAbs _ bod) cont env =+            resolveInterface bod cont env+        resolveInterface (TyPComb t _ _) cont env =+            resolveInterface t cont env+        resolveInterface PAs{} _ _ =+            fail "resolveInterface: type ascription"+        resolveInterface (PInst _ bod) cont env =+            resolveInterface bod cont env+        resolveInterface PVar{} cont env =+            cont env+        resolveInterface (PConst s ty) cont env =+            do iface <- gets getInterface+               let maps = filter (\ (s', _) -> s' == s) iface+               if null maps +                  then cont env+                  else tryFind (\ (_, (_, ty')) -> +                                do ty'' <- pretypeInstance ty'+                                   cont =<< unify env (ty'', ty)) maps++-- Push specialization throughout a preterm+        solvePreterm :: PEnv -> PreTerm -> HOL cls thry PreTerm+        solvePreterm _ PApp{} =+            fail "solvePreterm: type application"+        solvePreterm env (PVar s ty) = return . PVar s $ solve env ty+        solvePreterm env (PComb f x) =+            do (f', x') <- pairMapM (solvePreterm env) (f, x)+               return $! PComb f' x'+        solvePreterm env (PAbs v bod) =+            do (v', bod') <- pairMapM (solvePreterm env) (v, bod)+               return $! PAbs v' bod'+        solvePreterm env (TyPAbs tv bod) =+            liftM (TyPAbs tv) $ solvePreterm env bod+        solvePreterm env (TyPComb t ty ti) =+            let ti' = solve env ti in+              do modifyHOLRef ref $+                   \ st -> st { smallSTVS = smallSTVS st `union` freeSTVS0 ti' }+                 t' <- solvePreterm env t+                 return $! TyPComb t' (solve env ty) ti'+        solvePreterm env (PInst tys bod) =+            liftM (PInst tys) $ solvePreterm env bod+        solvePreterm _ PAs{} =+            fail "solvePreterm: type ascription"+        solvePreterm env (PConst s ty) =+            let tys = solve env ty in+              (do iface <- gets getInterface+                  c' <- tryFind (\ (s', (c', ty')) ->+                                 if s == s'+                                 then do ty'' <- pretypeInstance ty'+                                         _ <- unify env (ty'', ty)+                                         return c'+                                 else mzero) iface+                  pmkCV c' tys)+              <|> (return $! PConst s tys)+          where pmkCV :: String -> PreType -> HOL cls thry PreTerm+                pmkCV name pty = +                    do cond <- can getConstType name+                       return $! if cond then PConst name pty +                                 else PVar name pty++-- Unification of types+        unify :: PEnv -> (PreType, PreType) -> HOL cls thry PEnv+        unify env (ty1, ty2)+            | ty1 == ty2 = return env+            | otherwise = +                case (ty1, ty2) of+                  (PTyComb f@STyVar{} fargs, PTyComb g gargs) ->+                    if length fargs == length gargs+                    then foldrM (flip unify) env $ (f, g) : zip fargs gargs+                    else fail $ "unify: " ++ show f ++ " WITH " ++ show g+                  (PTyComb{}, PTyComb STyVar{} _) ->+                    unify env (ty2, ty1)+                  (PTyComb f fargs, PTyComb g gargs) ->+                    if f == g && length fargs == length gargs+                    then foldrM (flip unify) env $ zip fargs gargs+                    else fail $ "unify: " ++ show f ++ " WITH " ++ show g+                  (PUTy tv1@UTyVar{} tbody1, PUTy tv2@UTyVar{} tbody2) ->+                      if tv1 == tv2 then unify env (tbody1, tbody2)+                      else let tv = variantUTyVar (utyvars tbody1 `union` +                                                   utyvars tbody2) tv1 in+                             unify env (pretypeSubst [(tv, tv1)] tbody1, +                                        pretypeSubst [(tv, tv2)] tbody2)+                  (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+                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++-- | Elaborator for 'PreType's.+tyElab :: PreType -> HOL cls thry HOLType+tyElab pty =+    do ref <- newHOLRef $ TypingRefs False False []+       tyElabRef ref pty++-- | Elaborator and type inference for 'PreTerm's.+elab :: PreTerm -> HOL cls thry HOLTerm+elab ptm = +    do ref <- newHOLRef $ TypingRefs False False []+       tmElab ref =<< preTypeOf ref [] ptm
+ src/HaskHOL/Core/Parser/Lib.hs view
@@ -0,0 +1,526 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, ViewPatterns #-}++{-|+  Module:    HaskHOL.Core.Parser.Lib+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines or re-exports common utility functions, type classes, +  and auxilliary data types used in HaskHOL's parsers.  These primarily fall+  three classes of objects:++  * Types and functions used by the parsers.++  * Benign flag and state extensions used by the parsers.++  * Predicates and modifiers for state extensions used by the parsers.++  Note that, because these state extensions were designed to be used with the+  parser, the accessor and predicate functions are written to use 'getExtCtxt' +  rather than 'getExt' for convenience.++  To see what is actually exported to the user, see the module +  "HaskHOL.Core.Parser".+-}++module HaskHOL.Core.Parser.Lib+    ( -- * Parser Utilities and Types+      PreType(..)+    , PreTerm(..)+    , dpty          -- :: PreType+    , pretypeOfType -- :: HOLType -> PreType+    , MyParser+    , myparens+    , mybraces+    , mybrackets+    , mycommaSep1+    , mysemiSep+    , myreserved+    , myidentifier+    , myinteger+    , myoperator+    , myreservedOp+    , choiceOp+    , mywhiteSpace+      -- * 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]+      -- * Re-export Parsec for convenience reasons+    , module Text.ParserCombinators.Parsec+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State+import HaskHOL.Core.Basics++import Text.ParserCombinators.Parsec hiding ((<|>))+import Text.ParserCombinators.Parsec.Token+import Text.ParserCombinators.Parsec.Language (emptyDef)++-- new flags and extensions+{-| +  Flag to say whether to treat a constant varstruct, i.e.  @\\ const . bod@, as+  variable.+-}+newFlag "FlagIgnoreConstVarstruct" True++{-|+  Flag indicating that the user should be warned if a type variable was invented+  during parsing.+-}+newFlag "FlagTyInvWarning" True++{-|+  Flag indicating that the user should be warned if a type operator variable was+  invented during parsing.+-}+newFlag "FlagTyOpInvWarning" True++{-|+  Flag to say whether implicit type applications are to be added during parsing.+-}+newFlag "FlagAddTyAppsAuto" True++newExtension "BinderOps" [| ["\\"] :: [String] |]++newExtension "TyBinderOps" [| ["\\\\"] :: [String] |]++newExtension "PrefixOps" [| [] :: [String] |]++newExtension "InfixOps" +  [| [("=", (12, AssocRight))] :: [(String, (Int, Assoc))] |]++newExtension "Interface" [| [] :: [(String, (String, HOLType))] |]++newExtension "Overload" [| [] :: [(String, HOLType)] |]++newExtension "TypeAbbreviations" [| [] :: [(String, HOLType)] |]++newExtension "Hidden" [| [] :: [String] |]++-- | 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)++-- | 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++-- | The default 'PreType' to be used as a blank for the type inference engine.+dpty :: PreType+dpty = PTyComb (PTyCon "") []++-- | Converts a 'HOLType' to 'PreType'+pretypeOfType :: HOLType -> PreType+pretypeOfType (view -> TyVar f v) = UTyVar f v 0+pretypeOfType (view -> 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) = +    PUTy (pretypeOfType tv) $ pretypeOfType tb+pretypeOfType _ = error "pretypeOfType: incomplete view pattern"++{-| +  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.+-}+type MyParser thry a = CharParser (HOLContext thry, [(String, Int)]) a++-- 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 = ["%", "_", "'", "->", "+", "#", "^", ":", ";"]+        })++-- | A version of 'parens' for our language.+myparens :: MyParser thry a -> MyParser thry a+myparens = parens lexer++-- | A version of 'braces' for our language.+mybraces :: MyParser thry a -> MyParser thry a+mybraces = braces lexer++-- | A version of 'brackets' for our language.+mybrackets :: MyParser thry a -> MyParser thry a+mybrackets = brackets lexer++-- | A version of 'commaSep1' for our language.+mycommaSep1 :: MyParser thry a -> MyParser thry [a]+mycommaSep1 = commaSep1 lexer++-- | A version of 'semiSep' for our language.+mysemiSep :: MyParser thry a -> MyParser thry [a]+mysemiSep = semiSep 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++-- | 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++-- | A version of 'reservedOp' for our language.+myreservedOp :: String -> MyParser thry ()+myreservedOp = reservedOp lexer++-- | Selects the first matching reserved operator.+choiceOp :: [String] -> MyParser thry String+choiceOp ops = +    choice $ map (\ name -> do myreservedOp name+                               return name) ops++-- | A version of 'whiteSpace' for our language.+mywhiteSpace :: MyParser thry ()+mywhiteSpace = whiteSpace lexer++-- State Extensions+-- Operators+-- | Specifies a 'String' to be recognized as a term binder by the parser.+parseAsBinder :: String -> HOL Theory thry ()+parseAsBinder op =+    modifyExt (\ (BinderOps ops) -> BinderOps $ op `insert` ops)++-- | Specifies a 'String' to be recognized as a type binder by the parser.+parseAsTyBinder :: String -> HOL Theory thry ()+parseAsTyBinder op =+    modifyExt (\ (TyBinderOps ops) -> TyBinderOps $ op `insert` ops)++-- | Specifies a 'String' to be recognized as a prefix operator by the parser.+parseAsPrefix :: String -> HOL Theory thry ()+parseAsPrefix op =+    modifyExt (\ (PrefixOps ops) -> PrefixOps $ op `insert` ops)++{-| +  Specifies a 'String' 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 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++-- | Specifies a 'String' for the parser to stop recognizing as a term binder.+unparseAsBinder :: String -> HOL Theory thry ()+unparseAsBinder op =+    modifyExt (\ (BinderOps ops) -> BinderOps $ op `delete` ops)++-- | Specifies a 'String' for the parser to stop recognizing as a type binder.+unparseAsTyBinder :: String -> HOL Theory thry ()+unparseAsTyBinder op =+    modifyExt (\ (TyBinderOps ops) -> TyBinderOps $ op `delete` ops)++{-| +  Specifies a 'String' for the parser to stop recognizing as a prefix operator.+-}+unparseAsPrefix :: String -> HOL Theory thry ()+unparseAsPrefix op =+    modifyExt (\ (PrefixOps ops) -> PrefixOps $ op `delete` ops)++{-| +  Specifies a 'String' for the parser to stop recognizing as an infix operator.+-}+unparseAsInfix :: String -> 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++-- | Predicate for 'String's recognized as term binders by the parser.+parsesAsBinder :: String -> HOLContext thry -> Bool+parsesAsBinder op = elem op . binders++-- | Predicate for 'String's recognized as term binders by the parser.+parsesAsTyBinder :: String -> HOLContext thry -> Bool+parsesAsTyBinder op = elem op . tyBinders++-- | Predicate for 'String's recognized as prefix operators by the parser.+isPrefix :: String -> HOLContext thry -> Bool+isPrefix op = elem op . prefixes++{-| +  Predicate for 'String'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 op = lookup op . infixes++-- Interface+{-|+  Specifies a 'String' 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.++  Note that defining a symbol as overloadable will erase any interface overloads+  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 s gty =+    do (Overload overs) <- getExt+       case lookup 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)++-- | Removes all instances of an overloaded symbol from the interface.+removeInterface :: String -> HOL Theory thry ()+removeInterface sym =+    modifyExt (\ (Interface iface) -> Interface $ +                                        filter (\ (x, _) -> x /= sym) iface)++{-| +  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 sym tm =+    do namty <- liftMaybe "reduceInterface: term not a constant or variable" $ +                  destConst tm <|> destVar tm+       modifyExt (\ (Interface iface) -> Interface $ +                                           (sym, namty) `delete` iface)++{-|+  Removes all existing overloads for a given symbol and replaces them with a+  single, specific instance.  Throws a 'HOLException' if the provided term is+  not a constant or variable term representing an instance of the overloaded+  symbol.++  Note that because 'overrideInterface' can introduce at most one overload for+  a symbol it does not have to be previously defined as overloadable via +  'makeOverloadable'.  However, if the symbol is defined as overloadable then +  the provided term must have a type that is matchable with the symbol's most+  general type.+-}+overrideInterface :: String -> 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+         Just gty -> if isNothing $ typeMatch gty (snd namty) ([], [], [])+                     then fail $ "overrideInterface: " +++                                 "not an instance of type skeleton"+                     else m+         _ -> m++{-|+  Introduces a new overload for a given symbol.  Throws a 'HOLException' in the+  following cases:++  * The symbol has not previously been defined as overloadable via +    'makeOverloadable'.+  +  * The provided term is not a constant or variable term representing a +    specific instance of the overloaded symbol.++  * The provided term does not have a type that is matchable with the+    overloadable symbol's specified most general type.++  Note that specifying an overload that already exists will move it to the front+  of the interface list, effectively prioritizing it.  This behavior is utilized+  by 'prioritizeOverload'.+-}+overloadInterface :: String -> HOLTerm -> HOL Theory thry ()+overloadInterface sym tm =+    do (Overload overs) <- getExt+       gty <- liftMaybe ("overloadInstace: symbol " ++ sym ++ +                         " is not overloadable.") $ lookup 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')++{-|+  Specifies a type to prioritize when the interface is used to overload a +  symbol.  Note that this applies to all overloads in the system whose match+  with the specified most general type involves the provided type.  +  Prioritization is done by redefining overloads via 'overloadInterface'.+-}+prioritizeOverload :: HOLType -> HOL Theory thry ()+prioritizeOverload ty =+    do (Overload overs) <- getExt+       mapM_ (\ (s, gty) -> +              (do (Interface iface) <- getExt+                  let (n, t') = fromJust $ +                                tryFind (\ (s', x@(_, t)) ->+                                         if s' /= s then Nothing+                                         else do (tys, _, _) <- typeMatch gty t+                                                                  ([], [], [])+                                                 _ <- ty `revLookup` tys+                                                 return x) iface+                  overloadInterface s $ mkVar n t')+              <|> return ()) 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++{-| +  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++-- Type Abbreviations+{-| +  Specifies a 'String' 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)++{-| +  Specifies a 'String' for the parser to stop recognizing as a type +  abbreviation.+-}+removeTypeAbbrev :: String -> HOL Theory thry ()+removeTypeAbbrev s =+    modifyExt (\ (TypeAbbreviations abvs) ->+                  TypeAbbreviations $ filter (\ (s', _) -> s' /= s) abvs)++{-| +  Returns all 'String'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++-- 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 'String' for the parser to resume recognizing as a constant.+unhideConstant :: String -> HOL Theory thry ()+unhideConstant c = modifyExt (\ (Hidden hcs) -> Hidden $ c `delete` hcs)++-- | 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++deriveLiftMany [ ''BinderOps, ''TyBinderOps +               , ''PrefixOps, ''InfixOps+               , ''Interface, ''Overload +               , ''TypeAbbreviations, ''Hidden ]
+ src/HaskHOL/Core/Parser/Rep.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, +             TypeSynonymInstances, UndecidableInstances #-}++{-|+  Module:    HaskHOL.Core.Parser.Rep+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  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+  terms/types as produced by the "HaskHOL.Core.Ext" module.+-}+module HaskHOL.Core.Parser.Rep+    ( HOLTypeRep(..)+    , HOLTermRep(..)+    ) where++import HaskHOL.Core.Kernel+import HaskHOL.Core.State++import HaskHOL.Core.Parser.Lib+import HaskHOL.Core.Parser.Elab+import {-# SOURCE #-} HaskHOL.Core.Parser (holTermParser, holTypeParser)++{-|+  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.+-}+class HOLTypeRep a thry | a -> thry where+    -- | Conversion from alternative type @a@ to 'HOLType'.+    toHTy :: a -> HOL cls thry HOLType++instance HOLTypeRep String a where+    toHTy x = +        do ctxt <- get+           tyElab =<< liftEither "toHTy" (holTypeParser x ctxt)++instance HOLTypeRep PreType a where+    toHTy = tyElab++instance HOLTypeRep HOLType a where+    toHTy = return++{-|+  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.+-}+class HOLTermRep a thry | a -> thry where+    -- | Conversion from alternative type @a@ to 'HOLTerm'.+    toHTm :: a -> HOL cls thry HOLTerm++instance HOLTermRep String a where+    toHTm x = +        do ctxt <- get+           elab =<< liftEither "toHTm" (holTermParser x ctxt)+                +instance HOLTermRep PreTerm a where+    toHTm = elab++instance HOLTermRep HOLTerm a where+    toHTm = return
+ src/HaskHOL/Core/Parser/TermParser.hs view
@@ -0,0 +1,225 @@+{-|+  Module:    HaskHOL.Core.Parser.TermParser+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines the parser for 'HOLTerm's that satisfies the following BNF+  grammar:++@+  PRETERM            :: APPL_PRETERM binop APPL_PRETERM                     +                      | APPL_PRETERM                                        +                                                                           +  APPL_PRETERM       :: BINDER_PRETERM+                               +                      | BINDER_PRETERM : type                                  +                                                                           +  BINDER_PRETERM     :: tybinder small-type-variables . PRETERM             +                      | binder VARSTRUCT_PRETERM+ . PRETERM                 +                      | let PRETERM and ... and PRETERM in PRETERM          +                      | TYPED_PRETERM                                       +                                                                            +  TYPED_PRETERM      :: TYINST (tyop-var : PRETYPE)+ ATOMIC_PRETERM         +                      | ATOMIC_PRETERM                                   +                                                                            +  VARSTRUCT_PRETERM  :: ATOMIC_PRETERM : type                               +                      | ATOMIC_PRETERM                                      +                                                                           +  ATOMIC_PRETERM     :: ( PRETERM )                                         +                      | [: type]                                 +                      | [ PRETERM; .. ; PRETERM ]                  +                      | if PRETERM then PRETERM else PRETERM                +                      | identifier                                          +@                                                                          + +  Note that arbitrary atomic preterms, typed or untyped, are allowed as     +  varstructs in order to simplify parsing.  We do not make the same +  simplification for @TYINST@ terms in order to avoid the mixing of terms, +  types, and type operators.   ++  Also note that a number of advanced HOL term features, mostly relating to sets+  and patterns, are not currently supported by the parser.  These will be added+  in as the relevant logic libraries are added to the system.++  As a heads up, the error messages thrown by this parser leave much to be+  desired.+-}+module HaskHOL.Core.Parser.TermParser+    ( pterm+    ) where++import HaskHOL.Core.Lib hiding (many)+import HaskHOL.Core.State++import HaskHOL.Core.Parser.Lib+import HaskHOL.Core.Parser.TypeParser++-- | Parser for HOL terms.+pterm :: MyParser thry PreTerm+pterm = +    do mywhiteSpace+       ctxt <- getState+       buildExpressionParser (partitionOps ctxt) 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)++pbinder :: MyParser thry PreTerm+pbinder = +    (do myreserved "let"+        tms <- pterm `sepBy1` 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+    where ++ptyped :: MyParser thry PreTerm+ptyped = +    (do myreserved "TYINST"+        vars <- many1 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)+                              ++pvar :: MyParser thry PreTerm+pvar =+    do tm <- patomic+       pas tm <|> return tm++pas :: PreTerm -> MyParser thry PreTerm+pas ptm =+    do myreservedOp ":"+       ty <- ptype+       return $! PAs ptm ty++patomic :: MyParser thry PreTerm+patomic = +    myparens (pterm <|> (do x <- myoperator+                            return $! PVar x dpty))+    <|> mybrackets +         ((do myreservedOp ":"+              ty <- ptype+              return $! PApp ty)+          <|> (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"+            e <- pterm+            return $! PComb (PComb (PComb (PVar "COND" dpty) c) t) e)+    <|> (do x <- myidentifier+            return $! PVar x dpty)++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'+                ++-- 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"++pdestEq :: PreTerm -> Maybe (PreTerm, PreTerm)+pdestEq (PComb (PComb (PVar "=" _) l) r) = Just (l, r)+pdestEq (PComb (PComb (PVar "<=>" _) l) r) = Just (l, r)+pdestEq _ = Nothing++mkLet :: [PreTerm] -> PreTerm -> Maybe PreTerm+mkLet binds bod = case length tms of+                    0 -> Nothing+                    _ -> Just $ foldl PComb letstart tms+    where (vars, tms) = unzip $ mapMaybe pdestEq binds+          letend = PComb (PVar "LET_END" dpty) bod+          ab = foldr PAbs letend vars+          letstart = PComb (PVar "LET" dpty) ab++mkBinder :: String -> 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 bind vars bod = foldr (mkBinder bind) bod vars++mkTyBinder :: String -> 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 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
+ src/HaskHOL/Core/Parser/TypeParser.hs view
@@ -0,0 +1,176 @@+{-|+  Module:    HaskHOL.Core.Parser.TypeParser+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines the parser for 'HOLType's that satisfies the following BNF+  grammar:++@+  TYPE        :: % small-type-variables . TYPE                              +               | SUMTYPE -> TYPE                                            +               | SUMTYPE                                                    +                                                                           +  SUMTYPE     :: PRODTYPE + SUMTYPE                                         +               | PRODTYPE                                                   +                                                                           +  PRODTYPE    :: POWTYPE # PRODTYPE                                         +               | POWTYPE     ++  POWTYPE     :: APPTYPE ^ POWTYPE+               | POWTYPE                                         +                                                                           +  APPTYPE     :: ( TYPELIST ) type-constructor [Provided arity matches]     +               | ( TYPELIST ) tyop-var [Provided arity matches or fresh]    +               | small-type-variables+ tyop-var [Special case of above]+               | ( TYPE )                                                   +               | ATOMICTYPE                                                 +                                                                           +  ATOMICTYPE  :: type-constructor      [Provided arity zero]                +               | tyop-var              [Provided arity zero or fresh]       +               | type-variable         [Large or Small]                     +                                                                           +  TYPELIST    :: TYPE , TYPELIST                                            +               | TYPE   +@++  Note that this module also exposes a parser for small type variables to be+  used by the term parser. ++  As a heads up, the error messages thrown by this parser leave much to be+  desired.+-}+module HaskHOL.Core.Parser.TypeParser +    ( ptype+    , psmall+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.State++import HaskHOL.Core.Parser.Lib++-- | Parser for HOL types.+ptype :: MyParser thry PreType+ptype = +    mywhiteSpace >> (putype <|> pbinty "->" "fun" psumty ptype)++-- | Parser for small type variables.+psmall :: MyParser thry PreType+psmall =+    do myreservedOp "'"+       x <- myidentifier+       return $! UTyVar True x 0++popvar :: MyParser thry (Either PreType PreType)+popvar =+    do myreservedOp "_"+       x <- myidentifier+       {-+         Tracks introduction of type operator variables to make sure that all+         tyopvars of the same name in a term are of the same arity.+         Left is fresh.+         Right is existing.+       -}+       let x' = '_':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 -> +          MyParser thry PreType+pbinty op name pty1 pty2 =+    do ty1 <- pty1+       (do myreservedOp op+           ty2 <- pty2+           return $! PTyComb (PTyCon name) [ty1, ty2]) +        <|> return ty1++putype :: MyParser thry PreType+putype = +    do myreservedOp "%"+       tvs <- many1 psmall+       myreservedOp "."+       ty <- ptype+       return $! foldr PUTy ty tvs++psumty :: MyParser thry PreType+psumty = pbinty "+" "sum" pprodty psumty++pprodty :: MyParser thry PreType+pprodty = pbinty "#" "prod" ppowty pprodty++ppowty :: MyParser thry PreType+ppowty = pbinty "^" "cart" pappty ppowty++pappty :: MyParser thry PreType+pappty =+    do tys <- myparens $ mycommaSep1 ptype+       (do c <- popvar+           case c of+             Left (UTyVar _ s _) ->+               -- fresh ty op var so add it to state+               let n = length tys in+                 do updateState $ second ((:) (s, n))+                    let c' = UTyVar False s n+                    return $! PTyComb c' tys+             Right c'@(UTyVar _ _ n) ->+               -- existing ty op var so check arity+               if n == length tys+               then return $! PTyComb c' tys+               else fail "type parser: bad arity for type application"+             _ -> fail $ "type parser: unrecognized case for type operator " +++                         "variable")+        <|> ((do x <- myidentifier+                 (ctxt, _) <- getState+                 case getTypeArityCtxt ctxt x of+                   Nothing -> fail $ "type parser: unsupported type " ++ +                                     "variable application"+                   Just n ->+                     if n == length tys+                     then return $! PTyComb (PTyCon x) tys+                     else fail "type parser: bad arity for type application")+        <|> (case tys of+               (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++patomty :: MyParser thry PreType+patomty = +    psmall+    <|> (do c <- popvar+            case c of+              Left c'@(UTyVar _ s 0) ->+                -- fresh ty-op of zero arity+                do updateState $ second ((:) (s, 0))+                   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+              Just ty -> return $! pretypeOfType ty+              Nothing -> case getTypeArityCtxt ctxt x of+                           Nothing -> return $! UTyVar False x 0+                           Just 0 -> return $! PTyComb (PTyCon x) []+                           _ -> fail "type parser: bad type construction")+
+ src/HaskHOL/Core/Printer.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,+             OverlappingInstances, TemplateHaskell, UndecidableInstances, +             ViewPatterns #-}++{-|+  Module:    HaskHOL.Core.Printer+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module defines pretty printers for 'HOLType's, 'HOLTerm's and 'HOLThm's. +  Note that the printers for terms and theorems are context dependent as they +  rely on the same theory extensions that the parsers utilize. ++  To make printing these objects easier within HOL computations, this module+  also defines the 'showHOL' and 'printHOL' methods which will automatically+  retrieve the current working theory to use for pretty printing.  Because the +  pretty printer for 'HOLType's is not context dependent it has definitions for +  both 'show' and 'showHOL'.++  Note that, like the parser, there are a number of HOL term forms that the+  printer does not currently support.  Again, these are mainly related to sets+  and patterns and will be added in when the HaskHOL system has libraries for+  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+      -- * Printing in the 'HOL' Monad+    , ShowHOL(..)+    , printHOL    -- :: ShowHOL a => a -> HOL cls thry ()+    ) where++import HaskHOL.Core.Lib hiding (empty, lefts, rights)+import HaskHOL.Core.Kernel+import HaskHOL.Core.State+import HaskHOL.Core.Basics+import HaskHOL.Core.Parser++{- +  Used for a number of pretty-printing primitives that don't really need to be+  exposed to the rest of the system.  Although no harm would come should we+  elect to move this to be re-exported by Core.Lib.+-}+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 prec ty =+            case destUTypes ty of+              Just (tvs, bod) -> +                  let tvs' = foldr (\ x acc -> ppTypeRec prec x <+> acc) +                               empty tvs in+                    parens $ char '%' <+> tvs' <+> char '.' <+> +                               ppTypeRec prec bod+              Nothing ->    +                  case do (op, tys) <- destType ty +                          let (name, ar) = destTypeOp op+                              name' = if ar < 0 then '_':name else name+                          return (name', tys) of+                    Just (op, []) -> text op+                    Just ("fun", ty1:ty2:[]) ->+                        ppTypeApp "->" (prec > 0) [ ppTypeRec 1 ty1+                                                  , ppTypeRec 0 ty2]+                    Just ("sum", ty1:ty2:[]) -> +                        ppTypeApp "+" (prec > 2) [ ppTypeRec 3 ty1+                                                 , ppTypeRec 2 ty2]+                    Just ("prod", ty1:ty2:[]) -> +                        ppTypeApp "#" (prec > 4) [ ppTypeRec 5 ty1+                                                 , ppTypeRec 4 ty2]+                    Just ("cart", ty1:ty2:[]) -> +                        ppTypeApp "^" (prec > 6) [ ppTypeRec 6 ty1+                                                 , ppTypeRec 7 ty2]+                    Just (bin, args) -> +                        ppTypeApp "," True (map (ppTypeRec 0) args) <+> text bin+                    _ -> text "ppType: printer error - unrecognized type"+  +        ppTypeApp :: String -> Bool -> [Doc] -> Doc+        ppTypeApp sepr flag ds =+            case tryFoldr1 (\ x y -> x <+> text sepr <+> y) ds of+              Nothing -> empty+              Just bod -> if flag then parens bod else bod++-- Printer for Terms+-- | Pretty printer for 'HOLTerm's.+ppTerm :: HOLContext thry -> HOLTerm -> String+ppTerm ctxt = render . ppTermRec 0+  where ppTermRec :: Int -> HOLTerm -> Doc+        ppTermRec prec tm =+-- List case+            case destList tm of+             Just tms -> brackets $ ppTermSeq ";" 0 tms+             Nothing ->+-- Type combination case+              case destTyComb tm of+               Just (t, ty) -> +                 let base = ppTermRec 999 t <+> +                            brackets (char ':' <> text (ppType ty)) in+                   if prec == 1000 then parens base else base+               Nothing ->+-- Let case+                case destLet tm of+                 Just (eq:eqs, bod) ->+                     let ppLet x = case uncurry primMkEq x of+                                     Right x' -> ppTermRec 0 x'+                                     _ -> text "<*bad let binding*>"+                         base = hang+                                (text "let" <+> +                                 foldr (\ eq' acc -> acc <+> text "and" <+> +                                          ppLet eq') (ppLet eq) eqs <+>+                                 text "in") 2 $ ppTermRec 0 bod in+                       if prec == 0 then base else parens base       +                 _ ->+                  let (hop, args) = stripComb tm in+-- Base term abstraction case+                    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+-- 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+-- 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+-- 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+-- Non-lambda term binder case+                    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+-- 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+-- 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+-- 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"++        grabInfix :: Assoc -> [(String, (Int, Assoc))] -> [(String, Int)]+        grabInfix a = +            mapMaybe (\ (x, (n, a')) -> if a == a' +                                        then Just (x, n)+                                        else Nothing)+        binds :: [String]+        binds = binders ctxt++        tybinds :: [String]+        tybinds = tyBinders ctxt++        prefix :: [String]+        prefix = prefixes ctxt++        lefts :: [(String, Int)]+        lefts = grabInfix AssocLeft $ infixes ctxt++        rights :: [(String, Int)]+        rights = grabInfix AssocRight $ infixes ctxt++        ppTermSeq :: String -> Int -> [HOLTerm] -> Doc+        ppTermSeq sepr prec = ppTermSeqRec+          where ppTermSeqRec [] = empty+                ppTermSeqRec (x:[]) = ppTermRec prec x+                ppTermSeqRec (x:xs) =+                  ppTermRec prec x <+> text sepr <+> ppTermSeqRec xs++        ppBinder :: Int -> String -> 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 '.'+                           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) = +                    stripTm (bv:acc, bod)+                stripTm pat@(acc, view -> Comb (view -> Const s _ _) +                                 (view -> Abs (view -> 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)+                    | otherwise = pat+                stripTy pat = pat++        destBinaryTm :: HOLTerm -> HOLTerm -> Maybe (HOLTerm, HOLTerm)+        destBinaryTm c tm =+            do (il, r) <- destComb tm+               (i, l) <- destComb il+               if i == c+                  then do i' <- destConst i+                          c' <- destConst c+                          if uncurry reverseInterface i' == +                             uncurry reverseInterface c'+                             then Just (l, r)+                             else Nothing+                  else Nothing++        reverseInterface :: String -> HOLType -> String+        reverseInterface s0 ty0+            | not (getBenignFlagCtxt FlagRevInterface ctxt) = s0+            | otherwise = fromMaybe s0 . liftM fst .+                            find (\ (_, (s', ty)) -> s' == s0 && +                                  isJust (typeMatch ty ty0 ([], [], []))) $+                              getInterface ctxt++-- Printer for Theorems+	+-- | Pretty printer for 'HOLTheorem's.	+ppThm :: HOLContext thry -> HOLThm -> String+ppThm ctxt (view -> Thm asl c) = render ppThmRec+  where ppThmRec :: Doc+        ppThmRec = +          let c' = text $ ppTerm ctxt c+              asl'+                  | null asl = [empty]+                  | not (getBenignFlagCtxt FlagPrintAllThm ctxt) = [text "..."]+                  | otherwise = showHOLListRec comma $ map (ppTerm ctxt) asl in+            sep (asl' ++ [text "|-" <+> c'])++{-| +  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+    {-| +      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++instance (ShowHOL a thry, ShowHOL b thry) => ShowHOL (a, b) thry 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 $ +                          [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 $ +                             [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+  +-- Useful to have at top level for ppThm.+showHOLListRec :: Doc -> [String] -> [Doc]+showHOLListRec _ [] = [empty]+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+    showHOL ty = return $ ':' : ppType ty++instance ShowHOL HOLTerm thry where+    showHOL tm = do ctxt <- get+                    return $! ppTerm ctxt tm++instance ShowHOL HOLThm thry where+    showHOL thm = do ctxt <- get+                     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 = putStrLnHOL <=< showHOL++deriveLiftMany [''UnspacedBinops, ''PrebrokenBinops]
+ src/HaskHOL/Core/State.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, ViewPatterns #-}++{-|+  Module:    HaskHOL.Core.State+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  Portability: unknown++  This module exports the stateful layer of HaskHOL.  It consists of:++  * Stateful type primitives not found in "HaskHOL.Core.Types".++  * Stateful term primitives not found in "HaskHOL.Core.Terms".++  * Stateful theory extension primitives not found in "HaskHOL.Core.Kernel".++  * A very primitive debugging system.+-}+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+    -- * 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+    -- * 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)+    -- * 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+      -- * Monad Re-Export+    , module HaskHOL.Core.State.Monad+    ) where++import HaskHOL.Core.Lib+import HaskHOL.Core.Kernel+import HaskHOL.Core.State.Monad++-- New flags and extensions+-- | 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)] |]++newExtension "TheAxioms" [| [] :: [(String, HOLThm)] |]++{- +  Extensible state type for term definitions introduced via +  newBasicDefinition.+-}+newExtension "TheCoreDefinitions" [| [] :: [HOLThm] |]++-- 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+  type operator value, i.e. ++  > ("bool", tyOpBool)+-}+types :: HOL cls thry [(String, 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.++  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++{-|+  A version of 'getTypeArityCtxt' that operates over the current working theory+  of a 'HOL' computation.  Throws a 'HOLException' if the provided type constant+  name is not defined.+-}+getTypeArity :: String -> HOL cls thry Int+getTypeArity name =+    do ctxt <- get+       liftMaybe ("getTypeArity: type " ++ name ++ " has not been defined.") $+         getTypeArityCtxt ctxt name++{- +  Primitive type constant construction function.  Used by newType and +  newBasicTypeDefinition.  Not exposed to the user.+-}+newType' :: String -> 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++{-| +  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 name arity = +    newType' name $ newPrimTypeOp name arity++{-|+  Constructs a type application given an operator name and a list of argument+  types.  If the provided name is not a currently defined type constant then+  this function defaults it to a type operator variable.  Throws a +  'HOLException' in the following cases:++  * A type operator's arity disagrees with the length of the argument list.++  * A type operator is applied to zero arguments.+-}+mkType :: String -> [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+         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+              failWhen (return $ null args)+                "mkType: type operator applied to zero args."+              liftEither "mkType: type operator variable application failed" $ +                tyApp (mkTypeOpVar name') args++{-|+  Constructs a function type safely using 'mkType'.  Should never fail provided+  that the initial value for type constants has not been modified.+-}+mkFunTy :: HOLType -> HOLType -> HOL cls thry HOLType+mkFunTy ty1 ty2 = mkType "fun" [ty1, ty2]++-- 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+  term constant value, i.e. ++  > ("=", tmEq tyA)+-}+constants :: HOL cls thry [(String, HOLTerm)]+constants =+    do (TermConstants consts) <- getExt+       return consts++{-|+  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 name =+    do (TermConstants consts) <- getExt+       tm <- liftMaybe "getConstType: not a constant name" $+               lookup name consts+       return $! typeOf tm++{-+  Primitive term constant construction function.  Used by newConstant,+  newBasicDefinition, and newBasicTypeDefinition.+-}+newConstant' :: String -> 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++{-|+  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 name ty =+    newConstant' name $ newPrimConst name ty++{-|+  Constructs a specific instance of a term constant when provided with its name+  and a type substition environment.  Throws a 'HOLException' in the +  following cases:++  * The instantiation as performed by 'instConst' fails.++  * The provided name is not a currently defined constant.+-}+mkConst :: TypeSubst l r => String -> [(l, r)] -> HOL cls thry HOLTerm+mkConst name tyenv =+    do (TermConstants consts) <- getExt+       tm <- liftMaybe "mkConst: not a constant name" $ +               lookup name consts+       liftMaybe "mkConst: instantiation failed" $ +         instConst tm tyenv++{-| +  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 name pat =+    do (TermConstants consts) <- getExt+       tm <- liftMaybe "mkConstFull: not a constant name" $+               lookup name consts+       liftMaybe "mkConstFull: instantiation failed" $ +         instConstFull tm pat+                                    +{-| +  Safely creates an equality between two terms using 'mkConst' using the type of+  the left hand side argument to perform the required instantiation.  Throws a+  'HOLException' in the case when the types of the two terms do not agree.+-}+mkEq :: HOLTerm -> HOLTerm -> HOL cls thry HOLTerm+mkEq l r =+    let ty = typeOf l in+      do eq <- mkConst "=" [(tyA, ty)]+         liftEither "mkEq" $+           liftM1 mkComb (mkComb eq l) r++-- State for Axioms	++{-|+  Retrieves the list of axioms from the current working theory.  The list+  contains pairs of string names and the axioms.  This names exists such that+  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++{-| +  Constructs a new axiom of a given name and conclusion term.  Also adds this+  new axiom to the current working theory.  Throws a 'HOLException' in the +  following cases:++  * The provided term is not a proposition.++  * 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++-- State for Definitions+{-|+  Retrieves the list of definitions from the current working theory.  See+  'newBasicDefinition' for more details.+-}+definitions :: HOL cls thry [HOLThm]+definitions =+    do (TheCoreDefinitions defs) <- getExt+       return defs++{-|+  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++{-|+  Introduces a new type constant, and two associated term constants, into the +  current working theory that is defined as an inhabited subset of an existing +  type constant.  Takes the following arguments:+  +  *  The name of the new type constant.++  *  The name of the new term constant that will be used to construct the type.++  *  The name of the new term constant that will be used to desctruct the type.++  *  A theorem that proves that the defining predicate has at least one+     satisfying value.++  Throws a 'HOLException' in the following cases:++  *  A term constant of either of the provided names has already been defined.++  *  A type constant of the provided name has already been defined.++  See 'newDefinedTypeOp' for more details.+-}+newBasicTypeDefinition :: String -> String -> String -> 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."+     (atyop, a, r, dth1, dth2) <- liftEither "newBasicTypeDefinition" $+                                    newDefinedTypeOp tyname absname repname dth+     failWhen (canNot (newType' tyname) atyop) $+       "newBasicTypeDefinition: Type " ++ tyname ++ " already defined."+     newConstant' absname a+     newConstant' repname r+     return (dth1, dth2)+++-- Primitive Debugging Functions+{-| +  Prints the provided string, with a new line, when the given boolean value is+  true.+-}+warn :: Bool -> String -> HOL cls thry ()+warn flag str = when flag $ putStrLnHOL str++{-|+  Prints the provided string, with a new line, when debugging is turned on, then+  returns the given 'HOL' computation.  A version of 'trace' for the 'HOL' monad+  that is referentially transparent.+-}+printDebugLn :: String -> HOL cls thry a -> HOL cls thry a+printDebugLn = printDebugBase putStrLnHOL++-- | A version of printDebug that does not print a new line.+printDebug :: String -> HOL cls thry a -> HOL cls thry a+printDebug = printDebugBase putStrHOL++-- Abstracted out for future flexibility.  Not exported.+printDebugBase :: (String -> HOL cls thry ()) -> String -> HOL cls thry a -> +                  HOL cls thry a+printDebugBase fn str x =+    do debug <- getBenignFlag FlagDebug+       if debug+          then fn str >> x+          else x++deriveLiftMany [ ''TypeConstants, ''TermConstants+               , ''TheAxioms, ''TheCoreDefinitions ]
+ src/HaskHOL/Core/State/Monad.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ExistentialQuantification, +             MultiParamTypeClasses, ScopedTypeVariables, TemplateHaskell #-}++{-|+  Module:    HaskHOL.Core.State.Monad+  Copyright: (c) The University of Kansas 2013+  LICENSE:   BSD3++  Maintainer:  ecaustin@ittc.ku.edu+  Stability:   unstable+  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.++  For higher level monadic combinators see the "HaskHOL.Core.State" and+  "HaskHOL.Core.Basics" modules.+-}+module HaskHOL.Core.State.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+      -- * Text Output Methods+    , putStrHOL   -- :: String -> HOL cls thry ()+    , putStrLnHOL -- :: String -> HOL cls thry ()+      -- * 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+      -- * 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 ()+      -- * Benign Flag Methods+    , BenignFlag(..)+    , setBenignFlag+    , unsetBenignFlag+    , getBenignFlagCtxt+    , getBenignFlag+      -- * 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]+      -- * Re-export for Extensible Exceptions+    , Exception+    ) where++import HaskHOL.Core.Lib++import Control.Exception (Exception)+import qualified Control.Exception as E++import Data.IORef+ +import Data.Typeable (cast, typeOf)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift(..))+++-- 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:++  * @cls@ - 'HOL' computations are split into two classes, those that extend the+            current working theory and those that are \"pure\"-ly used for+            proof.  The @cls@ parameter is used to indicate the classification+            of a computation.  It is a phantom type variable that is inhabited+            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+             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 +             @ExtThry EqualThry BaseThry@ would indicate a current working+             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+             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+  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) +        }++-- | The classification tag for theory extension computations.+data Theory+-- | The classification tag for proof computations.+data Proof++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'+    fail = throwHOL . HOLException++instance MonadPlus (HOL cls thry) where+    mzero = fail "mzero - HOL"+    mplus = (<||>)++instance Applicative (HOL cls thry) where+    pure = return+    (<*>) = ap++instance Alternative (HOL cls thry) where+    empty = fail "empty - HOL"+    (<|>) = (<||>)++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++{- +  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.+-}+put :: HOLContext thry -> HOL cls thry ()+put s = HOL $ \ _ -> return ((), s)++{-| +  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.++  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.+-}+get :: HOL cls thry (HOLContext thry)+get = HOL $ \ s -> return (s, s)++{-| +  A version of 'get' that applies a function to the state before returning the+  result.+-}+gets :: (HOLContext thry -> a) -> HOL cls thry a+gets f = liftM f get++-- See the above notes.  Not exported to the user.+modify :: (HOLContext thry -> HOLContext thry) -> HOL cls thry ()+modify = put <=< gets++-- 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)++-- | A version of 'putStrLn' lifted to the 'HOL' monad.+putStrLnHOL :: String -> HOL cls thry ()+putStrLnHOL str = HOL $ \ s -> putStrLn str >> return ((), s)++-- 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)+instance Exception HOLException++{-| +  A version of 'throwIO' lifted to the 'HOL' monad.  ++  Note that the following functions for the 'HOL' type rely on 'throwHOL':+ +  * 'fail' - Equivalent to ++    > throwHOL . HOLException++  * 'mzero' - Equivalent to ++    > fail "mzero - HOL"++  * 'empty' - Equivalent to ++    > fail "empty - HOL"+-}+throwHOL :: Exception e => e -> HOL cls thry a+throwHOL e = HOL $ \ _ -> E.throwIO e++{-| +  A version of 'E.catch' lifted to the 'HOL' monad.++  Note that 'mplus' and '<|>' are defined in terms of catching a +  'E.SomeException' with 'catchHOL' and then ignoring it to run an alternative+  computation instead.+-}+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++-- 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++{-| +  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 ++{-|+  Lifts an 'Either' value into the 'HOL' monad mapping 'Right's to 'return's+  and 'Left's to 'fail's.  ++  Note that the value inside the 'Left' must have an instance of the 'Show' +  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++-- Local vars+-- | A type synonym for 'IORef'.+type HOLRef = IORef++{-| +  Creates a new 'HOLRef' from a given starting value.  Functionally equivalent+  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)++{-|+  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)++{-|+  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)++{-|+  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)+++-- Context+{-|+  The 'ExtClass' type class is the heart of HaskHOL's extensible state+  mechanism.  It serves a number of purposes:++  * 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.++  * It defines an initial value for state extensions to use if they have not +    been introduced to the context by a computation yet.++  For more information see the documentation for 'HOLContext', 'getExtCtxt', and+  'putExt'.+-}+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++{-| +  Used to build heterogenous structures that hold state extensions.  See+  'ExtClass' for more details.+-}+data ExtState = forall a. ExtClass a => ExtState a++{-|+  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.+  These flags don't affect the underlying proof computations, hence their+  classification as benign, so we'd like to be able to toggle them on and off+  at will.  Unfortunately, if we store them in the extensible state and use +  'putExt' or 'modifyExt' we're limited to only being able to change them in+  'Theory' computations.  ++  Instead, we include them in a separate part of the theory context where we +  can interact with them in any way we want without sacrificing the safety of +  the extensible state portion of the context.++  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.+-}+class Typeable a => BenignFlag a where+    {-| +      The intial value for a benign flag.  The value returned when attempting to+      retrieve a flag that is not yet defined in the context.+    -}+    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++instance Show (HOLContext thry) where+    show (HCtxt (_, _, _, xs)) = show $ map fst xs++-- 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))++{-|+  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.++  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+  of the parsers and printers accordingly.++  Note that since the retrieval and storage of benign flags are driven by types,+  it is in the best interest of library implementors to guarantee that the types+  of their flags are unique.  The easiest way to do this is to create a unique+  @data@ type for each flag.  The type doesn't need to carry a payload, but it+  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@.++  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++-- | Unsets a benign flag making it 'False'.+unsetBenignFlag :: BenignFlag a => a -> HOL cls thry ()+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.++  Note that retrieval of the value requires a witness to the desired flag's+  type, i.e.++  > getBenignFlag FlagDebug++  or++  > getBenignFlag (undefined :: FlagDebug)++  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++-- 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 =+    do (HCtxt (f, tm, ty, s)) <- get+       let tm' = succ tm+       put $ HCtxt (f, tm', ty, s)+       return tm'++{-|+  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 =+    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++{-|+  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.++  Example:++  > newFlag "FlagDebug" True++  will construct the following Haskell code:++  > data FlagDebug = FlagDebug deriving Typeable+  > instance BenignFlag FlagDebug where+  >     initFlagValue _ = True+-}+newFlag :: String -> Bool -> Q [Dec]+newFlag flag val =+    do val' <- lift val+       let name = mkName flag+           ty = DataD [] name [] [NormalC name []] [''Typeable]+           cls = InstanceD [] (AppT (ConT ''BenignFlag) (ConT name)) +                   [FunD 'initFlagValue [Clause [WildP] (NormalB val') []]]+       return [ty, cls]++{-|+  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.++  Example:++  > newExtension "TheCoreDefinitions" [| [] :: [HOLThm] |]++  will construct the following Haskell code:++  > newtype TheCoreDefinitions = TheCoreDefinitions [HOLThm] deriving Typeable+  > instance ExtClass TheCoreDefinitions where+  >     initValue = TheCoreDefinitions []++  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'.+-}+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."++-- lift derivations+deriveLift ''ExtState