├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml ├── samples └── Sample.hs ├── src ├── Data │ └── Traversable │ │ └── Extensions.hs └── Language │ └── Haskell │ ├── Tactic.hs │ └── Tactic │ └── Internal │ ├── Judgement.hs │ ├── ProofState.hs │ ├── TH.hs │ ├── Tactic.hs │ └── Telescope.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | tactic-haskell.cabal 3 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for tactic-haskell 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tactic-haskell 2 | Tactic Metaprogramming as a library! This project aims to bring the proof automation 3 | capabilities of Coq and others to Haskell. 4 | 5 | Here's some examples: 6 | 7 | ```haskell 8 | tactic "pair" [t| forall a b. a -> b -> (a,b)|] $ do 9 | forall 10 | intros_ 11 | split 12 | assumption 13 | ``` 14 | 15 | ```haskell 16 | tactic "&" [t| forall a b. a -> (a -> b) -> b |] $ do 17 | forall 18 | intro "x" 19 | intro "f" 20 | apply "f" 21 | exact "x" 22 | ``` 23 | 24 | ```haskell 25 | tactic "foo" [t| forall a b c. a -> (a -> b) -> (b -> c) -> (a,c)|] $ do 26 | auto 5 27 | ``` 28 | 29 | ``` haskell 30 | tactic "either" [t| forall a b c. (a -> c) -> (b -> c) -> Either a b -> c |] $ auto 5 31 | ``` 32 | 33 | ``` haskell 34 | tactic "myFold" [t| forall a b. (a -> b -> b) -> b -> [a] -> b |] $ auto 5 35 | ``` 36 | 37 | ```haskell 38 | data Nat = Z | S Nat deriving (Show) 39 | 40 | tactic "plus" [t| Nat -> Nat -> Nat |] $ do 41 | intros ["n", "m"] 42 | induction "n" <@> 43 | [ exact "m" 44 | , do 45 | apply 'S 46 | exact "ind" 47 | ] 48 | ``` 49 | 50 | 51 | For more examples, see the `samples/` directory. 52 | 53 | ## TODOs 54 | - Add support for type classes. 55 | - Allow `auto` to use at top-level bindings/imported functions. 56 | - Tidy up the output of `induction` 57 | - Create a GHCI wrapper that allows usage from the command line/as an editor tool 58 | 59 | ## Disclaimer 60 | This is very much a work in progress! `tactic-haskell` makes 61 | no promises about anything at this stage. It could work perfectly, or it could decide to burn down your house. 62 | Also, even though `auto` is good at it's job, it isn't perfect, make sure to check the output by 63 | using `debugTactic`. 64 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: tactic-haskell 2 | version: 0.1.0.0 3 | github: "totbwf/tactic-haskell" 4 | license: BSD3 5 | author: "Reed Mullanix" 6 | maintainer: "reedmullanix@gmail.com" 7 | copyright: "2018 Reed Mullanix" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | ghc-options: 23 | - -Wall 24 | - -fno-warn-name-shadowing 25 | 26 | dependencies: 27 | - base >= 4.7 && < 5 28 | - pipes >= 4 && < 5 29 | - mmorph >= 1 && < 2 30 | - semigroupoids >= 5 && < 6 31 | - template-haskell >= 2 && < 3 32 | - megaparsec >= 6 && < 7 33 | - containers >= 0.5 && < 0.6 34 | - text >= 1 && < 2 35 | - prettyprinter >= 1 && < 2 36 | - pretty >= 1.1 && < 1.2 37 | - mtl >= 2 && < 3 38 | - ghc >= 8.4.3 && < 9 39 | 40 | library: 41 | source-dirs: src 42 | 43 | tests: 44 | tactic-haskell-test: 45 | main: Spec.hs 46 | source-dirs: test 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | dependencies: 52 | - tactic-haskell 53 | -------------------------------------------------------------------------------- /samples/Sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -ddump-splices #-} 4 | module Sample where 5 | 6 | 7 | import Data.Function 8 | import Language.Haskell.Tactic 9 | 10 | data Nat = Z | S Nat 11 | deriving (Show) 12 | 13 | data List a = Nil | Cons a (List a) 14 | deriving (Show) 15 | 16 | tactic "pair" [t| forall a b. a -> b -> (a,b) |] $ do 17 | forall 18 | intros_ 19 | split 20 | assumption 21 | 22 | tactic "foo" [t| forall a b c d. a -> (a -> b) -> (b -> c) -> (a, d -> c)|] $ do 23 | auto 5 24 | 25 | tactic "&" [t| forall a b. a -> (a -> b) -> b |] $ do 26 | forall 27 | intros ["x", "f"] 28 | apply "f" 29 | exact "x" 30 | 31 | tactic "if_" [t| forall a. a -> a -> Bool -> a |] $ do 32 | forall 33 | intros ["f", "t", "b"] 34 | induction "b" <@> [exact "f", exact "t"] 35 | 36 | -- No typeclass support yet for `apply` 37 | add :: Int -> Int -> Int 38 | add = (+) 39 | 40 | tactic "sum'" [t| List Int -> Int |] $ do 41 | intro "x" 42 | induction "x" <@> 43 | [ exact (0 :: Integer) 44 | , do 45 | apply 'add <@> [exact "ind", exact "ind1"] 46 | ] 47 | 48 | tactic "plus" [t| Nat -> Nat -> Nat |] $ do 49 | intros ["n", "m"] 50 | induction "n" <@> 51 | [ exact "m" 52 | , do 53 | apply 'S 54 | exact "ind" 55 | ] 56 | 57 | tactic "trick" [t| forall a b c. Either a b -> (a -> c) -> (b -> c) -> c |] $ 58 | auto 5 59 | 60 | tactic "myFold" [t| forall a b. (a -> b -> b) -> b -> [a] -> b |] $ do 61 | auto 5 62 | 63 | -- myFold' :: (a -> b -> b) -> b -> List a -> b 64 | -- myFold' f b as = fix (\ffix x -> case x of Nil -> b; Cons ind ind1 -> f ind (ffix ind1)) as 65 | -------------------------------------------------------------------------------- /src/Data/Traversable/Extensions.hs: -------------------------------------------------------------------------------- 1 | module Data.Traversable.Extensions 2 | ( 3 | module T 4 | , mapAccumLM 5 | , mapAccumRM 6 | ) where 7 | 8 | import Data.Traversable as T 9 | 10 | import Control.Applicative (liftA2) 11 | 12 | newtype StateLT s m a = StateLT { runStateLT :: s -> m (s,a) } 13 | 14 | instance (Functor m) => Functor (StateLT s m) where 15 | fmap f (StateLT k) = StateLT $ \s -> fmap (\(s',a) -> (s', f a)) $ k s 16 | 17 | instance Monad m => Applicative (StateLT s m) where 18 | pure a = StateLT $ \s -> return (s, a) 19 | StateLT kf <*> StateLT kv = StateLT $ \s -> do 20 | (s', f) <- kf s 21 | (s'', v) <- kv s' 22 | return (s'', f v) 23 | liftA2 f (StateLT kx) (StateLT ky) = StateLT $ \s -> do 24 | (s', x) <- kx s 25 | (s'', y) <- ky s' 26 | return (s'', f x y) 27 | 28 | mapAccumLM :: (Monad m, Traversable t) => (a -> b -> m (a,c)) -> a -> t b -> m (a, t c) 29 | mapAccumLM f s t = runStateLT (traverse (StateLT . flip f) t) s 30 | 31 | newtype StateRT s m a = StateRT { runStateRT :: s -> m (s,a) } 32 | 33 | instance (Functor m) => Functor (StateRT s m) where 34 | fmap f (StateRT k) = StateRT $ \s -> fmap (\(s',a) -> (s', f a)) $ k s 35 | 36 | instance Monad m => Applicative (StateRT s m) where 37 | pure a = StateRT $ \s -> return (s, a) 38 | StateRT kf <*> StateRT kv = StateRT $ \s -> do 39 | (s', v) <- kv s 40 | (s'', f) <- kf s' 41 | return (s'', f v) 42 | liftA2 f (StateRT kx) (StateRT ky) = StateRT $ \s -> do 43 | (s', y) <- ky s 44 | (s'', x) <- kx s' 45 | return (s'', f x y) 46 | 47 | mapAccumRM :: (Monad m, Traversable t) => (a -> b -> m (a,c)) -> a -> t b -> m (a, t c) 48 | mapAccumRM f s t = runStateRT (traverse (StateRT . flip f) t) s 49 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiWayIf #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | module Language.Haskell.Tactic 13 | ( Tactic 14 | -- * Tactics 15 | , (<@>) 16 | , (?) 17 | , try 18 | , Exact(..) 19 | , assumption 20 | , forall 21 | , intro 22 | , intro_ 23 | , intros 24 | , intros_ 25 | , Apply(..) 26 | , apply_ 27 | , split 28 | , induction 29 | , auto 30 | -- * Running Tactics 31 | , tactic 32 | , debugTactic 33 | -- * Re-Exports 34 | , Alt(..) 35 | ) where 36 | 37 | import Control.Monad.Except 38 | 39 | import Data.Foldable 40 | import Data.Traversable 41 | 42 | import Language.Haskell.TH hiding (match) 43 | 44 | import qualified Language.Haskell.Tactic.Internal.Telescope as Tl 45 | import Language.Haskell.Tactic.Internal.Telescope (Telescope, (@>)) 46 | import qualified Language.Haskell.Tactic.Internal.Judgement as J 47 | import Language.Haskell.Tactic.Internal.Judgement (Judgement(..)) 48 | import Language.Haskell.Tactic.Internal.TH 49 | import Language.Haskell.Tactic.Internal.Tactic 50 | 51 | class Exact e where 52 | -- | When the hypothesis variable passed in matches the goal type, 53 | -- discharge the goal and create no new subgoals. 54 | exact :: e -> Tactic () 55 | 56 | instance Exact String where 57 | exact n = mkTactic $ \j@(Judgement _ g) -> 58 | case J.lookup n j of 59 | Just (e, t) -> if (t == g) then return e else throwError $ TypeMismatch g e t 60 | Nothing -> throwError $ UndefinedHypothesis n 61 | 62 | instance Exact Name where 63 | exact n = mkTactic $ \(Judgement _ g) -> do 64 | (e, t) <- lookupVarType n 65 | case (t == g) of 66 | True -> return e 67 | False -> throwError $ TypeMismatch g e t 68 | 69 | instance Exact Integer where 70 | exact i = mkTactic $ \(Judgement _ g) -> implements g ''Num >>= \case 71 | True -> return $ AppE (VarE 'fromInteger) (LitE $ IntegerL i) 72 | False -> throwError $ GoalMismatch "exact" g 73 | 74 | -- | Searches the hypotheses, looking for one that matches the goal type. 75 | assumption :: Tactic () 76 | assumption = mkTactic $ \(Judgement hy g) -> 77 | case Tl.find ((== g) . snd) hy of 78 | Just (_,(e, _)) -> return e 79 | Nothing -> throwError $ GoalMismatch "assumption" g 80 | 81 | -- | Used to discharge any @forall@ statements at the begining 82 | -- of a polymorphic type signature. This will hopefully not exist 83 | -- for too long. DO NOT APPLY TO RANKNTYPES!!!! 84 | forall :: Tactic () 85 | forall = mkTactic $ \(Judgement hy g) -> 86 | case g of 87 | (ForallT _ _ t) -> do 88 | subgoal $ Judgement hy t 89 | t -> throwError $ GoalMismatch "forall" t 90 | 91 | -- | Applies to goals of the form @a -> b@. 92 | -- Brings @a@ in as a hypothesis, using the provided name, and generates 93 | -- a subgoal of type @t@. 94 | intro :: String -> Tactic () 95 | intro n = mkTactic $ \(Judgement hy g) -> 96 | case g of 97 | (Arrow a b) -> do 98 | x <- unique n 99 | LamE [VarP x] <$> subgoal (Judgement (hy @> (n,(VarE x, a))) b) 100 | -- return $ \[body] -> LamE [VarP x] body 101 | t -> throwError $ GoalMismatch "intro" t 102 | 103 | -- | Applies to goals of the form @a -> b@. 104 | -- Brings @a@ in as a hypothesis, and generates 105 | -- a subgoal of type @t@. 106 | intro_ :: Tactic () 107 | intro_ = mkTactic $ \(Judgement hy g) -> 108 | case g of 109 | (Arrow a b) -> do 110 | (n, x) <- fresh "x" 111 | LamE [VarP x] <$> subgoal (Judgement (hy @> (n, (VarE x, a))) b) 112 | t -> throwError $ GoalMismatch "intro_" t 113 | 114 | -- | Applies to goals of the form @a -> b -> c -> ...@ 115 | -- Brings each of the variables in as a hypothesis, 116 | -- and generates subgoals for each of them. 117 | intros :: [String] -> Tactic () 118 | intros ns = traverse_ intro ns 119 | 120 | -- | Applies to goals of the form @a -> b -> c -> ...@ 121 | -- Adds hypothesis for every single argument, and a subgoal 122 | -- for the return type. 123 | intros_ :: Tactic () 124 | intros_ = many intro_ >> pure () 125 | 126 | -- | Applies to goals of the form @(a,b, ..)@. 127 | -- Generates subgoals for every type contained in the tuple. 128 | split :: Tactic () 129 | split = mkTactic $ \(Judgement hy g) -> 130 | case g of 131 | (Tuple ts) -> do 132 | TupE <$> traverse (subgoal . Judgement hy) ts 133 | t -> throwError $ GoalMismatch "tuple" t 134 | 135 | class Apply e where 136 | -- | When the hypothesis variable passed in refers to a function whose return type matches the goal, 137 | -- this tactic generates subgoals for all of the argument types. 138 | apply :: e -> Tactic () 139 | 140 | instance Apply String where 141 | apply f = mkTactic $ \j@(Judgement hy g) -> 142 | case (J.lookup f j) of 143 | Just (e, (Function args ret)) | ret == g -> do 144 | foldl AppE e <$> traverse (subgoal . Judgement hy) args 145 | Just (_, t) -> throwError $ GoalMismatch "apply" t 146 | Nothing -> throwError $ UndefinedHypothesis f 147 | 148 | instance Apply Name where 149 | apply n = mkTactic $ \(Judgement hy g) -> 150 | lookupVarType n >>= \case 151 | (x, Function args ret) | ret == g -> do 152 | foldl AppE x <$> traverse (subgoal . Judgement hy) args 153 | (_, t) -> throwError $ GoalMismatch "apply" t 154 | 155 | -- | Looks through the context, trying to find a function that could potentially be applied. 156 | apply_ :: Tactic () 157 | apply_ = mkTactic $ \(Judgement hy g) -> 158 | case Tl.find (\case (_, Function _ ret) -> ret == g; _ -> False) hy of 159 | Just (_, (f, Function args _)) -> do 160 | foldl AppE f <$> traverse (subgoal . Judgement hy) args 161 | _ -> throwError $ GoalMismatch "apply_" g 162 | 163 | 164 | 165 | -- | The induction tactic works on inductive data types. 166 | induction :: String -> Tactic () 167 | induction n = mkTactic $ \j@(Judgement _ goal) -> 168 | case (J.lookup n j) of 169 | Just (x, Constructor indn tvars) -> do 170 | ctrs <- lookupConstructors indn tvars 171 | -- Because this can be used inside of something like an apply, 172 | -- we need to use "fix" 173 | (_, ffixn) <- fresh "ffix" 174 | (_, xfixn) <- fresh "x" 175 | matches <- for ctrs $ \(DCon cn tys) -> do 176 | -- Generate names for each of the parameters of the constructor 177 | ns <- traverse (const (fresh "ind")) tys 178 | -- Generate all of the pattern variables 179 | let pats = fmap (VarP . snd) ns 180 | -- If we see an instance of a recursive datatype, replace the type with the type of goal -- and the expression with a reference to the fix point 181 | let newHyps = zipWith (\(s, n) -> \case 182 | Constructor tyn _ | tyn == indn -> (s, (AppE (VarE ffixn) (VarE n), goal)) 183 | t -> (s, (VarE n, t))) ns tys 184 | body <- subgoal (J.extends (Tl.fromList newHyps) $ J.remove n j) 185 | return $ Match (ConP cn pats) (NormalB body) [] 186 | return $ fixExp (LamE [VarP ffixn, VarP xfixn] (CaseE (VarE xfixn) matches)) x 187 | Just (_, t) -> throwError $ GoalMismatch "induction" t 188 | Nothing -> throwError $ UndefinedHypothesis n 189 | where 190 | fixExp :: Exp -> Exp -> Exp 191 | fixExp f a = AppE (AppE (VarE 'fix) f) a 192 | 193 | -- | Tries to automatically solve a given goal. 194 | auto :: Int -> Tactic () 195 | auto 0 = pure () 196 | auto n = do 197 | try forall 198 | try intros_ 199 | choice 200 | [ split >> auto (n - 1) 201 | , attemptOn apply matchingFns 202 | , attemptOn induction matchingCtrs 203 | , assumption >> auto (n - 1) -- This should come last to prevent any stupidity regarding folds/etc 204 | ] 205 | where 206 | attemptOn :: (String -> Tactic ()) -> (Judgement -> [String]) -> Tactic () 207 | attemptOn ft fv = match $ choice . fmap (\s -> ft s >> solve (auto (n - 1))) . fv 208 | 209 | getVars :: Telescope String (Exp, Type) -> (Type -> Bool) -> [String] 210 | getVars hys pred = fmap fst $ Tl.toList $ Tl.filter pred $ fmap snd hys 211 | 212 | matchingFns :: Judgement -> [String] 213 | matchingFns (Judgement hys t) = getVars hys $ \case 214 | (Function _ ret) -> ret == t 215 | _ -> False 216 | 217 | matchingCtrs :: Judgement -> [String] 218 | matchingCtrs (Judgement hys _) = getVars hys $ \case 219 | (Constructor _ _) -> True 220 | _ -> False 221 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic/Internal/Judgement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | module Language.Haskell.Tactic.Internal.Judgement 3 | ( Judgement(..) 4 | , empty 5 | , extend 6 | , extends 7 | , remove 8 | , lookup 9 | ) where 10 | 11 | import Prelude hiding (lookup) 12 | 13 | import Language.Haskell.TH 14 | import Language.Haskell.TH.PprLib hiding (empty, (<>)) 15 | 16 | import Language.Haskell.Tactic.Internal.Telescope (Telescope(..), (@>)) 17 | import qualified Language.Haskell.Tactic.Internal.Telescope as Tl 18 | 19 | -- | A @'Judgement'@ consists of a series of hypotheses (in this case, @'Name'@s bound to @'Type'@s), along with a goal (@'Type'@). 20 | data Judgement = Judgement (Telescope String (Exp, Type)) Type 21 | deriving (Show, Eq) 22 | 23 | instance Ppr Judgement where 24 | ppr (Judgement hyps goal) = 25 | let pprHyps = vcat $ fmap (\(x, (_, t)) -> text x <+> text "::" <+> ppr t) $ Tl.toList hyps 26 | delim = text "===============" 27 | pprGoal = ppr goal 28 | in pprHyps $$ delim $$ pprGoal 29 | 30 | -- | Empty @'Judgement'@. 31 | empty :: Type -> Judgement 32 | empty t = Judgement (mempty) t 33 | 34 | -- | Extend a @'Judgement'@ with a hypothesis. 35 | extend :: String -> Exp -> Type -> Judgement -> Judgement 36 | extend x e t (Judgement hyps goal) = Judgement (hyps @> (x,(e, t))) goal 37 | 38 | -- | Extend a @'Judgement'@ with a telescope. 39 | extends :: Telescope String (Exp, Type) -> Judgement -> Judgement 40 | extends tl (Judgement hyps goal) = Judgement (hyps <> tl) goal 41 | 42 | -- | Remove a hypothesis from a @'Judgement'@ 43 | remove :: String -> Judgement -> Judgement 44 | remove n (Judgement hyps goal) = Judgement (Tl.remove n hyps) goal 45 | 46 | -- | Look up a hypothesis variable in a @'Judgement'@. Note that this uses @'nameBase'@ for comparison. 47 | lookup :: String -> Judgement -> Maybe (Exp, Type) 48 | lookup x (Judgement hyps _) = fmap snd $ Tl.findVar ((== x)) hyps 49 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic/Internal/ProofState.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | 3 | -- Module : Language.Haskell.Tactic.Internal.ProofState 4 | -- Copyright : (c) Reed Mullanix 2019 5 | -- License : BSD-style 6 | -- Maintainer : reedmullanix@gmail.com 7 | -- 8 | -- 9 | -- = The Proof State 10 | -- 11 | -- This module provides the standard LCF definition of a proof state. 12 | -- However, there are a couple of interesting points. Namely, @'ProofState' jdg@ 13 | -- is parameterized, which means that @'ProofState'@ becomes a @'Monad'@! 14 | {-# LANGUAGE LambdaCase #-} 15 | {-# LANGUAGE FlexibleInstances #-} 16 | {-# LANGUAGE MultiParamTypeClasses #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | module Language.Haskell.Tactic.Internal.ProofState 19 | ( ProofStateT(..) 20 | , axiom 21 | ) where 22 | 23 | import Data.Functor.Alt 24 | import Control.Monad.Except 25 | import Control.Monad.Fail as F 26 | 27 | import Pipes.Core 28 | 29 | import Language.Haskell.TH 30 | 31 | -- | @ProofStateT m jdg@ is "morally" equivalent to @m ([jdg], [Exp] -> Exp)@. 32 | -- However, to preserve associativity when presented with non-commutative base Monads, 33 | -- we need to use a streaming style, similar to @'ListT'@. However, due to the 34 | -- required transformation from judgements to extracts, we build upon @'Client'@. 35 | newtype ProofStateT m jdg = ProofStateT { unProofStateT :: Client jdg Exp m Exp } 36 | 37 | instance (Monad m) => Functor (ProofStateT m) where 38 | fmap f (ProofStateT p) = ProofStateT $ (request . f) >\\ p 39 | 40 | instance (MonadError err m) => Alt (ProofStateT m) where 41 | (ProofStateT p1) (ProofStateT p2) = ProofStateT $ p1 `catchError` (const p2) 42 | 43 | instance (Monad m) => Applicative (ProofStateT m) where 44 | pure a = ProofStateT $ request a 45 | (ProofStateT pf) <*> (ProofStateT pa) = ProofStateT $ (\f -> (request . f) >\\ pa) >\\ pf 46 | 47 | instance (Monad m) => Monad (ProofStateT m) where 48 | return = pure 49 | (ProofStateT p) >>= k = ProofStateT $ (unProofStateT . k) >\\ p 50 | 51 | instance MonadTrans (ProofStateT) where 52 | lift m = ProofStateT $ request =<< (lift m) 53 | 54 | instance (MonadFail m) => MonadFail (ProofStateT m) where 55 | fail s = ProofStateT $ lift $ F.fail s 56 | 57 | instance (MonadIO m) => MonadIO (ProofStateT m) where 58 | liftIO m = ProofStateT $ request =<< (liftIO m) 59 | 60 | instance (MonadError err m) => MonadError err (ProofStateT m) where 61 | throwError err = ProofStateT $ throwError err 62 | catchError (ProofStateT m) handler = ProofStateT $ catchError m (unProofStateT . handler) 63 | 64 | -- | Create a @'ProofState'@ with no subgoals. 65 | axiom :: (Monad m) => Exp -> ProofStateT m jdg 66 | axiom e = ProofStateT $ return e 67 | 68 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic/Internal/TH.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.Haskell.Tactic.Internal.TH 4 | -- Copyright : (c) Reed Mullanix 2019 5 | -- License : BSD-style 6 | -- Maintainer : reedmullanix@gmail.com 7 | -- 8 | -- 9 | -- =TH 10 | -- This module exports some handy TH AST pattern synonyms 11 | {-# LANGUAGE PatternSynonyms #-} 12 | {-# LANGUAGE ViewPatterns #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | module Language.Haskell.Tactic.Internal.TH 15 | ( pattern Arrow 16 | , pattern Function 17 | , pattern Tuple 18 | , pattern Constructor 19 | , DCon(..) 20 | ) where 21 | 22 | import Language.Haskell.TH 23 | 24 | -- | Pattern for a single function arrow 25 | pattern Arrow :: Type -> Type -> Type 26 | pattern Arrow t1 t2 = AppT (AppT ArrowT t1) t2 27 | 28 | function :: Type -> Maybe ([Type], Type) 29 | function (Arrow t1 t2) = 30 | let ts = go t2 31 | in Just $ (t1:init ts, last ts) 32 | where 33 | go :: Type -> [Type] 34 | go (Arrow t1 t2) = t1:go t2 35 | go t = [t] 36 | function _ = Nothing 37 | 38 | -- | Pattern for a function of any given arity 39 | pattern Function :: [Type] -> Type -> Type 40 | pattern Function args ret <- (function -> Just (args, ret)) 41 | 42 | tuple :: Type -> Maybe [Type] 43 | tuple = go [] 44 | where 45 | go :: [Type] -> Type -> Maybe [Type] 46 | go ts (AppT (TupleT i) t) = 47 | let ts' = t:ts 48 | in (if length ts' == i then Just ts' else Nothing) 49 | go ts (AppT t1 t2) = go (t2:ts) t1 50 | go _ _ = Nothing 51 | 52 | -- | Pattern for a tuple of any given arity 53 | pattern Tuple :: [Type] -> Type 54 | pattern Tuple ts <- (tuple -> Just ts) 55 | 56 | constructor :: Type -> Maybe (Name, [Type]) 57 | constructor (ConT n) = Just (n, []) 58 | constructor (AppT ListT t) = Just (''[], [t]) 59 | constructor ty = go [] ty 60 | where 61 | go :: [Type] -> Type -> Maybe (Name, [Type]) 62 | go ts (AppT (ConT n) t) = Just (n, t:ts) 63 | go ts (AppT t1 t2) = go (t2:ts) t1 64 | go _ _ = Nothing 65 | 66 | -- | Pattern for a constructor application 67 | pattern Constructor :: Name -> [Type] -> Type 68 | pattern Constructor n ts <- (constructor -> Just (n, ts)) 69 | 70 | -- | Simple Data Constructor Type 71 | data DCon = DCon Name [Type] 72 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic/Internal/Tactic.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.Haskell.Tactic.Internal.Tactic 4 | -- Copyright : (c) Reed Mullanix 2019 5 | -- License : BSD-style 6 | -- Maintainer : reedmullanix@gmail.com 7 | -- 8 | -- 9 | -- = Tactics 10 | {-# LANGUAGE TupleSections #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Language.Haskell.Tactic.Internal.Tactic 17 | ( Tactic 18 | , TacticError(..) 19 | -- * Built-ins 20 | , (<@>) 21 | , match 22 | , (?) 23 | -- * Backtracking 24 | , try 25 | , choice 26 | , progress 27 | , solve 28 | -- * Tactic Construction 29 | , Tac 30 | , mkTactic 31 | , subgoal 32 | -- ** Name Management 33 | , unique 34 | , fresh 35 | -- ** Reify Wrappers 36 | , lookupConstructors 37 | , lookupVarType 38 | , implements 39 | -- ** Debugging helpers 40 | , debugPrint 41 | -- * Running Tactics 42 | , tactic 43 | , debugTactic 44 | -- * Re-Exports 45 | , Alt(..) 46 | ) where 47 | 48 | import Data.Functor.Alt 49 | import Control.Monad.Except 50 | import Control.Monad.State.Strict 51 | import Control.Monad.Fail (MonadFail) 52 | import Control.Monad.Morph 53 | 54 | import Data.Traversable 55 | import Data.Map.Strict (Map) 56 | import qualified Data.Map.Strict as Map 57 | 58 | import Pipes.Core 59 | import Pipes.Lift 60 | import qualified Text.PrettyPrint as P (render) 61 | import Language.Haskell.TH hiding (match) 62 | import Language.Haskell.TH.PprLib (Doc, (<+>), ($+$)) 63 | import qualified Language.Haskell.TH.PprLib as P 64 | 65 | import Language.Haskell.Tactic.Internal.Judgement (Judgement(..)) 66 | import qualified Language.Haskell.Tactic.Internal.Judgement as J 67 | import Language.Haskell.Tactic.Internal.ProofState 68 | import Language.Haskell.Tactic.Internal.TH 69 | 70 | -- | A @'Tactic'@ is simply a function from a 'Judgement' to a @'ProofState'@. 71 | -- However, we add an extra parameter 'a' so that @'Tactic'@ can become a @'Monad'@. 72 | newtype Tactic a = Tactic { unTactic :: StateT TacticState (ProofStateT (ExceptT TacticError Q)) a } 73 | deriving (Functor, Applicative, Monad, MonadFail, MonadIO, MonadError TacticError) 74 | 75 | 76 | data TacticState = TacticState 77 | { goal :: Judgement 78 | , boundVars :: Map String Int 79 | } 80 | 81 | instance Alt (Tactic) where (Tactic t1) (Tactic t2) = Tactic $ StateT $ \j -> (runStateT t1 j) (runStateT t2 j) 82 | 83 | -- | @try t@ tries to apply a tactic @t@, and applies the identity tactic if 84 | -- it fails. 85 | try :: Tactic () -> Tactic () 86 | try t = t (pure ()) 87 | 88 | -- | @choice ts@ tries to apply a series of tactics @ts@, and commits 89 | -- to the 1st tactic that succeeds. If they all fail, then @NoApplicableTactic@ 90 | -- is thrown. 91 | choice :: [Tactic ()] -> Tactic () 92 | choice [] = throwError NoApplicableTactic 93 | choice (t:ts) = t choice ts 94 | 95 | -- | @progress t@ applies the tactic @t@, and throws a @NoProgress@ if 96 | -- the resulting subgoals are all syntactically equal to the initial goal. 97 | -- TODO: Use alpha-equality rather than literal equality. However, 98 | -- That comes along with a big can of worms WRT type equality. 99 | progress :: Tactic () -> Tactic () 100 | progress (Tactic t) = Tactic $ StateT $ \s -> do 101 | s' <- execStateT t s 102 | if (goal s' == goal s) 103 | then throwError NoProgress 104 | else return ((), s') 105 | 106 | solve :: Tactic () -> Tactic () 107 | solve t = t >> throwError NoProgress 108 | 109 | -- | @match f@ takes a function from a judgement to a @Tactic@, and 110 | -- then applies the resulting @Tactic@. 111 | match :: (Judgement -> Tactic ()) -> Tactic () 112 | match f = Tactic $ StateT $ \s -> runStateT (unTactic $ f $ goal s) s 113 | 114 | 115 | -- | @t \<\@> ts@ Applies the tactic @t@, then applies each of the tactics in the list to one of the resulting subgoals. 116 | -- If @ts@ is shorter than the list of resulting subgoals, the identity tactic will be applied to the remainder. 117 | (<@>) :: Tactic () -> [Tactic ()] -> Tactic () 118 | (Tactic t) <@> ts = Tactic $ StateT $ \s -> ProofStateT $ 119 | flip evalStateT (ts ++ repeat (pure ())) $ distribute $ applyTac >\\ (hoist lift $ unProofStateT $ runStateT t s) 120 | where 121 | applyTac :: ((), TacticState) -> Client ((), TacticState) Exp (StateT [Tactic ()] (ExceptT TacticError Q)) Exp 122 | applyTac (_, s) = do 123 | t <- gets (unTactic . head) 124 | modify tail 125 | hoist lift $ unProofStateT $ runStateT t s 126 | 127 | -- | @t ? lbl@ traces out the proof state after applying @t@, annotated with the label @lbl@. 128 | (?) :: Tactic () -> String -> Tactic () 129 | (Tactic t) ? lbl = Tactic $ StateT $ \j -> ProofStateT $ do 130 | (e, sg) <- flip runStateT [] $ distribute $ collectSubgoals >\\ (hoist lift $ unProofStateT $ runStateT t j) 131 | let warning = P.text "Proof State" <+> P.parens (P.text lbl) $+$ P.nest 4 (P.vcat (fmap pGoal $ zip [1..] (reverse sg))) 132 | lift $ lift $ reportWarning $ render warning 133 | return e 134 | where 135 | collectSubgoals :: ((), TacticState) -> Client ((), TacticState) Exp (StateT [Judgement] (ExceptT TacticError Q)) Exp 136 | collectSubgoals (_, s) = do 137 | modify (goal s:) 138 | request ((), s) 139 | 140 | pGoal :: (Int, Judgement) -> Doc 141 | pGoal (i, j) = P.text "#" P.<> P.int i $+$ P.nest 2 (ppr j $+$ P.text "") 142 | 143 | runTactic :: Tactic () -> Judgement -> Q (Exp, [Judgement]) 144 | runTactic (Tactic t) j = do 145 | r <- runExceptT $ flip runStateT [] $ runEffect $ server +>> (hoist lift $ unProofStateT $ execStateT t $ TacticState j Map.empty) 146 | case r of 147 | Left err -> hoistError err 148 | Right (e, st) -> return $ (e, reverse $ fmap goal st) 149 | where 150 | server :: jdg -> Server jdg Exp (StateT [jdg] (ExceptT TacticError Q)) Exp 151 | server j = do 152 | modify (j:) 153 | hole <- lift $ lift $ lift $ newName "_" 154 | respond (UnboundVarE hole) >>= server 155 | 156 | type Tac a = StateT TacticState (Client TacticState Exp (ExceptT TacticError Q)) a 157 | 158 | -- | Creates a @'Tactic'@. See @'subgoal'@ for the rest of the API. 159 | mkTactic :: (Judgement -> Tac Exp) -> Tactic () 160 | mkTactic f = Tactic $ StateT $ \s -> ProofStateT $ (\s' -> request ((), s')) >\\ evalStateT (f $ goal s) s 161 | 162 | -- | Creates a subgoal, and returns the extract. 163 | subgoal :: Judgement -> Tac Exp 164 | subgoal j = do 165 | s <- get 166 | lift $ request (s { goal = j }) 167 | 168 | liftQ :: Q a -> Tac a 169 | liftQ = lift . lift . lift 170 | 171 | -- | Tries to create a name, and fails with @'DuplicateHypothesis'@ if the name is already taken. 172 | -- Furthermore, names that begin with '_' are reserved for wildcard names. 173 | unique :: String -> Tac Name 174 | unique "" = throwError $ InvalidHypothesisName "\"\"" 175 | unique n = gets (Map.member n . boundVars) >>= \case 176 | True -> throwError $ DuplicateHypothesis n 177 | False -> do 178 | modify (\s -> s { boundVars = Map.insert n 1 $ boundVars s }) 179 | liftQ $ newName n 180 | -- where 181 | -- isDefined :: String -> Map String Int -> Bool 182 | -- isDefined nm s = (head nm == '_') || (Map.member nm s) 183 | 184 | -- | Tries to create a name provided a base, potentially appending numbers to make it unique. 185 | -- Furthermore, names that begin with '_' are reserved for wildcard names. 186 | fresh :: String -> Tac (String, Name) 187 | fresh "" = throwError $ InvalidHypothesisName "\"\"" 188 | fresh n = gets (Map.lookup n . boundVars) >>= \case 189 | Just i -> do 190 | modify (\s -> s { boundVars = Map.adjust (+ 1) n $ boundVars s }) 191 | let n' = n ++ show i 192 | -- TODO: What happens if someone freshens something that ends 193 | (n', ) <$> (liftQ $ newName n') 194 | Nothing -> do 195 | modify (\s -> s { boundVars = Map.insert n 1 $ boundVars s }) 196 | (n, ) <$> (liftQ $ newName n) 197 | 198 | -- | Looks up a type's constructors. 199 | lookupConstructors :: Name -> [Type] -> Tac ([DCon]) 200 | lookupConstructors n inst = (liftQ $ reify n) >>= \case 201 | TyConI (DataD _ _ tvarBndrs _ cs _) -> do 202 | let instMap = Map.fromList $ zip (fmap (\case (PlainTV tn) -> tn; (KindedTV tn _) -> tn) tvarBndrs) inst 203 | let instantiate (_, t) = case t of 204 | VarT tv -> Map.findWithDefault t tv instMap 205 | _ -> t 206 | for cs $ \case 207 | NormalC cn ts -> return $ DCon cn $ fmap instantiate ts 208 | InfixC t1 cn t2 -> return $ DCon cn [instantiate t1, instantiate t2] 209 | c -> throwError $ NotImplemented $ "lookupConstructors: Constructors of form " ++ show c 210 | i -> throwError $ NotImplemented $ "lookupConstructors: Declarations of form " ++ show i 211 | 212 | -- | Looks up the the type of a variable binding, along with 213 | -- the expression form of the name 214 | lookupVarType :: Name -> Tac (Exp, Type) 215 | lookupVarType n = (liftQ $ reify n) >>= \case 216 | VarI _ t _ -> return (VarE n, t) 217 | DataConI _ t _ -> return (ConE n, t) 218 | i -> throwError $ NotImplemented $ "lookupVarType: Variable Type " ++ show i 219 | 220 | -- | Check to see if a type implements a typeclass 221 | implements :: Type -> Name -> Tac Bool 222 | implements ty n = liftQ $ isInstance n [ty] 223 | 224 | -- | Prints a debug message as a warning 225 | debugPrint :: String -> Tac () 226 | debugPrint msg = liftQ $ reportWarning $ "DEBUG:" ++ msg 227 | 228 | data TacticError 229 | = TypeMismatch { expectedType :: Type, expr :: Exp, exprType :: Type } 230 | | GoalMismatch { tacName :: String, appliedGoal :: Type } 231 | | UndefinedHypothesis String 232 | | DuplicateHypothesis String 233 | | InvalidHypothesisName String 234 | | UnsolvedGoals [Judgement] 235 | | NoProgress 236 | | NoApplicableTactic 237 | | NotImplemented String 238 | 239 | render :: Doc -> String 240 | render = P.render . P.to_HPJ_Doc 241 | 242 | hoistError :: (MonadFail m) => TacticError -> m a 243 | hoistError e = 244 | let errText = case e of 245 | TypeMismatch{ expectedType, expr, exprType } -> 246 | P.text "Expected Type" <+> ppr expectedType <+> P.text "but" <+> ppr expr <+> P.text "has type" <+> ppr exprType $+$ 247 | P.text "Expected Type (Debug):" <+> (P.text $ show expectedType) $+$ 248 | P.text "Actual Type (Debug):" <+> (P.text $ show exprType) 249 | GoalMismatch{ tacName, appliedGoal } -> 250 | P.text "Tactic" <+> P.text tacName <+> P.text "doesn't support goals of the form" <+> ppr appliedGoal $+$ 251 | P.text "Debug:" <+> (P.text $ show appliedGoal) 252 | UndefinedHypothesis v -> 253 | P.text "Undefined Hypothesis" <+> P.text v 254 | DuplicateHypothesis v -> 255 | P.text "Duplicate Hypothesis" <+> P.text v 256 | InvalidHypothesisName v -> 257 | P.text "Invalid Hypothesis Name" <+> P.text v 258 | UnsolvedGoals ps -> 259 | P.text "Unsolved Subgoals" $+$ ppr ps 260 | NoProgress -> P.text "No Progress" 261 | NoApplicableTactic -> P.text "No Applicable Tactic" 262 | NotImplemented t -> P.text t <+> P.text "isn't implemented yet" 263 | in fail $ render $ P.text "Tactic Error:" <+> errText 264 | 265 | -- | @'tactic' nm [t| ty |] tac@ creates a declaration with the name @nm@ of type @ty@ 266 | -- by applying the tactic @tac@ 267 | tactic :: String -> Q Type -> Tactic () -> Q [Dec] 268 | tactic nm qty tac = do 269 | decName <- newName nm 270 | ty <- qty 271 | (ext, subgoals) <- runTactic tac $ J.empty ty 272 | case subgoals of 273 | [] -> do 274 | return [ValD (VarP decName) (NormalB $ ext) []] 275 | _ -> hoistError $ UnsolvedGoals subgoals 276 | 277 | -- | @debugTactic nm [t| ty |] tac@ behaves exactly the same as @tactic@, 278 | -- but it prints out the resulting expression as a warning. 279 | debugTactic :: String -> Q Type -> Tactic () -> Q [Dec] 280 | debugTactic nm qty tac = do 281 | decName <- newName nm 282 | ty <- qty 283 | (ext, subgoals) <- runTactic tac $ J.empty ty 284 | case subgoals of 285 | [] -> do 286 | reportWarning $ render $ ppr ext 287 | return [ValD (VarP decName) (NormalB $ ext) []] 288 | _ -> hoistError $ UnsolvedGoals subgoals 289 | -------------------------------------------------------------------------------- /src/Language/Haskell/Tactic/Internal/Telescope.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module Language.Haskell.Tactic.Internal.Telescope 4 | ( Telescope(..) 5 | , empty 6 | , singleton 7 | , extend 8 | , (@>) 9 | , foldlWithVar, foldrWithVar 10 | , foldlMWithVar, foldrMWithVar 11 | , toList 12 | , fromList 13 | , filter 14 | , lookup 15 | , find 16 | , findVar 17 | , remove 18 | ) where 19 | 20 | import Prelude hiding (filter, lookup) 21 | 22 | import Data.Bifunctor 23 | 24 | import Language.Haskell.TH 25 | import Language.Haskell.TH.Ppr 26 | import qualified Language.Haskell.TH.PprLib as P 27 | 28 | data Telescope v t 29 | = Empty 30 | | Snoc (Telescope v t) v t 31 | deriving (Show, Eq, Functor, Foldable, Traversable) 32 | 33 | instance (Ppr v, Ppr t) => Ppr (Telescope v t) where 34 | ppr tl = commaSepWith (\(x,t) -> ppr x P.<> P.text "::" P.<> ppr t) (toList tl) 35 | 36 | instance Semigroup (Telescope v t) where 37 | Empty <> t = t 38 | t <> Empty = t 39 | tl <> (Snoc tl' x a) = Snoc (tl <> tl') x a 40 | 41 | instance Monoid (Telescope v t) where 42 | mempty = Empty 43 | 44 | instance Bifunctor Telescope where 45 | first _ Empty = Empty 46 | first f (Snoc tl v t) = Snoc (first f tl) (f v) t 47 | 48 | second _ Empty = Empty 49 | second f (Snoc tl v t) = Snoc (second f tl) v (f t) 50 | 51 | empty :: Telescope v t 52 | empty = Empty 53 | 54 | singleton :: v -> t -> Telescope v t 55 | singleton x t = Snoc Empty x t 56 | 57 | extend :: v -> t -> Telescope v t -> Telescope v t 58 | extend x t tl = Snoc tl x t 59 | 60 | (@>) :: Telescope v t -> (v, t) -> Telescope v t 61 | tl @> (v, t) = Snoc tl v t 62 | 63 | foldlWithVar :: (b -> v -> a -> b) -> b -> Telescope v a -> b 64 | foldlWithVar _ b Empty = b 65 | foldlWithVar f b (Snoc tl x a) = f (foldlWithVar f b tl) x a 66 | 67 | foldrWithVar :: (v -> a -> b -> b) -> b -> Telescope v a -> b 68 | foldrWithVar _ b Empty = b 69 | foldrWithVar f b (Snoc tl x a) = foldrWithVar f (f x a b) tl 70 | 71 | foldlMWithVar :: (Monad m) => (b -> v -> a -> m b) -> b -> Telescope v a -> m b 72 | foldlMWithVar _ b Empty = return b 73 | foldlMWithVar f b (Snoc tl x a) = do 74 | b' <- foldlMWithVar f b tl 75 | f b' x a 76 | 77 | foldrMWithVar :: (Monad m) => (v -> a -> b -> m b) -> b -> Telescope v a -> m b 78 | foldrMWithVar _ b Empty = return b 79 | foldrMWithVar f b (Snoc tl x a) = do 80 | b' <- f x a b 81 | foldrMWithVar f b' tl 82 | 83 | filter :: (t -> Bool) -> Telescope v t -> Telescope v t 84 | filter _ Empty = Empty 85 | filter f (Snoc tl x a) | f a = Snoc (filter f tl) x a 86 | | otherwise = filter f tl 87 | 88 | toList :: Telescope v t -> [(v,t)] 89 | toList = foldrWithVar (\x t -> (:) (x,t)) [] 90 | 91 | fromList :: [(v,t)] -> Telescope v t 92 | fromList = foldl (\tl (x,t) -> Snoc tl x t) empty 93 | 94 | lookup :: (Eq v) => v -> Telescope v t -> Maybe t 95 | lookup _ Empty = Nothing 96 | lookup x (Snoc tl y t) | x == y = Just t 97 | | otherwise = lookup x tl 98 | 99 | find :: (t -> Bool) -> Telescope v t -> Maybe (v, t) 100 | find _ Empty = Nothing 101 | find f (Snoc tl x t) | f t = Just (x, t) 102 | | otherwise = find f tl 103 | 104 | findVar :: (v -> Bool) -> Telescope v t -> Maybe (v, t) 105 | findVar _ Empty = Nothing 106 | findVar f (Snoc tl x t) | f x = Just (x, t) 107 | | otherwise = findVar f tl 108 | 109 | remove :: (Eq v) => v -> Telescope v t -> Telescope v t 110 | remove _ Empty = Empty 111 | remove x (Snoc tl y t) | x == y = tl 112 | | otherwise = Snoc (remove x tl) y t 113 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.10 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | extra-deps: [] 42 | 43 | # Override default flag values for local packages and extra-deps 44 | # flags: {} 45 | 46 | # Extra package databases containing global packages 47 | # extra-package-dbs: [] 48 | 49 | # Control whether we use the GHC we find on the path 50 | # system-ghc: true 51 | # 52 | # Require a specific version of stack, using version ranges 53 | # require-stack-version: -any # Default 54 | # require-stack-version: ">=1.7" 55 | # 56 | # Override the architecture used by stack, especially useful on Windows 57 | # arch: i386 58 | # arch: x86_64 59 | # 60 | # Extra directories used by stack for building 61 | # extra-include-dirs: [/path/to/dir] 62 | # extra-lib-dirs: [/path/to/dir] 63 | # 64 | # Allow a newer minor version of GHC than the snapshot specifies 65 | # compiler-check: newer-minor 66 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -ddump-splices #-} 4 | 5 | import Language.Haskell.TH 6 | import Language.Haskell.Tactic 7 | 8 | main :: IO () 9 | main = return () 10 | 11 | 12 | -- p :: forall a b. a -> b -> (a, b) 13 | -- p = $(solveWith [t| a -> b -> (a,b)|] $ do 14 | -- x <- lam 15 | -- y <- lam 16 | -- tuple <..> [use x, use y]) 17 | -- tuple <..> [use x, use y]) 18 | -- each []) 19 | -- intro <..> [use x, use y]) 20 | 21 | -- foo :: a 22 | -- foo = $(reify 'foo *> fail "Oh no") 23 | 24 | -- f :: forall a b. a -> (a -> b) -> b 25 | -- f = $(solveWith [t| a -> (a -> b) -> b |] $ do 26 | -- x <- lam 27 | -- f <- lam 28 | -- v <- elim f) 29 | -- f = $(tactic [t| forall a b. a -> (a -> b) -> b|] $ do 30 | -- intro 31 | -- x <- intro 32 | -- f <- intro 33 | -- elim f 34 | -- assumption) 35 | 36 | -- foo :: forall a. [a] -> Maybe a 37 | -- foo = $(tactic [t| [a] -> Maybe a |] $ do 38 | -- xs <- intro 39 | -- induction xs <..> 40 | -- [ use [| Nothing :: Maybe a |] 41 | -- , with $ \x -> use [| Just $(useName x) :: Maybe a |] 42 | -- ] 43 | -- ) 44 | --------------------------------------------------------------------------------