├── HaskHOL-Core.cabal ├── LICENSE ├── README.md ├── Setup.hs ├── data └── .dummy └── src └── HaskHOL ├── Core.hs └── Core ├── Basics.hs ├── Basics ├── Nets.hs └── Stateful.hs ├── Ext.hs ├── Ext ├── Protected.hs └── QQ.hs ├── Kernel.hs ├── Kernel ├── Prims.hs ├── Terms.hs └── Types.hs ├── Lib.hs ├── Lib ├── Families.hs └── Lift.hs ├── Overloadings.hs ├── Parser.hs ├── Parser ├── Elab.hs ├── Lib.hs ├── Rep.hs ├── TermParser.hs └── TypeParser.hs ├── Printer.hs ├── State.hs └── State └── Monad.hs /HaskHOL-Core.cabal: -------------------------------------------------------------------------------- 1 | name: haskhol-core 2 | version: 1.3.0 3 | synopsis: The core logical system of HaskHOL, an EDSL for HOL theorem 4 | proving. 5 | description: More details can be found at the following page: 6 | http:\/\/haskhol.org. 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Evan Austin 10 | maintainer: Evan Austin 11 | category: Theorem Provers 12 | cabal-version: >=1.22 13 | build-type: Simple 14 | stability: experimental 15 | homepage: http://haskhol.org 16 | 17 | data-dir: data 18 | data-files: .dummy 19 | 20 | library 21 | default-language: Haskell2010 22 | default-extensions: DeriveDataTypeable, OverloadedStrings, 23 | PatternSynonyms, QuasiQuotes, TemplateHaskell 24 | build-depends: base >= 4.9 && < 5.0 25 | , ghc-prim >= 0.5 26 | , template-haskell >= 2.11 27 | , acid-state >= 0.14 28 | , ansi-wl-pprint >= 0.6 29 | , cereal-conduit >= 0.7 30 | , conduit >= 1.2 31 | , conduit-extra >= 1.1 32 | , containers >= 0.5 33 | , deepseq >= 1.4 34 | , exceptions >= 0.8 35 | , filepath >= 1.4 36 | , hashable >= 1.2 37 | , hint >= 0.6 38 | , lens >= 4.14 39 | , mtl >= 2.2 40 | , parsec >= 3.1 41 | , safecopy >= 0.9 42 | , shelly >= 1.6 43 | , text >= 1.2 44 | , text-show >= 3.2 45 | , th-lift-instances >= 0.1.8 46 | , transformers >= 0.4 47 | , unordered-containers >= 0.2 48 | 49 | exposed-modules: 50 | HaskHOL.Core 51 | HaskHOL.Core.Basics 52 | HaskHOL.Core.Lib 53 | HaskHOL.Core.Lib.Families 54 | HaskHOL.Core.Kernel 55 | HaskHOL.Core.Kernel.Terms 56 | HaskHOL.Core.Kernel.Types 57 | HaskHOL.Core.State 58 | HaskHOL.Core.State.Monad 59 | HaskHOL.Core.Parser 60 | HaskHOL.Core.Printer 61 | HaskHOL.Core.Ext 62 | HaskHOL.Core.Overloadings 63 | 64 | exposed: True 65 | buildable: True 66 | hs-source-dirs: src 67 | 68 | other-modules: 69 | HaskHOL.Core.Basics.Nets 70 | HaskHOL.Core.Basics.Stateful 71 | HaskHOL.Core.Ext.Protected 72 | HaskHOL.Core.Ext.QQ 73 | HaskHOL.Core.Kernel.Prims 74 | HaskHOL.Core.Parser.Elab 75 | HaskHOL.Core.Parser.Lib 76 | HaskHOL.Core.Parser.Rep 77 | HaskHOL.Core.Parser.TermParser 78 | HaskHOL.Core.Parser.TypeParser 79 | Paths_haskhol_core 80 | 81 | ghc-prof-options: -O2 -funbox-strict-fields -Wall -fprof-auto 82 | ghc-options: -O2 -funbox-strict-fields -Wall 83 | 84 | source-repository head 85 | type: git 86 | location: git://github.com/ecaustin/haskhol-core.git 87 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Evan Austin 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | haskhol-core 2 | ============ 3 | 4 | The core logical system of the HaskHOL theorem prover. See haskhol.org for more details. 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /data/.dummy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ecaustin/haskhol-core/094c204cf7c4cd69ad3c6d16a1e3bc6efd6c7d6d/data/.dummy -------------------------------------------------------------------------------- /src/HaskHOL/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-| 3 | Module: HaskHOL.Core 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module is the one to import for users looking to include the entirety of 12 | the core of the HaskHOL proof system. It re-exports all of the core 13 | sub-modules in addition to a number of overloaded functions that work with 14 | 'HOLTermRep' and 'HOLTypeRep' representations for convenience reasons. 15 | -} 16 | module HaskHOL.Core 17 | ( -- * Library and Utility Functions 18 | module HaskHOL.Core.Lib 19 | -- * Stateful Primitives, including complete overloadings for Kernel, Basic, and Parser libraries. 20 | , module HaskHOL.Core.State 21 | -- * HaskHOL Pretty Printers 22 | , module HaskHOL.Core.Printer 23 | -- * HaskHOL Core Extensions 24 | , module HaskHOL.Core.Ext 25 | ) where 26 | 27 | import HaskHOL.Core.Lib 28 | import HaskHOL.Core.State 29 | import HaskHOL.Core.Printer 30 | import HaskHOL.Core.Ext 31 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Basics/Nets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-| 3 | Module: HaskHOL.Core.Basics.Nets 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines term nets, an efficient tree structure used for fast 12 | lookups of values that match a given "pattern" term. Typically term nets are 13 | used to store a collection of conversions or tactics to be used for rewriting. 14 | By associating these operations with the pattern that they are valid for, the 15 | rewrite process can quickly prune computations that will obviously fail. 16 | 17 | For more information see the "nets" module from John Harrison's HOL Light. 18 | -} 19 | module HaskHOL.Core.Basics.Nets 20 | ( Net 21 | , netEmpty 22 | , netMap 23 | , netEnter 24 | , netLookup 25 | , netMerge 26 | ) where 27 | 28 | import HaskHOL.Core.Lib 29 | import HaskHOL.Core.Kernel 30 | 31 | -- ordered, unique insertion for sets as lists 32 | setInsert :: Ord a => a -> [a] -> [a] 33 | setInsert a xs = tryd xs $ sinsert a xs 34 | where sinsert :: Ord a => a -> [a] -> Catch [a] 35 | sinsert x [] = return [x] 36 | sinsert x l@(h:t) 37 | | h == x = fail' "sinsert" 38 | | x < h = return (x:l) 39 | | otherwise = do t' <- sinsert x t 40 | return (h:t') 41 | 42 | -- ordered, unique merging of two sets 43 | setMerge :: Ord a => [a] -> [a] -> [a] 44 | setMerge [] l2 = l2 45 | setMerge l1 [] = l1 46 | setMerge l1@(h1:t1) l2@(h2:t2) 47 | | h1 == h2 = h1 : setMerge t1 t2 48 | | h1 < h2 = h1 : setMerge t1 l2 49 | | otherwise = h2 : setMerge l1 t2 50 | 51 | -- The data type that defines a label for each node in a term net. 52 | data TermLabel 53 | = VNet -- variables 54 | | LCNet Text Int -- local constants 55 | | CNet Text Int -- constants 56 | | LNet Int -- term abstraction 57 | | LTyAbs -- type abstraction 58 | | LTyComb -- type combination 59 | deriving (Eq, Ord, Show, Typeable) 60 | 61 | deriveSafeCopy 0 'base ''TermLabel 62 | 63 | {-| 64 | Internally, 'Net's are represented with a tree structure; each node has a list 65 | of labeled branches and a list of values. The node labels are generated via 66 | the following guidelines: 67 | 68 | * Flattening of combinations favors the left hand side such that the head of 69 | an application is looked at first. 70 | 71 | * If the head of an application is variable, the whole term is considered 72 | variable. 73 | 74 | * Type abstractions and type combinations are effectively treated as local 75 | constants, though they do have their own node lable representations to avoid 76 | any potential issues with user provided variable lists for 'enter'. 77 | 78 | * Matching is conservative, such that all matching values will be returned, 79 | but some non-matching values may be returned. For example, a pattern term 80 | of the form @x \`op\` x@ will match any term of the form @a \`op\` b@ 81 | regardless of the values of @a@ and @b@. 82 | -} 83 | data Net a = 84 | NetNode !Integer !(Map TermLabel (Net a)) [a] deriving (Show, Typeable) 85 | 86 | deriveSafeCopy 0 'base ''Net 87 | 88 | -- | The empty 'Net'. 89 | netEmpty :: Net a 90 | netEmpty = NetNode 0 mapEmpty [] 91 | 92 | -- | A version of 'map' for Nets. 93 | netMap :: (a -> b) -> Net a -> Net b 94 | netMap f (NetNode n xs ys) = 95 | NetNode n (mapMap (netMap f) xs) $ map f ys 96 | 97 | {- 98 | Generates a net node label given a pattern term. Differs from labelToLookup 99 | in that it accepts a list of variables to treat as local constants when 100 | generating the label. 101 | -} 102 | labelToStore :: Integer -> [HOLTerm] -> HOLTerm -> (TermLabel, [HOLTerm]) 103 | labelToStore n lconsts tm = 104 | let (op, args) = revSplitList destComb tm in 105 | case op of 106 | (Const x _) -> (CNet x (length args), args) 107 | (Abs bv bod) -> 108 | let bod' = if bv `elem` lconsts 109 | then let v = mkVar ('_' `cons` textShow n) $ typeOf bv in 110 | try' $! varSubst [(bv, v)] bod 111 | else bod in 112 | (LNet (length args), bod':args) 113 | (TyAbs _ t) -> (LTyAbs, [t]) 114 | (TyComb t _) -> (LTyComb, [t]) 115 | (Var x _) -> if op `elem` lconsts 116 | then (LCNet x (length args), args) 117 | else (VNet, []) 118 | _ -> error "labelToStore: stripComb broken" 119 | 120 | {- 121 | Used by enter in order to update a net. Recursively generates node labels for 122 | the provided pattern using labelToStore. 123 | -} 124 | netUpdate :: Ord a => [HOLTerm] -> (a, [HOLTerm], Net a) -> Net a 125 | netUpdate _ (b, [], NetNode n edges tips) = 126 | NetNode n edges $ setInsert b tips 127 | netUpdate lconsts (b, tm:rtms, NetNode n edges tips) = 128 | let (label, ntms) = labelToStore n lconsts tm 129 | (child, others) = tryd (netEmpty, edges) $ mapRemove label edges 130 | newChild = netUpdate lconsts (b, ntms++rtms, child) in 131 | NetNode (succ n) (mapInsert label newChild others) tips 132 | 133 | {-| 134 | Inserts a new element, paired with a pattern term, into a provided net. The 135 | first argument is a list of variables that should be treated as local 136 | constants, such that only patterns with those variables at the exact same 137 | position will match. See the documentation for 'Net' for more details. 138 | 139 | Never fails. 140 | -} 141 | netEnter :: Ord a => [HOLTerm] -> (HOLTerm, a) -> Net a -> Net a 142 | netEnter lconsts (tm, b) net = netUpdate lconsts (b, [tm], net) 143 | 144 | {- 145 | Generates a node label from a provided pattern term. Differs from 146 | labelToStore in that no list of local constants to consider is given. 147 | -} 148 | labelForLookup :: HOLTerm -> (TermLabel, [HOLTerm]) 149 | labelForLookup tm = 150 | let (op, args) = revSplitList destComb tm in 151 | case op of 152 | (Const x _) -> (CNet x (length args), args) 153 | (Abs _ bod) -> (LNet (length args), bod:args) 154 | (TyAbs _ t) -> (LTyAbs, [t]) 155 | (TyComb t _) -> (LTyComb, [t]) 156 | (Var x _) -> (LCNet x (length args), args) 157 | _ -> error "labelForLookup: stripComb broken" 158 | 159 | {- 160 | Traverses a Net following the labels generated from pattern terms via 161 | labelForLookup. Returns a list of all values that satisfy the generated 162 | pattern. 163 | -} 164 | follow :: ([HOLTerm], Net a) -> [a] 165 | follow ([], NetNode _ _ tips) = tips 166 | follow (tm:rtms, NetNode _ edges _) = 167 | let (label, ntms) = labelForLookup tm 168 | collection = case mapAssoc label edges of 169 | Just child -> follow (ntms++rtms, child) 170 | Nothing -> [] in 171 | if label == VNet then collection 172 | else case mapAssoc VNet edges of 173 | Just vn -> collection ++ follow (rtms, vn) 174 | Nothing -> collection 175 | 176 | {-| 177 | Returns the list of all values stored in a term net that satisfy a provided 178 | pattern term. See the documentation for 'Net' for more details. 179 | -} 180 | netLookup :: HOLTerm -> Net a -> [a] 181 | netLookup tm net = follow ([tm], net) 182 | 183 | {-| 184 | Merges two term nets together. The values for the two nets are merged, 185 | maintaining order and uniqueness, with the term labels adjusted appropriately. 186 | The algorithm to do so is courtesy of Don Syme via John Harrison's 187 | implementation in HOL Light. 188 | -} 189 | netMerge :: Ord a => Net a -> Net a -> Net a 190 | netMerge (NetNode n1 l1 data1) (NetNode n2 l2 data2) = 191 | NetNode (max n1 n2) 192 | (mapFoldrWithKey addNode (mapFoldrWithKey addNode mapEmpty l1) l2) $ 193 | setMerge data1 data2 194 | where addNode :: Ord a => TermLabel -> Net a -> Map TermLabel (Net a) -> 195 | Map TermLabel (Net a) 196 | addNode lab net l = 197 | case mapRemove lab l of 198 | Just (net', rest) -> 199 | mapInsert lab (netMerge net net') rest 200 | Nothing -> mapInsert lab net l 201 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Basics/Stateful.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} 2 | module HaskHOL.Core.Basics.Stateful where 3 | 4 | import HaskHOL.Core.Lib 5 | import HaskHOL.Core.Kernel 6 | 7 | -- Pre-Req Syntax 8 | {-| 9 | A version of 'mkBinary' that accepts the operator as a pre-constructed term. 10 | -} 11 | mkBinop :: MonadCatch m => HOLTerm -> HOLTerm -> HOLTerm -> m HOLTerm 12 | mkBinop op tm1 tm2 = 13 | (do tm <- mkComb op tm1 14 | mkComb tm tm2) "mkBinop" 15 | 16 | {-| 17 | A version of 'mkComb' that instantiates the type variables in the left hand 18 | argument. Relies internally on 'typeMatch' in order to provide a match 19 | between the domain type of the function and the type of the argument. Fails 20 | with 'Nothing' if instantiation is impossible. 21 | -} 22 | mkIComb :: MonadCatch m => HOLTerm -> HOLTerm -> m HOLTerm 23 | mkIComb tm1 tm2 = 24 | do (ty, _) <- destFunTy $ typeOf tm1 25 | mat <- typeMatch ty (typeOf tm2) ([], [], []) 26 | mkComb (instFull mat tm1) tm2 27 | 28 | {-| 29 | Constructs a complex combination that represents the application of a 30 | function to a list of arguments. Fails with 'Left' if any internal call to 31 | 'mkComb' fails. 32 | -} 33 | listMkComb :: MonadThrow m => HOLTerm -> [HOLTerm] -> m HOLTerm 34 | listMkComb = foldlM mkComb 35 | 36 | -- Stateful Basics 37 | {-| 38 | Retrieves the type of a given term constant. Throws a 'HOLException' if the 39 | provided term constant name is not defined. 40 | -} 41 | getConstType :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 42 | => Text -> m HOLType 43 | getConstType name = 44 | do consts <- ?constsFun 45 | (typeOf `fmap` mapAssoc name consts) 46 | "getConstType: not a constant name" 47 | 48 | {-| 49 | Constructs a type application given an operator name and a list of argument 50 | types. If the provided name is not a currently defined type constant then 51 | this function defaults it to a type operator variable. Throws a 52 | 'HOLException' in the following cases: 53 | 54 | * A type operator's arity disagrees with the length of the argument list. 55 | 56 | * A type operator is applied to zero arguments. 57 | -} 58 | mkType :: (MonadCatch m, ?typesFun :: m (Map Text TypeOp)) 59 | => Text -> [HOLType] -> m HOLType 60 | mkType name args = 61 | do consts <- ?typesFun 62 | case runCatch $ mapAssoc name consts of 63 | Right tyOp -> tyApp tyOp args 64 | "mkType: type constructor application failed" 65 | Left{} -> 66 | {- This seemed to be the easiest way to supress superfluous warnings 67 | when parsing type operators. -} 68 | do name' <- if textHead name == '_' 69 | then return $! textTail name 70 | else return name 71 | failWhen (return $ null args) 72 | "mkType: type operator applied to zero args." 73 | tyApp (mkTypeOpVar name') args 74 | "mkType: type operator variable application failed" 75 | 76 | {-| 77 | Constructs a function type safely using 'mkType'. Should never fail provided 78 | that the initial value for type constants has not been modified. 79 | -} 80 | mkFunTy :: (MonadCatch m, ?typesFun :: m (Map Text TypeOp)) 81 | => HOLType -> HOLType -> m HOLType 82 | mkFunTy ty1 ty2 = mkType "fun" [ty1, ty2] 83 | 84 | {-| 85 | Constructs a specific instance of a term constant when provided with its name 86 | and a type substition environment. Throws a 'HOLException' in the 87 | following cases: 88 | 89 | * The instantiation as performed by 'instConst' fails. 90 | 91 | * The provided name is not a currently defined constant. 92 | -} 93 | mkConst :: (MonadCatch m, TypeSubst l r, ?constsFun :: m (Map Text HOLTerm)) 94 | => Text -> [(l, r)] -> m HOLTerm 95 | mkConst name tyenv = 96 | do consts <- ?constsFun 97 | tm <- mapAssoc name consts "mkConst: not a constant name" 98 | instConst tm tyenv "mkConst: instantiation failed" 99 | 100 | {-| 101 | A version of 'mkConst' that accepts a triplet of type substitition 102 | environments. Frequently used with the 'typeMatch' function. 103 | -} 104 | mkConst_FULL :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 105 | => Text -> SubstTrip -> m HOLTerm 106 | mkConst_FULL name tyenv = 107 | do consts <- ?constsFun 108 | tm <- mapAssoc name consts "mkConstFull: not a constant name" 109 | instConstFull tm tyenv "mkConstFull: instantiation failed" 110 | 111 | mkConst_NIL :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 112 | => Text -> m HOLTerm 113 | mkConst_NIL tm = mkConst tm ([] :: HOLTypeEnv) 114 | 115 | -- matching version of mkConst 116 | {-| 117 | Constructs an instance of a constant of the provided name and type. Relies 118 | internally on 'typeMatch' in order to provide a match between the most general 119 | type of the constant and the provided type. Throws a 'HOLException' in the 120 | following cases: 121 | 122 | * The provided string is not the name of a defined constant. 123 | 124 | * Type matching fails. 125 | -} 126 | mkMConst :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 127 | => Text -> HOLType -> m HOLTerm 128 | mkMConst name ty = 129 | do uty <- getConstType name "mkMConst: not a constant name" 130 | (mkConst_FULL name =<< typeMatch uty ty ([], [], [])) 131 | "mkMConst: generic type cannot be instantiated" 132 | 133 | {-| 134 | An iterative version of 'mkIComb' that builds a complex combination given a 135 | constant name and a list of arguments, attempting to find a correct 136 | instantiation at every step. Throws a 'HOLException' in the following cases: 137 | 138 | * The provided name is not a currently defiend constant. 139 | 140 | * Any internal call to mkIComb fails. 141 | -} 142 | listMkIComb :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 143 | => Text -> [HOLTerm] -> m HOLTerm 144 | listMkIComb cname args = 145 | do cnst <- mkConst_NIL cname "listMkIComb: not a constant name" 146 | foldlM mkIComb cnst args "listMkIComb: type cannot be instantiated" 147 | 148 | {-| 149 | Constructs a binary application given a constant name and two argument terms. 150 | Note that no instantiation is performed, thus the constant must be monomorphic 151 | or the provided arguments must match the constant's general type. Throws a 152 | 'HOLException' if any of the internal calls to 'mkConst' or 'mkComb' fail. 153 | -} 154 | mkBinary :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 155 | => Text -> HOLTerm -> HOLTerm -> m HOLTerm 156 | mkBinary s l r = 157 | (do c <- mkConst_NIL s 158 | let c' = inst [(tyA, typeOf l), (tyB, typeOf r)] c 159 | l' <- mkComb c' l 160 | mkComb l' r) 161 | "mkBinary: " ++ show s 162 | 163 | {-| 164 | Constructs an abstraction given a binder name and two argument terms. Throws 165 | a 'HOLException' if any of the internal calls to 'mkConst', 'mkAbs', or 166 | 'mkComb' fail. 167 | 168 | Note that the given string can actually be any constant name of type 169 | @(A -> *) -> *@, such that a well-typed term of the form @c (\\x . t)@ can be 170 | produced. 171 | -} 172 | mkBinder :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 173 | => Text -> HOLTerm -> HOLTerm -> m HOLTerm 174 | mkBinder op v tm = 175 | (do op' <- mkConst op [(tyA, typeOf v)] 176 | mkComb op' =<< mkAbs v tm) "mkBinder: " ++ show op 177 | 178 | {-| 179 | Constructs a type abstraction given a type binder name, a type variable to 180 | find, and a body term. Throws a 'HOLException' if any of the internal calls 181 | to 'mkConst', 'mkTyAbs', or 'mkComb' fail. 182 | 183 | Note that the given string can actually be any constant name of type 184 | @(% 'a . *) -> *@, such that a well-typed term of the form @c (\\\\x . t)@ can 185 | be produced. 186 | -} 187 | mkTyBinder :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 188 | => Text -> HOLType -> HOLTerm -> m HOLTerm 189 | mkTyBinder op v tm = 190 | (do op' <- mkConst_NIL op 191 | mkComb op' =<< mkTyAbs v tm) "mkTyBinder: " ++ show op 192 | 193 | {-| 194 | Constructor for boolean conjunctions. Throws a 'HOLException' if the internal 195 | calls to 'mkComb' fail. 196 | -} 197 | mkIff :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 198 | => HOLTerm -> HOLTerm -> m HOLTerm 199 | mkIff l r = 200 | (do op <- mkConst "=" [(tyA, tyBool)] 201 | l' <- mkComb op l 202 | mkComb l' r) "mkIff" 203 | 204 | {-| 205 | Constructor for boolean conjunctions. Throws a 'HOLException' if the internal 206 | call to 'mkBinary' fails. 207 | -} 208 | mkConj :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 209 | => HOLTerm -> HOLTerm -> m HOLTerm 210 | mkConj = mkBinary "/\\" 211 | 212 | {-| 213 | Constructor for boolean implications. Throws a 'HOLException' if the internal 214 | call to 'mkBinary' fails. 215 | -} 216 | mkImp :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 217 | => HOLTerm -> HOLTerm -> m HOLTerm 218 | mkImp = mkBinary "==>" 219 | 220 | {-| 221 | Constructor for universal term quantification. Throws a 'HOLException' if the 222 | internal call to 'mkBinder' fails. 223 | -} 224 | mkForall :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 225 | => HOLTerm -> HOLTerm -> m HOLTerm 226 | mkForall = mkBinder "!" 227 | 228 | {-| 229 | Constructor for existential term quantification. Throws a 'HOLException' if 230 | the internal call to 'mkBinder' fails. 231 | -} 232 | mkExists :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 233 | => HOLTerm -> HOLTerm -> m HOLTerm 234 | mkExists = mkBinder "?" 235 | 236 | {-| 237 | Constructor for boolean disjunctions. Throws a 'HOLException' if the internal 238 | call to 'mkBinary' fails. 239 | -} 240 | mkDisj :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 241 | => HOLTerm -> HOLTerm -> m HOLTerm 242 | mkDisj = mkBinary "\\/" 243 | 244 | {-| 245 | Constructor for boolean negations. Throws a 'HOLException' if any of the 246 | internal calls to 'mkConst' or 'mkComb' fail. 247 | -} 248 | mkNeg :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 249 | => HOLTerm -> m HOLTerm 250 | mkNeg tm = 251 | (do op <- mkConst_NIL "~" 252 | mkComb op tm) "mkNeg" 253 | 254 | {-| 255 | Constructor for unique, existential term quantification. Throws a 256 | 'HOLException' if the internal call to 'mkBinder' fails. 257 | -} 258 | mkUExists :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 259 | => HOLTerm -> HOLTerm -> m HOLTerm 260 | mkUExists = mkBinder "?!" 261 | 262 | {-| 263 | Constructor for term-level universal type quantification. Throws a 264 | 'HOLException' if the internal call to 'mkTyBinder' fails. 265 | -} 266 | mkTyAll :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 267 | => HOLType -> HOLTerm -> m HOLTerm 268 | mkTyAll = mkTyBinder "!!" 269 | 270 | {-| 271 | Constructor for term-level existential type quantification. Throws a 272 | 'HOLException' if the internal call to 'mkTyBinder' fails. 273 | -} 274 | mkTyEx :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 275 | => HOLType -> HOLTerm -> m HOLTerm 276 | mkTyEx = mkTyBinder "??" 277 | 278 | -- | Constructs a complex conjunction from a given list of propositions. 279 | listMkConj :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 280 | => [HOLTerm] -> m HOLTerm 281 | listMkConj = foldr1M mkConj 282 | 283 | -- | Constructs a complex disjunction from a given list of propositions. 284 | listMkDisj :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 285 | => [HOLTerm] -> m HOLTerm 286 | listMkDisj = foldr1M mkDisj 287 | 288 | -- | A specific version of 'listMkAbs' for universal term quantification. 289 | listMkForall :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 290 | => [HOLTerm] -> HOLTerm -> m HOLTerm 291 | listMkForall = flip (foldrM mkForall) 292 | 293 | -- | A specific version of 'listMkAbs' for existential term quantification. 294 | listMkExists :: (MonadCatch m, ?constsFun :: m (Map Text HOLTerm)) 295 | => [HOLTerm] -> HOLTerm -> m HOLTerm 296 | listMkExists = flip (foldrM mkExists) 297 | 298 | {-| 299 | Constructor for generalized abstractions. Generalized abstractions extend 300 | term abstractions to the more general of notion of a function mapping some 301 | structure to some term. This allows us to bind patterns more complicated 302 | than a variable, i.e. binding pairs 303 | 304 | > \ (x:num, y:num) -> x + y 305 | 306 | or lists 307 | 308 | > \ CONS x xs -> x 309 | 310 | Note that in the case where the pattern to bind is simply a variable 'mkGAbs' 311 | just calls 'mkAbs'. 312 | -} 313 | mkGAbs :: forall m. (MonadCatch m, ?typesFun :: m (Map Text TypeOp), 314 | ?constsFun :: m (Map Text HOLTerm)) 315 | => HOLTerm -> HOLTerm -> m HOLTerm 316 | mkGAbs tm1@Var{} tm2 = mkAbs tm1 tm2 "mkGAbs: simple abstraction failed" 317 | mkGAbs tm1 tm2 = 318 | let fvs = frees tm1 in 319 | (do fTy <- mkFunTy (typeOf tm1) $ typeOf tm2 320 | let f = variant (frees tm1++frees tm2) $ mkVar "f" fTy 321 | tm1' <- mkComb f tm1 322 | bodIn <- listMkForall fvs =<< mkGEq tm1' tm2 323 | bndr <- mkConst "GABS" [(tyA, fTy)] 324 | mkComb bndr =<< mkAbs f bodIn) "mkGAbs" 325 | where mkGEq :: HOLTerm -> HOLTerm -> m HOLTerm 326 | mkGEq l r = 327 | do op <- mkConst "GEQ" [(tyA, typeOf l)] 328 | mkBinop op l r 329 | 330 | -- | A specific version of 'listMkAbs' for general abstractions. 331 | listMkGAbs :: (MonadCatch m, ?typesFun :: m (Map Text TypeOp), 332 | ?constsFun :: m (Map Text HOLTerm)) 333 | => [HOLTerm] -> HOLTerm -> m HOLTerm 334 | listMkGAbs = flip (foldrM mkGAbs) 335 | 336 | {-| 337 | Constructs a let binding term provided a list of variable/value pairs and a 338 | body term. 339 | -} 340 | mkLet :: (MonadCatch m, ?typesFun :: m (Map Text TypeOp), 341 | ?constsFun :: m (Map Text HOLTerm)) 342 | => HOLTermEnv -> HOLTerm -> m HOLTerm 343 | mkLet assigs bod = 344 | do tmLetEnd <- mkConst "LET_END" [(tyA, typeOf bod)] 345 | let (ls, rs) = unzip assigs 346 | lend <- mkComb tmLetEnd bod 347 | lbod <- listMkGAbs ls lend 348 | (ty1, ty2) <- destFunTy $ typeOf lbod 349 | tmLet <- mkConst "LET" [(tyA, ty1), (tyB, ty2)] 350 | listMkComb tmLet (lbod:rs) 351 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Ext.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-| 3 | Module: HaskHOL.Core.Ext 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module exports HaskHOL's non-trivial extensions to the underlying HOL 12 | system, i.e. the compile time operations. These operations are split into 13 | three categories: 14 | 15 | * Methods related to the Protect and Serve Mechanism for sealing and unsealing 16 | data against a provided theory context. 17 | 18 | * Methods related to quasi-quoting of 'HOLTerm's. 19 | 20 | * Methods related to compile time extension and caching of theory contexts. 21 | -} 22 | module HaskHOL.Core.Ext 23 | ( -- * Protected Data Methods 24 | -- $Protect 25 | module HaskHOL.Core.Ext.Protected 26 | -- * Quasi-Quoter Methods 27 | -- $QQ 28 | , module HaskHOL.Core.Ext.QQ 29 | , module Language.Haskell.TH {-| 30 | Re-exports 'Q', 'Dec', and 'Exp' for the purpose of writing type 31 | signatures external to this module. 32 | -} 33 | , module Language.Haskell.TH.Quote {-| 34 | Re-exports 'QuasiQuoter' for the purpose of writing type signatures 35 | external to this module. 36 | -} 37 | ) where 38 | 39 | import HaskHOL.Core.Ext.Protected 40 | import HaskHOL.Core.Ext.QQ 41 | 42 | import Language.Haskell.TH (Q, Dec, Exp) 43 | import Language.Haskell.TH.Quote (QuasiQuoter) 44 | 45 | import Prelude hiding (FilePath) 46 | 47 | -- Documentation copied from sub-modules 48 | 49 | {-$Protect 50 | The basic goal behind the Protect and Serve mechanism is to recapture some of 51 | the efficiency lost as a result of moving from an impure, interpretted host 52 | language to a pure, compiled one. We do this by forcing the evaluation of 53 | large computations, usually proofs, such that they are only run once. To 54 | maintain soundness of our proof system, we must track what information 55 | was used to force the computation and guarantee that information is present 56 | in all cases where this new value is to be used. This is the purpose of the 57 | @Protected@ class and the 'liftProtectedExp' and 'liftProtected' methods. 58 | -} 59 | 60 | {-$QQ 61 | Quasi-quoting provides a way to parse 'HOLTerm's at compile time safely. 62 | Just as with proofs, we seal these terms against the theory context used to 63 | parse them with 'protect' and 'serve' to preserve soundness. See the 64 | documentation for 'base' for a brief discussion on when quasi-quoting should 65 | be used vs. 'toHTm'. 66 | -} 67 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Ext/Protected.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, 2 | TypeFamilies, TypeSynonymInstances #-} 3 | {-| 4 | Module: HaskHOL.Core.Ext.Protected 5 | Copyright: (c) Evan Austin 2015 6 | LICENSE: BSD3 7 | 8 | Maintainer: e.c.austin@gmail.com 9 | Stability: unstable 10 | Portability: unknown 11 | 12 | This module defines a mechanism for sealing and unsealing values against a 13 | given context. Additionally, a number of compile time operations are 14 | provided that leverage this technique as an example of how it can be used. 15 | 16 | The basic goal behind the content of this module is to recapture some of the 17 | efficiency lost as a result of moving from an impure, interpretted host 18 | language to a pure, compiled one. We do this by forcing the evaluation of 19 | large computations, usually proofs, such that they are only run once. To 20 | maintain soundness of our proof system, we must track what information 21 | was used to force the computation and guarantee that information is present 22 | in all cases where this new value is to be used. This is the purpose of the 23 | @Protected@ class and the 'liftProtectedExp' and 'liftProtected' methods. 24 | -} 25 | module HaskHOL.Core.Ext.Protected 26 | ( Protected 27 | , PData 28 | , protect 29 | , serve 30 | , PType 31 | , PTerm 32 | , liftProtectedExp 33 | , liftProtected 34 | ) where 35 | 36 | import HaskHOL.Core.Kernel 37 | import HaskHOL.Core.State.Monad 38 | 39 | import Language.Haskell.TH 40 | import Language.Haskell.TH.Syntax (Lift(..)) 41 | 42 | -- protected values 43 | {-| 44 | The Protected class is the associated type class that facilitates our 45 | protect/serve protection mechanism. 46 | 47 | It defines: 48 | 49 | * A data wrapper for our protected type. 50 | 51 | * Conversions to/from this new type, protect and serve. 52 | 53 | * Some boilerplate code to enable template haskell lifting. 54 | -} 55 | class Lift a => Protected a where 56 | -- | The associated type for the 'Protected' class. 57 | data PData a thry 58 | -- | Protects a value by sealing it against a provided context. 59 | protect :: TheoryPath thry -> a -> PData a thry 60 | {-| 61 | Unseals a protected value, returning it in a monadic computation whose 62 | current working theory satisfies the context that the value was originally 63 | sealed with. 64 | -} 65 | serve :: PData a thry -> HOL cls thry a 66 | -- | Unseals a protected value, returning a pure, unprotected value. 67 | liftTy :: a -> Type 68 | protLift :: PData a thry -> Q Exp 69 | 70 | instance Protected HOLTerm where 71 | data PData HOLTerm thry = PTm HOLTerm 72 | protect _ = PTm 73 | serve (PTm tm) = return tm 74 | liftTy _ = ConT ''HOLTerm 75 | protLift (PTm tm) = conE 'PTm `appE` lift tm 76 | -- | Type synonym for protected 'HOLTerm's. 77 | type PTerm thry = PData HOLTerm thry 78 | 79 | instance Protected HOLType where 80 | data PData HOLType thry = PTy HOLType 81 | protect _ = PTy 82 | serve (PTy ty) = return ty 83 | liftTy _ = ConT ''HOLType 84 | protLift (PTy ty) = conE 'PTy `appE` lift ty 85 | -- | Type synonym for protected 'HOLType's. 86 | type PType thry = PData HOLType thry 87 | 88 | {- 89 | Builds the theory contrainst for a lifted, protected value. 90 | For example: 91 | 92 | > buildThryType (x::PData a BoolType) 93 | 94 | builds the context 95 | 96 | > forall thry. BoolCtxt thry => PData a thry 97 | -} 98 | buildThryType :: forall a thry. (Protected a, CtxtName thry) => 99 | PData a thry -> Q Type 100 | buildThryType _ = 101 | do tyname <- newName "thry" 102 | let cls = ConT (mkName $ ctxtName (undefined::thry)) `AppT` VarT tyname 103 | return . ForallT [PlainTV tyname] [cls] . 104 | AppT (AppT (ConT ''PData) $ liftTy (undefined :: a)) $ 105 | VarT tyname 106 | 107 | 108 | {-| 109 | Lifts a protected data value as an expression using an ascribed type. 110 | For example: 111 | 112 | > liftProtectedExp (x::PData a Bool) 113 | 114 | produces the following spliceable expression 115 | 116 | > [| x :: forall thry. BoolCtxt thry => PData a Bool |] 117 | -} 118 | liftProtectedExp :: (Protected a, CtxtName thry) => PData a thry -> Q Exp 119 | liftProtectedExp pdata = 120 | do pdata' <- protLift pdata 121 | ty <- buildThryType pdata 122 | return $! SigE pdata' ty 123 | 124 | {-| 125 | Lifts a protected data value as a declaration of a given name with an ascribed 126 | type signature. 127 | For example: 128 | 129 | > liftProtected "protX" (x::PData a Bool) 130 | 131 | produces the following list of spliceable declarations 132 | 133 | > [ [d| protX :: forall thry. BoolCtxt thry => PData a Bool |] 134 | > , [d| protX = x |] ] 135 | 136 | See 'extractAxiom' for a basic example of how this function may be used. 137 | -} 138 | liftProtected :: (Protected a, CtxtName thry) => 139 | String -> PData a thry -> Q [Dec] 140 | liftProtected lbl pdata = 141 | do pdata' <- protLift pdata 142 | ty <- buildThryType pdata 143 | let name = mkName lbl 144 | tysig = SigD name ty 145 | dec = ValD (VarP name) (NormalB pdata') [] 146 | return [tysig, dec] 147 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Ext/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-| 3 | Module: HaskHOL.Core.Ext.QQ 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines a mechanism for compile time quasi-quoting of 'HOLTerm's. 12 | The 'baseQuoter' method constructs a theory specific quasi-quoter that parses 13 | 'HOLTerm's at the expression level using 'toHTm'. An example, 'base' is 14 | provided to demonstrate how this process works. 15 | 16 | Additionally, a specialized quasi-quoter for 'String's is provided that 17 | escapes special characters and trims white-space. This can be helpful when 18 | expressing 'HOLTerm's as 'String's, i.e. @\"\\ x . x\"@. 19 | -} 20 | module HaskHOL.Core.Ext.QQ 21 | ( baseQuoter 22 | , baseQQ 23 | , txt 24 | , liftParseContext 25 | ) where 26 | 27 | import HaskHOL.Core.Lib 28 | import HaskHOL.Core.State.Monad 29 | import HaskHOL.Core.Parser 30 | import HaskHOL.Core.Ext.Protected 31 | 32 | {- 33 | We require some Template Haskell primitives that shouldn't be exposed outside 34 | of this module, i.e. runIO 35 | -} 36 | import Language.Haskell.TH 37 | import Language.Haskell.TH.Quote 38 | import Language.Haskell.TH.Syntax 39 | 40 | {-| 41 | This is the base quasi-quoter for the HaskHOL system. When provided with a 42 | theory context value, it constucts a theory specific quasi-quoter that parses 43 | a 'String' as a term, protecting and lifting the result. 44 | 45 | Note that, at this point in time, we only allowing quoting at the expression 46 | level. 47 | -} 48 | baseQuoter :: CtxtName thry => TheoryPath thry -> ParseContext -> QuasiQuoter 49 | baseQuoter thry ctxt = QuasiQuoter quoteBaseExps nothing nothing nothing 50 | where quoteBaseExps :: String -> Q Exp 51 | quoteBaseExps x = 52 | let x' = textStrip $ pack x in 53 | if textHead x' == ':' 54 | then body tyElab holTypeParser $ textTail x' 55 | else body elab holTermParser x' 56 | 57 | nothing _ = fail "quoting here not supported" 58 | 59 | body :: Protected b 60 | => (ParseContext -> a -> Catch b) 61 | -> (ParseContext -> Text -> Catch a) 62 | -> Text -> Q Exp 63 | body efun pfun x' = 64 | case runCatch $ efun ctxt =<< pfun ctxt x' of 65 | Right res -> liftProtectedExp $ protect thry res 66 | Left err -> fail $ show err 67 | 68 | {-| 69 | An instance of 'baseQuoter' for the core theory context, 'ctxtBase'. 70 | Example: 71 | 72 | > [baseQQ| x = y |] 73 | 74 | will parse the provided string and construct the 'HOLTerm' @x = y@ at compile 75 | time. Note that this term is protected, such that it has to be accessed via 76 | 'serve'. This is advantageous in computations that may be run many times, 77 | for example: 78 | 79 | > do tm <- serve [baseQQ| x = y |] 80 | > ... 81 | 82 | will parse the term exactly once, only checking the @thry@ tag of the 83 | computation for each evaluation. Conversely, 84 | 85 | > do tm <- toHTm "x = y" 86 | > ... 87 | 88 | will parse the term for every evaluation of that computation. Generally, the 89 | use of 'toHTm' is reserved for run time parsing and in larger computations 90 | that themselves are evaluated at copmile time to minimize the amount of work 91 | Template Haskell has to do. 92 | -} 93 | baseQQ :: QuasiQuoter 94 | baseQQ = baseQuoter ctxtBase initParseContext 95 | 96 | {-| 97 | This is a specialized quasi-quoter for 'Text's. It can be used to strip 98 | white space and automatically escape special characters. It is typically used 99 | in conjunction with 'toHTm' directly or indirectly. 100 | -} 101 | txt :: QuasiQuoter 102 | txt = QuasiQuoter quoteStrExp nothing nothing nothing 103 | where quoteStrExp x = [| textStrip $ pack $(litE $ StringL x) |] 104 | nothing _ = fail "quoting here not supported" 105 | 106 | liftParseContext :: TheoryPath thry -> Q Exp 107 | liftParseContext ctxt = 108 | lift =<< runIO (runHOLProof False parseContextCache ctxt) 109 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Kernel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-| 3 | Module: HaskHOL.Core.Kernel 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module exports the logical kernel of HaskHOL. It consists of: 12 | 13 | * A safe view of HOL theorems for HaskHOL. 14 | 15 | * The primitive inference rules of the system. 16 | 17 | * The primitive, stateless theory extension functions. 18 | 19 | For clarity, all of these items have been seperated based on their influential 20 | system: HOL Light, Stateless HOL, and HOL2P. 21 | 22 | Note that, per the stateless approach, any stateful, but still primitive, 23 | functions related to theorems or theory extension have been relocated to the 24 | "HaskHOL.Core.State" module. 25 | -} 26 | module HaskHOL.Core.Kernel 27 | ( -- * A View of HOL Types, Terms, and Theorems 28 | -- ** A Quick Note on Pattern Synonyms 29 | -- $ViewPatterns 30 | -- ** Destructors and Accessors for Theorems 31 | HOLThm 32 | , pattern Thm 33 | , destThm 34 | , hyp 35 | , concl 36 | -- * HOL Light Primitive Inference Rules 37 | , primREFL 38 | , primTRANS 39 | , primMK_COMB 40 | , primABS 41 | , primBETA 42 | , primASSUME 43 | , primEQ_MP 44 | , primDEDUCT_ANTISYM 45 | , primINST_TYPE 46 | , primINST_TYPE_FULL 47 | , primINST 48 | -- * HOL2P Primitive Inference Rules 49 | , primTYABS 50 | , primTYAPP2 51 | , primTYAPP 52 | , primTYBETA 53 | -- * Stateless HOL Primitive Theory Extensions 54 | , axiomThm 55 | , newDefinedConst 56 | , newDefinedTypeOp 57 | -- * Primitive Re-Exports 58 | , HOLPrimError(..) 59 | , module HaskHOL.Core.Kernel.Types 60 | , module HaskHOL.Core.Kernel.Terms 61 | ) where 62 | 63 | import HaskHOL.Core.Lib 64 | import HaskHOL.Core.Kernel.Prims 65 | import HaskHOL.Core.Kernel.Types 66 | import HaskHOL.Core.Kernel.Terms 67 | 68 | import Data.Hashable 69 | 70 | {- 71 | Used to quickly make an equality between two terms we know to be of the same 72 | type. Not exposed to the user. 73 | -} 74 | safeMkEq :: HOLTerm -> HOLTerm -> HOLTerm 75 | safeMkEq l r = 76 | let eq = tmEq $ typeOf l in 77 | CombIn (CombIn eq l) r 78 | 79 | 80 | {- 81 | Unions two lists of terms, ordering the result modulo alpha-equivalence. Not 82 | exposed to the user. 83 | -} 84 | termUnion :: [HOLTerm] -> [HOLTerm] -> [HOLTerm] 85 | termUnion [] l2 = l2 86 | termUnion l1 [] = l1 87 | termUnion l1@(h1:t1) l2@(h2:t2) = 88 | case alphaOrder h1 h2 of 89 | EQ -> h1 : termUnion t1 t2 90 | LT -> h1 : termUnion t1 l2 91 | _ -> h2 : termUnion l1 t2 92 | 93 | {- 94 | Removes a term from a term list, ordering the result modulo alpha-equivalence. 95 | Not exposed to the user. 96 | -} 97 | termRemove :: HOLTerm -> [HOLTerm] -> [HOLTerm] 98 | termRemove _ [] = [] 99 | termRemove t l@(s:ss) = 100 | case alphaOrder t s of 101 | GT -> s : termRemove t ss 102 | EQ -> ss 103 | _ -> l 104 | 105 | {- 106 | Maps a function over a list of terms, termUnion-ing the result at each step. 107 | Roughly equivalent to a composition of nub and map that orders the result 108 | modulo alpha-equivalence. Not exposed to the user 109 | -} 110 | termImage :: (HOLTerm -> HOLTerm) -> [HOLTerm] -> [HOLTerm] 111 | termImage _ [] = [] 112 | termImage f (h:t) = termUnion [f h] $ termImage f t 113 | 114 | termImageM :: Monad m => (HOLTerm -> m HOLTerm) -> [HOLTerm] -> m [HOLTerm] 115 | termImageM _ [] = return [] 116 | termImageM f (h:t) = 117 | do h' <- f h 118 | termUnion [h'] `fmap` termImageM f t 119 | 120 | {- 121 | HOL Light Theorem Primitives 122 | -} 123 | {-| 124 | Destructs a theorem, returning its list of assumption terms and conclusion 125 | term. 126 | -} 127 | destThm :: HOLThm -> ([HOLTerm], HOLTerm) 128 | destThm (ThmIn as c) = (as, c) 129 | 130 | -- | Accessor for the hypotheses, or assumption terms, of a theorem. 131 | hyp :: HOLThm -> [HOLTerm] 132 | hyp (ThmIn as _) = as 133 | 134 | -- | Accessor for the conclusion term of a theorem. 135 | concl :: HOLThm -> HOLTerm 136 | concl (ThmIn _ c) = c 137 | 138 | {- 139 | HOL Light Primitive Inference Rules 140 | -} 141 | 142 | -- Basic Equality Rules 143 | 144 | {-|@ 145 | t 146 | ----------- 147 | |- t = t 148 | @ 149 | 150 | Never fails. 151 | -} 152 | primREFL :: HOLTerm -> HOLThm 153 | primREFL tm = ThmIn [] $ safeMkEq tm tm 154 | 155 | {-|@ 156 | A1 |- t1 = t2 A2 |- t2 = t3 157 | ------------------------------- 158 | A1 U A2 |- t1 = t3 159 | @ 160 | 161 | Fails with 'Left' in the following cases: 162 | 163 | * The middle terms are not alpha-equivalent. 164 | 165 | * One, or both, of the theorem conclusions is not an equation. 166 | -} 167 | primTRANS :: MonadThrow m => HOLThm -> HOLThm -> m HOLThm 168 | primTRANS th@(ThmIn as1 (CombIn eql@(CombIn (TmEq _) _) m1)) 169 | (ThmIn as2 (m2 := r)) 170 | | m1 `aConv` m2 = 171 | let as' = termUnion as1 as2 in 172 | return . ThmIn as' $ CombIn eql r 173 | | otherwise = throwM $! HOLThmError th "primTRANS: middle terms don't agree" 174 | primTRANS th _ = throwM $! HOLThmError th "primTRANS: not both equations" 175 | 176 | -- Basic Congruence Rules 177 | 178 | {-|@ 179 | A1 |- f = g A2 |- x = y 180 | --------------------------- 181 | A1 U A2 |- f x = g y 182 | @ 183 | 184 | Fails with 'Left' in the following cases: 185 | 186 | * One, or both, of the theorem conclusions is not an equation. 187 | 188 | * The first theorem conclusion is not an equation of function terms. 189 | 190 | * The types of the function terms and argument terms do not agree. 191 | -} 192 | primMK_COMB :: MonadThrow m => HOLThm -> HOLThm -> m HOLThm 193 | primMK_COMB th@(ThmIn as1 (l1 := r1)) (ThmIn as2 (l2 := r2)) = 194 | case typeOf l1 of 195 | TyAppIn TyOpFun (ty:_:_) 196 | | typeOf l2 `tyAConv` ty -> 197 | let as' = termUnion as1 as2 in 198 | return . ThmIn as' $ safeMkEq (CombIn l1 l2) (CombIn r1 r2) 199 | | otherwise -> throwM $! HOLThmError th 200 | "primMK_COMB: types do not agree" 201 | _ -> throwM $! HOLThmError th "primMK_COMB: not a function type" 202 | primMK_COMB th _ = throwM $! HOLThmError th "primMK_COMB: not both equations" 203 | 204 | {-|@ 205 | A |- t1 = t2 206 | ------------------------------- 207 | A |- (\\ x . t1) = (\\ x . t2) 208 | @ 209 | 210 | Fails with 'Left' in the following cases: 211 | 212 | * The term to bind is free in the assumption list of the theorem. 213 | 214 | * The conclusion of the theorem is not an equation. 215 | -} 216 | primABS :: MonadThrow m => HOLTerm -> HOLThm -> m HOLThm 217 | primABS v@VarIn{} th@(ThmIn as (l := r)) 218 | | any (varFreeIn v) as = 219 | throwM $! HOLThmError th "primABS: variable is free in assumptions" 220 | | otherwise = 221 | return . ThmIn as $ safeMkEq (AbsIn v l) (AbsIn v r) 222 | primABS _ th = throwM $! HOLThmError th "primABS: not an equation" 223 | 224 | -- Beta Reduction 225 | {-|@ 226 | (\\ x . t) x 227 | ---------------------------- 228 | |- (\\ x . t) x = t 229 | @ 230 | 231 | Fails with 'Left' in the following cases: 232 | 233 | * The term is not a valid application. 234 | 235 | * The reduction is not a trivial one, i.e. the argument term is not equivalent 236 | to the bound variable. 237 | -} 238 | primBETA :: MonadThrow m => HOLTerm -> m HOLThm 239 | primBETA t@(CombIn (AbsIn bv bod) arg) 240 | | arg == bv = 241 | return . ThmIn [] $ safeMkEq t bod 242 | | otherwise = throwM $! HOLTermError t 243 | "primBETA_PRIM: not a trivial beta reduction" 244 | primBETA t = throwM $! HOLTermError t "primBETA_PRIM: not a valid application" 245 | 246 | -- Deduction Rules 247 | {-|@ 248 | t 249 | ----------- 250 | t |- t 251 | @ 252 | 253 | Fails with 'Left' if the term is not a proposition. 254 | -} 255 | primASSUME :: MonadThrow m => HOLTerm -> m HOLThm 256 | primASSUME tm 257 | | typeOf tm == tyBool = return $! ThmIn [tm] tm 258 | | otherwise = throwM $! HOLTermError tm "primASSUME" 259 | 260 | {-|@ 261 | A1 |- t1 = t2 A2 |- t1 262 | ---------------------------- 263 | A1 U A2 |- t2 264 | @ 265 | 266 | Fails with 'Left' in the following cases: 267 | 268 | * The conclusion of the first theorem is not an equation. 269 | 270 | * The conclusion term of the second theorem and the left hand side of the 271 | equation are not alpha-equivalent. 272 | -} 273 | primEQ_MP :: MonadThrow m => HOLThm -> HOLThm -> m HOLThm 274 | primEQ_MP th@(ThmIn as1 (l := r)) (ThmIn as2 c) 275 | | l `aConv` c = 276 | let as' = termUnion as1 as2 in 277 | return $! ThmIn as' r 278 | | otherwise = throwM $! HOLThmError th "primEQ_MP: terms do not agree" 279 | primEQ_MP th _ = throwM $! HOLThmError th "primEQ_MP: term is not an equation" 280 | 281 | {-|@ 282 | A |- p B |- q 283 | -------------------------------- 284 | (A - q) U (B - p) |- p \<=\> q 285 | @ 286 | 287 | Never fails. 288 | -} 289 | primDEDUCT_ANTISYM :: HOLThm -> HOLThm -> HOLThm 290 | primDEDUCT_ANTISYM (ThmIn as p) (ThmIn bs q) = 291 | let as' = termRemove q as `termUnion` termRemove p bs in 292 | ThmIn as' $ safeMkEq p q 293 | 294 | -- Instantiation Rules 295 | {-|@ 296 | [(ty1, tv1), ..., (tyn, tvn)] A |- t 297 | ---------------------------------------- 298 | A[ty1, ..., tyn/tv1, ..., tvn] 299 | |- t[ty1, ..., tyn/tv1, ..., tvn] 300 | @ 301 | 302 | Never fails. 303 | -} 304 | primINST_TYPE :: Inst a b => [(a, b)] -> HOLThm -> HOLThm 305 | primINST_TYPE tyenv (ThmIn as t) = 306 | let instFun = inst tyenv in 307 | ThmIn (termImage instFun as) $ instFun t 308 | 309 | -- | A version of 'primINST_TYPE' that instantiates a theorem via 'instFull'. 310 | primINST_TYPE_FULL :: SubstTrip -> HOLThm -> HOLThm 311 | primINST_TYPE_FULL tyenv (ThmIn as t) = 312 | let instFun = instFull tyenv in 313 | ThmIn (termImage instFun as) $ instFun t 314 | 315 | {-|@ 316 | [(t1, x1), ..., (tn, xn)] A |- t 317 | ------------------------------------ 318 | A[t1, ..., tn/x1, ..., xn] 319 | |- t[t1, ..., tn/x1, ..., xn] 320 | @ 321 | 322 | Fails with 'Nothing' in the case where a bad substitution list is provided. 323 | -} 324 | primINST :: MonadThrow m => HOLTermEnv -> HOLThm -> m HOLThm 325 | primINST env (ThmIn as t) = 326 | let instFun = varSubst env in 327 | do as' <- termImageM instFun as 328 | ThmIn as' `fmap` instFun t 329 | 330 | {- 331 | HOL2P Primitive Inference Rules 332 | -} 333 | 334 | -- Type Congruence rules 335 | 336 | {-|@ 337 | A |- t1 = t2 338 | ------------------------------- 339 | A |- (\\\\ x . t1) = (\\\\ x . t2) 340 | @ 341 | 342 | Fails with 'Left' in the following cases: 343 | 344 | * The type to bind is not a small type variable. 345 | 346 | * The conclusion of the theorem is not an equation. 347 | 348 | * The type to bind is free in the assumption list of the theorem. 349 | 350 | * The type variable to bind is free in the conclusion of the theorem. 351 | -} 352 | primTYABS :: MonadThrow m => HOLType -> HOLThm -> m HOLThm 353 | primTYABS tv@(TyVarIn True _) th@(ThmIn as (l := r)) 354 | | tv `notElem` typeVarsInTerms as = 355 | let fvs = frees l `union` frees r in 356 | if any (\ x -> tv `elem` tyVars (typeOf x)) fvs 357 | then throwM $! HOLThmError th 358 | "primTYABS: type variable is free in conclusion" 359 | else return . ThmIn as $ safeMkEq (TyAbsIn tv l) (TyAbsIn tv r) 360 | | otherwise = throwM $! HOLThmError th 361 | "primTYABS: type variable is free in assumptions" 362 | primTYABS (TyVarIn True _) th = throwM $! HOLThmError th 363 | "primTYABS: conclusion not an equation" 364 | primTYABS tv _ = throwM $! HOLTypeError tv 365 | "primTYABS: first argument not a small type variable" 366 | 367 | {-|@ 368 | A |- t1 = t2 369 | ------------------------------- 370 | A |- t1 [: ty1] = t2 [: ty2] 371 | @ 372 | 373 | Fails with 'Left' in the following cases: 374 | 375 | * The conclusion of the theorem is not an equation of terms of universal type. 376 | 377 | * The type arguments are not alpha-equivalent. 378 | 379 | * One, or both, of the type arguments is not small. 380 | -} 381 | primTYAPP2 :: MonadThrow m => HOLType -> HOLType -> HOLThm -> m HOLThm 382 | primTYAPP2 ty1 ty2 th@(ThmIn as (l := r)) 383 | | ty1 `tyAConv` ty2 = 384 | case typeOf l of 385 | UTypeIn{} 386 | | not $ isSmall ty1 -> 387 | throwM $! HOLTypeError ty1 "primTYAPP2: ty1 not small" 388 | | not $ isSmall ty2 -> 389 | throwM $! HOLTypeError ty2 "primTYAPP2: ty2 not small" 390 | | otherwise -> 391 | return . ThmIn as $ safeMkEq (TyCombIn l ty1) (TyCombIn r ty2) 392 | _ -> throwM $! HOLThmError th 393 | "primTYAPP2: terms not of universal type" 394 | | otherwise = throwM $! HOLTypeError ty1 395 | "primTYAPP2: type arguments not alpha-convertible" 396 | primTYAPP2 _ _ th = throwM $! HOLThmError th 397 | "primTYAPP2: conclusion not an equation" 398 | 399 | {-|@ 400 | A |- t1 = t2 401 | ---------------------------- 402 | A |- t1 [: ty] = t2 [: ty] 403 | @ 404 | 405 | Fails with 'Nothing' if the conclusion of the theorem is not an equation. 406 | 407 | Note that 'primTYAPP' is equivalent to 'primTYAPP2' when the same type is 408 | applied to both sides, i.e. 409 | 410 | @ primTYAPP ty === primTYAPP2 ty ty @ 411 | -} 412 | primTYAPP :: MonadThrow m => HOLType -> HOLThm -> m HOLThm 413 | primTYAPP ty thm@(ThmIn _ (_ := _)) = primTYAPP2 ty ty thm 414 | primTYAPP _ th = throwM $! HOLThmError th "primTYAPP" 415 | 416 | -- Type Beta Reduction 417 | 418 | {-|@ 419 | (\\\\ ty . t[ty]) [: ty] 420 | --------------------------------- 421 | |- (\\\\ ty . t[ty]) [: ty] = t 422 | @ 423 | 424 | Fails with 'Left' in the following cases: 425 | 426 | * The term is not a valid type application. 427 | 428 | * The reduction is not a trivial one, i.e. the argument type is not equivalent 429 | to the bound type variable. 430 | -} 431 | primTYBETA :: MonadThrow m => HOLTerm -> m HOLThm 432 | primTYBETA tm@(TyCombIn (TyAbsIn tv bod) argt) 433 | | argt == tv = 434 | return . ThmIn [] $ safeMkEq tm bod 435 | | otherwise = throwM $! HOLTermError tm 436 | "primTYBETA: not a trivial type beta reduction" 437 | primTYBETA tm = throwM $! HOLTermError tm 438 | "primTYBETA: not a valid type application" 439 | 440 | {- 441 | Stateless HOL Theory Extension Primitives 442 | Note that the following primitives are in HaskHOL.Core.State as per 443 | Stateless HOL: 444 | axioms, newAxiom, newBasicDefinition, newBasicTypeDefinition 445 | -} 446 | 447 | {-| 448 | Creates a new axiom theorem. 449 | 450 | Note that, as discussed in the documentation for 'HOLThm', the introduction of 451 | axioms is not tracked until the stateful layer of the system is introduced so 452 | be careful using this function. 453 | -} 454 | axiomThm :: HOLTerm -> HOLThm 455 | axiomThm = ThmIn [] 456 | 457 | {-|@ 458 | c = t 459 | ----------- 460 | |- c = t 461 | @ 462 | 463 | Creates a new defined constant given a term that equates a variable of the 464 | desired constant name and type to its desired definition. The return value 465 | is a pair of the new constant and its definitional theorem. 466 | 467 | Note that internally the constant is tagged with its definitional term via the 468 | @Defined@ 'ConstTag'. 469 | 470 | Fails with 'Left' in the following cases: 471 | 472 | * The provided term is not an equation. 473 | 474 | * The provided term is not closed. 475 | 476 | * There are free type variables present in the definition that are not also in 477 | the desired type of the constant. 478 | -} 479 | newDefinedConst :: MonadThrow m => HOLTerm -> m (HOLTerm, HOLThm) 480 | newDefinedConst tm@(VarIn cname ty := r) 481 | | not $ freesIn [] r = 482 | throwM $! HOLTermError tm "newDefinedConst: not closed" 483 | | not $ typeVarsInTerm r `subset` tyVars ty = 484 | throwM $! HOLTermError tm 485 | "newDefinedConst: type vars not refelcted in const" 486 | | otherwise = 487 | let c = ConstIn cname ty (DefinedIn $ hash r) 488 | dth = ThmIn [] $ safeMkEq c r in 489 | return (c, dth) 490 | newDefinedConst tm = throwM $! HOLTermError tm 491 | "newDefinedConst: not an equation" 492 | 493 | {-|@ 494 | |- p x:rep 495 | ----------------------------------------------------------------- 496 | (|- mk:rep->ty (dest:ty->rep a) = a, |- P r \<=\> dest(mk r) = r) 497 | @ 498 | 499 | Creates a new defined type constant that is defined as an inhabited subset 500 | of an existing type constant. The return value is a pentuple that 501 | collectively provides a bijection between the new type and the old type. 502 | 503 | The following four items are taken as input: 504 | 505 | * The name of the new type constant - @ty@ in the above sequent. 506 | 507 | * The name of the new term constant that will be used to make an instance of 508 | the new type - @mk@ in the above sequent. 509 | 510 | * The name of the new term constant that will be used to destruct an instance 511 | of the new type - @dest@ in the above sequent. 512 | 513 | * A theorem proving that the desired subset is non-empty. The conclusion of 514 | this theorem must take the form @p x@ where @p@ is the predicate that 515 | defines the subset and @x@ is a witness to inhabitation. 516 | 517 | The following items are returned as part of the resultant pentuple: 518 | 519 | * The new defined type operator. These type operators carry their name, 520 | arity, and definitional theorem. The arity, in this case, is inferred from 521 | the number of free type variables found in the predicate of the definitional 522 | theorem. 523 | 524 | * The new term constants, @mk@ and @dest@, as described above. Note that 525 | constants constructed in this manner are tagged with special instances of 526 | 'ConstTag', @MkAbstract@ and @DestAbstract@ accordingly, that carry the 527 | name, arity, and definitional theorem of their related type constant. 528 | 529 | * The two theorems proving the bijection, as shown in the sequent above. 530 | -} 531 | newDefinedTypeOp :: MonadThrow m => Text -> Text -> Text -> HOLThm -> 532 | m (TypeOp, HOLTerm, HOLTerm, HOLThm, HOLThm) 533 | newDefinedTypeOp tyname absname repname th@(ThmIn [] c@(CombIn p x)) 534 | | containsUType $ typeOf x = throwM $! HOLThmError th 535 | "newDefinedTypeOp: must not contain universal types" 536 | | not $ freesIn [] p = throwM $! HOLThmError th 537 | "newDefinedTypeOp: predicate is not closed" 538 | | otherwise = 539 | let tys = sort (<=) $ typeVarsInTerm p 540 | arity = length tys 541 | hsh = hash c 542 | atyop = TyDefinedIn tyname arity hsh 543 | rty = typeOf x 544 | aty = TyAppIn atyop tys 545 | atm = VarIn "a" aty 546 | rtm = VarIn "r" rty 547 | absCon = ConstIn absname (TyAppIn tyOpFun [rty, aty]) $ 548 | MkAbstractIn tyname arity hsh 549 | repCon = ConstIn repname (TyAppIn tyOpFun [aty, rty]) $ 550 | DestAbstractIn tyname arity hsh 551 | c1 = CombIn absCon $ CombIn repCon atm 552 | c2 = CombIn p rtm 553 | c3 = CombIn repCon $ CombIn absCon rtm in 554 | return (atyop, absCon, repCon, 555 | ThmIn [] $ safeMkEq c1 atm, 556 | ThmIn [] . safeMkEq c2 $ safeMkEq c3 rtm) 557 | newDefinedTypeOp _ _ _ th = throwM $! HOLThmError th 558 | "newDefinedTypeOp: poorly formed predicate" 559 | 560 | 561 | -- Documentation copied from HaskHOL.Core.Prims 562 | 563 | {-$ViewPatterns 564 | The primitive data types of HaskHOL are implemented using pattern synonyms in 565 | order to simulate private data types: 566 | 567 | * Internal constructors are hidden to prevent manual construction of terms. 568 | 569 | * Unideriectional pattern synonyms ('Thm', etc.) are exposed to enable 570 | pattern matching. 571 | -} 572 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Kernel/Prims.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveLift, GADTs, 2 | PatternSynonyms, StandaloneDeriving, TemplateHaskell #-} 3 | 4 | {-| 5 | Module: HaskHOL.Core.Kernel.Prims 6 | Copyright: (c) Evan Austin 2015 7 | LICENSE: BSD3 8 | 9 | Maintainer: e.c.austin@gmail.com 10 | Stability: unstable 11 | Portability: unknown 12 | 13 | This module defines the primitive data types for HaskHOL: 14 | 'HOLType', 'HOLTerm', and 'HOLThm'. 15 | 16 | Note: This module is intended to be hidden by cabal to prevent manual, and 17 | possibly unsound, construction of the primitive data types. 18 | 19 | To include the contents of this module with the appropriate restrictions in 20 | place, along with the entirey of the core system, import the "HaskHOL.Core" 21 | module. Alternatively, the following modules also export individual 22 | primitive types with their associated restrictions: 23 | * "HaskHOL.Core.Types" - Exports types 24 | * "HaskHOL.Core.Terms" - Exports terms 25 | * "HaskHOL.Core.Kernel" - Exports theorems 26 | -} 27 | 28 | module HaskHOL.Core.Kernel.Prims 29 | ( -- * HOL types 30 | HOLType(..) 31 | , pattern TyVar 32 | , pattern TyApp 33 | , pattern UType 34 | , TypeOp(..) 35 | , pattern TyOpVar 36 | , pattern TyPrimitive 37 | , pattern TyDefined 38 | , HOLTypeEnv 39 | , SubstTrip 40 | -- * HOL terms 41 | , HOLTerm(..) 42 | , pattern Var 43 | , pattern Const 44 | , pattern Comb 45 | , pattern Abs 46 | , pattern TyComb 47 | , pattern TyAbs 48 | , ConstTag(..) 49 | , pattern Primitive 50 | , pattern Defined 51 | , pattern MkAbstract 52 | , pattern DestAbstract 53 | , HOLTermEnv 54 | -- * HOL theorems 55 | , HOLThm(..) 56 | , pattern Thm 57 | -- Primitive Error Types 58 | , HOLPrimError(..) 59 | ) where 60 | 61 | import Control.DeepSeq (NFData, rnf) 62 | import Control.Monad.Catch (Exception) 63 | 64 | import Data.Hashable 65 | import Data.SafeCopy (deriveSafeCopy, base) 66 | import Data.Text.Lazy (Text) 67 | 68 | import GHC.Generics 69 | 70 | import Instances.TH.Lift () 71 | import Language.Haskell.TH.Syntax 72 | 73 | {- 74 | A quick note on how the primitive data types of HaskHOL are implemented -- 75 | unidirectional pattern synonyms are used to simulate private data types for 76 | HOL types, terms, and theorems. 77 | -} 78 | 79 | {- 80 | The following data types combined provide the definition of HOL types in 81 | HaskHOL. 82 | 83 | The primary data type, 'HOLType', follows closely from the 84 | simply typed lambda calculus approach used in John Harrison's HOL Light 85 | system. 86 | 87 | There are two principle changes to Harrison's implementation: 88 | 1. Type operators have been introduced, via the 'TypeOp' data type, to 89 | facilitate a semi-stateless logical kernel following from Freek Wiedijk's 90 | Stateless HOL system. 91 | 92 | 2. Universal types and type operator variables have been introduced to move 93 | the logic from simply typed to polymorphic following from Norbert 94 | Voelker's HOL2P system. 95 | -} 96 | {-| 97 | The 'HOLType' data type defines the internal constructors for HOL types in 98 | HaskHOL. 99 | -} 100 | data HOLType 101 | = TyVarIn !Bool !Text 102 | | TyAppIn !TypeOp ![HOLType] 103 | | UTypeIn !HOLType !HOLType 104 | deriving (Eq, Ord, Generic, Lift) 105 | 106 | instance Hashable HOLType 107 | 108 | -- | A type variable consisting of a constraint flag and name. 109 | pattern TyVar :: Bool -> Text -> HOLType 110 | pattern TyVar b s <- TyVarIn b s 111 | 112 | {-| 113 | A type application consisting of a type operator and a list of type 114 | arguments. See 'TypeOp' for more details. 115 | -} 116 | pattern TyApp :: TypeOp -> [HOLType] -> HOLType 117 | pattern TyApp op tys <- TyAppIn op tys 118 | {-| 119 | A universal type consisting of a bound type and a body type. Note that 120 | the bound type must be a small, type variable. 121 | -} 122 | pattern UType :: HOLType -> HOLType -> HOLType 123 | pattern UType tv bod <- UTypeIn tv bod 124 | 125 | {-| 126 | The data type for type operators, 'TypeOp', is a mashing together of the 127 | representation of type operators from both both HOL2P and Stateless HOL. 128 | For more information regarding construction of the different operators, see 129 | the documentation of the following functions: 'mkTypeOpVar', 130 | 'newPrimitiveTypeOp', and 'newDefinedTypeOp' 131 | -} 132 | data TypeOp 133 | = TyOpVarIn !Text 134 | | TyPrimitiveIn !Text !Int 135 | | TyDefinedIn !Text !Int !Int -- Hash of concl of thm 136 | deriving (Eq, Ord, Generic, Lift) 137 | 138 | instance Hashable TypeOp 139 | 140 | -- | A type operator variable consisting of a name. 141 | pattern TyOpVar :: Text -> TypeOp 142 | pattern TyOpVar s <- TyOpVarIn s 143 | 144 | -- | A type operator primitive consisting of a name and arity. 145 | pattern TyPrimitive :: Text -> Int -> TypeOp 146 | pattern TyPrimitive s n <- TyPrimitiveIn s n 147 | 148 | -- | A defined type operator consisting of a name and arity. 149 | pattern TyDefined :: Text -> Int -> TypeOp 150 | pattern TyDefined s n <- TyDefinedIn s n _ 151 | 152 | {- 153 | In order to keep HaskHOL's type system decidable, we follow the same 154 | \"smallness\" constraint used by HOL2P: type variables that are constrained 155 | to be small cannot be replaced with types that contain either universal types 156 | or unconstrained type variables. This constraint, in addition to the 157 | restriction that universal types can only bind small type variables, prevents 158 | the system from performing a substitution that would result in a higher rank 159 | type than the system is capable of dealing with. This effectively limits the 160 | type system to 2nd order polymorphism. 161 | 162 | Voelker elected to rely on syntactic distinction to differentiate between the 163 | many kinds of type variables (small, unconstrained, and operator); depending 164 | on how it was to be used, the name of a variable was prepended with a special 165 | symbol. Internal to HaskHOL, we elected to replace these syntactic 166 | distinctions with structural ones such that the following hold true: 167 | 168 | * @TyVarIn True \"x\"@ represents the small type variable @\'x@ 169 | 170 | * @TyVarIn False \"x\"@ represents the unconstrainted type variable @x@ 171 | 172 | * @TyOpVar "x"@ represents the type operator variable @_x@ 173 | 174 | Note that external to HaskHOL, during I/O of terms, both the parser and 175 | pretty-printer still rely on the syntactic distinctions introduced by 176 | Voelker. 177 | -} 178 | 179 | -- | Type synonym for the commonly used, list-based, type environment. 180 | type HOLTypeEnv = [(HOLType, HOLType)] 181 | 182 | {-| 183 | Type synonym for the commonly used triplet of substitution environments. 184 | See 'TypeSubst' for more information. 185 | -} 186 | type SubstTrip = (HOLTypeEnv, [(TypeOp, HOLType)], [(TypeOp, TypeOp)]) 187 | 188 | instance Show TypeOp where 189 | show (TyOpVarIn s) = '_' : show s 190 | show (TyPrimitiveIn s _) = show s 191 | show (TyDefinedIn s _ _) = show s 192 | 193 | {- 194 | The following data types combined provide the definition of HOL terms in 195 | HaskHOL. 196 | 197 | Corresponding with the 'HOLType' data type, 'HOLTerm' follows closely from 198 | the definition of terms in HOL Light. Again, the appropriate modifications 199 | have been made to facilitate a stateless and polymorphic term language. 200 | 201 | Most notably this includes: 202 | (1) The introduction of tags for constants to carry information formerly 203 | contained in the state. 204 | 205 | 2. Additional constructors have been added to 'HOLTerm' to facilitate 206 | term-level, type abstractions and applications. 207 | -} 208 | 209 | {-| 210 | The 'HOLTerm' data type defines the internal constructors for HOL terms in 211 | HaskHOL. For more details, see the documentation for its view pattern data 212 | type, 'HOLTermView'. 213 | -} 214 | data HOLTerm 215 | = VarIn !Text !HOLType 216 | | ConstIn !Text !HOLType !ConstTag 217 | | CombIn !HOLTerm !HOLTerm 218 | | AbsIn !HOLTerm !HOLTerm 219 | | TyCombIn !HOLTerm !HOLType 220 | | TyAbsIn !HOLType !HOLTerm 221 | deriving (Eq, Ord, Generic, Lift) 222 | 223 | instance Hashable HOLTerm 224 | 225 | -- | A term variable consisting of a name and type. 226 | pattern Var :: Text -> HOLType -> HOLTerm 227 | pattern Var s ty <- VarIn s ty 228 | 229 | {-| 230 | A term constant consisting of a name, type, and tag. See 'ConstTag' for 231 | more information. 232 | -} 233 | pattern Const :: Text -> HOLType -> HOLTerm 234 | pattern Const s ty <- ConstIn s ty _ 235 | 236 | -- | A term application consisting of a function term and argument term. 237 | pattern Comb :: HOLTerm -> HOLTerm -> HOLTerm 238 | pattern Comb l r <- CombIn l r 239 | 240 | {-| 241 | A term abstraction consisting of a bound term and a body term. Note that 242 | the bound term must be a type variable. 243 | -} 244 | pattern Abs :: HOLTerm -> HOLTerm -> HOLTerm 245 | pattern Abs bv bod <- AbsIn bv bod 246 | 247 | {-| 248 | A term-level, type application consisting of a body term and an argument 249 | type. Note that the body term must have a universal type. 250 | -} 251 | pattern TyComb :: HOLTerm -> HOLType -> HOLTerm 252 | pattern TyComb tm ty <- TyCombIn tm ty 253 | 254 | {-| 255 | A term-level, type abstraction consisting of a bound type and a body term. 256 | Note that the bound type must be a small, type variable. 257 | -} 258 | pattern TyAbs :: HOLType -> HOLTerm -> HOLTerm 259 | pattern TyAbs ty tm <- TyAbsIn ty tm 260 | 261 | {-| 262 | The data type for constant tags, 'ConstTag', follows identically from the 263 | implementation in Stateless HOL. For more information regarding construction 264 | of the different tags, see the documentation of the following functions: 265 | 'newPrimitiveConst', 'newDefinedConst', and 'newDefinedTypeOp'. 266 | -} 267 | data ConstTag 268 | = PrimitiveIn 269 | | DefinedIn !Int -- hash 270 | | MkAbstractIn !Text !Int !Int -- name, arity, hash 271 | | DestAbstractIn !Text !Int !Int -- name, arity, hash 272 | deriving (Eq, Ord, Generic, Lift) 273 | 274 | instance Hashable ConstTag 275 | 276 | -- | A primitive constant tag. 277 | pattern Primitive :: ConstTag 278 | pattern Primitive <- PrimitiveIn 279 | 280 | -- | A defined constant tag. 281 | pattern Defined :: ConstTag 282 | pattern Defined <- DefinedIn _ 283 | 284 | {-| A defined constant tag for type construction consisting of a name and 285 | arity. 286 | -} 287 | pattern MkAbstract :: Text -> Int -> ConstTag 288 | pattern MkAbstract s n <- MkAbstractIn s n _ 289 | 290 | {-| A defined constant tag for type destruction consisting of a name and 291 | arity. 292 | -} 293 | pattern DestAbstract :: Text -> Int -> ConstTag 294 | pattern DestAbstract s n <- DestAbstractIn s n _ 295 | 296 | instance Show ConstTag where 297 | show PrimitiveIn = "Prim" 298 | show (DefinedIn _) = "Defined" 299 | show (MkAbstractIn s _ _) = "Mk__" ++ show s 300 | show (DestAbstractIn s _ _) = "Dest__" ++ show s 301 | 302 | -- | Type synonym for the commonly used, list-based, term environment. 303 | type HOLTermEnv = [(HOLTerm, HOLTerm)] 304 | 305 | {-| 306 | The 'HOLThm' data type defines HOL Theorems in HaskHOL. A theorem is defined 307 | simply as a list of assumption terms and a conclusion term. 308 | 309 | Note that this representation, in combination with a stateless 310 | approach, means that the introduction of axioms is not tracked in the kernel. 311 | Axioms can be tracked once the stateful layer of the prover is introduced, 312 | though. For more details see the documentation for `newAxiom`. 313 | -} 314 | data HOLThm = ThmIn ![HOLTerm] !HOLTerm deriving (Eq, Ord, Generic, Lift) 315 | 316 | instance Hashable HOLThm 317 | 318 | -- | The pattern synonym for HOL theorems. 319 | pattern Thm :: [HOLTerm] -> HOLTerm -> HOLThm 320 | pattern Thm as c <- ThmIn as c 321 | 322 | -- Error types 323 | -- | HaskHOL's primitive exception type. 324 | data HOLPrimError where 325 | HOLTypeOpError :: TypeOp -> String -> HOLPrimError 326 | HOLTypeError :: HOLType -> String -> HOLPrimError 327 | HOLTermError :: HOLTerm -> String -> HOLPrimError 328 | HOLThmError :: HOLThm -> String -> HOLPrimError 329 | HOLMiscError :: Show a => a -> String -> HOLPrimError 330 | HOLErrorMsg :: String -> HOLPrimError 331 | HOLExhaustiveWarning :: String -> HOLPrimError 332 | HOLMZero :: HOLPrimError 333 | 334 | instance Show HOLPrimError where 335 | show (HOLTypeOpError _ str) = str 336 | show (HOLTypeError _ str) = str 337 | show (HOLTermError _ str) = str 338 | show (HOLThmError _ str) = str 339 | show (HOLMiscError x str) = str ++ "<* witness - " ++ show x ++ " *>" 340 | show (HOLErrorMsg str) = str 341 | show (HOLExhaustiveWarning str) = 342 | "<* exhaustive case warning - " ++ str ++ " *>" 343 | show HOLMZero = "<* mzero *>" 344 | 345 | instance Exception HOLPrimError 346 | 347 | {- 348 | Deepseq instances for the primitive data types. These are included as they 349 | are commonly used by a number of benchmarking libraries. 350 | -} 351 | instance NFData HOLType where 352 | rnf (TyVarIn b s) = rnf b `seq` rnf s 353 | rnf (TyAppIn s tys) = rnf s `seq` rnf tys 354 | rnf (UTypeIn tv tb) = rnf tv `seq` rnf tb 355 | 356 | instance NFData TypeOp where 357 | rnf (TyOpVarIn s) = rnf s 358 | rnf (TyPrimitiveIn s n) = rnf s `seq` rnf n 359 | rnf (TyDefinedIn s n h) = rnf s `seq` rnf n `seq` rnf h 360 | 361 | instance NFData HOLTerm where 362 | rnf (VarIn s ty) = rnf s `seq` rnf ty 363 | rnf (ConstIn s ty tag) = rnf s `seq` rnf ty `seq` rnf tag 364 | rnf (CombIn l r) = rnf l `seq` rnf r 365 | rnf (AbsIn bv bod) = rnf bv `seq` rnf bod 366 | rnf (TyAbsIn bty bod) = rnf bty `seq` rnf bod 367 | rnf (TyCombIn tm ty) = rnf tm `seq` rnf ty 368 | 369 | instance NFData ConstTag where 370 | rnf PrimitiveIn = () 371 | rnf (DefinedIn h) = rnf h 372 | rnf (MkAbstractIn s i h) = rnf s `seq` rnf i `seq` rnf h 373 | rnf (DestAbstractIn s i h) = rnf s `seq` rnf i `seq` rnf h 374 | 375 | instance NFData HOLThm where 376 | rnf (ThmIn asl c) = rnf asl `seq` rnf c 377 | 378 | deriveSafeCopy 0 'base ''TypeOp 379 | deriveSafeCopy 0 'base ''HOLType 380 | deriveSafeCopy 0 'base ''ConstTag 381 | deriveSafeCopy 0 'base ''HOLTerm 382 | deriveSafeCopy 0 'base ''HOLThm 383 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Kernel/Terms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, PatternSynonyms #-} 2 | {-| 3 | Module: HaskHOL.Core.Kernel.Terms 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module exports a safe view of HOL terms for HaskHOL. It also defines 12 | the primitive functions related to terms. For clarity, these functions have 13 | been seperated based on their influential system: HOL Light, Stateless HOL, 14 | and HOL2P. 15 | 16 | Note that, per the stateless approach, any stateful, but still primitive, 17 | functions related to terms have been relocated to the "HaskHOL.Core.State" 18 | module. 19 | -} 20 | module HaskHOL.Core.Kernel.Terms 21 | ( -- * A View of HOL Terms 22 | -- ** A Quick Note on View Patterns 23 | -- $ViewPatterns 24 | -- ** A High-Level Overview of HOL Terms 25 | -- $HOLTerms 26 | HOLTerm 27 | , pattern Var 28 | , pattern Const 29 | , pattern Comb 30 | , pattern Abs 31 | , pattern TyComb 32 | , pattern TyAbs 33 | , ConstTag 34 | , pattern Primitive 35 | , pattern Defined 36 | , pattern MkAbstract 37 | , pattern DestAbstract 38 | , HOLTermEnv 39 | -- * HOL Light Term Primitives 40 | -- ** Alpha-Equivalence of Terms 41 | , alphaOrder 42 | , aConv 43 | -- ** Predicates, Constructors, and Destructors for Basic Terms 44 | , isVar 45 | , isConst 46 | , isAbs 47 | , isComb 48 | , mkVar 49 | , mkAbs 50 | , mkComb 51 | , destVar 52 | , destConst 53 | , destComb 54 | , destAbs 55 | -- ** Term and Type Variable Extractors 56 | , frees 57 | , catFrees 58 | , freesIn 59 | , varFreeIn 60 | , typeVarsInTerm 61 | , typeVarsInTerms 62 | -- ** Term Substitution and Instantiation 63 | , varSubst 64 | , Inst 65 | , inst 66 | , instFull 67 | , instConst 68 | , instConstFull 69 | -- ** Commonly Used Terms and Functions 70 | , tmEq 71 | , pattern TmEq 72 | , pattern (:=) 73 | , isEq 74 | , primMkEq 75 | , destEq 76 | , variant 77 | , variants 78 | -- * Stateless HOL Term Primitives 79 | -- ** Constructors for Constant Tags 80 | , newPrimitiveConst 81 | -- ** Type Operator Variable Extractors 82 | , typeOpVarsInTerm 83 | , typeOpVarsInTerms 84 | -- * HOL2P Term Primitives 85 | -- ** Predicates, Constructors, and Destructors for Term-Level Types 86 | , isTyAbs 87 | , isTyComb 88 | , mkTyAbs 89 | , mkTyComb 90 | , destTyAbs 91 | , destTyComb 92 | , initTermConstants 93 | ) where 94 | 95 | import HaskHOL.Core.Lib 96 | import HaskHOL.Core.Kernel.Prims 97 | import HaskHOL.Core.Kernel.Types 98 | 99 | {- 100 | HOL Light Term Primitives 101 | Note that the following primitives are in HaskHOL.Core.State as per 102 | Stateless HOL: 103 | constants, getConstType, newConstant, mkConst, mkEq 104 | -} 105 | -- | Provides an ordering for two terms modulo alpha-equivalence 106 | alphaOrder :: HOLTerm -> HOLTerm -> Ordering 107 | alphaOrder = orda [] 108 | where orda :: [(HOLTerm, HOLTerm)] -> HOLTerm -> HOLTerm -> Ordering 109 | orda env tm1@VarIn{} tm2@VarIn{} = ordav env tm1 tm2 110 | orda _ tm1@ConstIn{} tm2@ConstIn{} = tm1 `aorder` tm2 111 | orda env (CombIn s1 t1) (CombIn s2 t2) = 112 | case orda env s1 s2 of 113 | EQ -> orda env t1 t2 114 | res -> res 115 | orda env (AbsIn x1@(VarIn _ ty1) t1) 116 | (AbsIn x2@(VarIn _ ty2) t2) = 117 | case tyAlphaOrder ty1 ty2 of 118 | EQ -> orda ((x1, x2):env) t1 t2 119 | res -> res 120 | orda _ tm1@AbsIn{} tm2@AbsIn{} = compare tm1 tm2 121 | orda env (TyAbsIn tv1@(TyVarIn True _) tb1) 122 | (TyAbsIn tv2@(TyVarIn True _) tb2) = 123 | let tb2' = inst [(tv2, tv1)] tb2 in 124 | orda env tb1 tb2' 125 | orda _ tm1@TyAbsIn{} tm2@TyAbsIn{} = compare tm1 tm2 126 | orda env (TyCombIn t1 ty1) (TyCombIn t2 ty2) = 127 | case orda env t1 t2 of 128 | EQ -> tyAlphaOrder ty1 ty2 129 | res -> res 130 | orda _ ConstIn{} _ = LT 131 | orda _ _ ConstIn{} = GT 132 | orda _ VarIn{} _ = LT 133 | orda _ _ VarIn{} = GT 134 | orda _ CombIn{} _ = LT 135 | orda _ _ CombIn{} = GT 136 | orda _ AbsIn{} _ = LT 137 | orda _ _ AbsIn{} = GT 138 | orda _ TyAbsIn{} _ = LT 139 | orda _ _ TyAbsIn{} = GT 140 | 141 | ordav :: [(HOLTerm, HOLTerm)] -> HOLTerm -> HOLTerm -> Ordering 142 | ordav [] x1 x2 = x1 `aorder` x2 143 | ordav ((l, r):oenv) x1 x2 144 | | x1 == l = if x2 == r then EQ else LT 145 | | otherwise = if x2 == r then GT else ordav oenv x1 x2 146 | 147 | aorder :: HOLTerm -> HOLTerm -> Ordering 148 | aorder (VarIn s1 ty1) (VarIn s2 ty2) = 149 | case compare s1 s2 of 150 | EQ -> tyAlphaOrder ty1 ty2 151 | res -> res 152 | aorder (ConstIn s1 ty1 tag1) (ConstIn s2 ty2 tag2) = 153 | case compare s1 s2 of 154 | EQ -> case compare tag1 tag2 of 155 | EQ -> tyAlphaOrder ty1 ty2 156 | res -> res 157 | res -> res 158 | aorder x y = compare x y 159 | 160 | -- | Tests if two terms are alpha-equivalent 161 | aConv :: HOLTerm -> HOLTerm -> Bool 162 | aConv tm1 tm2 = alphaOrder tm1 tm2 == EQ 163 | 164 | -- | Predicate for term variables. 165 | isVar :: HOLTerm -> Bool 166 | isVar VarIn{} = True 167 | isVar _ = False 168 | 169 | -- | Predicate for term constants. 170 | isConst :: HOLTerm -> Bool 171 | isConst ConstIn{} = True 172 | isConst _ = False 173 | 174 | -- | Predicate for term abstractions. 175 | isAbs :: HOLTerm -> Bool 176 | isAbs AbsIn{} = True 177 | isAbs _ = False 178 | 179 | -- | Predicate for term combinations. 180 | isComb :: HOLTerm -> Bool 181 | isComb CombIn{} = True 182 | isComb _ = False 183 | 184 | -- | Constructs a term variable of a given name and type. 185 | mkVar :: Text -> HOLType -> HOLTerm 186 | mkVar = VarIn 187 | 188 | {-| 189 | Constructs a term abstraction of a given bound term and body term. 190 | Fails if the bound term is not a variable. 191 | -} 192 | mkAbs :: MonadThrow m => HOLTerm -> HOLTerm -> m HOLTerm 193 | mkAbs bv@VarIn{} bod = return $! AbsIn bv bod 194 | mkAbs bv _ = throwM $! HOLTermError bv "mkAbs" 195 | 196 | {-| 197 | Constructs a combination of two given terms. Fails with 'Left' in the 198 | following cases: 199 | 200 | * The first term does not have a function type. 201 | 202 | * The types of the two terms does not agree. 203 | -} 204 | mkComb :: MonadThrow m => HOLTerm -> HOLTerm -> m HOLTerm 205 | mkComb f a = 206 | case typeOf f of 207 | (TyAppIn (TyPrimitiveIn "fun" _) (ty:_)) -> 208 | if typeOf a `tyAConv` ty 209 | then return $! CombIn f a 210 | else throwM $! HOLTermError a "mkComb: argument type mismatch." 211 | _ -> throwM $! HOLTermError f "mkComb: argument not of function type." 212 | 213 | {-| 214 | Destructs a term variable, returning its name and type. Fails with 'Nothing' 215 | if the provided term is not a variable. 216 | -} 217 | destVar :: MonadThrow m => HOLTerm -> m (Text, HOLType) 218 | destVar (VarIn s ty) = return (s, ty) 219 | destVar tm = throwM $! HOLTermError tm "destVar" 220 | 221 | {-| 222 | Destructs a term constant, returning its name and type. Note that no constant 223 | tag information is returned. Fails with 'Nothing' if the provided term is 224 | not a constant. 225 | -} 226 | destConst :: MonadThrow m => HOLTerm -> m (Text, HOLType) 227 | destConst (ConstIn s ty _) = return (s, ty) 228 | destConst tm = throwM $! HOLTermError tm "destConst" 229 | 230 | {-| 231 | Destructs a term combination, returning its function and argument terms. 232 | Fails with 'Nothing' if the provided term is not a combination. 233 | -} 234 | destComb :: MonadThrow m => HOLTerm -> m (HOLTerm, HOLTerm) 235 | destComb (CombIn f x) = return (f, x) 236 | destComb tm = throwM $! HOLTermError tm "destComb" 237 | 238 | {-| 239 | Destructs a term abstraction, returning its bound term and body term. Fails 240 | with 'Nothing' if the provided term is not an abstraction. 241 | -} 242 | destAbs :: MonadThrow m => HOLTerm -> m (HOLTerm, HOLTerm) 243 | destAbs (AbsIn v b) = return (v, b) 244 | destAbs tm = throwM $! HOLTermError tm "destAbs" 245 | 246 | -- | Returns a list of all free, term variables in a term. 247 | frees :: HOLTerm -> [HOLTerm] 248 | frees ConstIn{} = [] 249 | frees (AbsIn bv bod) = frees bod \\ [bv] 250 | frees (CombIn s t) = frees s `union` frees t 251 | frees (TyAbsIn _ t) = frees t 252 | frees (TyCombIn t _) = frees t 253 | frees t@VarIn{} = [t] 254 | 255 | -- | Returns a list of all free, term variables in a list of terms. 256 | catFrees :: [HOLTerm] -> [HOLTerm] 257 | catFrees = foldr (union . frees) [] 258 | 259 | -- | Checks a list of term variables to see if they are all free in a give term. 260 | freesIn :: [HOLTerm] -> HOLTerm -> Bool 261 | freesIn _ ConstIn{} = True 262 | freesIn acc (AbsIn bv bod) = freesIn (bv:acc) bod 263 | freesIn acc (CombIn s t) = freesIn acc s && freesIn acc t 264 | freesIn acc (TyAbsIn _ t) = freesIn acc t 265 | freesIn acc (TyCombIn t _) = freesIn acc t 266 | freesIn acc t@VarIn{} = t `elem` acc 267 | 268 | -- | Checks if a variable or constant term is free in a given term. 269 | varFreeIn :: HOLTerm -> HOLTerm -> Bool 270 | varFreeIn v (AbsIn bv bod) = v /= bv && varFreeIn v bod 271 | varFreeIn v (CombIn s t) = varFreeIn v s || varFreeIn v t 272 | varFreeIn v (TyAbsIn _ t) = varFreeIn v t 273 | varFreeIn v (TyCombIn t _) = varFreeIn v t 274 | varFreeIn v tm = v == tm 275 | 276 | {-| 277 | Returns a list of all free, type variables in a term, not including 278 | type operator variables. 279 | -} 280 | typeVarsInTerm :: HOLTerm -> [HOLType] 281 | typeVarsInTerm (VarIn _ ty) = tyVars ty 282 | typeVarsInTerm (ConstIn _ ty _) = tyVars ty 283 | typeVarsInTerm (CombIn s t) = 284 | typeVarsInTerm s `union` typeVarsInTerm t 285 | typeVarsInTerm (AbsIn bv t) = 286 | typeVarsInTerm bv `union` typeVarsInTerm t 287 | typeVarsInTerm (TyAbsIn tv tm) = 288 | typeVarsInTerm tm \\ [tv] 289 | typeVarsInTerm (TyCombIn tm ty) = 290 | typeVarsInTerm tm `union` tyVars ty 291 | 292 | {-| 293 | Returns a list of all free, type variables in a list of terms, not including 294 | type operator variables. 295 | -} 296 | typeVarsInTerms :: [HOLTerm] -> [HOLType] 297 | typeVarsInTerms = 298 | foldr (\ tm tvs -> typeVarsInTerm tm `union` tvs) [] 299 | 300 | {-| 301 | Performs a basic term substitution using a substitution environment containing 302 | pairs of term variables and terms. 303 | Note that the substitution environment is treated as an association list, such 304 | that: 305 | 306 | * The term variable acts as an index in the list, i.e. the substitution pair 307 | @(A, \\ x.x)@ indicates that the lambda term @\\x.x@ should be substituted 308 | for the term variable @A@. 309 | 310 | Substitution fails with 'Nothing' in the case where a bad substitution list is 311 | presented. 312 | -} 313 | varSubst :: MonadThrow m => HOLTermEnv -> HOLTerm -> m HOLTerm 314 | varSubst [] term = return term 315 | varSubst theta term 316 | | all validPair theta = varSubstRec theta term 317 | | otherwise = throwM $! HOLTermError term "varSubst" 318 | where validPair :: (HOLTerm, HOLTerm) -> Bool 319 | validPair (VarIn _ ty, t) = ty `tyAConv` typeOf t 320 | validPair _ = False 321 | 322 | varSubstRec :: MonadThrow m => HOLTermEnv -> HOLTerm -> m HOLTerm 323 | varSubstRec _ tm@ConstIn{} = return tm 324 | varSubstRec env (CombIn s t) = 325 | do s' <- varSubstRec env s 326 | mkComb s' =<< varSubstRec env t 327 | varSubstRec env tm@(AbsIn v s) = 328 | let env' = filter (\ (x, _) -> x /= v) env in 329 | if null env' then return tm 330 | else do s' <- varSubstRec env' s 331 | if s' == s 332 | then return tm 333 | else if any (\ (x, t) -> varFreeIn v t && 334 | varFreeIn x s) env' 335 | then let v' = variant [s'] v in 336 | mkAbs v' =<< varSubstRec ((v, v'):env') s 337 | else mkAbs v =<< varSubstRec env' s 338 | varSubstRec env (TyAbsIn tv t) = 339 | mkTyAbs tv =<< varSubstRec env t 340 | varSubstRec env (TyCombIn t ty) = 341 | do t' <- varSubstRec env t 342 | mkTyComb t' ty 343 | varSubstRec env tm@VarIn{} = return $! assocd tm env tm 344 | 345 | {-| 346 | The @Inst@ class provides the framework for type instantiation in HaskHOL. 347 | Note that in the simplest cases, instantiation is simply a type substitution 348 | for the types of term variables and constants. Therefore, instantiation is 349 | constrained by the 'TypeSubst' class. 350 | 351 | The move to a polymorphic type system further complicates things as types can 352 | now be bound at the term level, requiring renaming for type instantiation. 353 | Since we have three different possible substitution environment types, we have 354 | three different possible instantiation environment types and, therefore, three 355 | different ways to handle renaming: 356 | 357 | * For @(x::'HOLType', r::'HOLType')@ substitution pairs we rename in the case 358 | where a type abstraction binds a type variable present in @r@ and @x@ is 359 | present in the body of the type abstraction. 360 | 361 | * For @(_::'TypeOp', _::'TypeOp')@ substitution pairs we can safely ignore 362 | renaming as our logic does not permit the binding of type operator 363 | variables. 364 | 365 | * For @(x::'TypeOp', r::'HOLType')@ substitution pairs we rename in the case 366 | where a type abstraction binds a type variable present in @r@ and @x@ is 367 | present in the body of the type abstraction. 368 | 369 | Just as we did for the 'TypeSubst' class, we hide the internals of @Inst@ to 370 | prevent unsound re-definition. The correct functions to call for 371 | type instantiation are 'inst' and 'instFull'. 372 | -} 373 | class TypeSubst a b => Inst a b where 374 | {-| 375 | Handles the specific case of instantiating a type abstraction term. This 376 | method is not exposed to the user. Call the 'inst' or 'instFull' function 377 | instead. 378 | -} 379 | instTyAbs :: MonadCatch m => HOLTermEnv -> [(a, b)] -> HOLTerm -> m HOLTerm 380 | 381 | instance Inst HOLType HOLType where 382 | instTyAbs env tyenv tm@(TyAbsIn tv t) = 383 | let tyenv' = filter (\ (x, _) -> x /= tv) tyenv in 384 | if null tyenv' then return tm 385 | else if any (\ (x, r) -> tv `elem` tyVars r && 386 | x `elem` typeVarsInTerm t) tyenv' 387 | -- avoid capture by renaming type variable 388 | then let tvt = typeVarsInTerm t 389 | tvpatts = map fst tyenv' 390 | tvrepls = catTyVars . mapFilter (`assoc` tyenv') $ 391 | tvt `intersect` tvpatts 392 | tv' = variantTyVar ((tvt \\ tvpatts) `union` tvrepls) 393 | tv in 394 | mkTyAbs tv' =<< instRec env ((tv, tv'):tyenv') t 395 | else mkTyAbs tv =<< instRec env tyenv' t 396 | instTyAbs _ _ tm = return tm 397 | 398 | instance Inst TypeOp TypeOp where 399 | instTyAbs env tyenv (TyAbsIn tv t) = 400 | mkTyAbs tv =<< instRec env tyenv t 401 | instTyAbs _ _ tm = return tm 402 | 403 | instance Inst TypeOp HOLType where 404 | instTyAbs env tyenv (TyAbsIn tv t) = 405 | if any (\ (x, ty) -> tv `elem` tyVars ty && 406 | x `elem` typeOpVarsInTerm t) tyenv 407 | -- avoid capture by renaming type variable 408 | then let tvbs = typeOpVarsInTerm t 409 | tvpatts = map fst tyenv 410 | tvrepls = catTyVars . mapFilter (`assoc` tyenv) $ 411 | tvbs `intersect` tvpatts 412 | tv' = variantTyVar tvrepls tv in 413 | mkTyAbs tv' =<< instRec env tyenv (inst [(tv, tv')] t) 414 | else mkTyAbs tv =<< instRec env tyenv t 415 | instTyAbs _ _ tm = return tm 416 | 417 | {-| 418 | Type instantiation for terms. Accepts the same types of substitution 419 | environments as discussed in the documentation for the 'TypeSubst' class, 420 | with invalid substitution pairs being pruned internally by 'typeSubst' as 421 | necessary. 422 | 423 | For more information on why the 'Inst' class constraint is necessary and how 424 | renaming of bound types is performed, see that classes documentation. 425 | -} 426 | inst :: Inst a b => [(a, b)] -> HOLTerm -> HOLTerm 427 | inst [] tm = tm 428 | inst theta tm = 429 | case runCatch $ instRec [] theta tm of 430 | Right res -> res 431 | Left _ -> tm 432 | 433 | -- Used internally by inst and instTyAbs both. Not exposed to the user. 434 | instRec :: (MonadCatch m, Inst a b) 435 | => HOLTermEnv -> [(a, b)] -> HOLTerm -> m HOLTerm 436 | instRec env tyenv tm@(VarIn n ty) = 437 | let tm' = mkVar n $ typeSubst tyenv ty in 438 | if assocd tm' env tm == tm then return tm' 439 | else throwM $! HOLTermError tm' "instRec: clash" 440 | instRec _ tyenv (ConstIn s ty tag) = 441 | let ty' = typeSubst tyenv ty in 442 | return $! ConstIn s ty' tag 443 | instRec env tyenv (CombIn f x) = 444 | do f' <- instRec env tyenv f 445 | x' <- instRec env tyenv x 446 | mkComb f' x' 447 | instRec env tyenv (AbsIn y@(VarIn _ ty) t) = 448 | do y'<- instRec [] tyenv y 449 | (do t' <- instRec ((y', y):env) tyenv t 450 | mkAbs y' t') `catch` 451 | (\ e@(HOLTermError w' _) -> 452 | if w' /= y' then throwM e 453 | else do ifrees <- mapM (instRec [] tyenv) $ frees t 454 | case variant ifrees y' of 455 | (VarIn x _) -> 456 | let z = mkVar x ty in 457 | instRec env tyenv =<< mkAbs z =<< varSubst [(y, z)] t 458 | _ -> throwM e) 459 | instRec env tyenv tm@TyAbsIn{} = instTyAbs env tyenv tm 460 | instRec env tyenv (TyCombIn tm ty) = 461 | do tm' <- instRec env tyenv tm 462 | let ty' = typeSubst tyenv ty 463 | mkTyComb tm' ty' 464 | instRec _ _ tm@AbsIn{} = throwM $! HOLTermError tm 465 | "instRec: bad term construction." 466 | 467 | {-| 468 | A version of 'inst' that accepts a triplet of type substitution environments. 469 | -} 470 | instFull :: SubstTrip -> HOLTerm -> HOLTerm 471 | instFull (tyenv, tyOps, opOps) = inst opOps . inst tyOps . inst tyenv 472 | 473 | {-| 474 | A simplified version of 'inst' that works only for term constants. 475 | Fails if the provided term is not a constant. 476 | Used internally by 'mkConst' to guarantee that only constants are constructed. 477 | -} 478 | instConst :: (MonadThrow m, TypeSubst a b) => HOLTerm -> [(a, b)] -> m HOLTerm 479 | instConst (ConstIn s uty tag) tyenv = 480 | let ty = typeSubst tyenv uty in 481 | return $! ConstIn s ty tag 482 | instConst tm _ = throwM $! HOLTermError tm "instConst" 483 | 484 | {-| 485 | A version of 'instConst' that accepts a triplet of type substitition 486 | environments. 487 | -} 488 | instConstFull :: MonadThrow m => HOLTerm -> SubstTrip -> m HOLTerm 489 | instConstFull (ConstIn s uty tag) tyenv = 490 | let ty = typeSubstFull tyenv uty in 491 | return $! ConstIn s ty tag 492 | instConstFull tm _ = throwM $! HOLTermError tm "instConstFull" 493 | 494 | -- | Constructs an instance of the HOL equality constant, @=@, for a given type. 495 | tmEq :: HOLType -> HOLTerm 496 | tmEq ty = 497 | ConstIn "=" (TyAppIn tyOpFun [ty, TyAppIn tyOpFun [ty, tyBool]]) 498 | PrimitiveIn 499 | 500 | -- | The pattern synonym equivalent of 'tmEq'. 501 | pattern TmEq :: HOLType -> HOLTerm 502 | pattern TmEq ty <- Const "=" (TyFun ty (TyFun _ TyBool)) 503 | 504 | -- | The infix pattern synonym for term equality. 505 | pattern (:=) :: HOLTerm -> HOLTerm -> HOLTerm 506 | pattern l := r <- Comb (Comb (Const "=" _) l) r 507 | 508 | -- | Predicate for equations, i.e. terms of the form @l = r@. 509 | isEq :: HOLTerm -> Bool 510 | isEq (CombIn (CombIn (ConstIn "=" _ PrimitiveIn) _) _) = True 511 | isEq _ = False 512 | 513 | {-| 514 | Constructs an equation term given the left and right hand side arguments. 515 | Fails if the types of the terms are not alpha-equivalent. 516 | -} 517 | primMkEq :: MonadThrow m => HOLTerm -> HOLTerm -> m HOLTerm 518 | primMkEq l r 519 | | ty `tyAConv` typeOf r = 520 | return $! CombIn (CombIn (tmEq ty) l) r 521 | | otherwise = throwM $! HOLTermError l "primMkEq" 522 | where ty = typeOf l 523 | 524 | {-| 525 | Destructs an equation term, returning the left and right hand side arguments. 526 | Fails with 'Nothing' if the term is not an equation, i.e. of the form @l = r@. 527 | -} 528 | destEq :: MonadThrow m => HOLTerm -> m (HOLTerm, HOLTerm) 529 | destEq (CombIn (CombIn (ConstIn "=" _ PrimitiveIn) l) r) = return (l, r) 530 | destEq tm = throwM $! HOLTermError tm "destEq" 531 | 532 | {-| 533 | Renames a term variable to avoid sharing a name with any of a given list of 534 | term variables. Returns the original term if it's not a term variable. 535 | -} 536 | variant :: [HOLTerm] -> HOLTerm -> HOLTerm 537 | variant avoid v@(VarIn s ty) 538 | | any (varFreeIn v) avoid = 539 | variant avoid $ mkVar (s `snoc` '\'') ty 540 | | otherwise = v 541 | variant _ tm = tm 542 | 543 | {-| 544 | Renames a list of term variables to avoid sharing a name with any of a given 545 | list of term variables. As each term variable is processed it is added to 546 | the list of avoids such that the resultant list of term variables are all 547 | uniquely named. 548 | -} 549 | variants :: [HOLTerm] -> [HOLTerm] -> [HOLTerm] 550 | variants _ [] = [] 551 | variants avoid (v:vs) = 552 | let vh = variant avoid v in 553 | vh : variants (vh:avoid) vs 554 | 555 | {- 556 | Stateless HOL Term Primitives 557 | -} 558 | 559 | {-| 560 | Constructs a primitive constant given a name and type. Note that primitive 561 | constants are tagged with a @Primitive@ 'ConstTag' indicating that they have 562 | no definition. 563 | -} 564 | newPrimitiveConst :: Text -> HOLType -> HOLTerm 565 | newPrimitiveConst name ty = ConstIn name ty PrimitiveIn 566 | 567 | -- | Returns the list of all type operator variables in a term. 568 | typeOpVarsInTerm :: HOLTerm -> [TypeOp] 569 | typeOpVarsInTerm (VarIn _ ty) = typeOpVars ty 570 | typeOpVarsInTerm (ConstIn _ ty _) = typeOpVars ty 571 | typeOpVarsInTerm (CombIn s t) = 572 | typeOpVarsInTerm s `union` typeOpVarsInTerm t 573 | typeOpVarsInTerm (AbsIn bv t) = 574 | typeOpVarsInTerm bv `union` typeOpVarsInTerm t 575 | typeOpVarsInTerm (TyAbsIn _ t) = typeOpVarsInTerm t 576 | typeOpVarsInTerm (TyCombIn t ty) = 577 | typeOpVarsInTerm t `union` typeOpVars ty 578 | 579 | -- | Returns the list of all type operator variables in a list of terms. 580 | typeOpVarsInTerms :: [HOLTerm] -> [TypeOp] 581 | typeOpVarsInTerms = 582 | foldr (\ tm topvs -> typeOpVarsInTerm tm `union` topvs) [] 583 | 584 | {- 585 | HOL2P Term Primitives 586 | -} 587 | -- | Predicate for type abstraction terms. 588 | isTyAbs :: HOLTerm -> Bool 589 | isTyAbs TyAbsIn{} = True 590 | isTyAbs _ = False 591 | 592 | -- | Predicate for type combination terms. 593 | isTyComb :: HOLTerm -> Bool 594 | isTyComb TyCombIn{} = True 595 | isTyComb _ = False 596 | 597 | {-| 598 | Constructs a type abstraction term given a bound type and a body term. Fails 599 | with 'Left' in the following cases: 600 | 601 | * The bound type is not a small type variable. 602 | -} 603 | mkTyAbs :: MonadThrow m => HOLType -> HOLTerm -> m HOLTerm 604 | mkTyAbs tv@(TyVarIn True _) bod = return $! TyAbsIn tv bod 605 | mkTyAbs ty _ = throwM $! HOLTypeError ty 606 | "mkTyAbs: first argument not a small type variable." 607 | 608 | {-| 609 | Constructs a type combination term given a body term and a type argument to 610 | apply. Fails with 'Left' in the following cases: 611 | 612 | * The type argument is not a small type. 613 | 614 | * The type of the body term is not a universal type. 615 | -} 616 | mkTyComb :: MonadThrow m => HOLTerm -> HOLType -> m HOLTerm 617 | mkTyComb tm ty 618 | | isSmall ty = 619 | case typeOf tm of 620 | UTypeIn{} -> 621 | return $! TyCombIn tm ty 622 | _ -> throwM $! HOLTermError tm 623 | "mkTyComb: term must have universal type." 624 | | otherwise = 625 | throwM $! HOLTypeError ty "mkTyComb: type argument not small." 626 | 627 | {-| 628 | Destructs a type abstraction, returning its bound type and body term. Fails 629 | with 'Nothing' if the provided term is not a type abstraction. 630 | -} 631 | destTyAbs :: MonadThrow m => HOLTerm -> m (HOLType, HOLTerm) 632 | destTyAbs (TyAbsIn tv bod) = return (tv, bod) 633 | destTyAbs tm = throwM $! HOLTermError tm "destTyAbs" 634 | 635 | {-| 636 | Destructs a type combination, returning its body term and type argument. 637 | Fails with 'Nothing' if the provided term is not a type combination. 638 | -} 639 | destTyComb :: MonadThrow m => HOLTerm -> m (HOLTerm, HOLType) 640 | destTyComb (TyCombIn tm ty) = return (tm, ty) 641 | destTyComb tm = throwM $! HOLTermError tm "destTyComb" 642 | 643 | -- | The initial term constants. 644 | initTermConstants :: Map Text HOLTerm 645 | initTermConstants = mapFromList [("=", tmEq tyA)] 646 | 647 | -- Documentation copied from HaskHOL.Core.Prims 648 | 649 | {-$ViewPatterns 650 | The primitive data types of HaskHOL are implemented using pattern synonyms in 651 | order to simulate private data types: 652 | 653 | * Internal constructors are hidden to prevent manual construction of terms. 654 | 655 | * Unidirectional pattern synonyms ('Var', etc.) are exposed to enable pattern 656 | matching. 657 | -} 658 | 659 | {-$HOLTerms 660 | The following data types combined provide the definition of HOL terms in 661 | HaskHOL. 662 | 663 | Corresponding with the 'HOLType' data type, 'HOLTerm' follows closely from 664 | the definition of terms in HOL Light. Again, the appropriate modifications 665 | have been made to facilitate a semi-stateless and polymorphic term language. 666 | 667 | Most notably this includes: 668 | (1) The introduction of tags for constants to carry information formerly 669 | contained in the state. 670 | 671 | 2. Additional constructors have been added to 'HOLTerm' to facilitate 672 | term-level, type abstractions and applications. 673 | -} 674 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Lib/Families.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} 2 | {-| 3 | Module: HaskHOL.Core.Lib.Families 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines type families for basic, type-level boolean computation. 12 | It is implemented separately given GHC's limitations on exporting type 13 | families with operators for names. 14 | -} 15 | module HaskHOL.Core.Lib.Families where 16 | 17 | -- | Type family equality between types of the same kind. 18 | type family (a :: k) == (b :: k) :: Bool 19 | 20 | -- | Type family disjunction. 21 | type family ((a :: Bool) || (b :: Bool)) :: Bool 22 | type instance 'True || a = 'True 23 | type instance a || 'True = 'True 24 | type instance 'False || a = a 25 | type instance a || 'False = a 26 | 27 | -- | Type family conjunction. 28 | type family ((a :: Bool) && (b :: Bool)) :: Bool 29 | type instance 'True && a = a 30 | type instance 'False && a = 'False 31 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Lib/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE FlexibleInstances, MagicHash, OverlappingInstances, 3 | TemplateHaskell, TypeSynonymInstances #-} 4 | 5 | {-| 6 | Module: HaskHOL.Core.Lib.Lift 7 | Copyright: (c) Ian Lynagh 2006 8 | LICENSE: BSD3 9 | 10 | Maintainer: e.c.austin@gmail.com 11 | Stability: unstable 12 | Portability: unknown 13 | 14 | This module is a re-export of the th-lift library originally written by Ian 15 | Lynagh and maintained by Mathieu Boespflug. A very minor change was made by 16 | Evan Austin in order to facilitate derivation of lift instances for quantified 17 | type constructors. 18 | 19 | The decision to include this source as part of the HaskHOL system, rather than 20 | import the original library, was made to facilitate the above change and to 21 | sever HaskHOL's only dependence on a non-Haskell Platform library. 22 | -} 23 | 24 | {- 25 | The original copyright is included in its entirety below, as required by BSD3: 26 | 27 | Copyright (c) Ian Lynagh. 28 | All rights reserved. 29 | 30 | Redistribution and use in source and binary forms, with or without 31 | modification, are permitted provided that the following conditions 32 | are met: 33 | 1. Redistributions of source code must retain the above copyright 34 | notice, this list of conditions and the following disclaimer. 35 | 2. Redistributions in binary form must reproduce the above copyright 36 | notice, this list of conditions and the following disclaimer in the 37 | documentation and/or other materials provided with the distribution. 38 | 3. The names of the author may not be used to endorse or promote 39 | products derived from this software without specific prior written 40 | permission. 41 | 42 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 43 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 44 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 45 | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 46 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 47 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 48 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 49 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 50 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 51 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 52 | SUCH DAMAGE. 53 | -} 54 | 55 | module HaskHOL.Core.Lib.Lift 56 | ( deriveLift' -- :: Info -> Q [Dec] 57 | , deriveLift -- :: Name -> Q [Dec] 58 | , deriveLiftMany -- :: [Name] -> Q [Dec] 59 | , module TH {-| 60 | Re-exports 'Lift' for the purpose of writing type signatures external to 61 | this module. 62 | -} 63 | ) where 64 | 65 | import GHC.Exts 66 | import Language.Haskell.TH 67 | import Language.Haskell.TH.Syntax 68 | import qualified Language.Haskell.TH.Syntax as TH (Lift) 69 | import Control.Monad ((<=<)) 70 | 71 | 72 | -- | Derive Lift instances for the given datatype. 73 | deriveLift :: Name -> Q [Dec] 74 | deriveLift = deriveLift' <=< reify 75 | 76 | -- | Derive Lift instances for many datatypes. 77 | deriveLiftMany :: [Name] -> Q [Dec] 78 | deriveLiftMany = deriveLiftMany' <=< mapM reify 79 | 80 | -- | Obtain Info values through a custom reification function. This is useful 81 | -- when generating instances for datatypes that have not yet been declared. 82 | deriveLift' :: Info -> Q [Dec] 83 | deriveLift' = fmap (:[]) . deriveLiftOne 84 | 85 | deriveLiftMany' :: [Info] -> Q [Dec] 86 | deriveLiftMany' = mapM deriveLiftOne 87 | 88 | deriveLiftOne :: Info -> Q Dec 89 | deriveLiftOne i = 90 | case i of 91 | TyConI (DataD dcx n vsk cons _) -> 92 | liftInstance dcx n (map unTyVarBndr vsk) (map doCons cons) 93 | TyConI (NewtypeD dcx n vsk con _) -> 94 | liftInstance dcx n (map unTyVarBndr vsk) [doCons con] 95 | _ -> fail ("deriveLift: unhandled: " ++ pprint i) 96 | where liftInstance dcx n vs cases = 97 | instanceD (ctxt dcx vs) (conT ''Lift `appT` typ n vs) [funD 'lift cases] 98 | typ n = foldl appT (conT n) . map varT 99 | ctxt dcx = fmap (dcx ++) . cxt . map liftPred 100 | unTyVarBndr (PlainTV v) = v 101 | unTyVarBndr (KindedTV v _) = v 102 | liftPred n = classP ''Lift [varT n] 103 | 104 | doCons :: Con -> Q Clause 105 | doCons (NormalC c sts) = do 106 | let ns = zipWith (\_ i -> 'x' : show i) sts [(0::Integer)..] 107 | con = [| conE c |] 108 | args = [ [| lift $(varE (mkName n)) |] | n <- ns ] 109 | e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args 110 | clause [conP c (map (varP . mkName) ns)] (normalB e) [] 111 | doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts] 112 | doCons (InfixC sty1 c sty2) = do 113 | let con = [| conE c |] 114 | left = [| lift $(varE (mkName "x0")) |] 115 | right = [| lift $(varE (mkName "x1")) |] 116 | e = [| infixApp $left $con $right |] 117 | clause [infixP (varP (mkName "x0")) c (varP (mkName "x1"))] (normalB e) [] 118 | -- ECA 119 | doCons (ForallC _ _ con) = doCons con 120 | 121 | instance Lift Name where 122 | lift (Name occName nameFlavour) = [| Name occName nameFlavour |] 123 | 124 | instance Lift OccName where 125 | lift n = [| mkOccName $(lift $ occString n) |] 126 | 127 | instance Lift PkgName where 128 | lift n = [| mkPkgName $(lift $ pkgString n) |] 129 | 130 | instance Lift ModName where 131 | lift n = [| mkModName $(lift $ modString n) |] 132 | 133 | instance Lift NameFlavour where 134 | lift NameS = [| NameS |] 135 | lift (NameQ moduleName) = [| NameQ moduleName |] 136 | lift (NameU i) = [| case $( lift (I# i) ) of 137 | I# i' -> NameU i' |] 138 | lift (NameL i) = [| case $( lift (I# i) ) of 139 | I# i' -> NameL i' |] 140 | lift (NameG nameSpace pkgName moduleName) 141 | = [| NameG nameSpace pkgName moduleName |] 142 | 143 | instance Lift NameSpace where 144 | lift VarName = [| VarName |] 145 | lift DataName = [| DataName |] 146 | lift TcClsName = [| TcClsName |] 147 | 148 | -- These instances should really go in the template-haskell package. 149 | 150 | instance Lift () where 151 | lift _ = [| () |] 152 | 153 | instance Lift Rational where 154 | lift x = return (LitE (RationalL x)) 155 | 156 | --ECA 157 | instance Lift String where 158 | lift = liftString 159 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Overloadings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, 2 | MultiParamTypeClasses, TypeFamilies #-} 3 | module HaskHOL.Core.Overloadings 4 | ( module HaskHOL.Core.Kernel 5 | , module HaskHOL.Core.Basics 6 | , module HaskHOL.Core.Parser 7 | , module HaskHOL.Core.Overloadings 8 | ) 9 | where 10 | 11 | import HaskHOL.Core.Lib 12 | 13 | import HaskHOL.Core.Kernel hiding 14 | (tyApp, destFunTy, primTYBETA, primTYAPP, primTYAPP2, primTYABS, 15 | primINST, primINST_TYPE_FULL, primINST_TYPE, primDEDUCT_ANTISYM, 16 | primEQ_MP, primASSUME, primBETA, primABS, primMK_COMB, primTRANS, 17 | primREFL, varSubst, destEq, destTyComb, destTyAbs, destComb, destAbs, 18 | destVar, mkTyComb, mkTyAbs, mkComb, mkAbs, mkVar, inst, typeMatch, 19 | mkUTypes, mkUType, typeOf) 20 | import qualified HaskHOL.Core.Kernel as K 21 | 22 | import HaskHOL.Core.Basics hiding 23 | (destNumeral, destLet, destList, destCons, destTyEx, destTyAll, destUExists, 24 | destNeg, destDisj, destExists, destForall, destImp, destConj, destIff, 25 | destTyBinder, destBinder, destGAbs, listMkBinop, mkBinop, destBinop, 26 | destBinary, mkIComb, bodyTyabs, bndvarTyabs, body, bndvar, rand, rator, 27 | listMkTyAbs, listMkAbs, listMkTyComb, listMkComb, alphaTyabs, alpha, 28 | subst, mkEq, alphaUtype, tysubst) 29 | import qualified HaskHOL.Core.Basics as B 30 | 31 | import HaskHOL.Core.Parser hiding 32 | (newTypeAbbrev, prioritizeOverload, overloadInterface, overrideInterface, 33 | reduceInterface, makeOverloadable) 34 | import qualified HaskHOL.Core.Parser as P 35 | 36 | import HaskHOL.Core.State.Monad (HOL, Theory, Constraint) 37 | 38 | 39 | -- Overloading Skeletons 40 | class Overload a b where 41 | type family OverloadTy a b cls thry :: Constraint 42 | overload :: OverloadTy a b cls thry => b -> HOL cls thry a 43 | 44 | instance Overload HOLType ty where 45 | type OverloadTy HOLType ty cls thry = HOLTypeRep ty cls thry 46 | overload = toHTy 47 | 48 | instance Overload HOLTerm tm where 49 | type OverloadTy HOLTerm tm cls thry = HOLTermRep tm cls thry 50 | overload = toHTm 51 | 52 | instance Overload HOLThm thm where 53 | type OverloadTy HOLThm thm cls thry = HOLThmRep thm cls thry 54 | overload = toHThm 55 | 56 | instance (Overload a1 b1, Overload a2 b2) => Overload (a1, a2) (b1, b2) where 57 | type OverloadTy (a1, a2) (b1, b2) cls thry = 58 | (OverloadTy a1 b1 cls thry, OverloadTy a2 b2 cls thry) 59 | overload = overload `ffCombM` overload 60 | 61 | instance (Overload a1 b1, Overload a2 b2, Overload a3 b3) => 62 | Overload (a1, a2, a3) (b1, b2, b3) where 63 | type OverloadTy (a1, a2, a3) (b1, b2, b3) cls thry = 64 | (OverloadTy a1 b1 cls thry, OverloadTy a2 b2 cls thry, 65 | OverloadTy a3 b3 cls thry) 66 | overload (x, y, z) = 67 | do {x' <- overload x; y' <- overload y; z' <- overload z; return (x',y',z')} 68 | 69 | -- Has the potential for a space leak for large argument lists due to mapM. 70 | instance Overload a b => Overload [a] [b] where 71 | type OverloadTy [a] [b] cls thry = OverloadTy a b cls thry 72 | overload = mapM overload 73 | 74 | -- One off to clean up overloadings related to type substitution 75 | instance Overload K.TypeOp K.TypeOp where 76 | type OverloadTy K.TypeOp K.TypeOp cls thry = () 77 | overload = return 78 | 79 | overload1 :: (Overload a b, OverloadTy a b cls thry) 80 | => (a -> HOL cls thry c) -> b -> HOL cls thry c 81 | overload1 f x = join (f <$!> overload x) 82 | 83 | overload2 :: (Overload a1 b1, OverloadTy a1 b1 cls thry, 84 | Overload a2 b2, OverloadTy a2 b2 cls thry) 85 | => (a1 -> a2 -> HOL cls thry c) -> b1 -> b2 -> HOL cls thry c 86 | overload2 f x y = join (f <$!> overload x <*> overload y) 87 | 88 | overload3 :: (Overload a1 b1, OverloadTy a1 b1 cls thry, 89 | Overload a2 b2, OverloadTy a2 b2 cls thry, 90 | Overload a3 b3, OverloadTy a3 b3 cls thry) 91 | => (a1 -> a2 -> a3 -> HOL cls thry c) 92 | -> b1 -> b2 -> b3 -> HOL cls thry c 93 | overload3 f x y z = join (f <$!> overload x <*> overload y <*> overload z) 94 | 95 | -- Kernel Type Functions 96 | destFunTy :: HOLTypeRep ty cls thry => ty -> HOL cls thry (HOLType, HOLType) 97 | destFunTy = overload1 K.destFunTy 98 | 99 | tyApp :: HOLTypeRep ty cls thry => TypeOp -> [ty] -> HOL cls thry HOLType 100 | tyApp = overload2 K.tyApp 101 | 102 | mkUType :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry) 103 | => ty1 -> ty2 -> HOL cls thry HOLType 104 | mkUType = overload2 K.mkUType 105 | 106 | mkUTypes :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry) 107 | => [ty1] -> ty2 -> HOL cls thry HOLType 108 | mkUTypes = overload2 K.mkUTypes 109 | 110 | typeMatch :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry, 111 | HOLTypeRep ty3 cls thry, HOLTypeRep ty4 cls thry, 112 | HOLTypeRep ty5 cls thry) 113 | => ty1 -> ty2 114 | -> ([(ty3, ty4)], [(K.TypeOp, ty5)], [(K.TypeOp, K.TypeOp)]) 115 | -> HOL cls thry SubstTrip 116 | typeMatch = overload3 K.typeMatch 117 | 118 | {-# INLINEABLE typeMatch_NIL #-} 119 | typeMatch_NIL :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry) 120 | => ty1 -> ty2 -> HOL cls thry SubstTrip 121 | typeMatch_NIL x y = 122 | HaskHOL.Core.Overloadings.typeMatch x y (([], [], [])::SubstTrip) 123 | 124 | -- Kernel Term Functions 125 | typeOf :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLType 126 | typeOf = overload1 (return . K.typeOf) 127 | 128 | mkVar :: HOLTypeRep ty cls thry => Text -> ty -> HOL cls thry HOLTerm 129 | mkVar x = overload1 (return . K.mkVar x) 130 | 131 | mkAbs :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 132 | => tm1 -> tm2 -> HOL cls thry HOLTerm 133 | mkAbs = overload2 K.mkAbs 134 | 135 | mkComb :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 136 | => tm1 -> tm2 -> HOL cls thry HOLTerm 137 | mkComb = overload2 K.mkComb 138 | 139 | mkTyAbs :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 140 | => ty -> tm -> HOL cls thry HOLTerm 141 | mkTyAbs = overload2 K.mkTyAbs 142 | 143 | mkTyComb :: (HOLTermRep tm cls thry, HOLTypeRep ty cls thry) 144 | => tm -> ty -> HOL cls thry HOLTerm 145 | mkTyComb = overload2 K.mkTyComb 146 | 147 | destVar :: HOLTermRep tm cls thry => tm -> HOL cls thry (Text, HOLType) 148 | destVar = overload1 K.destVar 149 | 150 | destAbs :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 151 | destAbs = overload1 K.destAbs 152 | 153 | destComb :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 154 | destComb = overload1 K.destComb 155 | 156 | destTyAbs :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLType, HOLTerm) 157 | destTyAbs = overload1 K.destTyAbs 158 | 159 | destTyComb :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLType) 160 | destTyComb = overload1 K.destTyComb 161 | 162 | destEq :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 163 | destEq = overload1 K.destEq 164 | 165 | varSubst :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry, 166 | HOLTermRep tm3 cls thry) 167 | => [(tm1, tm2)] -> tm3 -> HOL cls thry HOLTerm 168 | varSubst = overload2 K.varSubst 169 | 170 | 171 | -- Is there a cleaner way to do this? Overloading requires ambiguous types. 172 | class InstHOL a b cls thry where 173 | instHOL :: [(a, b)] -> HOLTerm -> HOL cls thry HOLTerm 174 | instTypeHOL :: [(a, b)] -> HOLThm -> HOL cls thry HOLThm 175 | 176 | instance (HOLTypeRep l cls thry, HOLTypeRep r cls thry) => 177 | InstHOL l r cls thry where 178 | instHOL penv tm = 179 | do env <- mapM (toHTy `ffCombM` toHTy) penv 180 | return $! K.inst env tm 181 | instTypeHOL penv thm = 182 | do env <- mapM (toHTy `ffCombM` toHTy) penv 183 | return $! K.primINST_TYPE env thm 184 | 185 | instance HOLTypeRep r cls thry => InstHOL TypeOp r cls thry where 186 | instHOL penv tm = 187 | do env <- mapM (return `ffCombM` toHTy) penv 188 | return $! K.inst env tm 189 | instTypeHOL penv thm = 190 | do env <- mapM (return `ffCombM` toHTy) penv 191 | return $! K.primINST_TYPE env thm 192 | 193 | instance InstHOL TypeOp TypeOp cls thry where 194 | instHOL penv tm = return $! K.inst penv tm 195 | instTypeHOL penv thm = return $! K.primINST_TYPE penv thm 196 | 197 | inst :: (InstHOL a b cls thry, HOLTermRep tm cls thry) 198 | => [(a, b)] -> tm -> HOL cls thry HOLTerm 199 | inst penv = overload1 (instHOL penv) 200 | 201 | -- Kernel Theorem Functions 202 | 203 | {-| 204 | A redefinition of 'K.primREFL' to overload it for all valid term 205 | representations as defined by 'HOLTermRep'. 206 | -} 207 | primREFL :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLThm 208 | primREFL = overload1 (return . K.primREFL) 209 | 210 | {-| 211 | A redefinition of 'K.primTRANS' to overload it for all valid theorem 212 | representations as defined by 'HOLThmRep'. 213 | -} 214 | primTRANS :: (HOLThmRep thm1 cls thry, HOLThmRep thm2 cls thry) 215 | => thm1 -> thm2 -> HOL cls thry HOLThm 216 | primTRANS = overload2 K.primTRANS 217 | 218 | {-| 219 | A redefinition of 'K.primMK_COMB' to overload it for all valid theorem 220 | representations as defined by 'HOLThmRep'. 221 | -} 222 | primMK_COMB :: (HOLThmRep thm1 cls thry, HOLThmRep thm2 cls thry) 223 | => thm1 -> thm2 -> HOL cls thry HOLThm 224 | primMK_COMB = overload2 K.primMK_COMB 225 | 226 | {-| 227 | A redefinition of 'K.primABS' to overload it for all valid term and theorem 228 | representations as defined by 'HOLTermRep' and 'HOLThmRep'. 229 | -} 230 | primABS :: (HOLTermRep tm cls thry, HOLThmRep thm cls thry) 231 | => tm -> thm -> HOL cls thry HOLThm 232 | primABS = overload2 K.primABS 233 | 234 | {-| 235 | A redefinition of 'K.primBETA' to overload it for all valid term 236 | representations as defined by 'HOLTermRep'. 237 | -} 238 | primBETA :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLThm 239 | primBETA = overload1 K.primBETA 240 | 241 | {-| 242 | A redefinition of 'K.primASSUME' to overload it for all valid term 243 | representations as defined by 'HOLTermRep'. 244 | -} 245 | primASSUME :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLThm 246 | primASSUME = overload1 K.primASSUME 247 | 248 | {-| 249 | A redefinition of 'K.primEQ_MP' to overload it for all valid theorem 250 | representations as defined by 'HOLThmRep'. 251 | -} 252 | primEQ_MP :: (HOLThmRep thm1 cls thry, HOLThmRep thm2 cls thry) 253 | => thm1 -> thm2 -> HOL cls thry HOLThm 254 | primEQ_MP = overload2 K.primEQ_MP 255 | 256 | {-| 257 | A redefinition of 'K.primDEDUCT_ANTISYM' to overload it for all valid theorem 258 | representations as defined by 'HOLThmRep'. 259 | -} 260 | primDEDUCT_ANTISYM :: (HOLThmRep thm1 cls thry, HOLThmRep thm2 cls thry) 261 | => thm1 -> thm2 -> HOL cls thry HOLThm 262 | primDEDUCT_ANTISYM = overload2 (\ x -> return . K.primDEDUCT_ANTISYM x) 263 | 264 | {-| 265 | A redefinition of 'K.primINST_TYPE' to overload it for all valid theorem 266 | representations as defined by 'HOLThmRep'. 267 | -} 268 | primINST_TYPE :: (InstHOL a b cls thry, HOLThmRep thm cls thry) 269 | => [(a, b)] -> thm -> HOL cls thry HOLThm 270 | primINST_TYPE penv = overload1 (instTypeHOL penv) 271 | 272 | {-| 273 | A redefinition of 'K.primINST_TYPE_FULL' to overload it for all valid theorem 274 | representations as defined by 'HOLThmRep'. 275 | -} 276 | primINST_TYPE_FULL :: HOLThmRep thm cls thry 277 | => SubstTrip -> thm -> HOL cls thry HOLThm 278 | primINST_TYPE_FULL tyenv = overload1 (return . K.primINST_TYPE_FULL tyenv) 279 | 280 | {-| 281 | A redefinition of 'K.primINST' to overload it for all valid theorem 282 | representations as defined by 'HOLThmRep'. 283 | -} 284 | primINST :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry, 285 | HOLThmRep thm cls thry) 286 | => [(tm1, tm2)] -> thm -> HOL cls thry HOLThm 287 | primINST = overload2 K.primINST 288 | 289 | {-| 290 | A redefinition of 'K.primTYABS' to overload it for all valid theorem 291 | representations as defined by 'HOLThmRep'. 292 | -} 293 | primTYABS :: (HOLTypeRep ty cls thry, HOLThmRep thm cls thry) 294 | => ty -> thm -> HOL cls thry HOLThm 295 | primTYABS = overload2 K.primTYABS 296 | 297 | {-| 298 | A redefinition of 'K.primTYAPP2' to overload it for all valid type and theorem 299 | representations as defined by 'HOLTypeRep' and 'HOLThmRep'. 300 | -} 301 | primTYAPP2 :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry, 302 | HOLThmRep thm cls thry) 303 | => ty1 -> ty2 -> thm -> HOL cls thry HOLThm 304 | primTYAPP2 = overload3 K.primTYAPP2 305 | 306 | {-| 307 | A redefinition of 'K.primTYAPP' to overload it for all valid type and theorem 308 | representations as defined by 'HOLTypeRep' and 'HOLThmRep'. 309 | -} 310 | primTYAPP :: (HOLTypeRep ty cls thry, HOLThmRep thm cls thry) 311 | => ty -> thm -> HOL cls thry HOLThm 312 | primTYAPP = overload2 K.primTYAPP 313 | 314 | {-| 315 | A redefinition of 'K.primTYBETA' to overload it for all valid term 316 | representations as defined by 'HOLTermRep'. 317 | -} 318 | primTYBETA :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLThm 319 | primTYBETA = overload1 K.primTYBETA 320 | 321 | -- Core "Basic" Functions 322 | tysubst :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry, 323 | HOLTypeRep ty3 cls thry) 324 | => [(ty1, ty2)] -> ty3 -> HOL cls thry HOLType 325 | tysubst = overload2 B.tysubst 326 | 327 | alphaUtype :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry) 328 | => ty1 -> ty2 -> HOL cls thry HOLType 329 | alphaUtype = overload2 B.alphaUtype 330 | 331 | mkEq :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 332 | => tm1 -> tm2 -> HOL cls thry HOLTerm 333 | mkEq = overload2 B.mkEq 334 | 335 | subst :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry, 336 | HOLTermRep tm3 cls thry) 337 | => [(tm1, tm2)] -> tm3 -> HOL cls thry HOLTerm 338 | subst = overload2 B.subst 339 | 340 | alpha :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 341 | => tm1 -> tm2 -> HOL cls thry HOLTerm 342 | alpha = overload2 B.alpha 343 | 344 | alphaTyabs :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 345 | => ty -> tm -> HOL cls thry HOLTerm 346 | alphaTyabs = overload2 B.alphaTyabs 347 | 348 | listMkComb :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 349 | => tm1 -> [tm2] -> HOL cls thry HOLTerm 350 | listMkComb = overload2 B.listMkComb 351 | 352 | listMkTyComb :: (HOLTermRep tm cls thry, HOLTypeRep ty cls thry) 353 | => tm -> [ty] -> HOL cls thry HOLTerm 354 | listMkTyComb = overload2 B.listMkTyComb 355 | 356 | listMkAbs :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 357 | => [tm1] -> tm2 -> HOL cls thry HOLTerm 358 | listMkAbs = overload2 B.listMkAbs 359 | 360 | listMkTyAbs :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 361 | => [ty] -> tm -> HOL cls thry HOLTerm 362 | listMkTyAbs = overload2 B.listMkTyAbs 363 | 364 | rator :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 365 | rator = overload1 B.rator 366 | 367 | rand :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 368 | rand = overload1 B.rand 369 | 370 | bndvar :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 371 | bndvar = overload1 B.bndvar 372 | 373 | body :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 374 | body = overload1 B.body 375 | 376 | bndvarTyabs :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLType 377 | bndvarTyabs = overload1 B.bndvarTyabs 378 | 379 | bodyTyabs :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 380 | bodyTyabs = overload1 B.bodyTyabs 381 | 382 | mkIComb :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 383 | => tm1 -> tm2 -> HOL cls thry HOLTerm 384 | mkIComb = overload2 B.mkIComb 385 | 386 | destBinary :: HOLTermRep tm cls thry 387 | => Text -> tm -> HOL cls thry (HOLTerm, HOLTerm) 388 | destBinary s = overload1 (B.destBinary s) 389 | 390 | destBinop :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 391 | => tm1 -> tm2 -> HOL cls thry (HOLTerm, HOLTerm) 392 | destBinop = overload2 B.destBinop 393 | 394 | mkBinop :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry, 395 | HOLTermRep tm3 cls thry) 396 | => tm1 -> tm2 -> tm3 -> HOL cls thry HOLTerm 397 | mkBinop = overload3 B.mkBinop 398 | 399 | listMkBinop :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 400 | => tm1 -> [tm2] -> HOL cls thry HOLTerm 401 | listMkBinop = overload2 B.listMkBinop 402 | 403 | destGAbs :: HOLTermRep tm cls thry 404 | => tm -> HOL cls thry (HOLTerm, HOLTerm) 405 | destGAbs = overload1 B.destGAbs 406 | 407 | destBinder :: HOLTermRep tm cls thry 408 | => Text -> tm -> HOL cls thry (HOLTerm, HOLTerm) 409 | destBinder op = overload1 (B.destBinder op) 410 | 411 | destTyBinder :: HOLTermRep tm cls thry 412 | => Text -> tm -> HOL cls thry (HOLType, HOLTerm) 413 | destTyBinder op = overload1 (B.destTyBinder op) 414 | 415 | destIff :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 416 | destIff = overload1 B.destIff 417 | 418 | destConj :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 419 | destConj = overload1 B.destConj 420 | 421 | destImp :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 422 | destImp = overload1 B.destImp 423 | 424 | destForall :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 425 | destForall = overload1 B.destForall 426 | 427 | destExists :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 428 | destExists = overload1 B.destExists 429 | 430 | destNeg :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 431 | destNeg = overload1 B.destNeg 432 | 433 | destDisj :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 434 | destDisj = overload1 B.destDisj 435 | 436 | destUExists :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 437 | destUExists = overload1 B.destUExists 438 | 439 | destTyAll :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLType, HOLTerm) 440 | destTyAll = overload1 B.destTyAll 441 | 442 | destTyEx :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLType, HOLTerm) 443 | destTyEx = overload1 B.destTyEx 444 | 445 | destCons :: HOLTermRep tm cls thry => tm -> HOL cls thry (HOLTerm, HOLTerm) 446 | destCons = overload1 B.destCons 447 | 448 | destList :: HOLTermRep tm cls thry => tm -> HOL cls thry [HOLTerm] 449 | destList = overload1 B.destList 450 | 451 | destLet :: HOLTermRep tm cls thry 452 | => tm -> HOL cls thry ([(HOLTerm, HOLTerm)], HOLTerm) 453 | destLet = overload1 B.destLet 454 | 455 | destNumeral :: HOLTermRep tm cls thry => tm -> HOL cls thry Integer 456 | destNumeral = overload1 B.destNumeral 457 | 458 | -- Parser Functions 459 | {-| 460 | A redefinition of 'P.makeOverloadable' to overload it for all valid type 461 | representations as defined by 'HOLTypeRep'. 462 | -} 463 | makeOverloadable :: HOLTypeRep ty Theory thry 464 | => Text -> ty -> HOL Theory thry () 465 | makeOverloadable s = overload1 (P.makeOverloadable s) 466 | 467 | {-| 468 | A redefinition of 'P.reduceInterface' to overload it for all valid term 469 | representations as defined by 'HOLTermRep'. 470 | -} 471 | reduceInterface :: HOLTermRep tm Theory thry 472 | => Text -> tm -> HOL Theory thry () 473 | reduceInterface s = overload1 (P.reduceInterface s) 474 | 475 | {-| 476 | A redefinition of 'P.overrideInterface' to overload it for all valid term 477 | representations as defined by 'HOLTermRep'. 478 | -} 479 | overrideInterface :: HOLTermRep tm Theory thry 480 | => Text -> tm -> HOL Theory thry () 481 | overrideInterface s = overload1 (P.overrideInterface s) 482 | 483 | {-| 484 | A redefinition of 'P.overloadInterface' to overload it for all valid term 485 | representations as defined by 'HOLTermRep'. 486 | -} 487 | overloadInterface :: HOLTermRep tm Theory thry 488 | => Text -> tm -> HOL Theory thry () 489 | overloadInterface s = overload1 (P.overloadInterface s) 490 | 491 | {-| 492 | A redefinition of 'P.prioritizeOverload' to overload it for all valid type 493 | representations as defined by 'HOLTypeRep'. 494 | -} 495 | prioritizeOverload :: HOLTypeRep ty Theory thry => ty -> HOL Theory thry () 496 | prioritizeOverload = overload1 P.prioritizeOverload 497 | 498 | {-| 499 | A redefinition of 'P.newTypeAbbrev' to overload it for all valid type 500 | representations as defined by 'HOLTypeRep'. 501 | -} 502 | newTypeAbbrev :: HOLTypeRep ty Theory thry => Text -> ty -> HOL Theory thry () 503 | newTypeAbbrev s = overload1 (P.newTypeAbbrev s) 504 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-| 3 | Module: HaskHOL.Core.Parser 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines the parsers for 'HOLType's and 'HOLTerm's. 12 | 13 | It also re-exports the related benign flags, theory extension mechanisms, 14 | and type/term elaborators. 15 | 16 | For examples of the parsers and elaborators in use see the 17 | "HaskHOL.Core.TermRep" module. 18 | -} 19 | module HaskHOL.Core.Parser 20 | ( -- * Elaboration Functions 21 | tyElab 22 | , elab 23 | -- * Parsing Functions 24 | , ptype 25 | , holTypeParser 26 | , pterm 27 | , holTermParser 28 | -- * Type/Term Representation Conversions 29 | , HOLTypeRep(..) 30 | , HOLTermRep(..) 31 | , HOLThmRep(..) 32 | -- * Extensible Parser Operators 33 | , parseAsBinder 34 | , parseAsTyBinder 35 | , parseAsPrefix 36 | , parseAsInfix 37 | , unparseAsBinder 38 | , unparseAsTyBinder 39 | , unparseAsPrefix 40 | , unparseAsInfix 41 | , parsesAsBinder 42 | , parsesAsTyBinder 43 | , parsesAsPrefix 44 | , parsesAsInfix 45 | , binders 46 | , tyBinders 47 | , prefixes 48 | , infixes 49 | -- * Overloading and Interface Mapping 50 | , getInterface 51 | , getOverloads 52 | , removeInterface 53 | , reduceInterface 54 | , overrideInterface 55 | , makeOverloadable 56 | , overloadInterface 57 | , prioritizeOverload 58 | -- * Hidden Constant Mappings 59 | , getHidden 60 | , hideConstant 61 | , unhideConstant 62 | -- * Type Abbreviations 63 | , newTypeAbbrev 64 | , removeTypeAbbrev 65 | , typeAbbrevs 66 | -- * Primitive Parser types, utility functions, and extensions. 67 | , module HaskHOL.Core.Parser.Lib 68 | ) where 69 | 70 | import HaskHOL.Core.Lib 71 | import HaskHOL.Core.Kernel 72 | import HaskHOL.Core.State.Monad 73 | (HOL, Theory, overParseContext, viewParseContext, testParseContext) 74 | import qualified HaskHOL.Core.State.Monad as State 75 | 76 | import HaskHOL.Core.Parser.Lib hiding ((<|>)) 77 | import HaskHOL.Core.Parser.TypeParser 78 | import HaskHOL.Core.Parser.TermParser 79 | import HaskHOL.Core.Parser.Elab 80 | import HaskHOL.Core.Parser.Rep 81 | 82 | -- Parser Methods 83 | -- | Specifies a 'Text' to be recognized as a term binder by the parser. 84 | parseAsBinder :: Text -> HOL Theory thry () 85 | parseAsBinder op = let fun ops = nub (op : ops) in 86 | overParseContext State.binders fun 87 | 88 | -- | Specifies a 'Text' to be recognized as a type binder by the parser. 89 | parseAsTyBinder :: Text -> HOL Theory thry () 90 | parseAsTyBinder op = let fun ops = nub (op : ops) in 91 | overParseContext State.tyBinders fun 92 | 93 | -- | Specifies a 'Text' to be recognized as a prefix operator by the parser. 94 | parseAsPrefix :: Text -> HOL Theory thry () 95 | parseAsPrefix op = let fun ops = nub (op : ops) in 96 | overParseContext State.prefixes fun 97 | 98 | {-| 99 | Specifies a 'Text' to be recognized as an infix operator by the parser with 100 | a given precedence level and associativity. 101 | -} 102 | parseAsInfix :: (Text, (Int, Text)) -> HOL Theory thry () 103 | parseAsInfix i@(n, (p, as)) = 104 | do overParseContext State.infixes insertFun 105 | let f = if as == "right" then State.rights else State.lefts 106 | overParseContext f (\ ops -> nub ((n, p) : ops)) 107 | where insertFun :: [(Text, (Int, Text))] -> [(Text, (Int, Text))] 108 | insertFun is 109 | | test' (find (\ (n', _) -> n == n') is) = is 110 | | otherwise = sort (\ (s, (x, a)) (t, (y, b)) -> 111 | x < y || x == y && a > b || x == y && a == b && s < t) (i:is) 112 | 113 | -- | Specifies a 'Text' for the parser to stop recognizing as a term binder. 114 | unparseAsBinder :: Text -> HOL Theory thry () 115 | unparseAsBinder op = let fun = delete op in 116 | overParseContext State.binders fun 117 | 118 | -- | Specifies a 'Text' for the parser to stop recognizing as a type binder. 119 | unparseAsTyBinder :: Text -> HOL Theory thry () 120 | unparseAsTyBinder op = let fun = delete op in 121 | overParseContext State.tyBinders fun 122 | {-| 123 | Specifies a 'Text' for the parser to stop recognizing as a prefix operator. 124 | -} 125 | unparseAsPrefix :: Text -> HOL Theory thry () 126 | unparseAsPrefix op = let fun = delete op in 127 | overParseContext State.prefixes fun 128 | 129 | {-| 130 | Specifies a 'Text' for the parser to stop recognizing as an infix operator. 131 | -} 132 | unparseAsInfix :: Text -> HOL Theory thry () 133 | unparseAsInfix op = let fun = filter (\ (x, _) -> x /= op) in 134 | do overParseContext State.infixes fun 135 | overParseContext State.rights fun 136 | overParseContext State.lefts fun 137 | 138 | -- | Predicate for 'Text's recognized as term binders by the parser. 139 | parsesAsBinder :: Text -> HOL cls thry Bool 140 | parsesAsBinder op = testParseContext State.binders (elem op) 141 | 142 | -- | Predicate for 'Text's recognized as type binders by the parser. 143 | parsesAsTyBinder :: Text -> HOL cls thry Bool 144 | parsesAsTyBinder op = testParseContext State.tyBinders (elem op) 145 | 146 | -- | Predicate for 'Text's recognized as prefix operators by the parser. 147 | parsesAsPrefix :: Text -> HOL cls thry Bool 148 | parsesAsPrefix op = testParseContext State.prefixes (elem op) 149 | 150 | -- | Predicate for 'Text's recognized as infix operators by the parser. 151 | parsesAsInfix :: Text -> HOL cls thry Bool 152 | parsesAsInfix op = testParseContext State.infixes (test' . assoc op) 153 | 154 | -- | Returns all binders defined in the context. 155 | binders :: HOL cls thry [Text] 156 | binders = viewParseContext State.binders 157 | 158 | -- | Returns all type binders defined in the context. 159 | tyBinders :: HOL cls thry [Text] 160 | tyBinders = viewParseContext State.tyBinders 161 | 162 | -- | Returns all prefix operators defined in the context. 163 | prefixes :: HOL cls thry [Text] 164 | prefixes = viewParseContext State.prefixes 165 | 166 | -- | Returns all infix operators defined in the context. 167 | infixes :: HOL cls thry [(Text, (Int, Text))] 168 | infixes = viewParseContext State.infixes 169 | 170 | -- Interface 171 | -- | Returns the current parser interface. 172 | getInterface :: HOL cls thry [(Text, (Text, HOLType))] 173 | getInterface = viewParseContext State.interface 174 | 175 | -- | Returns the current mapping of overloads for the parser. 176 | getOverloads :: HOL cls thry (Map Text HOLType) 177 | getOverloads = viewParseContext State.overloads 178 | 179 | -- | Removes all instances of an overloaded symbol from the interface. 180 | removeInterface :: Text -> HOL Theory thry () 181 | removeInterface sym = let fun = filter (\ (x, _) -> x /= sym) in 182 | overParseContext State.interface fun 183 | {-| 184 | Removes a specific instance of an overloaded symbol from the interface. 185 | Throws a 'HOLException' if the provided term is not a constant or varible term 186 | representing an instance of the overloaded symbol. 187 | -} 188 | reduceInterface :: Text -> HOLTerm -> HOL Theory thry () 189 | reduceInterface sym tm = 190 | do namty <- destConst tm <|> destVar tm 191 | "reduceInterface: term not a constant or variable" 192 | let fun = delete (sym, namty) 193 | overParseContext State.interface fun 194 | {-| 195 | Removes all existing overloads for a given symbol and replaces them with a 196 | single, specific instance. Throws a 'HOLException' if the provided term is 197 | not a constant or variable term representing an instance of the overloaded 198 | symbol. 199 | 200 | Note that because 'overrideInterface' can introduce at most one overload for 201 | a symbol it does not have to be previously defined as overloadable via 202 | 'makeOverloadable'. However, if the symbol is defined as overloadable then 203 | the provided term must have a type that is matchable with the symbol's most 204 | general type. 205 | -} 206 | overrideInterface :: Text -> HOLTerm -> HOL Theory thry () 207 | overrideInterface sym tm = 208 | do namty <- destConst tm <|> destVar tm 209 | "overrideInterface: term not a constant or variable" 210 | let fun ifc = (sym, namty) : filter (\ (x, _) -> x /= sym) ifc 211 | m = overParseContext State.interface fun 212 | overs <- getOverloads 213 | case runCatch $ sym `mapAssoc` overs of 214 | Right gty -> if not . test' $ typeMatch gty (snd namty) ([], [], []) 215 | then fail $ "overrideInterface: " ++ 216 | "not an instance of type skeleton" 217 | else m 218 | _ -> m 219 | 220 | {-| 221 | Specifies a 'Text' that can act as an overloadable identifier within the 222 | parser. The provided type is the most general type that instances of this 223 | symbol may have. Throws a 'HOLException' if the given symbol has already been 224 | declared as overloadable with a different type. 225 | 226 | Note that defining a symbol as overloadable will erase any interface overloads 227 | that were previously introduced via 'overrideInterface' in order to guarantee 228 | that all overloads are matchable with their most general type. 229 | -} 230 | makeOverloadable :: Text -> HOLType -> HOL Theory thry () 231 | makeOverloadable s gty = 232 | do overs <- getOverloads 233 | case runCatch $ mapAssoc s overs of 234 | Right ty 235 | | gty == ty -> return () 236 | | otherwise -> 237 | fail "makeOverloadable: differs from existing skeleton" 238 | _ -> do overParseContext State.overloads (mapInsert s gty) 239 | removeInterface s 240 | 241 | {-| 242 | Introduces a new overload for a given symbol. Throws a 'HOLException' in the 243 | following cases: 244 | 245 | * The symbol has not previously been defined as overloadable via 246 | 'makeOverloadable'. 247 | 248 | * The provided term is not a constant or variable term representing a 249 | specific instance of the overloaded symbol. 250 | 251 | * The provided term does not have a type that is matchable with the 252 | overloadable symbol's specified most general type. 253 | 254 | Note that specifying an overload that already exists will move it to the front 255 | of the interface list, effectively prioritizing it. This behavior is utilized 256 | by 'prioritizeOverload'. 257 | -} 258 | overloadInterface :: Text -> HOLTerm -> HOL Theory thry () 259 | overloadInterface sym tm = 260 | do overs <- getOverloads 261 | gty <- mapAssoc sym overs ("overloadInstace: symbol " ++ show sym ++ 262 | " is not overloadable.") 263 | namty <- destConst tm <|> destVar tm 264 | "overloadInstance: term not a constant or variable" 265 | if not . test' $ typeMatch gty (snd namty) ([], [], []) 266 | then fail "overloadInstance: not an instance of type skeleton" 267 | else let i = (sym, namty) 268 | fun ifc = i : delete i ifc in 269 | overParseContext State.interface fun 270 | 271 | {-| 272 | Specifies a type to prioritize when the interface is used to overload a 273 | symbol. Note that this applies to all overloads in the system whose match 274 | with the specified most general type involves the provided type. 275 | Prioritization is done by redefining overloads via 'overloadInterface'. 276 | -} 277 | prioritizeOverload :: HOLType -> HOL Theory thry () 278 | prioritizeOverload ty = 279 | do overs <- getOverloads 280 | mapM_ (\ (s, gty) -> 281 | (do iface <- getInterface 282 | (n, t') <- tryFind (\ (s', x@(_, t)) -> 283 | if s' /= s then fail' "tryFind" 284 | else do (ts, _, _) <- typeMatch gty t 285 | ([], [], []) 286 | _ <- ty `revAssoc` ts 287 | return x) iface 288 | overloadInterface s $ mkVar n t') 289 | <|> return ()) $ mapToList overs 290 | 291 | -- Hidden Constants 292 | getHidden :: HOL cls thry [Text] 293 | getHidden = viewParseContext State.hidden 294 | 295 | -- | Specifies a 'Text' for the parser to stop recognizing as a constant. 296 | hideConstant :: Text -> HOL Theory thry () 297 | hideConstant sym = 298 | overParseContext State.hidden (\ syms -> sym : syms) 299 | 300 | -- | Specifies a 'Text' for the parser to resume recognizing as a constant. 301 | unhideConstant :: Text -> HOL Theory thry () 302 | unhideConstant sym = 303 | overParseContext State.hidden (\ syms -> syms \\ [sym]) 304 | 305 | -- Type Abbreviations 306 | {-| 307 | Specifies a 'Text' to act as an abbreviation for a given type in the parser. 308 | Upon recognizing the abbreviation the parser will replace it with the 309 | 'PreType' value for it's associated 'HOLType' such that the elaborator can 310 | infer the correct type for polymorphic abbreviations. 311 | -} 312 | newTypeAbbrev :: Text -> HOLType -> HOL Theory thry () 313 | newTypeAbbrev s ty = 314 | overParseContext State.typeAbbrevs (mapInsert s ty) 315 | 316 | {-| 317 | Specifies a 'Text' for the parser to stop recognizing as a type 318 | abbreviation. 319 | -} 320 | removeTypeAbbrev :: Text -> HOL Theory thry () 321 | removeTypeAbbrev s = overParseContext State.typeAbbrevs (mapDelete s) 322 | 323 | {-| 324 | Returns all 'Text's currently acting as type abbreviations in the parser 325 | paired with their associated types. 326 | -} 327 | typeAbbrevs :: HOL cls thry (Map Text HOLType) 328 | typeAbbrevs = viewParseContext State.typeAbbrevs 329 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Parser/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, PatternSynonyms, TypeFamilies #-} 2 | {-| 3 | Module: HaskHOL.Core.Parser.Lib 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines or re-exports common utility functions, type classes, 12 | and auxilliary data types used in HaskHOL's parsers. These primarily fall 13 | three classes of objects: 14 | 15 | * Types and functions used by the parsers. 16 | 17 | * Benign flag and state extensions used by the parsers. 18 | 19 | * Predicates and modifiers for state extensions used by the parsers. 20 | 21 | To see what is actually exported to the user, see the module 22 | "HaskHOL.Core.Parser". 23 | -} 24 | 25 | module HaskHOL.Core.Parser.Lib 26 | ( -- * Parser Utilities and Types 27 | PreType(..) 28 | , PreTerm(..) 29 | , dpty 30 | , pretypeOfType 31 | , MyParser 32 | , ParseError 33 | , ParseContext 34 | , runHOLParser 35 | , parseContext 36 | , initParseContext 37 | , runParser 38 | , langDef 39 | , lexer 40 | , mysymbol 41 | , myparens 42 | , mybraces 43 | , mybrackets 44 | , mycommaSep1 45 | , mysemiSep 46 | , mysemiSep1 47 | , myreserved 48 | , myidentifier 49 | , myinteger 50 | , myoperator 51 | , myreservedOp 52 | , choiceSym 53 | , choiceId 54 | , mywhiteSpace 55 | , mymany 56 | , mymany1 57 | , mysepBy1 58 | , mytry 59 | , (<|>) 60 | -- * Parser state manipulations 61 | , getState 62 | , gets 63 | , setState 64 | , updateState 65 | ) where 66 | 67 | import HaskHOL.Core.Lib hiding ((<|>), ()) 68 | import HaskHOL.Core.Kernel 69 | import HaskHOL.Core.State.Monad 70 | 71 | import Text.Parsec hiding 72 | (runParser, setState, getState, updateState,ParseError) 73 | import qualified Text.Parsec as P 74 | import Text.Parsec.Language 75 | import Text.Parsec.Token 76 | 77 | import Control.Lens hiding (op) 78 | 79 | 80 | -- | Parsed, but pre-elaborated HOL types. 81 | data PreType 82 | = PTyCon !Text 83 | | UTyVar !Bool !Text !Int 84 | | STyVar !Integer 85 | | PTyComb !PreType ![PreType] 86 | | PUTy !PreType !PreType 87 | deriving (Eq, Show) 88 | 89 | -- | Parsed, but pre-elaborated HOL terms. 90 | data PreTerm 91 | = PVar !Text !PreType 92 | | PConst !Text !PreType 93 | | PComb !PreTerm !PreTerm 94 | | PAbs !PreTerm !PreTerm 95 | | PAs !PreTerm !PreType 96 | | PInst ![(PreType, Text)] !PreTerm 97 | | PApp !PreType 98 | | TyPAbs !PreType !PreTerm 99 | | TyPComb !PreTerm !PreType !PreType 100 | deriving (Eq, Show) 101 | 102 | -- | A re-export of 'P.ParseError'. 103 | type ParseError = P.ParseError 104 | 105 | -- | The default 'PreType' to be used as a blank for the type inference engine. 106 | dpty :: PreType 107 | dpty = PTyComb (PTyCon textEmpty) [] 108 | 109 | -- | Converts a 'HOLType' to 'PreType' 110 | pretypeOfType :: HOLType -> PreType 111 | pretypeOfType (TyVar f v) = UTyVar f v 0 112 | pretypeOfType (TyApp tyop args) = 113 | let (s, n) = destTypeOp tyop 114 | tyop' = if n == -1 then UTyVar False s (length args) else PTyCon s in 115 | PTyComb tyop' $ map pretypeOfType args 116 | pretypeOfType (UType tv tb) = 117 | PUTy (pretypeOfType tv) $ pretypeOfType tb 118 | pretypeOfType _ = error "pretypeOfType: exhaustive warning." 119 | 120 | {-| 121 | An alias to a stateful 'GenParser' that carries a 'HOLContext', a list of 122 | known type operator variables with their arity, and a counter The list of 123 | operators is used to guarantee that all instances of a type operator variable 124 | in a term have the same arity. The counter is used to generate fresh names 125 | in a term. 126 | -} 127 | type MyParser = Parsec Text (Map Text Int, Int, ParseContext) 128 | 129 | {-| Runs a custom parser when provided with an input 'String' and a 130 | 'HOLContext'. 131 | -} 132 | runHOLParser :: MonadThrow m => MyParser a -> ParseContext -> Text -> m a 133 | runHOLParser parser ctxt input = 134 | either (fail' . show) return $ runParser parser (mapEmpty, 0, ctxt) "" input 135 | 136 | -- | The Parsec 'LanguageDef' for HaskHOL. 137 | langDef :: Monad m => GenLanguageDef Text st m 138 | langDef = LanguageDef 139 | { commentStart = "" 140 | , commentEnd = "" 141 | , commentLine = "" 142 | , nestedComments = True 143 | , identStart = alphaNum <|> char '_' 144 | , identLetter = alphaNum <|> oneOf "_'" 145 | , opStart = oneOf ",:!#$%&*+./<=>?@\\^|-~" 146 | , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" 147 | , reservedNames = [ "TYINST", "let", "and", "in", "if", "then", "else" 148 | , "match", "with", "when", "function" ] 149 | , reservedOpNames = ["(", ")", "[", "]", "{", "}" 150 | , "%", "_", "'", "->", ".", ":", ";", "|"] 151 | , caseSensitive = True 152 | } 153 | 154 | -- | The Parsec token parser for HaskHOL. 155 | lexer :: GenTokenParser Text (Map Text Int, Int, ParseContext) Identity 156 | lexer = makeTokenParser langDef 157 | 158 | -- | A version of 'symbol' for our language. 159 | mysymbol :: String -> MyParser Text 160 | mysymbol s = pack `fmap` symbol lexer s 161 | 162 | -- | A version of 'parens' for our language. 163 | myparens :: MyParser a -> MyParser a 164 | myparens = parens lexer 165 | 166 | -- | A version of 'braces' for our language. 167 | mybraces :: MyParser a -> MyParser a 168 | mybraces = braces lexer 169 | 170 | -- | A version of 'brackets' for our language. 171 | mybrackets :: MyParser a -> MyParser a 172 | mybrackets = brackets lexer 173 | 174 | -- | A version of 'commaSep1' for our language. 175 | mycommaSep1 :: MyParser a -> MyParser [a] 176 | mycommaSep1 = commaSep1 lexer 177 | 178 | -- | A version of 'semiSep' for our language. 179 | mysemiSep :: MyParser a -> MyParser [a] 180 | mysemiSep = semiSep lexer 181 | 182 | -- | A version of 'semiSep1' for our language. 183 | mysemiSep1 :: MyParser a -> MyParser [a] 184 | mysemiSep1 = semiSep1 lexer 185 | 186 | -- | A version of 'reserved' for our language. 187 | myreserved :: String -> MyParser () 188 | myreserved = reserved lexer 189 | 190 | -- | A version of 'identifier' for our language. 191 | myidentifier :: MyParser Text 192 | myidentifier = pack `fmap` identifier lexer 193 | 194 | -- | A version of 'integer' for our language. 195 | myinteger :: MyParser Integer 196 | myinteger = integer lexer 197 | 198 | -- | A version of 'operator' for our language. 199 | myoperator :: MyParser Text 200 | myoperator = pack `fmap` operator lexer 201 | 202 | -- | A version of 'reservedOp' for our language. 203 | myreservedOp :: String -> MyParser () 204 | myreservedOp = reservedOp lexer 205 | 206 | -- | Selects the first matching symbol. 207 | choiceSym :: [String] -> MyParser Text 208 | choiceSym ops = choice $ map mysymbol ops 209 | 210 | -- | Selects the first matching reserved operator. 211 | choiceId :: [Text] -> MyParser Text 212 | choiceId ops = choice $ map 213 | (\ s -> mytry $ do s' <- myidentifier <|> myoperator 214 | if s' == s 215 | then return s 216 | else fail "choiceId") ops 217 | 218 | -- | A version of 'whiteSpace' for our language. 219 | mywhiteSpace :: MyParser () 220 | mywhiteSpace = whiteSpace lexer 221 | 222 | -- | A re-export of 'P.many'. 223 | mymany :: MyParser a -> MyParser [a] 224 | mymany = P.many 225 | 226 | -- | A re-export of 'P.many1'. 227 | mymany1 :: MyParser a -> MyParser [a] 228 | mymany1 = P.many1 229 | 230 | -- | A re-export of 'P.sepBy1'. 231 | mysepBy1 :: MyParser a -> MyParser b -> MyParser [a] 232 | mysepBy1 = P.sepBy1 233 | 234 | -- | A re-export of 'P.try'. 235 | mytry :: MyParser a -> MyParser a 236 | mytry = P.try 237 | 238 | -- Re-exports 239 | -- | A re-export of 'P.runParserT'. 240 | runParser :: Stream s Identity t => Parsec s u a -> u -> SourceName -> s 241 | -> Either ParseError a 242 | runParser = P.runParser 243 | 244 | -- | A re-export of 'P.getState'. 245 | getState :: Monad m => P.ParsecT s u m u 246 | getState = P.getState 247 | 248 | -- | A version of 'getState' that retrieves a specified field of the context. 249 | gets :: Monad m => (u3 -> a) -> P.ParsecT s (u1, u2, u3) m a 250 | gets f = 251 | do (_, _, ctxt) <- getState 252 | return $! f ctxt 253 | 254 | -- | A re-export of 'P.setState'. 255 | setState :: Monad m => u -> P.ParsecT s u m () 256 | setState = P.setState 257 | 258 | -- | A re-export of 'P.updateState'. 259 | updateState :: Monad m => (u -> u) -> P.ParsecT s u m () 260 | updateState = P.updateState 261 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Parser/Rep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, 2 | TypeSynonymInstances #-} 3 | {-| 4 | Module: HaskHOL.Core.Parser.Rep 5 | Copyright: (c) Evan Austin 2015 6 | LICENSE: BSD3 7 | 8 | Maintainer: e.c.austin@gmail.com 9 | Stability: unstable 10 | Portability: unknown 11 | 12 | This module defines conversions for alternative type and term representations 13 | via the 'HOLTermRep' and 'HOLTypeRep' classes. 14 | 15 | The most commonly used alternative representations are 'Text' and protected 16 | terms/types as produced by the "HaskHOL.Core.Ext" module. 17 | -} 18 | module HaskHOL.Core.Parser.Rep where 19 | 20 | import HaskHOL.Core.Lib 21 | import HaskHOL.Core.Kernel 22 | import HaskHOL.Core.State.Monad 23 | 24 | import HaskHOL.Core.Ext.Protected 25 | 26 | import HaskHOL.Core.Parser.Lib 27 | import HaskHOL.Core.Parser.Elab 28 | import HaskHOL.Core.Parser.TypeParser 29 | import HaskHOL.Core.Parser.TermParser 30 | 31 | -- Types 32 | {-| 33 | The 'HOLTypeRep' class provides a conversion from an alternative 34 | representation of types to 'HOLType' within the 'HOL' monad. 35 | 36 | The first parameter is the type of the alternative representation. 37 | 38 | The second parameter is the classification of the monad computation. This 39 | is used to assert type equality when converting between monadic 40 | representations. 41 | 42 | The third parameter is the tag for the last checkpoint of the 43 | current working theory. This enables us to safely have conversions between 44 | representations that are theory dependent. 45 | -} 46 | class HOLTypeRep a cls thry where 47 | -- | Conversion from alternative type @a@ to 'HOLType'. 48 | toHTy :: a -> HOL cls thry HOLType 49 | 50 | instance HOLTypeRep Text cls thry where 51 | toHTy x = do ctxt <- parseContext 52 | pty <- holTypeParser ctxt x 53 | tyElab ctxt pty 54 | 55 | instance thry1 ~ thry2 => HOLTypeRep (PType thry1) cls thry2 where 56 | toHTy = serve 57 | 58 | instance HOLTypeRep PreType cls thry where 59 | toHTy x = do ctxt <- parseContext 60 | tyElab ctxt x 61 | 62 | instance HOLTypeRep HOLType cls thry where 63 | toHTy = return 64 | 65 | instance HOLTypeRep (Catch HOLType) cls thry where 66 | toHTy = either (fail . show) return . runCatch 67 | 68 | instance (cls1 ~ cls2, thry1 ~ thry2) => 69 | HOLTypeRep (HOL cls1 thry1 HOLType) cls2 thry2 where 70 | toHTy = id 71 | 72 | -- Terms 73 | {-| 74 | The 'HOLTermRep' class provides a conversion from an alternative 75 | representation of terms to 'HOLTerm' within the 'HOL' monad. 76 | 77 | The second parameter is the classification of the monad computation. This 78 | is used to assert type equality when converting between monadic 79 | representations. 80 | 81 | The third parameter is the tag for the last checkpoint of the 82 | current working theory. This enables us to safely have conversions between 83 | representations that are theory dependent. 84 | -} 85 | class HOLTermRep a cls thry where 86 | -- | Conversion from alternative type @a@ to 'HOLTerm'. 87 | toHTm :: a -> HOL cls thry HOLTerm 88 | 89 | instance HOLTermRep Text cls thry where 90 | toHTm x = do ctxt <- parseContext 91 | ptm <- holTermParser ctxt x 92 | elab ctxt ptm 93 | 94 | instance thry1 ~ thry2 => HOLTermRep (PTerm thry1) cls thry2 where 95 | toHTm = serve 96 | 97 | instance HOLTermRep PreTerm cls thry where 98 | toHTm tm = do ctxt <- parseContext 99 | elab ctxt tm 100 | 101 | instance HOLTermRep HOLTerm cls thry where 102 | toHTm = return 103 | 104 | instance HOLTermRep (Catch HOLTerm) cls thry where 105 | toHTm = either (fail . show) return . runCatch 106 | 107 | instance (cls1 ~ cls2, thry1 ~ thry2) => 108 | HOLTermRep (HOL cls1 thry1 HOLTerm) cls2 thry2 where 109 | toHTm = id 110 | 111 | -- Theorems 112 | {-| 113 | The 'HOLThmRep' class provides a conversion from an alternative 114 | representation of theorems to 'HOLThm' within the 'HOL' monad. 115 | 116 | The second parameter is the classification of the monad computation. This 117 | is used to assert type equality when converting between monadic 118 | representations. 119 | 120 | The third parameter is the tag for the last checkpoint of the 121 | current working theory. This enables us to safely have conversions between 122 | representations that are theory dependent. 123 | -} 124 | class HOLThmRep a cls thry where 125 | -- | Conversion from alternative type @a@ to 'HOLThm'. 126 | toHThm :: a -> HOL cls thry HOLThm 127 | 128 | instance HOLThmRep HOLThm cls thry where 129 | toHThm = return 130 | 131 | instance HOLThmRep (Catch HOLThm) cls thry where 132 | toHThm = either (fail . show) return . runCatch 133 | 134 | instance (cls1 ~ cls2, thry1 ~ thry2) => 135 | HOLThmRep (HOL cls1 thry1 HOLThm) cls2 thry2 where 136 | toHThm = id 137 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Parser/TermParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 2 | {-| 3 | Module: HaskHOL.Core.Parser.TermParser 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines the parser for 'HOLTerm's that satisfies the following BNF 12 | grammar: 13 | 14 | @ 15 | PRETERM :: APPL_PRETERM binop APPL_PRETERM 16 | | APPL_PRETERM 17 | 18 | APPL_PRETERM :: BINDER_PRETERM+ 19 | | BINDER_PRETERM : type 20 | 21 | BINDER_PRETERM :: tybinder small-type-variables . PRETERM 22 | | binder VARSTRUCT_PRETERM+ . PRETERM 23 | | let PRETERM and ... and PRETERM in PRETERM 24 | | TYPED_PRETERM 25 | 26 | TYPED_PRETERM :: TYINST (tyop-var : PRETYPE)+ ATOMIC_PRETERM 27 | | ATOMIC_PRETERM 28 | 29 | VARSTRUCT_PRETERM :: ATOMIC_PRETERM : type 30 | | ATOMIC_PRETERM 31 | 32 | ATOMIC_PRETERM :: ( PRETERM ) 33 | | [: type] 34 | | [ PRETERM; .. ; PRETERM ] 35 | | if PRETERM then PRETERM else PRETERM 36 | | match PRETERM with CLAUSES 37 | | function CLAUSES 38 | | identifier 39 | 40 | CLAUSES :: PATTERN -> PRETERM | .. | PATTERN -> PRETERM 41 | 42 | PATTERN :: PRETERM when PRETERM 43 | | PRETERM 44 | @ 45 | 46 | Note that arbitrary atomic preterms, typed or untyped, are allowed as 47 | varstructs in order to simplify parsing. We do not make the same 48 | simplification for @TYINST@ terms in order to avoid the mixing of terms, 49 | types, and type operators. 50 | 51 | Also note that a number of advanced HOL term features, mostly relating to sets 52 | and patterns, are not currently supported by the parser. These will be added 53 | in as the relevant logic libraries are added to the system. 54 | 55 | As a heads up, the error messages thrown by this parser leave much to be 56 | desired. 57 | -} 58 | module HaskHOL.Core.Parser.TermParser 59 | ( pterm 60 | , holTermParser 61 | ) where 62 | 63 | import HaskHOL.Core.Lib hiding ((<|>)) 64 | import HaskHOL.Core.Parser.Lib 65 | import HaskHOL.Core.Parser.TypeParser 66 | import HaskHOL.Core.State.Monad 67 | 68 | import Control.Lens (view, views) 69 | 70 | -- | Parser for 'HOLTerm's. 71 | holTermParser :: MonadThrow m => ParseContext -> Text -> m PreTerm 72 | holTermParser = runHOLParser pterm 73 | 74 | -- | Parse method for HOL terms. 75 | pterm :: MyParser PreTerm 76 | pterm = 77 | (do mywhiteSpace 78 | expressionParser ptyped) 79 | <|> (do s <- myidentifier <|> myoperator 80 | return $! PVar s dpty) 81 | 82 | ptyped :: MyParser PreTerm 83 | ptyped = pas =<< pappl 84 | 85 | pappl :: MyParser PreTerm 86 | pappl = 87 | (do p <- pprefix 88 | tm <- pappl 89 | return $! PComb (PVar p dpty) tm) 90 | <|> do (tm:tms) <- mymany1 pbinder 91 | return $! foldr (flip PComb) tm (reverse tms) 92 | 93 | pprefix :: MyParser Text 94 | pprefix = choiceId =<< gets (view prefixes) 95 | 96 | pbinder :: MyParser PreTerm 97 | pbinder = 98 | (do myreserved "let" 99 | tms <- pterm `mysepBy1` myreserved "and" 100 | myreserved "in" 101 | bod <- pterm 102 | case mkLet tms bod of 103 | Nothing -> fail "pterm: invalid let construction" 104 | Just tm -> return tm) 105 | <|> (do bind <- choiceId =<< gets (view binders) 106 | (do vars <- mymany1 pvar 107 | myreservedOp "." 108 | bod <- pterm 109 | return $! mkBinders bind vars bod) 110 | <|> (return $! PVar bind dpty)) 111 | <|> (do bind <- choiceId =<< gets (view tyBinders) 112 | (do vars <- mymany1 psmall 113 | myreservedOp "." 114 | bod <- pterm 115 | return $! mkTyBinders bind vars bod) 116 | <|> (return $! PVar bind dpty)) 117 | <|> pinst 118 | 119 | psmall :: MyParser PreType 120 | psmall = 121 | do myreservedOp "'" 122 | x <- myidentifier 123 | return $! UTyVar True x 0 124 | 125 | pinst :: MyParser PreTerm 126 | pinst = 127 | (do myreserved "TYINST" 128 | vars <- mymany1 pinst' 129 | tm <- patomic 130 | return $! PInst vars tm) 131 | <|> patomic 132 | where pinst' :: MyParser (PreType, Text) 133 | pinst' = myparens $ do myreservedOp "_" 134 | x <- myidentifier 135 | myreservedOp ":" 136 | ty <- ptype 137 | return (ty, x) 138 | 139 | pvar :: MyParser PreTerm 140 | pvar = pas =<< patomic 141 | 142 | pas :: PreTerm -> MyParser PreTerm 143 | pas tm = 144 | (do myreservedOp ":" 145 | ty <- ptype 146 | return $! PAs tm ty) <|> return tm 147 | 148 | patomic :: MyParser PreTerm 149 | patomic = 150 | myparens ((do myreservedOp ":" 151 | ty <- ptype 152 | return $! PAs (PVar "UNIV" dpty) 153 | (PTyComb (PTyCon "fun") 154 | [ty, PTyComb (PTyCon "bool") []])) 155 | <|> mytry pterm 156 | <|> (do s <- myidentifier <|> myoperator 157 | return (PVar s dpty))) 158 | <|> (do myreserved "if" 159 | c <- pterm 160 | myreserved "then" 161 | t <- pterm 162 | myreserved "else" 163 | e <- pterm 164 | return $! PComb (PComb (PComb (PVar "COND" dpty) c) t) e) 165 | <|> mybrackets 166 | ((do myreservedOp ":" 167 | ty <- ptype 168 | return $! PApp ty) 169 | <|> (do tms <- mysemiSep pterm 170 | return (foldr (\ x y -> PVar "CONS" dpty `PComb` 171 | x `PComb` y) 172 | (PVar "NIL" dpty) tms))) 173 | {- 174 | <|> mybraces 175 | ((do tms <- mycommaSep pterm 176 | return $! foldr (\ x y -> PComb (PComb (PVar "INSERT" dpty) x) y) 177 | (PVar "EMPTY" dpty) tms) 178 | <|> (do tms <- pterm `sepBy1` myreservedOp "|" 179 | case tms of 180 | (l:r:[]) -> pmkSetAbs l r 181 | (f:v:b:[]) -> pmkSetCompr f (pfrees vs []) b 182 | _ -> fail "patomic: bad set construction.")) 183 | -} 184 | <|> (do myreserved "match" 185 | e <- pterm 186 | myreserved "with" 187 | c <- pclauses 188 | return $! PComb (PComb (PVar "_MATCH" dpty) e) c) 189 | <|> (do myreserved "function" 190 | c <- pclauses 191 | return $! PComb (PVar "_FUNCTION" dpty) c) 192 | <|> mytry (do x <- myidentifier <|> myoperator 193 | ops1 <- gets $ view prefixes 194 | ops2 <- gets $ views infixes (map fst) 195 | ops3 <- gets $ view binders 196 | ops4 <- gets $ view tyBinders 197 | if any (x `elem`) [ops1, ops2, ops3, ops4] 198 | then fail "patomic" 199 | else return $! PVar x dpty) 200 | 201 | pclauses :: MyParser PreTerm 202 | pclauses = 203 | do c <- pclause `mysepBy1` myreservedOp "|" 204 | return $! foldr1 (\ s t -> PComb (PComb (PVar "_SEQPATTERN" dpty) s) t) c 205 | where pclause :: MyParser PreTerm 206 | pclause = do (pat:guards) <- pterm `mysepBy1` myreserved "when" 207 | myreservedOp "->" 208 | res <- pterm 209 | mkPattern pat guards res 210 | 211 | -- helper functions 212 | pgenVar :: MyParser PreTerm 213 | pgenVar = 214 | do (ops, n, ctxt) <- getState 215 | setState (ops, succ n, ctxt) 216 | return $! PVar (pack $ "_GENPVAR_" ++ show n) dpty 217 | 218 | pfrees :: PreTerm -> [PreTerm] -> MyParser [PreTerm] 219 | pfrees ptm@(PVar v pty) acc 220 | | textNull v && pty == dpty = return acc 221 | | otherwise = 222 | do cond1 <- getConstType' v 223 | let cond2 = test' (numOfString (unpack v) :: Catch Integer) 224 | cond3 <- getInterface' v 225 | if cond1 || cond2 || cond3 226 | then return acc 227 | else return $! ptm `insert` acc 228 | pfrees PConst{} acc = return acc 229 | pfrees (PComb p1 p2) acc = pfrees p1 =<< pfrees p2 acc 230 | pfrees (PAbs p1 p2) acc = 231 | do p1s <- pfrees p1 [] 232 | p2s <- pfrees p2 acc 233 | return $! p2s \\ p1s 234 | pfrees (PAs p _) acc = pfrees p acc 235 | pfrees (PInst _ p) acc = pfrees p acc 236 | pfrees PApp{} acc = return acc 237 | pfrees (TyPAbs _ p) acc = pfrees p acc 238 | pfrees (TyPComb p _ _) acc = pfrees p acc 239 | 240 | 241 | pdestEq :: MonadThrow m => PreTerm -> m (PreTerm, PreTerm) 242 | pdestEq (PComb (PComb (PVar "=" _) l) r) = return (l, r) 243 | pdestEq (PComb (PComb (PVar "<=>" _) l) r) = return (l, r) 244 | pdestEq _ = fail' "pdestEq" 245 | 246 | mkLet :: [PreTerm] -> PreTerm -> Maybe PreTerm 247 | mkLet binds bod = case length tms of 248 | 0 -> Nothing 249 | _ -> Just $ foldl PComb letstart tms 250 | where (vars, tms) = unzip $ mapFilter pdestEq binds 251 | letend = PComb (PVar "LET_END" dpty) bod 252 | ab = foldr PAbs letend vars 253 | letstart = PComb (PVar "LET" dpty) ab 254 | 255 | mkBinder :: Text -> PreTerm -> PreTerm -> PreTerm 256 | mkBinder "\\" v bod = PAbs v bod 257 | mkBinder n v bod = PComb (PVar n dpty) $ PAbs v bod 258 | 259 | mkBinders :: Text -> [PreTerm] -> PreTerm -> PreTerm 260 | mkBinders bind vars bod = foldr (mkBinder bind) bod vars 261 | 262 | mkTyBinder :: Text -> PreType -> PreTerm -> PreTerm 263 | mkTyBinder "\\\\" v bod = TyPAbs v bod 264 | mkTyBinder n v bod = PComb (PVar n dpty) $ TyPAbs v bod 265 | 266 | mkTyBinders :: Text -> [PreType] -> PreTerm -> PreTerm 267 | mkTyBinders bind vars bod = foldr (mkTyBinder bind) bod vars 268 | 269 | mkPattern :: PreTerm -> [PreTerm] -> PreTerm -> MyParser PreTerm 270 | mkPattern pat guards res = 271 | do x <- pgenVar 272 | y <- pgenVar 273 | vs <- pfrees pat [] 274 | let bod = if null guards 275 | then PComb (PComb (PVar "_UNGUARDED_PATTERN" dpty) $ 276 | mkGEQ pat x) $ mkGEQ res y 277 | else PComb (PComb (PComb (PVar "_GUARDED_PATTERN" dpty) $ 278 | mkGEQ pat x) $ head guards) $ mkGEQ res y 279 | return . PAbs x . PAbs y $ foldr mkExists bod vs 280 | where mkGEQ :: PreTerm -> PreTerm -> PreTerm 281 | mkGEQ l = PComb (PComb (PVar "GEQ" dpty) l) 282 | 283 | mkExists :: PreTerm -> PreTerm -> PreTerm 284 | mkExists v ptm = PComb (PVar "?" dpty) $ PAbs v ptm 285 | 286 | 287 | -- build expression parser from infix operators in context 288 | expressionParser :: MyParser PreTerm -> MyParser PreTerm 289 | expressionParser prs = expressionParser' =<< gets (view infixes) 290 | where expressionParser' :: [(Text, (Int, Text))] 291 | -> MyParser PreTerm 292 | expressionParser' [] = prs 293 | expressionParser' infxs@((_, (p, at)):_) = 294 | let (topins, rest) = partition (\ (_, pat') -> 295 | pat' == (p, at)) infxs 296 | parse' = if at == "right" then pRightBinary 297 | else pLeftBinary in 298 | parse' (expressionParser' rest) 299 | (choiceId (map fst topins)) 300 | (\ op x y -> PComb (PComb (PVar op dpty) x) y) 301 | 302 | sepPair :: MyParser Text -> MyParser PreTerm -> MyParser [(Text, PreTerm)] 303 | sepPair sep prs = 304 | mymany (do l <- sep 305 | r <- prs 306 | return (l, r)) 307 | 308 | pRightBinary :: MyParser PreTerm -> MyParser Text 309 | -> (Text -> PreTerm -> PreTerm -> PreTerm) 310 | -> MyParser PreTerm 311 | pRightBinary prs sep cns = 312 | do x <- prs 313 | opxs <- sepPair sep prs 314 | if null opxs 315 | then return x 316 | else let (ops, xs) = unzip opxs in 317 | case foldr2 cns (last xs) ops (x:init xs) of 318 | Just res -> return res 319 | _ -> fail "pRightBinary" 320 | 321 | pLeftBinary :: MyParser PreTerm -> MyParser Text 322 | -> (Text -> PreTerm -> PreTerm -> PreTerm) 323 | -> MyParser PreTerm 324 | pLeftBinary prs sep cns = 325 | do x <- prs 326 | opxs <- sepPair sep prs 327 | let (ops, xs) = unzip opxs in 328 | case foldr2 (\ op l r -> cns op r l) x (reverse ops) (reverse xs) of 329 | Just res -> return res 330 | _ -> fail "pLeftBinary" 331 | 332 | -- pure versions of stateful methods 333 | getConstType' :: Text -> MyParser Bool 334 | getConstType' x = gets $ views termConstants (test' . mapAssoc x) 335 | 336 | getInterface' :: Text -> MyParser Bool 337 | getInterface' x = gets $ views interface (test' . assoc x) 338 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Parser/TypeParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-| 3 | Module: HaskHOL.Core.Parser.TypeParser 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines the parser for 'HOLType's that satisfies the following BNF 12 | grammar: 13 | 14 | @ 15 | TYPE :: % small-type-variables . TYPE 16 | | SUMTYPE -> TYPE 17 | | SUMTYPE 18 | 19 | SUMTYPE :: PRODTYPE + SUMTYPE 20 | | PRODTYPE 21 | 22 | PRODTYPE :: POWTYPE # PRODTYPE 23 | | POWTYPE 24 | 25 | POWTYPE :: APPTYPE ^ POWTYPE 26 | | POWTYPE 27 | 28 | APPTYPE :: ( TYPELIST ) type-constructor [Provided arity matches] 29 | | ( TYPELIST ) tyop-var [Provided arity matches or fresh] 30 | | small-type-variables+ tyop-var [Special case of above] 31 | | ( TYPE ) 32 | | ATOMICTYPE 33 | 34 | ATOMICTYPE :: type-constructor [Provided arity zero] 35 | | tyop-var [Provided arity zero or fresh] 36 | | type-variable [Large or Small] 37 | 38 | TYPELIST :: TYPE , TYPELIST 39 | | TYPE 40 | @ 41 | 42 | Note that this module also exposes a parser for small type variables to be 43 | used by the term parser. 44 | 45 | As a heads up, the error messages thrown by this parser leave much to be 46 | desired. 47 | -} 48 | module HaskHOL.Core.Parser.TypeParser 49 | ( ptype 50 | , holTypeParser 51 | ) where 52 | 53 | import HaskHOL.Core.Lib hiding ((<|>)) 54 | import HaskHOL.Core.Parser.Lib 55 | import HaskHOL.Core.Kernel.Types 56 | import HaskHOL.Core.State.Monad 57 | 58 | import Control.Lens (view) 59 | 60 | -- | Parser for 'HOLType's. 61 | holTypeParser :: MonadThrow m => ParseContext -> Text -> m PreType 62 | holTypeParser = runHOLParser ptype 63 | 64 | -- | Parse method for HOL types. 65 | ptype :: MyParser PreType 66 | ptype = 67 | mywhiteSpace >> (putype <|> pbinty "->" "fun" psumty ptype) 68 | 69 | psmall :: MyParser PreType 70 | psmall = 71 | do myreservedOp "'" 72 | x <- myidentifier 73 | return $! UTyVar True x 0 74 | 75 | popvar :: MyParser (Either PreType PreType) 76 | popvar = 77 | do myreservedOp "_" 78 | x <- myidentifier 79 | {- 80 | Tracks introduction of type operator variables to make sure that all 81 | tyopvars of the same name in a term are of the same arity. 82 | Left is fresh. 83 | Right is existing. 84 | -} 85 | let x' = '_' `cons` x 86 | (opvars, _, _) <- getState 87 | case runCatch $ mapAssoc x' opvars of 88 | Left{} -> return . Left $ UTyVar False x' 0 89 | Right n -> return . Right $ UTyVar False x' n 90 | 91 | pbinty :: String -> Text -> MyParser PreType -> MyParser PreType 92 | -> MyParser PreType 93 | pbinty op name pty1 pty2 = 94 | do ty1 <- pty1 95 | (do myreservedOp op 96 | ty2 <- pty2 97 | return $! PTyComb (PTyCon name) [ty1, ty2]) 98 | <|> return ty1 99 | 100 | putype :: MyParser PreType 101 | putype = 102 | do myreservedOp "%" 103 | tvs <- mymany1 psmall 104 | myreservedOp "." 105 | ty <- ptype 106 | return $! foldr PUTy ty tvs 107 | 108 | psumty :: MyParser PreType 109 | psumty = pbinty "+" "sum" pprodty psumty 110 | 111 | pprodty :: MyParser PreType 112 | pprodty = pbinty "#" "prod" ppowty pprodty 113 | 114 | ppowty :: MyParser PreType 115 | ppowty = pbinty "^" "cart" pappty ppowty 116 | 117 | pappty :: MyParser PreType 118 | pappty = 119 | do tys <- myparens $ mycommaSep1 ptype 120 | (do c <- popvar 121 | case c of 122 | Left (UTyVar _ s _) -> 123 | -- fresh ty op var so add it to state 124 | let n = length tys in 125 | do updateState (\ (ops, cnt, ctxt) -> 126 | (mapInsert s n ops, cnt, ctxt)) 127 | let c' = UTyVar False s n 128 | return $! PTyComb c' tys 129 | Right c'@(UTyVar _ _ n) -> 130 | -- existing ty op var so check arity 131 | if n == length tys 132 | then return $! PTyComb c' tys 133 | else fail "type parser: bad arity for type application" 134 | _ -> fail $ "type parser: unrecognized case for type operator " ++ 135 | "variable") 136 | <|> ((do x <- myidentifier 137 | ar <- getTypeArity' x 138 | case ar of 139 | Nothing -> fail $ "type parser: unsupported type " ++ 140 | "variable application." 141 | Just n 142 | | n == length tys -> 143 | return $! PTyComb (PTyCon x) tys 144 | | otherwise -> 145 | fail "type parser: bad arity for type application") 146 | <|> (case tys of 147 | [ty] -> return ty 148 | _ -> fail "type parser: unexpected list of types")) 149 | <|> mytry (do tys <- mymany1 psmall 150 | c <- popvar 151 | case c of 152 | Left (UTyVar _ s _) -> 153 | let n = length tys in 154 | do updateState (\ (ops, cnt, ctxt) -> 155 | (mapInsert s n ops, cnt, ctxt)) 156 | return $! PTyComb (UTyVar False s n) tys 157 | Right c'@(UTyVar _ _ n) -> 158 | if n == length tys 159 | then return $! PTyComb c' tys 160 | else fail "type parser: bad type operator application." 161 | _ -> fail "type parser: unrecognized case for type operator.") 162 | <|> (do ty <- patomty 163 | mytry (do x <- myidentifier 164 | ar <- getTypeArity' x 165 | case ar of 166 | Nothing -> fail $ "type parser: unrecognized constant" 167 | ++ " in unary application." 168 | Just n -> 169 | if n == 1 170 | then return $! PTyComb (PTyCon x) [ty] 171 | else fail $ "type parser: bad arity for unary type" 172 | ++ " application") 173 | <|> return ty) 174 | 175 | patomty :: MyParser PreType 176 | patomty = 177 | psmall 178 | <|> (do c <- popvar 179 | case c of 180 | Left c'@(UTyVar _ s 0) -> 181 | -- fresh ty-op of zero arity 182 | do updateState (\ (ops, cnt, ctxt) -> 183 | (mapInsert s 0 ops, cnt, ctxt)) 184 | return $! PTyComb c' [] 185 | Right c'@(UTyVar _ _ 0) -> 186 | return $! PTyComb c' [] 187 | _ -> fail $ "type parser: type operator variable of non-zero " ++ 188 | "arity outside of application") 189 | <|> (do x <- myidentifier 190 | tyabvs <- gets $ view typeAbbrevs 191 | case runCatch $ mapAssoc x tyabvs of 192 | Right ty -> return $! pretypeOfType ty 193 | Left{} -> 194 | do cond <- getTypeArity' x 195 | case cond of 196 | Nothing -> return $! UTyVar False x 0 197 | Just 0 -> return $! PTyComb (PTyCon x) [] 198 | _ -> fail "type parser: bad type construction") 199 | 200 | -- Pure versions of stateful methods 201 | getTypeArity' :: Text -> MyParser (Maybe Int) 202 | getTypeArity' x = 203 | do tys <- gets $ view typeConstants 204 | return $ (snd . destTypeOp) `fmap` mapAssoc x tys 205 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-| 3 | Module: HaskHOL.Core.Printer 4 | Copyright: (c) Evan Austin 2015 5 | LICENSE: BSD3 6 | 7 | Maintainer: e.c.austin@gmail.com 8 | Stability: unstable 9 | Portability: unknown 10 | 11 | This module defines pretty printers for 'HOLType's, 'HOLTerm's and 'HOLThm's. 12 | Note that the printers for terms and theorems are context dependent as they 13 | rely on the same theory extensions that the parsers utilize. 14 | 15 | To make printing these objects easier within HOL computations, this module 16 | also defines the 'showHOL' and 'printHOL' methods which will automatically 17 | retrieve the current working theory to use for pretty printing. Because the 18 | pretty printer for 'HOLType's is not context dependent it has definitions for 19 | both 'show' and 'showHOL'. 20 | 21 | Note that, like the parser, there are a number of HOL term forms that the 22 | printer does not currently support. Again, these are mainly related to sets 23 | and patterns and will be added in when the HaskHOL system has libraries for 24 | them. 25 | -} 26 | module HaskHOL.Core.Printer 27 | ( -- * Pretty Printers 28 | ppType 29 | , ppTerm 30 | , ppThm 31 | -- * Extensible Printer Operators 32 | , addUnspacedBinop 33 | , addPrebrokenBinop 34 | , removeUnspacedBinop 35 | , removePrebrokenBinop 36 | , getUnspacedBinops 37 | , getPrebrokenBinops 38 | -- * Printing in the 'HOL' Monad 39 | , PrintM 40 | , getPrec 41 | , setPrec 42 | , ShowHOL(..) 43 | , showHOL 44 | , printHOL 45 | ) where 46 | 47 | import Prelude hiding ((<$>)) 48 | import HaskHOL.Core.Lib hiding (ask, base) 49 | import HaskHOL.Core.Kernel 50 | import HaskHOL.Core.State.Monad 51 | import HaskHOL.Core.Basics 52 | 53 | import Control.Lens hiding (Const, op, cons, snoc) 54 | import Control.Monad.ST 55 | import Data.STRef 56 | import Control.Monad.Trans 57 | import Control.Monad.Trans.Reader 58 | 59 | import Text.PrettyPrint.ANSI.Leijen 60 | 61 | {-| 62 | The computational monad for our pretty-printer. 63 | Exposed for use in later libraries. 64 | -} 65 | type PrintM s = ReaderT (STRef s PrintState) (CatchT (ST s)) 66 | 67 | data PrintState = PrintState 68 | { _precedence :: !Int 69 | , _printCtxt :: ParseContext 70 | } 71 | 72 | makeLenses ''PrintState 73 | 74 | initPrintState :: ParseContext -> PrintState 75 | initPrintState = PrintState 0 76 | 77 | modPrintState :: (PrintState -> PrintState) -> PrintM s () 78 | modPrintState f = 79 | do ref <- ask 80 | lift . lift $ modifySTRef' ref f 81 | 82 | viewPrintState :: (PrintState -> a) -> PrintM s a 83 | viewPrintState f = 84 | do ref <- ask 85 | lift . lift $ f `fmap` readSTRef ref 86 | 87 | testPrintState :: (PrintState -> a) -> (a -> Bool) -> PrintM s Bool 88 | testPrintState f p = 89 | do ref <- ask 90 | p `fmap` (lift . lift $ f `fmap` readSTRef ref) 91 | 92 | -- utility functions 93 | {-| 94 | Specifies a symbol to be recognized as an unspaced, binary operator by the 95 | printer. Applications involving these operators will be built with the '<>' 96 | combinator as opposed to '<+>'. 97 | 98 | Note that technically this method should be considered benign, however, for 99 | simplicity of implementation it is defined using 'modifyExt' and thus must be 100 | tagged a 'Theory' computation. 101 | -} 102 | addUnspacedBinop :: Text -> HOL Theory thry () 103 | addUnspacedBinop op = 104 | overParseContext unspaced (\ ops -> nub (op:ops)) 105 | 106 | {-| 107 | Specifies a symbol to be recognized as a prebroken, binary operator by the 108 | printer. Applications involving these operators will have their right-hand 109 | side argument printed on the next line using the 'hang' combinator. 110 | 111 | Note that technically this method should be considered benign, however, for 112 | simplicity of implementation it is defined using 'modifyExt' and thus must be 113 | tagged a 'Theory' computation. 114 | -} 115 | addPrebrokenBinop :: Text -> HOL Theory thry () 116 | addPrebrokenBinop op = 117 | overParseContext prebroken (\ ops -> nub (op:ops)) 118 | 119 | {-| 120 | Specifies a symbol to stop being recognized as an unspaced, binary operator 121 | by the printer. 122 | 123 | Note that technically this method should be considered benign, however, for 124 | simplicity of implementation it is defined using 'modifyExt' and thus must be 125 | tagged a 'Theory' computation. 126 | -} 127 | removeUnspacedBinop :: Text -> HOL Theory thry () 128 | removeUnspacedBinop op = 129 | overParseContext unspaced (delete op) 130 | 131 | {-| 132 | Specifies a symbol to stop being recognized as an prebroken, binary operator 133 | by the printer. 134 | 135 | Note that technically this method should be considered benign, however, for 136 | simplicity of implementation it is defined using 'modifyExt' and thus must be 137 | tagged a 'Theory' computation. 138 | -} 139 | removePrebrokenBinop :: Text -> HOL Theory thry () 140 | removePrebrokenBinop op = 141 | overParseContext prebroken (delete op) 142 | 143 | {-| 144 | Returns the list of all symbols current recognized as unspaced, binary 145 | operators by the printer. 146 | -} 147 | getUnspacedBinops :: HOL cls thry [Text] 148 | getUnspacedBinops = 149 | viewParseContext unspaced 150 | 151 | {-| 152 | Returns the list of all symbols current recognized as prebroken, binary 153 | operators by the printer. 154 | -} 155 | getPrebrokenBinops :: HOL cls thry [Text] 156 | getPrebrokenBinops = 157 | viewParseContext prebroken 158 | 159 | -- | Returns the current precedence value from the pretty-printer's state. 160 | getPrec :: PrintM s Int 161 | getPrec = viewPrintState $ view precedence 162 | 163 | -- | Sets a new precedence value in the pretty-printer's state. 164 | setPrec :: Int -> PrintM s () 165 | setPrec = modPrintState . set precedence 166 | 167 | getInterface :: PrintM s [(Text, (Text, HOLType))] 168 | getInterface = viewPrintState $ view (printCtxt . interface) 169 | 170 | getLefts :: PrintM s [(Text, Int)] 171 | getLefts = viewPrintState $ view (printCtxt . lefts) 172 | 173 | getRights :: PrintM s [(Text, Int)] 174 | getRights = viewPrintState $ view (printCtxt . rights) 175 | 176 | parsesAsBinder :: Text -> PrintM s Bool 177 | parsesAsBinder op = testPrintState (view (printCtxt . binders)) (elem op) 178 | 179 | parsesAsTyBinder :: Text -> PrintM s Bool 180 | parsesAsTyBinder op = testPrintState (view (printCtxt . tyBinders)) (elem op) 181 | 182 | parsesAsPrefix :: Text -> PrintM s Bool 183 | parsesAsPrefix op = testPrintState (view (printCtxt . prefixes)) (elem op) 184 | 185 | unspacedBinops :: PrintM s [Text] 186 | unspacedBinops = viewPrintState $ view (printCtxt . unspaced) 187 | 188 | prebrokenBinops :: PrintM s [Text] 189 | prebrokenBinops = viewPrintState $ view (printCtxt . prebroken) 190 | 191 | -- | Pretty printer for 'HOLType's. 192 | ppType :: HOLType -> PrintM s Doc 193 | ppType (TyVar False x) = return $! pretty (unpack x) 194 | ppType (TyVar True x) = return . pretty . unpack $ '\'' `cons` x 195 | ppType ty = 196 | case destUTypes ty of 197 | Just (tvs, bod) -> 198 | do tvs' <- mapM ppType tvs 199 | bod' <- ppType bod 200 | return $! parens (char '%' <+> hsep tvs' <+> char '.' <+> bod') 201 | Nothing -> 202 | do prec <- getPrec 203 | (op, tys) <- destType ty 204 | let (name, ar) = destTypeOp op 205 | name' = if ar < 0 then '_' `cons` name else name 206 | if null tys 207 | then return . pretty $ unpack name 208 | else case (name', tys) of 209 | ("fun", [ty1,ty2]) -> 210 | do ty1' <- setPrec 1 >> ppType ty1 211 | ty2' <- setPrec 0 >> ppType ty2 212 | return $! ppTypeApp "->" (prec > 0) [ty1', ty2'] 213 | ("sum", [ty1,ty2]) -> 214 | do ty1' <- setPrec 3 >> ppType ty1 215 | ty2' <- setPrec 2 >> ppType ty2 216 | return $! ppTypeApp "+" (prec > 2) [ty1', ty2'] 217 | ("prod", [ty1,ty2]) -> 218 | do ty1' <- setPrec 5 >> ppType ty1 219 | ty2' <- setPrec 4 >> ppType ty2 220 | return $! ppTypeApp "#" (prec > 4) [ty1', ty2'] 221 | ("cart", [ty1,ty2]) -> 222 | do ty1' <- setPrec 6 >> ppType ty1 223 | ty2' <- setPrec 7 >> ppType ty2 224 | return $! ppTypeApp "^" (prec > 6) [ty1', ty2'] 225 | (bin, args) -> 226 | do args' <- mapM (\ x -> setPrec 0 >> ppType x) args 227 | return $! ppTypeApp "," True args' <+> 228 | pretty (unpack bin) 229 | where ppTypeApp :: String -> Bool -> [Doc] -> Doc 230 | ppTypeApp sepr flag ds = 231 | case tryFoldr1 (\ x y -> x <+> text sepr <+> y) ds of 232 | Nothing -> empty 233 | Just bod -> if flag then parens bod else bod 234 | 235 | 236 | -- Printer for Terms 237 | -- | Pretty printer for 'HOLTerm's. 238 | ppTerm :: HOLTerm -> PrintM s Doc 239 | ppTerm tm = 240 | -- numeral case 241 | (pretty `fmap` destNumeral tm) <|> 242 | -- List case 243 | (encloseSep lbracket rbracket semi `fmap` 244 | (mapM (\ x -> setPrec 0 >> ppTerm x) =<< destList tm)) <|> 245 | -- Type combination case 246 | (ppTyComb =<< destTyComb tm) <|> 247 | -- Let case 248 | (ppLet =<< destLet tm) <|> 249 | -- General abstraction case -- needs work 250 | if isGAbs tm then ppGAbs tm 251 | else let (hop, args) = stripComb tm in 252 | -- Base term abstraction case 253 | if isAbs hop && null args then ppBinder "\\" False hop 254 | -- Base type abstraction case 255 | else if isTyAbs hop && null args then ppBinder "\\\\" True hop 256 | -- Reverse interface for other cases 257 | else let s0 = nameOf hop 258 | ty0 = typeOf hop in 259 | do s <- reverseInterface s0 ty0 260 | -- Match terms 261 | if s == "_MATCH" && length args == 2 && 262 | --not ideal from a performance aspect, but it makes things cleaner 263 | test' (destClauses $ args !! 1) 264 | then let (m:cs:_) = args in ppMatch m cs 265 | -- Conditional case 266 | else if s == "COND" && length args == 3 267 | then let (c:t:e:_) = args in ppCond c t e 268 | -- Prefix operator case 269 | else do cond1 <- parsesAsPrefix s 270 | if cond1 && length args == 1 271 | then ppPrefix s (head args) 272 | -- Non-lambda term and type binder case 273 | else ppBinders s hop args tm <|> 274 | (ppComb =<< destComb tm) <|> 275 | fail' "ppTerm: printer error - unrecognized term" 276 | 277 | ppBinders :: Text -> HOLTerm -> [HOLTerm] -> HOLTerm -> PrintM s Doc 278 | ppBinders s hop args tm = 279 | do cond2 <- parsesAsBinder s 280 | if cond2 && length args == 1 && isGAbs (head args) 281 | then ppBinder s False tm 282 | -- Non-lambda type binder case 283 | else do cond3 <- parsesAsTyBinder s 284 | if cond3 && length args == 1 && isTyAbs (head args) 285 | then ppBinder s True tm 286 | -- Infix operator case 287 | else ppOperators s hop args tm 288 | 289 | ppOperators :: Text -> HOLTerm -> [HOLTerm] -> HOLTerm -> PrintM s Doc 290 | ppOperators s hop args tm = 291 | do getRight <- assoc s `fmap` getRights 292 | getLeft <- assoc s `fmap` getLefts 293 | if (test' getRight || test' getLeft) && length args == 2 294 | then do args' <- 295 | if test' getRight 296 | then do (tms, tmt) <- splitListM (destBinaryTm hop) tm 297 | return $! tms ++ [tmt] 298 | else do (tmt, tms) <- revSplitListM (destBinaryTm hop) tm 299 | return $! tmt:tms 300 | prec <- getPrec 301 | uops <- unspacedBinops 302 | pops <- prebrokenBinops 303 | let newprec = tryd 0 (getRight <|> getLeft) 304 | wrapper = if newprec <= prec then parens else id 305 | sepr = if s `elem` uops then (<>) else (<+>) 306 | hanger x y = if s `elem` pops 307 | then x `sepr` (pretty (unpack s) <+> y) 308 | else (x <+> pretty (unpack s)) `sepr` y 309 | (barg:bargs) <- mapM (\x -> setPrec newprec >> ppTerm x) args' 310 | return . wrapper . foldr (flip hanger) barg $ reverse bargs 311 | -- Base constant or variable case 312 | else ppConstants s hop args 313 | where destBinaryTm :: HOLTerm -> HOLTerm -> PrintM s (HOLTerm, HOLTerm) 314 | destBinaryTm c t = 315 | do (il, r) <- destComb t 316 | (i, l) <- destComb il 317 | if i == c 318 | then do i' <- destConst i <|> destVar i 319 | c' <- destConst c <|> destVar c 320 | i'' <- uncurry reverseInterface i' 321 | c'' <- uncurry reverseInterface c' 322 | if i'' == c'' 323 | then return (l, r) 324 | else fail "destBinaryTm" 325 | else fail "destBinaryTm" 326 | 327 | ppConstants :: Text -> HOLTerm -> [HOLTerm] -> PrintM s Doc 328 | ppConstants s hop args 329 | | null args && (isConst hop || isVar hop) = 330 | do cond1 <- parsesAsBinder s 331 | cond2 <- parsesAsTyBinder s 332 | cond3 <- (test' . assoc s) `fmap` getRights 333 | cond4 <- (test' . assoc s) `fmap` getLefts 334 | cond5 <- parsesAsPrefix s 335 | let base = text $ unpack s 336 | return $! if cond1 || cond2 || cond3 || cond4 || cond5 337 | then parens base 338 | else base 339 | -- Base combination case 340 | | otherwise = fail "ppConstants: fall back to ppComb case." 341 | 342 | nameOf :: HOLTerm -> Text 343 | nameOf (Var x _) = x 344 | nameOf (Const x _) = x 345 | nameOf _ = textEmpty 346 | 347 | reverseInterface :: Text -> HOLType -> PrintM s Text 348 | reverseInterface s0 ty0 = 349 | do iface <- getInterface 350 | let s1 = find (\ (_, (s', ty)) -> 351 | s' == s0 && 352 | test' (typeMatch ty ty0 ([], [], []))) iface 353 | return $! maybe s0 fst s1 354 | 355 | ppTyComb :: (HOLTerm, HOLType) -> PrintM s Doc 356 | ppTyComb (t, ty) = 357 | do prec <- getPrec 358 | t' <- setPrec 999 >> ppTerm t 359 | ty' <- setPrec prec >> ppType ty 360 | let base = t' <+> brackets (char ':' <> ty') 361 | return $! if prec == 1000 then parens base else base 362 | 363 | ppLet :: ([(HOLTerm, HOLTerm)], HOLTerm) -> PrintM s Doc 364 | ppLet (eqs@(_:_), bod) = 365 | do prec <- getPrec 366 | eqs' <- mapM ppLet' eqs 367 | bod' <- setPrec 0 >> ppTerm bod 368 | let base = (text "let" <+> encloseSep empty empty (text "and") eqs' <+> 369 | text "in") <$> indent 2 bod' 370 | return $! if prec == 0 then base else parens base 371 | where ppLet' :: (HOLTerm, HOLTerm) -> PrintM s Doc 372 | ppLet' x = 373 | (do x' <- uncurry primMkEq x 374 | setPrec 0 >> ppTerm x') <|> 375 | (return $! text "<*bad let binding*>") 376 | ppLet (_, bod) = ppTerm bod 377 | 378 | ppGAbs :: HOLTerm -> PrintM s Doc 379 | ppGAbs tm = 380 | let (vs, bod) = stripGAbs tm in 381 | do prec <- getPrec 382 | vs' <- mapM (\ x -> setPrec 999 >> ppTerm x) vs 383 | bod' <- setPrec 0 >> ppTerm bod 384 | let base = char '\\' <+> sep vs' <+> char '.' <+> bod' 385 | return $! if prec == 0 then base else parens base 386 | 387 | ppBinder :: Text -> Bool -> HOLTerm -> PrintM s Doc 388 | ppBinder prep f tm = 389 | let (vs, bod) = strip f ([], tm) 390 | bvs = pretty (unpack prep) <> 391 | foldr (\ x acc -> acc <+> pretty (unpack x)) empty vs <> 392 | char '.' in 393 | do prec <- getPrec 394 | bod' <- ppTerm bod 395 | let base = let ident = min (1 + length (show bvs)) 5 in 396 | bvs <> nest ident bod' 397 | return $! if prec == 0 then base else parens base 398 | where strip :: Bool -> ([Text], HOLTerm) -> ([Text], HOLTerm) 399 | strip False pat@(acc, Comb (Var s _) (Abs (Var bv _) bod)) 400 | | s == prep = strip False (bv:acc, bod) 401 | | otherwise = pat 402 | strip False pat@(acc, Comb (Const s _) (Abs (Var bv _) bod)) 403 | | s == prep = strip False (bv:acc, bod) 404 | | otherwise = pat 405 | strip True pat@(acc, Comb (Var s _) (TyAbs (TyVar _ bv) bod)) 406 | | s == prep = strip True (('\'' `cons` bv):acc, bod) 407 | | otherwise = pat 408 | strip True pat@(acc, Comb (Const s _) (TyAbs (TyVar _ bv) bod)) 409 | | s == prep = strip True (('\'' `cons` bv):acc, bod) 410 | | otherwise = pat 411 | strip False (acc, Abs (Var bv _) bod) = 412 | strip False (bv:acc, bod) 413 | strip True (acc, TyAbs (TyVar _ bv) bod) = 414 | strip True (('\'' `cons` bv):acc, bod) 415 | strip _ pat = pat 416 | 417 | ppMatch :: HOLTerm -> HOLTerm -> PrintM s Doc 418 | ppMatch m cls = 419 | do prec <- getPrec 420 | m' <- setPrec 0 >> ppTerm m 421 | cls' <- ppClauses =<< destClauses cls 422 | let base = text "match" <+> m' <+> text "with" <+> cls' 423 | return $! if prec == 0 then base else parens base 424 | where ppClauses :: [[HOLTerm]] -> PrintM s Doc 425 | ppClauses [c] = ppClause c 426 | ppClauses (c:cs) = 427 | do c' <- ppClause c 428 | cs' <- ppClauses cs 429 | return $! c' <+> char '|' <+> cs' 430 | ppClauses _ = return empty 431 | 432 | ppClause :: [HOLTerm] -> PrintM s Doc 433 | ppClause [p, r] = 434 | do p' <- setPrec 1 >> ppTerm p 435 | r' <- setPrec 1 >> ppTerm r 436 | return $! p' <+> text "->" <+> r' 437 | ppClause [p, g, r] = 438 | do p' <- setPrec 1 >> ppTerm p 439 | g' <- setPrec 1 >> ppTerm g 440 | r' <- setPrec 1 >> ppTerm r 441 | return $! p' <+> "when" <+> g' <+> "->" <+> r' 442 | ppClause _ = return empty 443 | 444 | destClauses :: forall m. MonadThrow m => HOLTerm -> m [[HOLTerm]] 445 | destClauses tm = 446 | let (s, args) = stripComb tm in 447 | if nameOf s == "_SEQPATTERN" && length args == 2 448 | then do c <- destClause (head args) 449 | cs <- destClauses (args !! 1) 450 | return (c:cs) 451 | else do c <- destClause tm 452 | return [c] 453 | where destClause :: HOLTerm -> m [HOLTerm] 454 | destClause tm' = 455 | do (_, pbod) <- stripExists' `fmap` (body =<< body tm') 456 | let (s, args) = stripComb pbod 457 | if nameOf s == "_UNGUARDED_PATTERN" && length args == 2 458 | then do tm'1 <- rand =<< rator (head args) 459 | tm'2 <- rand =<< rator (args !! 1) 460 | return [tm'1, tm'2] 461 | else if nameOf s == "_GUARDED_PATTERN" && 462 | length args == 3 463 | then do tm'1 <- rand =<< rator (head args) 464 | let tm'2 = head $ tail args 465 | tm'3 <- rand =<< rator (args !! 2) 466 | return [tm'1, tm'2, tm'3] 467 | else fail' "destClause" 468 | 469 | stripExists' :: HOLTerm -> ([HOLTerm], HOLTerm) 470 | stripExists' = splitList (destBinder "?") 471 | 472 | ppCond :: HOLTerm -> HOLTerm -> HOLTerm -> PrintM s Doc 473 | ppCond c t e = 474 | do prec <- getPrec 475 | c' <- setPrec 0 >> ppTerm c 476 | t' <- setPrec 0 >> ppTerm t 477 | e' <- setPrec 0 >> ppTerm e 478 | let base = text "if" <+> c' <+> text "then" <+> t' <+> text "else" <+> e' 479 | return $! if prec == 0 then base else parens base 480 | 481 | ppPrefix :: Text -> HOLTerm -> PrintM s Doc 482 | ppPrefix s arg = 483 | do prec <- getPrec 484 | arg' <- setPrec 999 >> ppTerm arg 485 | let base = text (unpack s) <+> arg' 486 | return $! if prec == 1000 then parens base else base 487 | 488 | ppComb :: (HOLTerm, HOLTerm) -> PrintM s Doc 489 | ppComb (l, r) = 490 | do prec <- getPrec 491 | l' <- setPrec 999 >> ppTerm l 492 | r' <- setPrec 1000 >> ppTerm r 493 | let base = l' <+> r' 494 | return $! if prec == 1000 then parens base else base 495 | 496 | -- Printer for Theorems 497 | 498 | -- | Pretty printer for 'HOLThm's. 499 | ppThm :: HOLThm -> PrintM s Doc 500 | ppThm (Thm [] c) = 501 | do c' <- setPrec 0 >> ppTerm c 502 | return $! text "|-" <+> c' 503 | ppThm (Thm asl c) = 504 | do c' <- setPrec 0 >> ppTerm c 505 | asl' <- mapM (\ x -> setPrec 0 >> ppTerm x) asl 506 | return $! encloseSep empty empty comma asl' <+> text "|-" <+> c' 507 | ppThm _ = throwM $! HOLExhaustiveWarning "ppThm" 508 | 509 | {-| 510 | The @ShowHOL@ class is functionally equivalent to 'show' lifted to the 'HOL' 511 | monad. It is used to retrieve the current working theory to be used with the 512 | context sensitive pretty printers for 'HOLTerm's and 'HOLType's. 513 | -} 514 | class ShowHOL a where 515 | {-| 516 | A version of 'show' lifted to the 'HOL' monad for context sensitive pretty 517 | printers. 518 | -} 519 | buildDoc :: a -> PrintM s Doc 520 | 521 | buildDocList :: [a] -> PrintM s Doc 522 | buildDocList = buildDocList' brackets comma <=< mapM buildDoc 523 | 524 | instance ShowHOL a => ShowHOL [a] where 525 | buildDoc = buildDocList 526 | 527 | instance (ShowHOL a, ShowHOL b) => ShowHOL (a, b) where 528 | buildDoc (a, b) = buildDocList' parens comma =<< sequence 529 | [buildDoc a, buildDoc b] 530 | 531 | instance (ShowHOL a, ShowHOL b, ShowHOL c) => ShowHOL (a, b, c) where 532 | buildDoc (a, b, c) = buildDocList' parens comma =<< sequence 533 | [buildDoc a, buildDoc b, buildDoc c] 534 | 535 | instance (ShowHOL a, ShowHOL b,ShowHOL c, ShowHOL d) => 536 | ShowHOL (a, b, c, d) where 537 | buildDoc (a, b, c, d) = buildDocList' parens comma =<< sequence 538 | [ buildDoc a, buildDoc b 539 | , buildDoc c, buildDoc d ] 540 | 541 | -- Prints a list of strings provided a wrapper function and seperator document. 542 | buildDocList' :: (Doc -> Doc) -> Doc -> [Doc] -> PrintM s Doc 543 | buildDocList' wrap sepr = 544 | return . wrap . sep . buildDocListRec sepr 545 | 546 | -- Useful to have at top level for ppThm. 547 | buildDocListRec :: Doc -> [Doc] -> [Doc] 548 | buildDocListRec _ [] = [empty] 549 | buildDocListRec _ [x] = [x] 550 | buildDocListRec sepr (x:xs) = (x <> sepr <> space) : buildDocListRec sepr xs 551 | 552 | -- orphan instances 553 | instance ShowHOL HOLType where 554 | buildDoc ty = (char ':' <>) `fmap` ppType ty 555 | 556 | instance ShowHOL HOLTerm where 557 | buildDoc = ppTerm 558 | 559 | instance ShowHOL HOLThm where 560 | buildDoc = ppThm 561 | 562 | showHOL :: ShowHOL a => a -> HOL cls thry String 563 | showHOL x = 564 | do ctxt <- parseContext 565 | either (fail . show) (return . show) $ runST 566 | (do ref <- newSTRef $ initPrintState ctxt 567 | runCatchT $ runReaderT (buildDoc x) ref) 568 | 569 | {-| 570 | Prints a HOL object with a new line. A composition of 'putStrLnHOL' and 571 | 'buildDoc'. 572 | -} 573 | printHOL :: ShowHOL a => a -> HOL cls thry () 574 | printHOL x = 575 | do ctxt <- parseContext 576 | either (fail . show) putDocHOL $ runST 577 | (do ref <- newSTRef $ initPrintState ctxt 578 | runCatchT $ runReaderT (buildDoc x) ref) 579 | -------------------------------------------------------------------------------- /src/HaskHOL/Core/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, 2 | ImplicitParams, MultiParamTypeClasses, TypeFamilies #-} 3 | {-| 4 | Module: HaskHOL.Core.State 5 | Copyright: (c) Evan Austin 2015 6 | LICENSE: BSD3 7 | 8 | Maintainer: e.c.austin@gmail.com 9 | Stability: unstable 10 | Portability: unknown 11 | 12 | This module exports the stateful layer of HaskHOL. It consists of: 13 | 14 | * Stateful type primitives not found in "HaskHOL.Core.Types". 15 | 16 | * Stateful term primitives not found in "HaskHOL.Core.Terms". 17 | 18 | * Stateful theory extension primitives not found in "HaskHOL.Core.Kernel". 19 | 20 | * A very primitive debugging system. 21 | -} 22 | module HaskHOL.Core.State 23 | ( -- * Stateful Type Primitives 24 | types 25 | , tyDefinitions 26 | , getTypeArity 27 | , newType 28 | , mkType 29 | , mkFunTy 30 | -- * Stateful Term Primitives 31 | , constants 32 | , getConstType 33 | , newConstant 34 | , mkConst 35 | , mkConst_FULL 36 | , mkConst_NIL 37 | , genVarWithName 38 | , genVar 39 | , genSmallTyVar 40 | -- * Stateful Theory Extension Primitives 41 | , axioms 42 | , newAxiom 43 | , getAxiom 44 | , definitions 45 | , newBasicDefinition 46 | , getBasicDefinition 47 | , newBasicTypeDefinition 48 | , getBasicTypeDefinition 49 | -- * Primitive Debugging System 50 | , FlagDebug(..) 51 | , warn 52 | , printDebugLn 53 | , printDebug 54 | -- * Stateful Re-Exports and Overloadings 55 | , module HaskHOL.Core.State.Monad 56 | , module HaskHOL.Core.Overloadings 57 | , mkMConst 58 | , listMkIComb 59 | , mkBinary 60 | , mkBinder 61 | , mkTyBinder 62 | , mkIff 63 | , mkConj 64 | , mkImp 65 | , mkForall 66 | , mkExists 67 | , mkDisj 68 | , mkNeg 69 | , mkUExists 70 | , mkTyAll 71 | , mkTyEx 72 | , listMkConj 73 | , listMkDisj 74 | , listMkForall 75 | , listMkExists 76 | , mkGAbs 77 | , listMkGAbs 78 | , mkLet 79 | ) where 80 | 81 | import HaskHOL.Core.Lib 82 | import HaskHOL.Core.Kernel hiding (destEq, typeOf, mkVar) 83 | import HaskHOL.Core.State.Monad hiding 84 | (typeAbbrevs, infixes, prefixes, tyBinders, binders) 85 | import HaskHOL.Core.Parser.Rep 86 | 87 | import HaskHOL.Core.Overloadings hiding 88 | (getConstType, mkConst_NIL, mkConst_FULL, mkConst, mkFunTy, mkType, 89 | mkMConst, listMkIComb, mkBinary, mkBinder, mkTyBinder, mkIff, mkConj, mkImp, 90 | mkForall, mkExists, mkDisj, mkNeg, mkUExists, mkTyAll, mkTyEx, listMkConj, 91 | listMkDisj, listMkForall, listMkExists, mkGAbs, listMkGAbs, mkLet) 92 | import qualified HaskHOL.Core.Overloadings as O 93 | 94 | -- New flags and extensions 95 | -- | Flag states whether or not to print debug statements. 96 | newFlag "FlagDebug" True 97 | 98 | 99 | data TypeConstants = TypeConstants !(Map Text TypeOp) deriving Typeable 100 | 101 | deriveSafeCopy 0 'base ''TypeConstants 102 | 103 | insertTypeConstant :: Text -> TypeOp -> Update TypeConstants () 104 | insertTypeConstant ty op = 105 | do TypeConstants m <- get 106 | put (TypeConstants (mapInsert ty op m)) 107 | 108 | getTypeConstants :: Query TypeConstants (Map Text TypeOp) 109 | getTypeConstants = 110 | do TypeConstants m <- ask 111 | return m 112 | 113 | makeAcidic ''TypeConstants 114 | ['insertTypeConstant, 'getTypeConstants] 115 | 116 | 117 | data TypeDefinitions = TypeDefinitions !(Map Text (HOLThm, HOLThm)) 118 | deriving Typeable 119 | 120 | deriveSafeCopy 0 'base ''TypeDefinitions 121 | 122 | insertTypeDefinition :: Text -> (HOLThm, HOLThm) -> Update TypeDefinitions () 123 | insertTypeDefinition ty defs = 124 | do TypeDefinitions m <- get 125 | put (TypeDefinitions (mapInsert ty defs m)) 126 | 127 | getTypeDefinitions :: Query TypeDefinitions (Map Text (HOLThm, HOLThm)) 128 | getTypeDefinitions = 129 | do TypeDefinitions m <- ask 130 | return m 131 | 132 | getTypeDefinition :: Text -> Query TypeDefinitions (Maybe (HOLThm, HOLThm)) 133 | getTypeDefinition lbl = 134 | do (TypeDefinitions m) <- ask 135 | return $! mapAssoc lbl m 136 | 137 | makeAcidic ''TypeDefinitions 138 | ['insertTypeDefinition, 'getTypeDefinitions, 'getTypeDefinition] 139 | 140 | 141 | data TermConstants = TermConstants !(Map Text HOLTerm) deriving Typeable 142 | 143 | deriveSafeCopy 0 'base ''TermConstants 144 | 145 | insertTermConstant :: Text -> HOLTerm -> Update TermConstants () 146 | insertTermConstant tm op = 147 | do TermConstants m <- get 148 | put (TermConstants (mapInsert tm op m)) 149 | 150 | getTermConstants :: Query TermConstants (Map Text HOLTerm) 151 | getTermConstants = 152 | do TermConstants m <- ask 153 | return m 154 | 155 | makeAcidic ''TermConstants 156 | ['insertTermConstant, 'getTermConstants] 157 | 158 | data TheAxioms = TheAxioms !(Map Text HOLThm) deriving Typeable 159 | 160 | deriveSafeCopy 0 'base ''TheAxioms 161 | 162 | insertAxiom :: Text -> HOLThm -> Update TheAxioms () 163 | insertAxiom lbl thm = 164 | do TheAxioms m <- get 165 | put (TheAxioms (mapInsert lbl thm m)) 166 | 167 | getAxioms :: Query TheAxioms (Map Text HOLThm) 168 | getAxioms = 169 | do TheAxioms m <- ask 170 | return m 171 | 172 | getAxiom' :: Text -> Query TheAxioms (Maybe HOLThm) 173 | getAxiom' lbl = 174 | do TheAxioms m <- ask 175 | return $! mapAssoc lbl m 176 | 177 | makeAcidic ''TheAxioms ['insertAxiom, 'getAxioms, 'getAxiom'] 178 | 179 | 180 | data TheCoreDefinitions = 181 | TheCoreDefinitions !(Map Text HOLThm) deriving Typeable 182 | 183 | deriveSafeCopy 0 'base ''TheCoreDefinitions 184 | 185 | insertCoreDefinition :: Text -> HOLThm -> Update TheCoreDefinitions () 186 | insertCoreDefinition lbl thm = 187 | do TheCoreDefinitions defs <- get 188 | put (TheCoreDefinitions (mapInsert lbl thm defs)) 189 | 190 | getCoreDefinitions :: Query TheCoreDefinitions [HOLThm] 191 | getCoreDefinitions = 192 | do TheCoreDefinitions defs <- ask 193 | return $! mapElems defs 194 | 195 | getCoreDefinition :: Text -> Query TheCoreDefinitions (Maybe HOLThm) 196 | getCoreDefinition name = 197 | do (TheCoreDefinitions defs) <- ask 198 | return $! name `mapAssoc` defs 199 | 200 | makeAcidic ''TheCoreDefinitions 201 | ['insertCoreDefinition, 'getCoreDefinitions, 'getCoreDefinition] 202 | 203 | 204 | -- Term and Type Generation 205 | {-| 206 | Generates a new term variable consisting of a given prefix and the next value 207 | in the fresh term counter. 208 | -} 209 | genVarWithName :: HOLTypeRep ty cls thry => Text -> ty -> HOL cls thry HOLTerm 210 | genVarWithName n ty = 211 | do count <- tickTermCounter 212 | mkVar (n `append` textShow count) ty 213 | 214 | -- | A version of 'genVarWithName' that defaults to the prefix \"_\". 215 | genVar :: HOLTypeRep ty cls thry => ty -> HOL cls thry HOLTerm 216 | genVar = genVarWithName "_" 217 | 218 | {-| 219 | Generates a new small, type variable with a name built using the fresh type 220 | counter. 221 | -} 222 | genSmallTyVar :: HOL cls thry HOLType 223 | genSmallTyVar = 224 | do count <- tickTypeCounter 225 | (mkSmall . mkVarType $ '_' `cons` textShow count) "genSmallTyVar" 226 | 227 | -- Stateful HOL Light Type Primitives 228 | {-| 229 | Retrieves the 'Map' of type constants from the current working theory. The 230 | mapping pairs strings recognized by the parser with the associated 231 | type operator value, i.e. 232 | 233 | > ("bool", tyOpBool) 234 | -} 235 | types :: HOL cls thry (Map Text TypeOp) 236 | types = 237 | do acid <- openLocalStateHOL (TypeConstants initTypeConstants) 238 | m <- queryHOL acid GetTypeConstants 239 | closeAcidStateHOL acid 240 | return m 241 | 242 | -- | Retrieves the 'Map' of type definitions from the current working theory. 243 | tyDefinitions :: HOL cls thry (Map Text (HOLThm, HOLThm)) 244 | tyDefinitions = 245 | do acid <- openLocalStateHOL (TypeDefinitions mapEmpty) 246 | m <- queryHOL acid GetTypeDefinitions 247 | closeAcidStateHOL acid 248 | return m 249 | 250 | {-| 251 | Returns the arity associated with a type constant. 252 | Throws a 'HOLException' if the provided type constant 253 | name is not defined. 254 | -} 255 | getTypeArity :: Text -> HOL cls thry Int 256 | getTypeArity name = 257 | do tys <- types 258 | ((snd . destTypeOp) `fmap` mapAssoc name tys) 259 | "getTypeArity: name has not been defined." 260 | 261 | {- 262 | Primitive type constant construction function. Used by newType and 263 | newBasicTypeDefinition. Not exposed to the user. 264 | -} 265 | newType' :: Text -> TypeOp -> HOL Theory thry () 266 | newType' name tyop = 267 | do failWhen (can getTypeArity name) $ 268 | "newType: type " ++ show name ++ " has already been declared." 269 | acid <- openLocalStateHOL (TypeConstants initTypeConstants) 270 | updateHOL acid (InsertTypeConstant name tyop) 271 | closeAcidStateHOL acid 272 | overParseContext typeConstants (mapInsert name tyop) 273 | 274 | {-| 275 | Constructs a new primitve type constant of a given name and arity. Also adds 276 | this new type to the current working theory. Throws a 'HOLException' when a 277 | type of the same name has already been declared. 278 | -} 279 | newType :: Text -> Int -> HOL Theory thry () 280 | newType name arity = 281 | newType' name $ newPrimitiveTypeOp name arity 282 | 283 | {-| 284 | Constructs a type application given an operator name and a list of argument 285 | types. If the provided name is not a currently defined type constant then 286 | this function defaults it to a type operator variable. Throws a 287 | 'HOLException' in the following cases: 288 | 289 | * A type operator's arity disagrees with the length of the argument list. 290 | 291 | * A type operator is applied to zero arguments. 292 | -} 293 | mkType :: HOLTypeRep ty cls thry => Text -> [ty] -> HOL cls thry HOLType 294 | mkType op = let ?typesFun = types in overload1 (O.mkType op) 295 | 296 | {-| 297 | Constructs a function type safely using 'mkType'. Should never fail provided 298 | that the initial value for type constants has not been modified. 299 | -} 300 | mkFunTy :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry) 301 | => ty1 -> ty2 -> HOL cls thry HOLType 302 | mkFunTy = let ?typesFun = types in overload2 O.mkFunTy 303 | 304 | -- State for Constants 305 | {-| 306 | Retrieves the 'Map' of term constants from the current working theory. The 307 | mapping pairs strings recognized by the parser and the associated 308 | term constant value, i.e. 309 | 310 | > ("=", tmEq tyA) 311 | -} 312 | constants :: HOL cls thry (Map Text HOLTerm) 313 | constants = 314 | do acid <- openLocalStateHOL (TermConstants initTermConstants) 315 | m <- queryHOL acid GetTermConstants 316 | closeAcidStateHOL acid 317 | return m 318 | 319 | {-| 320 | Retrieves the type of a given term constant. Throws a 'HOLException' if the 321 | provided term constant name is not defined. 322 | -} 323 | getConstType :: Text -> HOL cls thry HOLType 324 | getConstType = let ?constsFun = constants in O.getConstType 325 | 326 | {- 327 | Primitive term constant construction function. Used by newConstant, 328 | newBasicDefinition, and newBasicTypeDefinition. 329 | -} 330 | newConstant' :: Text -> HOLTerm -> HOL Theory thry () 331 | newConstant' name c = 332 | do failWhen (can getConstType name) $ 333 | "newConstant: constant " ++ show name ++ " has already been declared." 334 | acid <- openLocalStateHOL (TermConstants initTermConstants) 335 | updateHOL acid (InsertTermConstant name c) 336 | closeAcidStateHOL acid 337 | overParseContext termConstants (mapInsert name c) 338 | 339 | {-| 340 | Constructs a new primitive term constant of a given name and type. Also adds 341 | this new term to the current working theory. Throws a 'HOLException' when a 342 | term of the same name has already been declared. 343 | -} 344 | newConstant :: HOLTypeRep ty Theory thry => (Text, ty) -> HOL Theory thry () 345 | newConstant (name, pty) = 346 | do cond <- can getConstType name 347 | if cond 348 | then printDebugLn ("newConstant: ignoring redefintion of " ++ 349 | show name) $ return () 350 | else do ty <- toHTy pty 351 | newConstant' name $ newPrimitiveConst name ty 352 | 353 | class TypeSubstHOL a b cls thry where 354 | mkConstHOL :: (?constsFun :: HOL cls thry (Map Text HOLTerm)) 355 | => Text -> [(a, b)] -> HOL cls thry HOLTerm 356 | 357 | instance (HOLTypeRep l cls thry, HOLTypeRep r cls thry) => 358 | TypeSubstHOL l r cls thry where 359 | mkConstHOL op = O.mkConst op <=< mapM (toHTy `ffCombM` toHTy) 360 | 361 | instance HOLTypeRep r cls thry => TypeSubstHOL TypeOp r cls thry where 362 | mkConstHOL op = O.mkConst op <=< mapM (return `ffCombM` toHTy) 363 | 364 | instance TypeSubstHOL TypeOp TypeOp cls thry where 365 | mkConstHOL = O.mkConst 366 | 367 | {-| 368 | Constructs a specific instance of a term constant when provided with its name 369 | and a type substition environment. Throws a 'HOLException' in the 370 | following cases: 371 | 372 | * The instantiation as performed by 'instConst' fails. 373 | 374 | * The provided name is not a currently defined constant. 375 | -} 376 | mkConst :: TypeSubstHOL l r cls thry 377 | => Text -> [(l, r)] -> HOL cls thry HOLTerm 378 | mkConst = let ?constsFun = constants in mkConstHOL 379 | 380 | {-| 381 | A version of 'mkConst' that accepts a triplet of type substitition 382 | environments. Frequently used with the 'typeMatch' function. 383 | -} 384 | mkConst_FULL :: (HOLTypeRep ty1 cls thry, HOLTypeRep ty2 cls thry, 385 | HOLTypeRep ty3 cls thry) 386 | => Text -> ([(ty1, ty2)], [(TypeOp, ty3)], [(TypeOp, TypeOp)]) 387 | -> HOL cls thry HOLTerm 388 | mkConst_FULL op = let ?constsFun = constants in overload1 (O.mkConst_FULL op) 389 | 390 | mkConst_NIL ::Text -> HOL cls thry HOLTerm 391 | mkConst_NIL = let ?constsFun = constants in O.mkConst_NIL 392 | 393 | -- State for Axioms 394 | 395 | {-| 396 | Retrieves the list of axioms from the current working theory. The list 397 | contains pairs of string names and the axioms. This names exists such that 398 | compile time operations have a tag with which they can use to extract axioms 399 | from saved theories. See 'extractAxiom' for more details. 400 | -} 401 | axioms :: HOL cls thry (Map Text HOLThm) 402 | axioms = 403 | do acid <- openLocalStateHOL (TheAxioms mapEmpty) 404 | m <- queryHOL acid GetAxioms 405 | closeAcidStateHOL acid 406 | return m 407 | 408 | {-| 409 | Constructs a new axiom of a given name and conclusion term. Also adds this 410 | new axiom to the current working theory. Throws a 'HOLException' in the 411 | following cases: 412 | 413 | * The provided term is not a proposition. 414 | 415 | * An axiom with the provided name has already been declared. 416 | -} 417 | newAxiom :: HOLTermRep tm Theory thry => (Text, tm) -> HOL Theory thry HOLThm 418 | newAxiom (name, ptm) = 419 | do acid <- openLocalStateHOL (TheAxioms mapEmpty) 420 | qth <- queryHOL acid (GetAxiom' name) 421 | closeAcidStateHOL acid 422 | case qth of 423 | Just th -> 424 | return th 425 | Nothing -> 426 | do tm <- toHTm ptm 427 | ty <- typeOf tm 428 | failWhen (return $! ty /= tyBool) "newAxiom: Not a proposition." 429 | let th = axiomThm tm 430 | acid' <- openLocalStateHOL (TheAxioms mapEmpty) 431 | updateHOL acid' (InsertAxiom name th) 432 | closeAcidStateHOL acid' 433 | return th 434 | 435 | -- | Retrieves an axiom by label from the theory context. 436 | getAxiom :: Text -> HOL cls thry HOLThm 437 | getAxiom lbl = 438 | do acid <- openLocalStateHOL (TheAxioms mapEmpty) 439 | qth <- queryHOL acid (GetAxiom' lbl) 440 | closeAcidStateHOL acid 441 | case qth of 442 | Just res -> return res 443 | _ -> fail $ "getAxiom: axiom " ++ show lbl ++ " not found." 444 | 445 | -- State for Definitions 446 | {-| 447 | Retrieves the list of definitions from the current working theory. See 448 | 'newBasicDefinition' for more details. 449 | -} 450 | definitions :: HOL cls thry [HOLThm] 451 | definitions = 452 | do acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty) 453 | m <- queryHOL acid GetCoreDefinitions 454 | closeAcidStateHOL acid 455 | return m 456 | 457 | {-| 458 | Introduces a definition of the form @c = t@ into the current working theory. 459 | Throws a 'HOLException' when the definitional term is ill-formed. See 460 | 'newDefinedConst' for more details. 461 | -} 462 | newBasicDefinition :: HOLTermRep tm Theory thry 463 | => (Text, tm) -> HOL Theory thry HOLThm 464 | newBasicDefinition (lbl, ptm) = 465 | getBasicDefinition lbl 466 | <|> do tm <- toHTm ptm 467 | pat <- destEq tm 468 | case pat of 469 | (Const _ _, _) -> 470 | fail "newBasicDefinition: constant already defined." 471 | (Var name _, _) 472 | | name /= lbl -> 473 | fail $ "newBasicDefinition: provided label does not " ++ 474 | "match provided term." 475 | | otherwise -> 476 | do (c@(Const x _), dth) <- newDefinedConst tm 477 | newConstant' x c 478 | acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty) 479 | updateHOL acid (InsertCoreDefinition lbl dth) 480 | closeAcidStateHOL acid 481 | return dth 482 | _ -> fail "newBasicDefinition: provided term not an equation." 483 | 484 | -- | Retrieves a basic term definition by label from the theory context. 485 | getBasicDefinition :: Text -> HOL cls thry HOLThm 486 | getBasicDefinition lbl = 487 | do acid <- openLocalStateHOL (TheCoreDefinitions mapEmpty) 488 | qth <- queryHOL acid (GetCoreDefinition lbl) 489 | closeAcidStateHOL acid 490 | case qth of 491 | Just res -> return res 492 | _ -> fail $ "getBasicDefinition: definition for " ++ show lbl ++ 493 | " not found." 494 | 495 | {-| 496 | Introduces a new type constant, and two associated term constants, into the 497 | current working theory that is defined as an inhabited subset of an existing 498 | type constant. Takes the following arguments: 499 | 500 | * The name of the new type constant. 501 | 502 | * The name of the new term constant that will be used to construct the type. 503 | 504 | * The name of the new term constant that will be used to desctruct the type. 505 | 506 | * A theorem that proves that the defining predicate has at least one 507 | satisfying value. 508 | 509 | Throws a 'HOLException' in the following cases: 510 | 511 | * A term constant of either of the provided names has already been defined. 512 | 513 | * A type constant of the provided name has already been defined. 514 | 515 | See 'newDefinedTypeOp' for more details. 516 | -} 517 | newBasicTypeDefinition :: HOLThmRep thm Theory thry => Text -> Text -> Text 518 | -> thm -> HOL Theory thry (HOLThm, HOLThm) 519 | newBasicTypeDefinition tyname absname repname pth = 520 | do failWhen (return or <*> mapM (can getConstType) [absname, repname]) $ 521 | "newBasicTypeDefinition: Constant(s) " ++ show absname ++ ", " ++ 522 | show repname ++ " already in use." 523 | dth <- toHThm pth 524 | (atyop, a, r, dth1, dth2) <- newDefinedTypeOp tyname absname repname dth 525 | failWhen (canNot (newType' tyname) atyop) $ 526 | "newBasicTypeDefinition: Type " ++ show tyname ++ " already defined." 527 | newConstant' absname a 528 | newConstant' repname r 529 | acid <- openLocalStateHOL (TypeDefinitions mapEmpty) 530 | updateHOL acid (InsertTypeDefinition tyname (dth1, dth2)) 531 | closeAcidStateHOL acid 532 | return (dth1, dth2) 533 | 534 | -- | Retrieves a basic type definition by label from the theory context. 535 | getBasicTypeDefinition :: Text -> HOL cls thry (HOLThm, HOLThm) 536 | getBasicTypeDefinition lbl = 537 | do acid <- openLocalStateHOL (TypeDefinitions mapEmpty) 538 | qth <- queryHOL acid (GetTypeDefinition lbl) 539 | closeAcidStateHOL acid 540 | case qth of 541 | Just res -> return res 542 | _ -> fail $ "getBasicTypeDefinition: definition for " ++ 543 | show lbl ++ " not found." 544 | 545 | -- Primitive Debugging Functions 546 | {-| 547 | Prints the provided string, with a new line, when the given boolean value is 548 | true. 549 | -} 550 | warn :: Bool -> String -> HOL cls thry () 551 | warn flag str = when flag $ putStrLnHOL str 552 | 553 | {-| 554 | Prints the provided string, with a new line, when debugging is turned on, then 555 | returns the given 'HOL' computation. A version of 'trace' for the 'HOL' monad 556 | that is referentially transparent. 557 | -} 558 | printDebugLn :: String -> HOL cls thry a -> HOL cls thry a 559 | printDebugLn = printDebugBase putStrLnHOL 560 | 561 | -- | A version of printDebug that does not print a new line. 562 | printDebug :: String -> HOL cls thry a -> HOL cls thry a 563 | printDebug = printDebugBase putStrHOL 564 | 565 | -- Abstracted out for future flexibility. Not exported. 566 | printDebugBase :: (String -> HOL cls thry ()) -> String -> HOL cls thry a -> 567 | HOL cls thry a 568 | printDebugBase fn str x = 569 | do debug <- getBenignFlag FlagDebug 570 | if debug 571 | then fn str >> x 572 | else x 573 | 574 | -- Overloadings 575 | mkMConst :: HOLTypeRep ty cls thry => Text -> ty -> HOL cls thry HOLTerm 576 | mkMConst op = let ?constsFun = constants in overload1 (O.mkMConst op) 577 | 578 | listMkIComb :: HOLTermRep tm cls thry => Text -> [tm] -> HOL cls thry HOLTerm 579 | listMkIComb op = let ?constsFun = constants in overload1 (O.listMkIComb op) 580 | 581 | mkBinary :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 582 | => Text -> tm1 -> tm2 -> HOL cls thry HOLTerm 583 | mkBinary op = let ?constsFun = constants in overload2 (O.mkBinary op) 584 | 585 | mkBinder :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 586 | => Text -> tm1 -> tm2 -> HOL cls thry HOLTerm 587 | mkBinder op = let ?constsFun = constants in overload2 (O.mkBinder op) 588 | 589 | mkTyBinder :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 590 | => Text -> ty -> tm -> HOL cls thry HOLTerm 591 | mkTyBinder op = let ?constsFun = constants in overload2 (O.mkTyBinder op) 592 | 593 | mkIff :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 594 | => tm1 -> tm2 -> HOL cls thry HOLTerm 595 | mkIff = let ?constsFun = constants in overload2 O.mkIff 596 | 597 | mkConj :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 598 | => tm1 -> tm2 -> HOL cls thry HOLTerm 599 | mkConj = let ?constsFun = constants in overload2 O.mkConj 600 | 601 | mkImp :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 602 | => tm1 -> tm2 -> HOL cls thry HOLTerm 603 | mkImp = let ?constsFun = constants in overload2 O.mkImp 604 | 605 | mkForall :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 606 | => tm1 -> tm2 -> HOL cls thry HOLTerm 607 | mkForall = let ?constsFun = constants in overload2 O.mkForall 608 | 609 | mkExists :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 610 | => tm1 -> tm2 -> HOL cls thry HOLTerm 611 | mkExists = let ?constsFun = constants in overload2 O.mkExists 612 | 613 | mkDisj :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 614 | => tm1 -> tm2 -> HOL cls thry HOLTerm 615 | mkDisj = let ?constsFun = constants in overload2 O.mkDisj 616 | 617 | mkNeg :: HOLTermRep tm cls thry => tm -> HOL cls thry HOLTerm 618 | mkNeg = let ?constsFun = constants in overload1 O.mkNeg 619 | 620 | mkUExists :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 621 | => tm1 -> tm2 -> HOL cls thry HOLTerm 622 | mkUExists = let ?constsFun = constants in overload2 O.mkUExists 623 | 624 | mkTyAll :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 625 | => ty -> tm -> HOL cls thry HOLTerm 626 | mkTyAll = let ?constsFun = constants in overload2 O.mkTyAll 627 | 628 | mkTyEx :: (HOLTypeRep ty cls thry, HOLTermRep tm cls thry) 629 | => ty -> tm -> HOL cls thry HOLTerm 630 | mkTyEx = let ?constsFun = constants in overload2 O.mkTyEx 631 | 632 | listMkConj :: HOLTermRep tm cls thry => [tm] -> HOL cls thry HOLTerm 633 | listMkConj = let ?constsFun = constants in overload1 O.listMkConj 634 | 635 | listMkDisj :: HOLTermRep tm cls thry => [tm] -> HOL cls thry HOLTerm 636 | listMkDisj = let ?constsFun = constants in overload1 O.listMkDisj 637 | 638 | listMkForall :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 639 | => [tm1] -> tm2 -> HOL cls thry HOLTerm 640 | listMkForall = let ?constsFun = constants in overload2 O.listMkForall 641 | 642 | listMkExists :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 643 | => [tm1] -> tm2 -> HOL cls thry HOLTerm 644 | listMkExists = let ?constsFun = constants in overload2 O.listMkExists 645 | 646 | mkGAbs :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 647 | => tm1 -> tm2 -> HOL cls thry HOLTerm 648 | mkGAbs = let ?typesFun = types 649 | ?constsFun = constants in overload2 O.mkGAbs 650 | 651 | listMkGAbs :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry) 652 | => [tm1] -> tm2 -> HOL cls thry HOLTerm 653 | listMkGAbs = let ?typesFun = types 654 | ?constsFun = constants in overload2 O.listMkGAbs 655 | 656 | mkLet :: (HOLTermRep tm1 cls thry, HOLTermRep tm2 cls thry, 657 | HOLTermRep tm3 cls thry) 658 | => [(tm1, tm2)] -> tm3 -> HOL cls thry HOLTerm 659 | mkLet = let ?typesFun = types 660 | ?constsFun = constants in overload2 O.mkLet 661 | --------------------------------------------------------------------------------