├── .gitignore ├── Control └── Monad │ ├── Env.hs │ └── Variant.hs ├── Data ├── IOStableRef.hs ├── Id │ └── Family.hs ├── Rule │ └── Family.hs ├── Term.hs ├── Term │ ├── Annotated.hs │ ├── Annotated │ │ ├── Narrowing.hs │ │ ├── Rewriting.hs │ │ └── Rules.hs │ ├── Automata.hs │ ├── Base.hs │ ├── Family.hs │ ├── IOVar.hs │ ├── Narrowing.hs │ ├── Ppr.hs │ ├── Rewriting.hs │ ├── Rules.hs │ ├── Simple.hs │ ├── Substitutions.hs │ ├── Utils.hs │ ├── Var.hs │ └── Variables.hs └── Var │ └── Family.hs ├── README ├── Setup.lhs ├── narradar-term.cabal └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.pdf 2 | .cabal-sandbox/ 3 | repo/ 4 | dist/ 5 | wordpress-theme/ 6 | yackage/ 7 | *.hi 8 | *.o 9 | *.p_o 10 | *.*_o 11 | *.*-boot 12 | *.*~ 13 | *.DS_Store 14 | *.dot 15 | *.pdf 16 | *.config 17 | *.aes 18 | *.prof 19 | *.log 20 | *.hp 21 | sandbox 22 | 23 | 24 | # Created by http://www.gitignore.io 25 | 26 | ### Haskell ### 27 | dist 28 | cabal-dev 29 | *.o 30 | *.hi 31 | *.chi 32 | *.chs.h 33 | .virtualenv 34 | .hsenv 35 | .cabal-sandbox/ 36 | .cabal-sandbox* 37 | cabal.sandbox.config 38 | cabal.config 39 | 40 | 41 | ### Emacs ### 42 | # -*- mode: gitignore; -*- 43 | *~ 44 | \#*\# 45 | /.emacs.desktop 46 | /.emacs.desktop.lock 47 | *.elc 48 | auto-save-list 49 | tramp 50 | .\#* 51 | 52 | # Org-mode 53 | .org-id-locations 54 | *_archive 55 | 56 | # flymake-mode 57 | *_flymake.* 58 | 59 | # eshell files 60 | /eshell/history 61 | /eshell/lastdir 62 | 63 | # elpa packages 64 | /elpa/ 65 | 66 | # reftex files 67 | *.rel 68 | 69 | # AUCTeX auto folder 70 | /auto/ 71 | -------------------------------------------------------------------------------- /Control/Monad/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Control.Monad.Env where 5 | 6 | import Control.Monad.List (ListT) 7 | import Control.Monad.RWS (RWST) 8 | import Control.Monad.Reader (ReaderT) 9 | import Control.Monad.State (StateT) 10 | import Control.Monad.Writer (WriterT) 11 | 12 | import Control.Monad.Free 13 | import Control.Monad.Trans 14 | import Control.Monad.Variant 15 | 16 | import Data.Term.Base 17 | import Data.Term.Family 18 | import qualified Data.Traversable as T 19 | 20 | -- | A monad for computations in an environment 21 | class Monad m => MonadEnv m where 22 | varBind :: Var m -> Term (TermF m) (Var m) -> m () 23 | lookupVar :: Var m -> m (Maybe (Term (TermF m) (Var m))) 24 | 25 | -- | Fixpoint recursive lookup of a variable in the environment 26 | find :: Var m -> m(Term (TermF m) (Var m)) 27 | find v = do 28 | mb_t <- lookupVar v 29 | case mb_t of 30 | Just (Pure v') -> find v' 31 | Just t -> varBind v t >> return t 32 | Nothing -> return (Pure v) 33 | 34 | -- | Fixpoint recursive lookup and mapping of variables in a term 35 | zonkM :: (Traversable (TermF m)) => (Var m -> m var') -> TermFor m -> m(Term (TermF m) var') 36 | zonkM fv = liftM join . T.mapM f where 37 | f v = do mb_t <- lookupVar v 38 | case mb_t of 39 | Nothing -> Pure `liftM` fv v 40 | Just t -> zonkM fv t 41 | 42 | find' :: MonadEnv m => Term (TermF m) (Var m) -> m(Term (TermF m) (Var m)) 43 | find' (Pure t) = find t 44 | find' t = return t 45 | 46 | -- ------------------------------ 47 | -- Liftings of monadic operations 48 | -- ------------------------------ 49 | 50 | --type instance Var (MVariantT v m) = Var m 51 | type instance TermF (MVariantT v m) = TermF m 52 | instance (Functor (TermF m), v ~ Var m, MonadEnv m) => MonadEnv (MVariantT v m) where 53 | varBind = (lift.) . varBind 54 | lookupVar = lift . lookupVar 55 | 56 | type instance TermF (WrappedMVariant v v' m) = TermF m 57 | instance (MonadEnv m, v' ~ Var m) => MonadEnv (WrappedMVariant v v' m) where 58 | varBind = (lift.) . varBind 59 | lookupVar = lift . lookupVar 60 | 61 | type instance TermF (WriterT w m) = TermF m 62 | type instance Var (WriterT w m) = Var m 63 | instance (Monoid w, Functor (TermF m), MonadEnv m) => MonadEnv (WriterT w m) where 64 | varBind = (lift.) . varBind 65 | lookupVar = lift . lookupVar 66 | 67 | type instance TermF (ListT m) = TermF m 68 | type instance Var (ListT m) = Var m 69 | instance MonadEnv m => MonadEnv (ListT m) where 70 | varBind = (lift.) . varBind 71 | lookupVar = lift . lookupVar 72 | 73 | type instance TermF (StateT s m) = TermF m 74 | type instance Var (StateT s m) = Var m 75 | instance (Functor (TermF m), MonadEnv m) => MonadEnv (StateT s m) where 76 | varBind = (lift.) . varBind 77 | lookupVar = lift . lookupVar 78 | 79 | type instance TermF (ReaderT r m) = TermF m 80 | type instance Var (ReaderT r m) = Var m 81 | instance (Functor (TermF m), MonadEnv m) => MonadEnv (ReaderT r m) where 82 | varBind = (lift.) . varBind 83 | lookupVar = lift . lookupVar 84 | 85 | type instance TermF (RWST r w s m) = TermF m 86 | type instance Var (RWST r w s m) = Var m 87 | instance (Monoid w, Functor (TermF m), MonadEnv m) => MonadEnv (RWST r w s m) where 88 | varBind = (lift.) . varBind 89 | lookupVar = lift . lookupVar 90 | -------------------------------------------------------------------------------- /Control/Monad/Variant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | 8 | module Control.Monad.Variant ( 9 | Rename(..), 10 | MonadVariant(..), 11 | MVariantT(..), runVariantT, runVariantT', runVariant, runVariant', 12 | WrappedMVariant, variantsWith 13 | )where 14 | 15 | import Control.Applicative 16 | import Control.Monad.Identity 17 | import Control.Monad.List 18 | #ifdef LOGICT 19 | import Control.Monad.Logic 20 | #endif 21 | import Control.Monad.State.Strict 22 | import Control.Monad.RWS 23 | import Control.Monad.Writer 24 | 25 | import Data.Term.Family 26 | 27 | import Debug.Hoed.Observe 28 | 29 | -- type Var m 30 | 31 | -- | Renaming of variables 32 | class Rename v where 33 | rename :: v -- ^ Original variable 34 | -> v -- ^ Fresh variable 35 | -> v -- ^ Result of renaming the original variable to the fresh variable 36 | 37 | instance (Rename v, Rename v') => Rename (Either v v') where 38 | rename (Left v) (Left v') = Left (rename v v') 39 | rename (Right v) (Right v') = Right (rename v v') 40 | rename _ _ = error "rename: incompatible variables" 41 | 42 | class (Rename (Var m), Monad m) => MonadVariant m where 43 | -- | Returns a fresh variable 44 | freshVar :: m (Var m) 45 | -- | Renames with a fresh variable 46 | renaming :: Var m-> m (Var m) 47 | renaming v = do {v' <- freshVar; return $ rename v v'} 48 | 49 | -- * A Monad 50 | newtype MVariantT v m a = MVariant {unMVariant :: StateT [v] m a} deriving (Applicative, Alternative, Functor, Monad, MonadTrans, MonadPlus) 51 | type MVariant v a = MVariantT v Identity a 52 | 53 | type instance Var (MVariantT v m) = v 54 | instance (Rename v, Monad m) => MonadVariant (MVariantT v m) where 55 | freshVar = do { x:xx <- MVariant get; MVariant(put xx); return x} 56 | 57 | 58 | #ifdef LOGICT 59 | --deriving instance (MonadLogic m) => MonadLogic (MVariantT v m) 60 | instance MonadLogic m => MonadLogic (MVariantT v m) where 61 | msplit m = MVariant $ (liftM.liftM) f (msplit (unMVariant m)) where 62 | f (a,m') = (a, MVariant m') 63 | 64 | type instance Var (LogicT m) = Var m 65 | type instance TermF (LogicT m) = TermF m 66 | instance MonadVariant m => MonadVariant (LogicT m) where freshVar = lift freshVar 67 | #endif 68 | 69 | -- | Runs a computation over the given set of fresh variables 70 | runVariantT' :: Monad m => [v] -> MVariantT v m a -> m a 71 | runVariantT' vars = (`evalStateT` vars) . unMVariant 72 | 73 | -- | Runs a computation over the set of all variables enumerated from 0 onwards 74 | runVariantT :: (Monad m, Enum v) => MVariantT v m a -> m a 75 | runVariantT = runVariantT' (map toEnum [0..]) 76 | 77 | -- | Runs a computation over the given set of fresh variables 78 | runVariant' :: [v] -> MVariant v a -> a 79 | runVariant' vars = runIdentity . runVariantT' vars 80 | 81 | -- | Runs a computation over the set of all variables enumerated from 0 onwards 82 | runVariant :: Enum v => MVariant v a -> a 83 | runVariant = runVariant' [toEnum 0..] 84 | 85 | instance (Monad m) => Observable1 (MVariantT v m) where 86 | observer1 = observeComp "" 87 | 88 | instance (Observable a, Monad m) => Observable(MVariantT v m a) where 89 | observer = observer1 90 | observers = observers1 91 | 92 | observeComp name comp p = do 93 | res <- comp 94 | send name (return return << res) p 95 | 96 | -- * A rebranding function 97 | -- | Applies the Yoneda transformation over MonadVariant 98 | newtype WrappedMVariant v v' m a = WrappedMVariant {unwrapMVariant :: (v -> v') -> m a} 99 | 100 | instance Monad m => Functor(WrappedMVariant v v' m) where 101 | fmap = liftM 102 | 103 | instance Monad m => Applicative(WrappedMVariant v v' m) where 104 | pure = return 105 | (<*>) = ap 106 | 107 | instance Monad m => Monad(WrappedMVariant v v' m) where 108 | return x = WrappedMVariant (\_ -> return x) 109 | m >>= k = WrappedMVariant (\f -> unwrapMVariant m f >>= ((`unwrapMVariant` f) . k)) 110 | 111 | instance MonadTrans (WrappedMVariant v v') where 112 | lift m = WrappedMVariant (\_ -> m) 113 | 114 | type instance Var (WrappedMVariant v v' m) = v' 115 | 116 | instance (MonadVariant m, Rename v', v ~ Var m) => MonadVariant (WrappedMVariant v v' m) where 117 | freshVar = WrappedMVariant ( `liftM` freshVar) 118 | 119 | -- variantsWith :: (MonadVariant m, Var m ~ v') => (v -> v') -> m a -> MVariantT v m a 120 | -- | Applies a morphism on the source of fresh variables of a MonadVariant computation 121 | variantsWith = flip unwrapMVariant -- f m = unwrapMVariant (WrappedMVariant m) f 122 | 123 | 124 | -- * Some instances 125 | 126 | -- instance (Rename v, Monad m) => MonadVariant (StateT [v] m) where 127 | -- type Var (StateT [v] m) = v 128 | 129 | 130 | -- instance (Rename v, Monad m) => MonadVariant (StateT (a,[v]) m) where 131 | -- type Var (StateT (a,[v]) m) = v 132 | -- freshVar = withSnd freshVar 133 | 134 | 135 | 136 | -- instance (Monoid w, Rename v, Monad m) => MonadVariant (RWST r w [v] m) where 137 | -- type Var (RWST r w [v] m) = v 138 | -- freshVar = do { x:xx <- get; put xx; return x} 139 | 140 | -- * Propagation 141 | 142 | type instance (Var (ListT m)) = Var m 143 | instance MonadVariant m => MonadVariant (ListT m) where 144 | freshVar = lift freshVar 145 | renaming = lift . renaming 146 | 147 | type instance Var (StateT s m) = Var m 148 | instance MonadVariant m => MonadVariant (StateT s m) where 149 | freshVar = lift freshVar 150 | renaming = lift . renaming 151 | 152 | type instance Var (RWST r w s m) = Var m 153 | instance (Monoid w, MonadVariant m) => MonadVariant (RWST r w s m) where 154 | freshVar = lift freshVar 155 | renaming = lift . renaming 156 | 157 | type instance Var (WriterT w m) = Var m 158 | instance (MonadVariant m,Monoid w) => MonadVariant (WriterT w m) where 159 | freshVar = lift freshVar 160 | renaming = lift . renaming 161 | 162 | -------------------------------------------------------------------------------- /Data/IOStableRef.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.IOStableRef 4 | -- Copyright : (c) Andrew Bromage 2002 5 | -- License : BSD-style (see the file libraries/base/LICENSE) 6 | -- 7 | -- Maintainer : libraries@haskell.org 8 | -- Stability : experimental 9 | -- Portability : portable 10 | -- 11 | -- Mutable references in the IO monad, with stable orderings. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Data.IOStableRef 16 | ( 17 | IOStableRef,-- abstract, instance of: Eq, Ord, Typeable 18 | newIOStableRef,-- :: a -> IO (IOStableRef a) 19 | readIOStableRef,-- :: IOStableRef a -> IO a 20 | writeIOStableRef,-- :: IOStableRef a -> a -> IO () 21 | modifyIOStableRef,-- :: IOStableRef a -> (a -> a) -> IO () 22 | hashIOStableRef,-- :: IOStableRef a -> Int 23 | ) where 24 | 25 | import Prelude 26 | import Data.IORef 27 | import Data.Unique 28 | 29 | data IOStableRef a 30 | = IOStableRef !Unique !(IORef a) 31 | 32 | instance Eq (IOStableRef a) where 33 | IOStableRef u1 _ == IOStableRef u2 _ = u1 == u2 34 | 35 | instance Ord (IOStableRef a) where 36 | IOStableRef u1 _ < IOStableRef u2 _ = u1 < u2 37 | IOStableRef u1 _ <= IOStableRef u2 _ = u1 <= u2 38 | IOStableRef u1 _ > IOStableRef u2 _ = u1 > u2 39 | IOStableRef u1 _ >= IOStableRef u2 _ = u1 >= u2 40 | compare (IOStableRef u1 _) (IOStableRef u2 _) = compare u1 u2 41 | 42 | instance Show (IOStableRef a) where show (IOStableRef u _) = 'v' : show (hashUnique u) 43 | 44 | hashIOStableRef :: IOStableRef a -> Int 45 | hashIOStableRef (IOStableRef u _) 46 | = hashUnique u 47 | 48 | newIOStableRef :: a -> IO (IOStableRef a) 49 | newIOStableRef x 50 | = newUnique >>= \u -> newIORef x >>= \r -> return (IOStableRef u r) 51 | 52 | readIOStableRef :: IOStableRef a -> IO a 53 | readIOStableRef (IOStableRef _ r) 54 | = readIORef r 55 | 56 | writeIOStableRef :: IOStableRef a -> a -> IO () 57 | writeIOStableRef (IOStableRef _ r) 58 | = writeIORef r 59 | 60 | modifyIOStableRef :: IOStableRef a -> (a -> a) -> IO () 61 | modifyIOStableRef (IOStableRef _ r) f 62 | = modifyIORef r f 63 | 64 | -------------------------------------------------------------------------------- /Data/Id/Family.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, PolyKinds #-} 2 | module Data.Id.Family where 3 | 4 | import Data.Set (Set) 5 | import Data.Map (Map) 6 | 7 | type family Id (f :: k) 8 | 9 | type instance Id (Maybe a) = Id a 10 | type instance Id [a] = Id a 11 | type instance Id (Set a) = Id a 12 | type instance Id (Map k a) = Id a 13 | -------------------------------------------------------------------------------- /Data/Rule/Family.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Data.Rule.Family where 4 | 5 | import Data.Set (Set) 6 | import Data.Map (Map) 7 | 8 | type family Rule (trs :: *) :: * 9 | --type family Rule1 (trs :: *) 10 | 11 | type instance Rule (Maybe a) = Rule a 12 | type instance Rule [a] = Rule a 13 | type instance Rule (Set a) = Rule a 14 | type instance Rule (Map k a) = Rule a 15 | -------------------------------------------------------------------------------- /Data/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Data.Term ( 4 | -- * Type Families 5 | Term, Var, Id, 6 | -- * Terms 7 | TermF, TermFor, UnwrappedTermFor, foldTerm, foldTermM, mapTerm, evalTerm, 8 | -- * Subterms 9 | subterms, properSubterms, directSubterms, mapSubterms, mapMSubterms, collect, 10 | someSubterm, someSubterm', someSubtermDeep, 11 | -- * Positions 12 | Position, positions, (!), (!*), (!?), updateAt, updateAt', updateAtM, occurrences, 13 | -- * Variables 14 | Rename(..), isVar, vars, isLinear, 15 | -- * Annotating terms 16 | WithNote(..), WithNote1(..), note, dropNote, noteV, annotateWithPos, annotateWithPosV, annotate, 17 | -- * Ids 18 | HasId(..), HasId1(..), MapId(..), rootSymbol, mapRootSymbol, mapTermSymbols, mapTermSymbolsM, 19 | -- * Matching & Unification (without occurs check) 20 | Match(..), Unify(..), unify, unifies, occursIn, 21 | match, matches, equiv, equiv2, EqModulo(..), 22 | -- * Substitutions 23 | Substitution, Substitution_(..), SubstitutionFor, 24 | mapSubst, fromListSubst, domain, codomain, subst, unSubst, 25 | lookupSubst, applySubst, zonkTerm, zonkTermM, zonkSubst, isEmpty, isRenaming, restrictTo, liftSubst, 26 | equiv, equiv2, EqModulo(..), 27 | -- * Variables 28 | GetVars(..), GetFresh(..), getFresh, getVariant, getFreshMdefault, 29 | -- * Environment monad 30 | MonadEnv(..), find', MEnvT, evalMEnv, execMEnv, runMEnv, evalMEnv, execMEnv, runMEnv, 31 | -- * Fresh monad 32 | MonadVariant(..), fresh, freshWith, freshWith', variant 33 | ) where 34 | 35 | import Control.Monad.Env 36 | import Control.Monad.Variant 37 | import Data.Term.Base 38 | import Data.Term.Family 39 | import Data.Term.Substitutions 40 | import Prelude.Extras 41 | 42 | type instance Id (Lift1 f) = Id f 43 | -------------------------------------------------------------------------------- /Data/Term/Annotated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, UndecidableInstances, ScopedTypeVariables #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE CPP #-} 9 | 10 | module Data.Term.Annotated ( 11 | Measured(..), 12 | -- * Terms 13 | Term, 14 | mkT, mkV, getT, getV, free, ann, 15 | foldTerm, foldTermM, mapTerm, evalTerm, 16 | annotate, dropNotes, 17 | -- * Subterms 18 | subterms, properSubterms, directSubterms, mapSubterms, mapMSubterms, collect, 19 | someSubterm, someSubterm', someSubtermDeep, 20 | -- * Positions 21 | Position, positions, (!), (!*), (!?), updateAt, updateAt', updateAtM, occurrences, 22 | -- * Variables 23 | Rename(..), isVar, vars, isLinear, 24 | -- * Annotating terms 25 | WithNote(..), WithNote1(..), note, dropNote, Sans.noteV, annotateWithPos, annotateWithPosV, 26 | -- * Ids 27 | HasId(..), MapId(..), rootSymbol, mapRootSymbol, mapTermSymbols, mapTermSymbolsM, 28 | -- * Matching & Unification (without occurs check) 29 | Match(..), Unify(..), unify, occursIn, match, matches, unifies, equiv, equiv2, EqModulo(..), 30 | -- * Substitutions 31 | Substitution, SubstitutionF(..), emptySubst, fromListSubst, domain, codomain, restrictTo, liftSubst, 32 | lookupSubst, applySubst, zonkTerm, zonkTermM, zonkSubst, isEmpty, isRenaming, 33 | -- Environment monad 34 | MonadEnv(..), find', 35 | -- Fresh monad 36 | MonadVariant(..), fresh, freshWith, variant 37 | ) where 38 | 39 | import Control.Applicative hiding (pure) 40 | import Control.Monad.Free.Annotated hiding (ann, fmap, join, mapM) 41 | import qualified Control.Monad.Free.Annotated as Free 42 | import Control.Monad (liftM, join, MonadPlus(..), msum, when) 43 | import Control.Monad.Identity (runIdentity) 44 | import Control.Monad.Trans (lift) 45 | 46 | import Control.Monad.State (State, StateT(..), get, put, modify, evalState, evalStateT, execStateT) 47 | import Control.Monad.List(ListT) 48 | import Control.Monad.Reader(ReaderT) 49 | import Control.Monad.RWS (RWST, ask, evalRWST) 50 | import Control.Monad.Writer(WriterT) 51 | 52 | import Data.Bifunctor 53 | import Data.Foldable (Foldable(..), toList) 54 | import Data.List ((\\)) 55 | import Data.Map (Map) 56 | import qualified Data.Map as Map 57 | import Data.Maybe (isJust) 58 | import Data.Monoid 59 | import Data.Set (Set) 60 | import qualified Data.Set as Set 61 | import Data.Traversable as T 62 | 63 | import Data.Term (HasId(..), MapId(..), WithNote(..), WithNote1(..), MonadVariant(..), Rename(..)) 64 | import qualified Data.Term as Sans 65 | import Data.Term.Utils 66 | import Prelude as P hiding (mapM) 67 | 68 | -- -------- 69 | -- * Terms 70 | -- -------- 71 | type Term = Free 72 | 73 | mkT :: (Functor t, Foldable t, Measured a ann) => t(Term ann t a) -> Term ann t a 74 | mkV :: Measured a ann => a -> Term ann t a 75 | 76 | mkT = impure 77 | mkV = pure 78 | 79 | getV = evalTerm Just (const Nothing) 80 | getT = evalTerm (const Nothing) Just 81 | 82 | free :: Term ann t a -> Either a (t(Term ann t a)) 83 | free (Impure _ f) = Right f 84 | free (Pure _ v) = Left v 85 | 86 | ann :: Term ann t a -> ann 87 | ann = Free.ann 88 | 89 | dropNotes :: Functor t => Term ann t a -> Sans.Term t a 90 | dropNotes = down 91 | 92 | annotate :: (Foldable t, Functor t, Measured a ann) => Sans.Term t a -> Term ann t a 93 | annotate = up 94 | 95 | foldTerm :: Functor t => (a -> b) -> (t b -> b) -> Term ann t a -> b 96 | foldTerm = foldFree 97 | 98 | foldTermM :: (Traversable t, Monad m) => (a -> m b) -> (t b -> m b) -> Term ann t a -> m b 99 | foldTermM = foldFreeM 100 | 101 | mapTerm :: (Functor t, Functor t', Foldable t', Measured a ann) => 102 | (forall a. t a -> t' a) -> Term ann t a -> Term ann t' a 103 | mapTerm = mapFree 104 | 105 | evalTerm :: (a -> b) -> (f (Term ann f a) -> b) -> Term ann f a -> b 106 | evalTerm = evalFree 107 | 108 | subterms, directSubterms, properSubterms :: (Functor termF, Foldable termF) => 109 | Term ann termF var -> [Term ann termF var] 110 | subterms t = t : properSubterms t 111 | directSubterms = evalFree (const []) toList 112 | properSubterms = evalFree (const []) (P.concatMap subterms . toList) 113 | 114 | mapSubterms :: (Foldable t, Functor t, Measured a ann) => 115 | (Term ann t a -> Term ann t a) -> Term ann t a -> Term ann t a 116 | mapSubterms f = evalFree' Pure (\_ -> impure . fmap f) 117 | 118 | mapMSubterms :: (Traversable t, Monad m, Measured a ann) => 119 | (Term ann t a -> m(Term ann t a)) -> Term ann t a -> m(Term ann t a) 120 | mapMSubterms f = evalFree' ((return.) . Pure) (\_ -> liftM impure . mapM f) 121 | 122 | 123 | -- | Only 1st level subterms 124 | someSubterm :: (Traversable f, MonadPlus m, Measured a ann) => 125 | (Term ann f a -> m(Term ann f a)) -> Term ann f a -> m (Term ann f a) 126 | someSubterm f = evalFree' ((return.) . Pure) (\ann -> msum . liftM2 (Impure ann) . interleaveM f) 127 | 128 | -- | Only 1st level subterms 129 | someSubterm' :: (Traversable f, MonadPlus m, Measured a ann) => 130 | (Term ann f a -> m(Term ann f a)) -> Term ann f a -> m (Position, Term ann f a) 131 | someSubterm' f = evalFree'( ((return . ([],)).) . Pure) 132 | (\_ -> 133 | msum 134 | . zipWith (\p -> liftM ([p],)) [1..] 135 | . liftM2 impure 136 | . interleaveM f) 137 | 138 | interleaveDeep :: forall m f a ann. (Monad m, Traversable f, Measured a ann) => 139 | (Term ann f a -> m (Term ann f a)) -> Term ann f a -> [m (Position, Term ann f a)] 140 | interleaveDeep f t 141 | = [liftM (\(t',_) -> (cursor,t')) $ evalRWST indexedComp cursor [] 142 | | cursor <- positions t] 143 | where 144 | indexedComp = foldFreeM' ((return.).Pure) f' t 145 | 146 | f' :: ann -> f (Term ann f a) -> RWST Position () Position m (Term ann f a) 147 | f' _ = liftM impure 148 | . unsafeZipWithGM (\pos t -> modify (++[pos]) >> indexedf t) 149 | [0..] 150 | 151 | indexedf :: Term ann f a -> RWST Position () Position m (Term ann f a) 152 | indexedf x = get >>= \pos -> ask >>= \cursor -> 153 | if pos == cursor then lift(f x) else return x 154 | 155 | unsafeZipWithGM f t1 t2 = evalStateT (mapM zipG' t2) (toList t1) 156 | where zipG' y = do (x:xx) <- get 157 | put xx 158 | lift (f x y) 159 | 160 | 161 | someSubtermDeep :: (Traversable f, MonadPlus m, Measured a ann) => 162 | (Term ann f a -> m(Term ann f a)) -> Term ann f a -> m (Position, Term ann f a) 163 | someSubtermDeep f = msum . interleaveDeep f 164 | 165 | collect :: (Foldable f, Functor f) => 166 | (Term ann f v -> Bool) -> Term ann f v -> [Term ann f v] 167 | collect pred t = [ u | u <- subterms t, pred u] 168 | 169 | vars :: (Functor termF, Foldable termF) => Term ann termF var -> [var] 170 | vars = toList 171 | 172 | isVar :: Term ann termF var -> Bool 173 | isVar = isPure 174 | 175 | isLinear :: (Ord v, Foldable t, Functor t) => Term ann t v -> Bool 176 | isLinear t = length(snub varst) == length varst where 177 | varst = vars t 178 | 179 | 180 | -- ----------- 181 | -- * Positions 182 | -- ----------- 183 | type Position = [Int] 184 | 185 | positions :: (Functor f, Foldable f) => Term ann f v -> [Position] 186 | positions = foldFree (const []) f where 187 | f x = [] : concat (zipWith (\i pp -> map (i:) pp) [1..] (toList x)) 188 | 189 | -- | get subterm at position or fail with error 190 | (!) :: Foldable f => Term ann f v -> Position -> Term ann f v 191 | t ! [] = t 192 | t ! (i:ii) = evalFree (error "(!): invalid position") (\it -> toList it !! (i-1) ! ii) t 193 | 194 | 195 | -- | t !? pos returns the deepest subterm at position p and some p' where pos = p.p' 196 | (!?) :: (Monad m, Foldable f) => Term ann f v -> Position -> m (Term ann f v, Position) 197 | t !? [] = return (t,[]) 198 | t !? (i:ii) = evalFree (\_ -> return (t,i:ii)) 199 | (\t -> do {x <- toList t !!* (i-1); x !? ii}) 200 | t 201 | -- | get subterm at position or call @fail@ in @m@ 202 | (!*) :: (Monad m, Foldable f) => Term ann f v -> Position -> m(Term ann f v) 203 | t !* [] = return t 204 | t !* (i:ii) = evalFree (fail "(!*): invalid position") 205 | (\t -> do {x <- toList t !!* (i-1); x !* ii}) 206 | t 207 | infixr 4 !!* 208 | (!!*) :: Monad m => [a] -> Int -> m a 209 | x:_ !!* 0 = return x 210 | _:xx !!* i = xx !!* i - 1 211 | [] !!* _ = fail "!!*: index too large" 212 | 213 | -- | Updates the subterm at the position given 214 | -- A failure to reach the position given results in a runtime error 215 | updateAt :: (Traversable f, Measured a ann) => Position -> (Term ann f a -> Term ann f a) -> Term ann f a -> Term ann f a 216 | updateAt (0:_) _ = error "updateAt: 0 is not a position!" 217 | updateAt [] f = f 218 | updateAt (i:ii) f = evalFree err (\t -> impure (unsafeZipWithG g [1..] t)) 219 | where g j st = if i==j then updateAt ii f st else st 220 | err = error "updateAt: invalid position given" 221 | 222 | 223 | -- | Updates the subterm at the position given, 224 | -- returning a tuple with the new term and the previous contents at that position. 225 | -- Failure is contained inside the monad 226 | updateAt' :: (Traversable f, Measured a ann, Monad m) => 227 | Position -> (Term ann f a -> Term ann f a) -> Term ann f a -> m (Term ann f a, Term ann f a) 228 | updateAt' pos f = updateAtM pos (return . f) 229 | 230 | -- | Monadic version of @updateAt'@ 231 | updateAtM :: (Traversable f, Measured a ann, Monad m) => 232 | Position -> (Term ann f a -> m(Term ann f a)) -> Term ann f a -> m (Term ann f a, Term ann f a) 233 | updateAtM pos f t = runStateT (go pos t) t where 234 | go (0:_) _ = fail "updateAt: 0 is not a position!" 235 | go [] t = put t >> lift(f t) 236 | go (i:ii) t = foldFreeM (\_ -> fai) (liftM impure . unsafeZipWithGM g [1..]) t 237 | where fai = fail "updateAt: invalid position given" 238 | g j st = if i==j then go ii st else return st 239 | 240 | 241 | note :: Term ann (WithNote1 n t) (WithNote n a) -> n 242 | note = evalFree (\(Note (n,_)) -> n) (\(Note1 (n,_)) -> n) 243 | 244 | dropNote :: (Functor t, Foldable t) => 245 | Term ann (WithNote1 n t) (WithNote n a) -> Free ann t a 246 | dropNote = foldFree' (\ann (Note (_,v)) -> Pure ann v) (\ann (Note1 (_,x)) -> Impure ann x) 247 | 248 | annotateWithPos :: (Traversable f, Monoid ann) => 249 | Term ann f v -> Term ann (WithNote1 Position f) (WithNote Position v) 250 | annotateWithPos = go [] where 251 | go pos = evalFree' (\ann -> Pure ann . Note . (pos,)) 252 | (\ann -> Impure ann . Note1 . (pos,) . unsafeZipWithG (\p' -> go (pos ++ [p'])) [1..] ) -- TODO Remove the append at tail 253 | 254 | annotateWithPosV :: (Traversable f, Monoid ann) => 255 | Term ann f v -> Term ann f (WithNote Position v) 256 | annotateWithPosV= go [] where 257 | go pos = evalFree' (\ann -> Pure ann . Note . (pos,)) 258 | (\ann -> Impure ann . unsafeZipWithG (\p' -> go (pos ++ [p'])) [1..]) -- TODO Remove the append at tail 259 | 260 | occurrences :: (Traversable f, Eq (Term ann f v), Monoid ann) => 261 | Term ann f v -> Term ann f v -> [Position] 262 | occurrences sub parent = [ note t | t <- subterms(annotateWithPos parent) 263 | , dropNote t == sub] 264 | 265 | instance Measured a m => Measured (WithNote note a) m where 266 | measure (Note (_,a)) = measure a 267 | 268 | instance Measured (f a) m => Measured (WithNote1 note f a) m where 269 | measure (Note1 (_,fa)) = measure fa 270 | 271 | {- 272 | newtype PosNote = PosNote (State [Position] Position) 273 | instance Monoid PosNote where 274 | mempty = PosNote $ return [] 275 | mappend (PosNote m1) (PosNote m2) = PosNote (m1>>m2) 276 | 277 | instance Measured var PosNote where 278 | measure _ = PosNote $ do 279 | p:pp <- get 280 | put pp 281 | return p 282 | -} 283 | -- ----- 284 | -- * Ids 285 | -- ----- 286 | instance HasId f => HasId (Free h f) where 287 | type TermId (Free h f) = TermId f 288 | getId = evalFree (const Nothing) getId 289 | 290 | rootSymbol :: HasId f => Term ann f v -> Maybe (TermId f) 291 | rootSymbol = getId 292 | 293 | mapRootSymbol :: (Functor (f id), Foldable (f id), MapId f, Measured v ann) => (id -> id) -> Term ann (f id) v -> Term ann (f id) v 294 | mapRootSymbol f = evalFree pure (impure . mapId f) 295 | 296 | mapTermSymbols :: (Functor (f id), Foldable (f id'), Functor (f id'), MapId f, Measured v ann) => 297 | (id -> id') -> Term ann (f id) v -> Term ann (f id') v 298 | mapTermSymbols f = mapFree (mapId f) 299 | 300 | mapTermSymbolsM :: (Traversable (f id), Functor (f id'), Foldable (f id'), MapId f, Measured v ann, Monad t) => 301 | (id -> t id') -> Term ann (f id) v -> t(Term ann (f id') v) 302 | mapTermSymbolsM f = mapFreeM (mapIdM f) 303 | 304 | -- --------------- 305 | -- * Substitutions 306 | -- --------------- 307 | type Substitution ann termF var = SubstitutionF var (Term ann termF var) 308 | 309 | newtype SubstitutionF k a = Subst {unSubst::Map k a} 310 | deriving (Functor) 311 | 312 | instance (Functor t, Foldable t, Measured v ann, Ord v) => Monoid (Substitution ann t v) where 313 | mempty = Subst mempty 314 | s1 `mappend` s2 = (applySubst s2 <$> s1) 315 | 316 | deriving instance (Eq v, Eq (Term ann t v)) => Eq (Substitution ann t v) 317 | deriving instance (Ord v, Ord (Term ann t v)) => Ord (Substitution ann t v) 318 | deriving instance (Show v, Show (Term ann t v)) => Show (Substitution ann t v) 319 | 320 | emptySubst :: Ord v => Substitution ann t v 321 | emptySubst = Subst mempty 322 | 323 | liftSubst :: (Map v (Term ann t v) -> Map v' (Term ann t' v')) -> Substitution ann t v -> Substitution ann t' v' 324 | liftSubst f (Subst e) = Subst (f e) 325 | 326 | lookupSubst :: Ord v => v -> Substitution ann t v -> Maybe (Term ann t v) 327 | lookupSubst v (Subst m) = Map.lookup v m 328 | 329 | applySubst :: (Ord v, Functor t, Foldable t, Measured v ann) => Substitution ann t v -> Term ann t v -> Term ann t v 330 | applySubst s = (Free.bind f) where 331 | f v = case lookupSubst v s of 332 | Nothing -> pure v 333 | Just t' -> t' 334 | 335 | domain :: Substitution ann t v -> Set v 336 | domain = Map.keysSet . unSubst 337 | 338 | codomain :: Substitution ann t v -> [Term ann t v] 339 | codomain = Map.elems . unSubst 340 | 341 | restrictTo :: Ord var => [var] -> Substitution ann id var -> Substitution ann id var 342 | restrictTo vv = liftSubst f where 343 | f e = Map.intersectionWith const e (Map.fromDistinctAscList (zip vv (repeat undefined))) 344 | 345 | isEmpty :: Substitution ann id v -> Bool 346 | isEmpty (Subst m) = Map.null m 347 | 348 | fromListSubst :: Ord v => [(v,Term ann termF v)] -> Substitution ann termF v 349 | fromListSubst = Subst . Map.fromList 350 | 351 | zonkTerm :: (Functor termF, Foldable termF, Ord var, Measured var' ann) => 352 | Substitution ann termF var -> (var -> var') -> Term ann termF var -> Term ann termF var' 353 | zonkTerm subst fv = (bind f) where 354 | f v = case lookupSubst v subst of 355 | Nothing -> pure (fv v) 356 | Just t -> zonkTerm subst fv t 357 | 358 | zonkTermM :: (Traversable termF, Measured var' ann, Ord var, MonadEnv ann termF var m) => 359 | (var -> m var') -> Term ann termF var -> m(Term ann termF var') 360 | zonkTermM fv = liftM Free.join . Free.mapM f where 361 | f v = do val <- lookupVar v 362 | case val of 363 | Nothing -> pure `liftM` fv v 364 | Just t -> zonkTermM fv t 365 | 366 | zonkSubst :: (Functor termF, Foldable termF, Measured var ann, Ord var) => 367 | Substitution ann termF var -> Substitution ann termF var 368 | zonkSubst s = liftSubst (Map.map (zonkTerm s id)) s 369 | 370 | isRenaming :: (Functor termF, Measured var ann, Ord var, Ord (Term ann termF var)) => 371 | Substitution ann termF var -> Bool 372 | isRenaming (Subst subst) = all isVar (Map.elems subst) && 373 | isBijective (Map.mapKeysMonotonic pure subst) 374 | where 375 | -- isBijective :: Ord k => Map.Map k k -> Bool 376 | isBijective rel = -- cheap hackish bijectivity check. 377 | -- Ensure that the relation is injective and its inverse is too. 378 | -- The sets of variables must be disjoint too 379 | -- Actually there should be no need to check the inverse 380 | -- since this is a Haskell Map and hence the domain contains no duplicates 381 | Set.size elemsSet == Map.size rel && 382 | Map.keysSet rel `Set.intersection` elemsSet == Set.empty 383 | where 384 | elemsSet = Set.fromList(Map.elems rel) 385 | 386 | -- -------------------------------------- 387 | -- ** Environments: handling substitutions 388 | -- -------------------------------------- 389 | -- | Instances need only to define 'varBind' and 'lookupVar' 390 | class (Functor termF, Monad m) => MonadEnv ann termF var m | m -> ann termF var where 391 | varBind :: var -> Term ann termF var -> m () 392 | lookupVar :: var -> m (Maybe (Term ann termF var)) 393 | 394 | find :: (Monoid ann, Measured var ann) => var -> m(Term ann termF var) 395 | find v = do 396 | mb_t <- lookupVar v 397 | case mb_t of 398 | Just t -> evalFree find (\_ -> varBind v t >> return t) t 399 | Nothing -> return (pure v) 400 | 401 | zonkM :: (Traversable termF, Measured var ann, Measured var' ann) => (var -> m var') -> Term ann termF var -> m(Term ann termF var') 402 | zonkM fv = liftM Free.join . Free.mapM f where 403 | f v = do mb_t <- lookupVar v 404 | case mb_t of 405 | Nothing -> pure `liftM` fv v 406 | Just t -> zonkM fv t 407 | 408 | 409 | {-# INLINE find' #-} 410 | find' :: (Monoid ann, Measured v ann) => MonadEnv ann termF v m => Term ann termF v -> m(Term ann termF v) 411 | find' t = evalFree find (\_ -> return t) t 412 | 413 | instance (Monad m, Functor t, Ord v) => MonadEnv ann t v (StateT (Substitution ann t v) m) where 414 | varBind v t = do {e <- get; put (liftSubst (Map.insert v t) e)} 415 | lookupVar t = get >>= \s -> return(lookupSubst t s) 416 | 417 | instance (Monad m, Functor t, Ord v) => MonadEnv ann t v (StateT (Substitution ann t v, a) m) where 418 | varBind v = withFst . varBind v 419 | lookupVar = withFst . lookupVar 420 | 421 | -- ------------------------------------ 422 | -- * Unification (without occurs check) 423 | -- ------------------------------------ 424 | unifies :: (Unify termF, Ord var, Measured var ann) => 425 | Term ann termF var -> Term ann termF var -> Bool 426 | unifies t u = isJust (unify t u) 427 | 428 | unify :: (Unify termF, Ord var, Measured var ann) => 429 | Term ann termF var -> Term ann termF var -> Maybe (Substitution ann termF var) 430 | unify t u = fmap zonkSubst (execStateT (unifyM t u) mempty) 431 | 432 | class (Traversable termF, Eq (termF ())) => Unify termF 433 | where unifyM :: (Monoid ann, Measured var ann, MonadEnv ann termF var m, Ord var) => Term ann termF var -> Term ann termF var -> m () 434 | 435 | -- Generic instance 436 | instance (Traversable termF, Eq (termF ())) => Unify termF where 437 | unifyM = unifyMDefault 438 | 439 | unifyMDefault :: ( Traversable termF, Eq (termF ()) 440 | , Monoid ann, Measured var ann 441 | , MonadEnv ann termF var m, Ord var 442 | ) => Term ann termF var -> Term ann termF var -> m () 443 | unifyMDefault t s = do 444 | t' <- find' t 445 | s' <- find' s 446 | unifyOne t' s' 447 | where 448 | unifyOne (Pure _ vt) s@(Pure _ vs) = when (vt /= vs) $ varBind vt s 449 | unifyOne (Pure _ vt) s = varBind vt s 450 | unifyOne t (Pure _ vs) = varBind vs t 451 | unifyOne t s = zipFree_ unifyM t s 452 | 453 | 454 | {- | Occurs function, to roll your own unification with occurs check. 455 | To do this, chip in your custom instance of Unify as follows 456 | 457 | > instance (Traversable termF, Eq (termF ())) => Unify termF where 458 | > unifyM t s = do 459 | > t' <- find' t 460 | > s' <- find' s 461 | > unifyOne t' s' 462 | > where 463 | > unifyOne (Pure vt) s@(Pure vs) = when (vt /= vs) $ varBind vt s 464 | > unifyOne (Pure vt) s = vt `occursIn` s' >>= \occ -> if occ then fail "occurs" else varBind vt s 465 | > unifyOne t (Pure vs) = vs `occursIn` t' >>= \occ -> if occ then fail "occurs" else varBind vs t 466 | > unifyOne t s = zipFree_ unifyM t s 467 | -} 468 | 469 | occursIn :: (Ord v, Measured v ann, Traversable t, MonadEnv ann t v m) => v -> Term ann t v -> m Bool 470 | occursIn v t = do 471 | t' <- zonkM return t 472 | return (v `Set.member` Set.fromList (vars t')) 473 | 474 | -- ---------- 475 | -- * Matching 476 | -- ---------- 477 | matches :: (Match termF, Ord var, Measured var ann) => 478 | Term ann termF var -> Term ann termF var -> Bool 479 | matches t u = isJust (match t u) 480 | 481 | match :: (Match termF, Ord var, Measured var ann) => 482 | Term ann termF var -> Term ann termF var -> Maybe (Substitution ann termF var) 483 | match t u = execStateT (matchM t u) mempty 484 | 485 | class (Eq (termF ()), Traversable termF) => Match termF where 486 | matchM :: (Eq var, Measured var ann, MonadEnv ann termF var m) => Term ann termF var -> Term ann termF var -> m () 487 | 488 | instance (Traversable termF, Eq (termF ())) => Match termF where 489 | matchM t s = do 490 | t' <- find' t 491 | matchOne t' s 492 | where matchOne (Pure _ v) (Pure _ u) | v == u = return () 493 | matchOne (Pure _ v) u = do 494 | bound_already <- isJust `liftM` lookupVar v 495 | if bound_already then fail "incompatible" else varBind v u 496 | matchOne t u = zipFree_ matchM t u 497 | 498 | -- ----------------------------- 499 | -- ** Equivalence up to renaming 500 | -- ----------------------------- 501 | 502 | equiv :: (Ord var, Rename var, Enum var, Measured var ann, Ord (Term ann termF var), Unify termF) => 503 | Term ann termF var -> Term ann termF var -> Bool 504 | equiv t u = maybe False isRenaming (match (variant t u) u) 505 | 506 | equiv2 t u = let t' = variant t u in matches t' u && matches u t' 507 | 508 | newtype EqModulo a = EqModulo {eqModulo::a} 509 | instance (Ord v, Rename v, Enum v, Measured v ann, Unify t, Ord (Term ann t v)) => 510 | Eq (EqModulo (Term ann t v)) 511 | where 512 | EqModulo t1 == EqModulo t2 = t1 `equiv2` t2 513 | 514 | -- -------------------------------- 515 | -- * Variants of terms and rules 516 | -- -------------------------------- 517 | 518 | fresh :: (Traversable t, Measured var ann, MonadEnv ann t var m, MonadVariant var m) => 519 | Term ann t var -> m (Term ann t var) 520 | fresh = go where 521 | go = liftM Free.join . Free.mapM f 522 | f v = do 523 | mb_v' <- lookupVar v 524 | case mb_v' of 525 | Nothing -> do {v' <- renaming v; varBind v (pure v'); return (pure v')} 526 | Just v' -> return v' 527 | 528 | instance (Measured a m, Measured b m) => Measured (Either a b) m where 529 | measure = either measure measure 530 | 531 | freshWith :: (Traversable t, Measured var ann, Measured var' ann, MonadEnv ann t (Either var var') m, MonadVariant var' m) => 532 | (var -> var' -> var') -> Term ann t var -> m (Term ann t var') 533 | freshWith fv = liftM Free.join . Free.mapM f where 534 | f v = do 535 | mb_v' <- lookupVar (Left v) 536 | case mb_v' of 537 | Nothing -> do {v' <- fv v `liftM` freshVar; varBind (Left v) (pure $ Right v'); return (pure v')} 538 | Just (Pure _ (Right v')) -> return (pure v') 539 | _ -> error "impossible: fresh'" 540 | 541 | variant :: forall v t t' ann. 542 | (Ord v, Rename v, Enum v, Functor t', Foldable t', Traversable t, Measured v ann) => 543 | Term ann t v -> Term ann t' v -> Term ann t v 544 | variant u t = fresh u `evalStateT` (mempty :: Substitution ann t v) `evalState` ([toEnum 0..] \\ vars t) 545 | 546 | -- ------------------------------ 547 | -- Liftings of monadic operations 548 | -- ------------------------------ 549 | instance (Monoid w, Functor t, MonadEnv ann t var m) => MonadEnv ann t var (WriterT w m) where 550 | varBind = (lift.) . varBind 551 | lookupVar = lift . lookupVar 552 | 553 | instance MonadEnv ann t v m => MonadEnv ann t v (ListT m) where 554 | varBind = (lift.) . varBind 555 | lookupVar = lift . lookupVar 556 | 557 | instance (Functor t, MonadEnv ann t var m) => MonadEnv ann t var (StateT s m) where 558 | varBind = (lift.) . varBind 559 | lookupVar = lift . lookupVar 560 | 561 | instance (Functor t, MonadEnv ann t var m) => MonadEnv ann t var (ReaderT r m) where 562 | varBind = (lift.) . varBind 563 | lookupVar = lift . lookupVar 564 | 565 | instance (Monoid w, Functor t, MonadEnv ann t var m) => MonadEnv ann t var (RWST r w s m) where 566 | varBind = (lift.) . varBind 567 | lookupVar = lift . lookupVar 568 | -------------------------------------------------------------------------------- /Data/Term/Annotated/Narrowing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | module Data.Term.Annotated.Narrowing ( 6 | contexts, fill, (|>), 7 | isRNF, 8 | narrow1, narrow1P, narrows, narrow, 9 | narrow1', narrow1P', narrows', narrow', 10 | narrowBasic, narrowsBasic, narrow1Basic, 11 | #ifdef LOGICT 12 | innNarrowing, innBnarrowing, 13 | #endif 14 | narrowBounded, narrowBasicBounded, 15 | narrowStepBasic 16 | ) where 17 | 18 | import Control.Arrow 19 | import qualified Control.Monad.Free.Annotated as Free 20 | #ifdef LOGICT 21 | import Control.Monad.Logic 22 | #endif 23 | import Control.Monad.State 24 | import Data.Foldable (Foldable) 25 | import Data.Monoid 26 | import Data.Traversable (Traversable) 27 | 28 | import Data.Term.Annotated 29 | import Data.Term.Annotated.Rules 30 | import Data.Term.Utils 31 | 32 | import Text.PrettyPrint.HughesPJClass 33 | 34 | -- | Rigid Normal Form 35 | isRNF :: (Ord v, Enum v, Rename v, Measured v ann, Unify t) => [Rule ann t v] -> Term ann t v -> Bool 36 | isRNF rr = null . narrow1 rr 37 | 38 | -- ----------- 39 | -- * Contexts 40 | -- ----------- 41 | type Context ann t v = Term ann t (Either Hole v) 42 | data Hole = Hole deriving (Eq, Ord, Show) 43 | instance Pretty Hole where pPrint _ = text "?h" 44 | instance Monoid ann => Measured Hole ann where measure = mempty 45 | 46 | instance (Measured v ann, Functor t, Foldable t) => Monoid (Context ann t v) where 47 | mempty = mkV (Left Hole) 48 | mappend ct1 ct2 = Free.bind f ct1 where 49 | f (Left Hole) = ct2 50 | f v = mkV v 51 | 52 | -- | Fill a hole in a context 53 | fill,(|>) :: (Measured v ann, Foldable t, Functor t) => Context ann t v -> Term ann t v -> Term ann t v 54 | fill ct t = Free.bind f ct 55 | where f (Left Hole) = t 56 | f (Right v) = mkV v 57 | 58 | (|>) = fill 59 | 60 | -- | Returns one layer of contexts. 61 | -- That is, a list of direct subterms and the corresponding contexts 62 | -- | forall subterm ctx . (subterm, ctx) <- contexts t ==> ctx |> subterm = t 63 | contexts :: (Traversable t, Measured v ann) => Term ann t v -> [(Term ann t v, Context ann t v, Position)] 64 | contexts t = [ (Free.fmap fromRight t_i, u, [i]) 65 | | i <- [1..length (directSubterms t)] 66 | , (u, t_i) <- updateAt' [i] (const mempty)(Free.fmap Right t) ] 67 | where fromRight (Right x) = x 68 | fromRight _ = error "contexts: the impossible happened" 69 | 70 | -- ------------ 71 | -- * Narrowing 72 | -- ------------ 73 | 74 | {-# INLINE narrowStepBasic #-} 75 | narrowStepBasic :: (Unify t, Ord v, Measured v ann, MonadPlus m, MonadVariant v m, MonadEnv ann t v m) => 76 | [Rule ann t v] -> Term ann t v -> m (Term ann t v, Position) 77 | narrowStepBasic rr t = go (t, mempty, []) 78 | where go (t, ct,pos) = do { t' <- narrowTop t; return (ct |> t', pos)} 79 | `mplus` 80 | msum [go (t', ct `mappend` ct', pos ++ i) | (t', ct', i) <- contexts t] 81 | narrowTop t = msum$ flip map rr $ \r -> do 82 | guard (not $ isVar t) 83 | lhs :-> rhs <- getFresh r 84 | unifyM lhs t 85 | return rhs 86 | 87 | -- | one step 88 | narrow1 :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 89 | narrow1 rr t = second (restrictTo (vars t)) `liftM` narrow1' rr t 90 | 91 | -- | one step, returns the position used 92 | narrow1P :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m ((Term ann t v, Position), Substitution ann t v) 93 | narrow1P rr t= second (restrictTo (vars t)) `liftM` narrow1P' rr t 94 | 95 | -- | narrowing to rigid normal form 96 | #ifdef LOGICT 97 | narrow :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadLogic m, Eq (Term ann t v)) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 98 | #else 99 | narrow :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m, Eq (Term ann t v)) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 100 | #endif 101 | narrow rr t = second (restrictTo (vars t)) `liftM` narrow' rr t 102 | 103 | -- | narrowing transitive closure 104 | narrows :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 105 | narrows rr t = second (restrictTo (vars t)) `liftM` narrows' rr t 106 | 107 | 108 | -- ** Dirty versions 109 | -- These do not trim the substitution before returning 110 | 111 | run :: (Enum v, Eq v, Monoid s, Functor t, Foldable t, Monad m) => (Term ann t v -> StateT (s, [v]) m a) -> Term ann t v -> m (a, s) 112 | run f t = second fst `liftM` (f t `runStateT` (mempty, freshVars)) where 113 | freshVars = [toEnum (1 + maximum ( 0 : map fromEnum (vars t))) ..] 114 | 115 | -- | one step 116 | narrow1' :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 117 | narrow1' rr = liftM (second zonkSubst) . run (narrowStepBasic rr >=> zonkM return . fst) 118 | 119 | -- | one step, returns the position used 120 | narrow1P' :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m ((Term ann t v, Position), Substitution ann t v) 121 | narrow1P' rr = liftM (second zonkSubst) . run (narrowStepBasic rr >=> firstM (zonkM return)) 122 | 123 | -- | narrowing to rigid normal form 124 | #ifdef LOGICT 125 | narrow' :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadLogic m, Eq (Term ann t v)) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 126 | narrow' rr = liftM (second zonkSubst) . run (fixMP(narrowStepBasic rr >=> zonkM return . fst)) 127 | #else 128 | narrow' :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m, Eq (Term ann t v)) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 129 | narrow' rr = liftM (second zonkSubst) . run (fixM_Eq(narrowStepBasic rr >=> zonkM return . fst)) 130 | #endif 131 | 132 | -- | one or more steps (transitive closure) 133 | narrows' :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 134 | narrows' rr = liftM (second zonkSubst) . run(closureMP(narrowStepBasic rr >=> zonkM return . fst)) 135 | 136 | ------------------------------ 137 | -- * Narrowing under Strategies 138 | -- --------------------------- 139 | 140 | #ifdef LOGICT 141 | -- | Innermost narrowing 142 | innNarrowing :: (Unify t, Ord v, Enum v, Rename v, Measured v ann, MonadLogic m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 143 | innNarrowing rr t = do 144 | (t', s) <- run (fixMP (innStepBasic rr >=> zonkM return)) t 145 | return (t', zonkSubst s) 146 | 147 | -- | Innermost Basic Narrowing 148 | innBnarrowing :: (Unify t, Ord v, Enum v, Rename v, Measured v ann, MonadLogic m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 149 | innBnarrowing rr t = second (restrictTo (vars t)) `liftM` run go t where go = fixMP (innStepBasic rr) 150 | 151 | -- TODO: Prove that this implementation really fulfills the innermost restriction 152 | innStepBasic :: (Ord v, Measured v ann, Unify t, MonadEnv ann t v m, MonadVariant v m, MonadLogic m) => [Rule ann t v] -> Term ann t v -> m(Term ann t v) 153 | innStepBasic rr t = do 154 | rr' <- mapM getFresh rr 155 | let go (t, ct) = ifte (msum [go (t, ct`mappend`ct1) | (t, ct1,_) <- contexts t]) -- Try 156 | return -- then return it 157 | ((ct |>) `liftM` narrowTop t) -- else narrow at the top 158 | narrowTop t = msum $ flip map rr' $ \(lhs:->rhs) -> do 159 | guard (not $ isVar t) 160 | unifyM lhs t 161 | return rhs 162 | go (t, mempty) 163 | #endif 164 | 165 | narrowBounded :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => (Term ann t v -> Bool) -> [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 166 | narrowBounded pred rr t = second (restrictTo (vars t)) `liftM` run go t where 167 | go t = do 168 | t' <- narrowStepBasic rr t >>= zonkM return . fst 169 | if pred t' then go t' else return t' 170 | 171 | -- ** Basic Narrowing 172 | narrow1Basic :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 173 | narrow1Basic = narrow1 174 | 175 | narrowsBasic :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 176 | narrowsBasic rr t = second (restrictTo (vars t)) `liftM` 177 | run (closureMP (liftM fst . narrowStepBasic rr) >=> zonkM return) t 178 | #ifdef LOGICT 179 | narrowBasic :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadLogic m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 180 | narrowBasic rr t = second (restrictTo (vars t)) `liftM` 181 | run (fixMP (liftM fst . narrowStepBasic rr) >=> zonkM return) t 182 | #else 183 | narrowBasic :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, Eq (Term ann t v), MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 184 | narrowBasic rr t = second (restrictTo (vars t)) `liftM` 185 | run (fixM_Eq (liftM fst . narrowStepBasic rr) >=> zonkM return) t 186 | #endif 187 | narrowBasicBounded :: (Ord v, Enum v, Rename v, Measured v ann, Unify t, MonadPlus m) => (Term ann t v -> Bool) -> [Rule ann t v] -> Term ann t v -> m (Term ann t v, Substitution ann t v) 188 | narrowBasicBounded pred rr t = second (restrictTo (vars t)) `liftM` run (go >=> zonkM return) t 189 | where 190 | go t = do 191 | t' <- fst `liftM` narrowStepBasic rr t 192 | if pred t' then go t' else return t' 193 | 194 | -------------------------------------------------------------------------------- /Data/Term/Annotated/Rewriting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Data.Term.Annotated.Rewriting ( 3 | -- * One step 4 | rewrite1, rewrite1', rewrite1p, 5 | -- * Big step 6 | rewrites, reduce 7 | ) where 8 | 9 | import Control.Applicative 10 | #ifdef LOGICT 11 | import Control.Monad.Logic 12 | #endif 13 | import Control.Monad.State 14 | import Data.List 15 | import Data.Foldable as F 16 | 17 | import Data.Term.Annotated 18 | import Data.Term.Annotated.Rules 19 | import Data.Term.Utils 20 | 21 | ---------------------------------------- 22 | -- * Rewriting 23 | ---------------------------------------- 24 | 25 | rewrite1 :: (Ord v, Enum v, Rename v, Measured v ann, Match t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m(Term ann t v) 26 | rewrite1 rr t = (snd `liftM` rewriteStep rr t) `evalStateT` freshvars 27 | where freshvars = [toEnum 0 ..] \\ vars t 28 | 29 | rewrite1' :: (Ord v, Enum v, Rename v, Measured v ann, Match t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m(Position, Term ann t v) 30 | rewrite1' rr t = rewriteStep rr t `evalStateT` freshvars 31 | where freshvars = [toEnum 0 ..] \\ vars t 32 | 33 | rewrite1p :: (Ord v, Enum v, Rename v, Measured v ann, Match t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> Position -> m(Term ann t v) 34 | rewrite1p rr t p = liftM fst $ updateAtM p (rewriteTop rr) t 35 | 36 | -- | Reflexive, Transitive closure 37 | rewrites :: (Ord v, Enum v, Rename v, Measured v ann, Match t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v) 38 | rewrites rr t = closureMP (liftM snd . rewriteStep rr) t `evalStateT` freshvars 39 | where freshvars = [toEnum 0 ..] \\ vars t 40 | 41 | rewriteStep :: (Ord v, Match t, Rename v, Measured v ann, MonadVariant v m, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Position, Term ann t v) 42 | rewriteStep rr t = do 43 | rr' <- mapM getFresh rr 44 | someSubtermDeep (rewriteTop rr') t 45 | 46 | rewriteTop rr t = F.msum $ forEach rr $ \r -> do 47 | lhs:->rhs <- return r 48 | case match lhs t of 49 | Just subst -> return (applySubst subst rhs) 50 | Nothing -> mzero 51 | 52 | #ifdef LOGICT 53 | -- | Normal forms, starting from leftmost outermost 54 | -- Assumes no extra variables in the rhs are present 55 | reduce :: (Ord v, Enum v, Rename v, Measured v ann, Match t, MonadLogic m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v) 56 | reduce rr t = fixMP (liftM snd . rewriteStep rr) t `evalStateT` freshvars 57 | where freshvars = [toEnum 0 ..] \\ vars t 58 | #else 59 | -- | Normal forms, starting from leftmost outermost 60 | -- Assumes no extra variables in the rhs are present 61 | reduce :: (Ord v, Enum v, Rename v, Measured v ann, Eq (Term ann t v), Match t, MonadPlus m) => [Rule ann t v] -> Term ann t v -> m (Term ann t v) 62 | reduce rr t = fixM_Eq (liftM snd . rewriteStep rr) t `evalStateT` freshvars 63 | where freshvars = [toEnum 0 ..] \\ vars t 64 | #endif 65 | -------------------------------------------------------------------------------- /Data/Term/Annotated/Rules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 2 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE PatternGuards #-} 9 | {-# LANGUAGE CPP #-} 10 | 11 | {-| This module works with an abstract notion of rule. 12 | 13 | A rule is a set of terms (generally a pair) which must 14 | be treated as a whole. Concrete examples include 15 | term rewriting rules and prolog clauses. 16 | 17 | To do this the module provides 18 | generalizations of the unify, match, equiv, fresh and vars 19 | operations which work with sets of terms. 20 | -} 21 | module Data.Term.Annotated.Rules 22 | (RuleF(..), Rule, left, right, HasRules(..), swapRule, IsTRS(..), 23 | Signature(..), R.mapSignature, R.allSymbols, HasSignature(..), 24 | R.getArity, R.getArities, R.getConstructorSymbols, R.getDefinedSymbols, R.getAllSymbols, 25 | isConstructorTerm, isRootDefined, collectIds, 26 | GetVars(..), 27 | GetUnifier(..), getUnifier, unifies', equiv', getUnifierMdefault, 28 | GetMatcher(..), getMatcher, matches', getMatcherMdefault, 29 | GetFresh(..), getFresh, getVariant, getFreshMdefault 30 | ) where 31 | 32 | import Control.Applicative 33 | import Control.Monad (zipWithM_) 34 | import Control.Monad.Free.Annotated 35 | import Control.Monad.State (evalState, execStateT, evalStateT) 36 | import Data.Foldable (Foldable, foldMap, toList) 37 | import Data.List ((\\)) 38 | import Data.Maybe 39 | import Data.Monoid 40 | import Data.Traversable (Traversable) 41 | import qualified Data.Traversable as T 42 | import qualified Data.Map as Map 43 | import qualified Data.Set as Set 44 | 45 | import Data.Term.Annotated 46 | import Data.Term.Rules (RuleF(..), Signature(..), HasSignature(..), GetVars(..) 47 | ,getConstructorSymbols, getDefinedSymbols) 48 | import qualified Data.Term.Rules as R 49 | 50 | -- ---------------- 51 | -- * Concrete rules 52 | -- ---------------- 53 | instance (Measured v ann, Traversable t) => GetFresh ann t v (Rule ann t v) where getFreshM = getFreshMdefault 54 | instance (Measured v ann, Eq v, Traversable t, Eq (t())) => GetUnifier ann t v (Rule ann t v) where getUnifierM = getUnifierMdefault 55 | instance (Measured v ann, Eq v, Traversable t, Eq (t())) => GetMatcher ann t v (Rule ann t v) where getMatcherM = getMatcherMdefault 56 | 57 | type Rule ann t v = RuleF (Term ann t v) 58 | 59 | {-# RULES "rules/tRS" forall x. tRS (rules x) = x #-} 60 | {-# RULES "tRS/rules" forall x. rules (tRS x) = x #-} 61 | 62 | class HasRules ann t v trs | trs -> ann t v where rules :: trs -> [Rule ann t v] 63 | class HasRules ann t v trs => IsTRS ann t v trs | trs -> ann t v where tRS :: [Rule ann t v] -> trs 64 | 65 | instance HasRules ann t v (Rule ann t v) where rules = (:[]) 66 | instance HasRules ann t v a => HasRules ann t v [a] where rules = foldMap rules 67 | instance IsTRS ann t v [Rule ann t v] where tRS = id 68 | 69 | swapRule :: RuleF a -> RuleF a 70 | swapRule (l :-> r) = r :-> l 71 | 72 | left,right :: (a -> a) -> RuleF a -> RuleF a 73 | 74 | left f (l :-> r) = f l :-> r 75 | right f (l :-> r) = l :-> f r 76 | 77 | -- ----------- 78 | -- * Variables 79 | -- ----------- 80 | instance (Functor termF, Foldable termF, Ord var) => GetVars var (Term ann termF var) where getVars = Set.fromList . toList 81 | 82 | -- ------------------------------------------ 83 | -- * GetFresh: Variants 84 | -- ------------------------------------------ 85 | 86 | class (Traversable termF) => GetFresh ann termF var thing | thing -> ann termF var where 87 | getFreshM :: (MonadVariant var m, MonadEnv ann termF var m) => thing -> m thing 88 | instance (Monoid ann, Measured var ann, Traversable termF) => GetFresh ann termF var (Term ann termF var) where 89 | getFreshM = fresh 90 | instance (Traversable termF, GetFresh ann termF var t) => GetFresh ann termF var [t] where 91 | getFreshM = getFreshMdefault 92 | 93 | getFreshMdefault :: (Traversable t, GetFresh ann term v a, MonadVariant v m, MonadEnv ann term v m) => t a -> m (t a) 94 | getFreshMdefault = T.mapM getFreshM 95 | 96 | getFresh :: forall ann t v m thing. (Ord v, Measured v ann, MonadVariant v m, GetFresh ann t v thing) => thing -> m thing 97 | getFresh t = evalStateT (getFreshM t) (mempty :: Substitution ann t v) 98 | 99 | getVariant :: (Monoid ann, Measured v ann, Enum v, Rename v, GetFresh ann termF v t, GetVars v t') => t -> t' -> t 100 | getVariant u t = evalState (getFresh u) ([toEnum 0..] \\ Set.toList (getVars t)) 101 | 102 | -- --------------------- 103 | -- * Signatures 104 | -- --------------------- 105 | 106 | instance (HasId t, Functor t, Foldable t) => HasSignature (Term ann t v) where 107 | type SignatureId (Term ann t v) = TermId t 108 | getSignature t = Sig{ definedSymbols = Map.empty 109 | , constructorSymbols = all } 110 | where 111 | all = Map.fromList [(f,length (directSubterms t)) 112 | | t <- subterms t 113 | , Just f <- [rootSymbol t]] 114 | 115 | instance (Functor t, Foldable t, HasId t) => HasSignature [Term ann t v] where 116 | type SignatureId [Term ann t v] = TermId t 117 | getSignature terms = Sig{ definedSymbols = Map.empty 118 | , constructorSymbols = all 119 | } 120 | where all = Map.fromList [(f,length (directSubterms t)) 121 | | t <- concatMap subterms terms 122 | , Just f <- [rootSymbol t]] 123 | 124 | 125 | instance (Functor t, Foldable t, HasId t) => HasSignature (Rule ann t v) where 126 | type SignatureId (Rule ann t v) = TermId t 127 | getSignature (l :-> r) 128 | | Just d <- rootSymbol l 129 | = Sig{ definedSymbols = Map.singleton d (length $ directSubterms l) 130 | , constructorSymbols = all} 131 | | otherwise 132 | = Sig { definedSymbols = Map.empty 133 | , constructorSymbols = Map.fromList [(f,length (directSubterms t)) 134 | | t <- concatMap subterms [l,r] 135 | , Just f <- [rootSymbol t]]} 136 | where 137 | all = Map.fromList [(f,length (directSubterms t)) 138 | | t <- concatMap subterms (r : directSubterms l) 139 | , Just f <- [rootSymbol t]] 140 | 141 | instance (Functor t, Foldable t, HasId t) => HasSignature [Rule ann t v] where 142 | type SignatureId [Rule ann t v] = TermId t 143 | getSignature rules = Sig{ definedSymbols = filterByKey (`Set.member` dd) all 144 | , constructorSymbols = filterByKey (`Set.notMember` dd) all 145 | } 146 | where 147 | filterByKey f = Map.filterWithKey (\k _ -> f k) 148 | dd = Set.fromList [ root | l :-> _ <- rules, let Just root = rootSymbol l] 149 | all = Map.fromList [(f,length (directSubterms t)) 150 | | l :-> r <- rules 151 | , t <- concatMap subterms [l,r] 152 | , Just f <- [rootSymbol t]] 153 | 154 | 155 | isConstructorTerm :: (Functor t, Foldable t, HasId t, HasSignature sig, TermId t ~ SignatureId sig) => sig -> Term ann t v -> Bool 156 | isConstructorTerm sig t = (`Set.member` getConstructorSymbols sig) `all` collectIds t 157 | 158 | isRootDefined :: ( HasId t, HasSignature sig, TermId t ~ SignatureId sig) => sig -> Term ann t v -> Bool 159 | isRootDefined sig t 160 | | Just id <- rootSymbol t = id `Set.member` getDefinedSymbols sig 161 | | otherwise = False 162 | 163 | collectIds :: (Functor t, Foldable t, HasId t) => Term ann t v -> [TermId t] 164 | collectIds = catMaybes . foldTerm (const [Nothing]) (\t -> getId t : concat (toList t)) 165 | 166 | -- ------------- 167 | -- * Unification 168 | -- ------------- 169 | getUnifier :: (Foldable termF, Measured var ann, GetUnifier ann termF var t, Ord var) => 170 | t -> t -> Maybe (Substitution ann termF var) 171 | getUnifier t u = zonkSubst <$> execStateT (getUnifierM t u) mempty 172 | 173 | unifies' :: forall ann termF v t. 174 | (Measured v ann, Foldable termF, Ord v, GetUnifier ann termF v t) => 175 | t -> t -> Bool 176 | unifies' s t = isJust (getUnifier s t) 177 | 178 | class Functor termF => GetUnifier ann termF var t | t -> ann termF var 179 | where getUnifierM :: (MonadEnv ann termF var m, Ord var) => t -> t -> m () 180 | 181 | instance (Monoid ann, Measured var ann, Eq var, Unify f) => GetUnifier ann f var (Term ann f var) where 182 | getUnifierM = unifyM 183 | instance (GetUnifier ann termF var t) => GetUnifier ann termF var [t] where 184 | getUnifierM = getUnifierMdefault 185 | 186 | 187 | getUnifierMdefault :: (Ord var, GetUnifier ann termF var t, MonadEnv ann termF var m, Functor f, Foldable f, Eq (f())) => 188 | f t -> f t -> m () 189 | getUnifierMdefault t u 190 | | (const () <$> t) == (const () <$> u) = zipWithM_ getUnifierM (toList t) (toList u) 191 | | otherwise = fail "structure mismatch" 192 | 193 | -- ------------ 194 | -- * Matching 195 | -- ------------ 196 | getMatcher :: (Foldable termF, Measured var ann, GetMatcher ann termF var t, Ord var) => 197 | t -> t -> Maybe (Substitution ann termF var) 198 | getMatcher t u = execStateT (getMatcherM t u) mempty 199 | 200 | matches' :: (Ord v, Measured v ann, Foldable termF, GetMatcher ann termF v t) => t -> t -> Bool 201 | matches' s t = isJust (getMatcher s t) 202 | 203 | class Functor termF => GetMatcher ann termF var t | t -> ann termF var 204 | where getMatcherM :: MonadEnv ann termF var m => t -> t -> m () 205 | 206 | instance (Eq var, Measured var ann, Match f) => GetMatcher ann f var (Term ann f var) where 207 | getMatcherM = matchM 208 | instance (GetMatcher ann termF var t) => GetMatcher ann termF var [t] where 209 | getMatcherM = getMatcherMdefault 210 | 211 | getMatcherMdefault :: (GetMatcher ann termF var t, MonadEnv ann termF var m, Functor f, Foldable f, Eq (f())) => 212 | f t -> f t -> m () 213 | getMatcherMdefault t u 214 | | (const () <$> t) == (const () <$> u) = zipWithM_ getMatcherM (toList t) (toList u) 215 | | otherwise = fail "structure mismatch" 216 | 217 | -- ---------------------------- 218 | -- * Equivalence up to renaming 219 | -- ---------------------------- 220 | --instance (Ord v, Enum v, Ord (Term t v), GetUnifier t v thing, GetVars v thing, GetFresh t v thing) => 221 | instance (Enum v, Rename v, Measured v ann, GetMatcher ann t v thing, GetVars v thing, GetFresh ann t v thing) => 222 | Eq (EqModulo thing) where 223 | EqModulo t1 == EqModulo t2 = t1 `equiv'` t2 224 | {- 225 | equiv' :: forall termF var t ann. 226 | (Ord var, Enum var, Rename var, Ord (Term ann termF var), 227 | GetUnifier ann termF var t, GetVars var t, GetFresh ann termF var t, 228 | Measured var ann 229 | ) => t -> t -> Bool 230 | equiv' t u = maybe False isRenaming (getUnifier (getVariant t u) u) 231 | -} 232 | 233 | equiv' :: forall termF var t ann. 234 | (Foldable termF, Ord var, Enum var, Rename var, Measured var ann, 235 | GetMatcher ann termF var t, GetVars var t, GetFresh ann termF var t 236 | ) => t -> t -> Bool 237 | equiv' t u = let t' = getVariant t u in matches' t' u && matches' u t' 238 | -------------------------------------------------------------------------------- /Data/Term/Automata.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 2 | {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE PatternSynonyms #-} 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE InstanceSigs #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | {-# LANGUAGE GADTs #-} 15 | {-# LANGUAGE LambdaCase #-} 16 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 17 | 18 | module Data.Term.Automata 19 | (TermMatcher, Tree, FastMatch, singleton, insert, createMatcher, createMatcherO 20 | , match, isNF, isNFO, Data.Term.Automata.map 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Applicative.Compose 25 | import Control.Monad.Free 26 | import Control.Monad.Free.Extras() 27 | import Control.Monad.State 28 | import Control.DeepSeq 29 | import Control.DeepSeq.Extras 30 | import Data.Foldable (Foldable) 31 | import Data.Function 32 | import qualified Data.Foldable as F 33 | import qualified Data.Map as Map 34 | import Data.Map.Strict (Map) 35 | import Data.Maybe (fromMaybe, isJust, isNothing) 36 | import Data.Monoid (Monoid(..)) 37 | import Data.Term 38 | import Data.Term.Simple 39 | import Data.Term.Var 40 | import Data.Term.Rules 41 | import qualified Data.Term.Rewriting as R 42 | import Data.Term.Substitutions 43 | import Data.Traversable as T 44 | import Data.Typeable 45 | import GHC.Generics (Generic) 46 | import Prelude.Extras 47 | import Unsafe.Coerce 48 | 49 | import Debug.Hoed.Observe 50 | import Debug.Hoed.Observe.Instances 51 | import Data.Term.Utils (interleave) 52 | 53 | -- ------------------------------------------- 54 | -- Fast normal form checking via Tree automata 55 | -- ------------------------------------------- 56 | 57 | {- This representation is wrong and needs to be fixed for: 58 | 1. Non linear terms, by replacing Any with named variables 59 | 2. Non total, overlapping terms. Example: 60 | f(a,x), f(x,b) 61 | where x is a variable, will not match the term f(c,c). 62 | However the term matcher obtained will be f(Any,Any) which will give a false match. 63 | -} 64 | data Tree a = Node a (Forest a) 65 | deriving (Eq, Show, Ord, Functor, Foldable, Traversable, Generic, Generic1, Typeable) 66 | type Forest a = [Tree a] 67 | type SubtermMatcher t v = Forest (TermMatcher t v) 68 | type FastMatch t v = (Ord1 t, Traversable t, NFData1 t, NFData v, Ord v, Observable v, Observable1 t, Observable1 (Term t)) 69 | 70 | data TermMatcher t v = 71 | Branch (Map (Lift1 t ()) (SubtermMatcher t v)) 72 | | Var v 73 | deriving (Generic, Generic1, Typeable) 74 | 75 | pattern Done = [] 76 | 77 | instance Eq1 t => Eq1 (TermMatcher t) where 78 | (==#) :: forall v. Eq v => TermMatcher t v -> TermMatcher t v -> Bool 79 | Branch m1 ==# Branch m2 = m1 == m2 80 | Var v1 ==# Var v2 = v1 == v2 81 | _ ==# _ = False 82 | instance (Eq1 t, Eq v) => Eq (TermMatcher t v) where (==) = (==#) 83 | 84 | instance Ord1 t => Ord1 (TermMatcher t) where 85 | compare1 :: forall v . Ord v => TermMatcher t v -> TermMatcher t v -> Ordering 86 | compare1 (Branch m1) (Branch m2) = compare m1 m2 87 | compare1 (Var v1) (Var v2) = compare v1 v2 88 | compare1 Branch{} Var{} = LT 89 | compare1 Var{} Branch{} = GT 90 | instance (Ord1 t, Ord v) => Ord (TermMatcher t v) where compare = compare1 91 | 92 | instance Show1 t => Show1 (TermMatcher t) where 93 | showsPrec1 :: forall v. Show v => Int -> TermMatcher t v -> ShowS 94 | showsPrec1 p (Var v) = showsPrec p v 95 | showsPrec1 p (Branch m) = showParen (p>=5) (("Branch " ++) . showsPrec 5 m) 96 | 97 | instance (Show1 t, Show v) => Show (TermMatcher t v) where showsPrec = showsPrec1 98 | 99 | mappendTM :: (Observable a, Observable1 t, Observable1 (Free t), Ord1 t, Eq a 100 | ) => Observer -> TermMatcher t a -> TermMatcher t a -> [TermMatcher t a] 101 | mappendSTM :: (Observable a, Observable1 (Free t), Observable1 t, Ord1 t, Eq a 102 | ) => Observer -> Forest (TermMatcher t a) -> Forest (TermMatcher t a) -> Forest(TermMatcher t a) 103 | mergeSTM :: (Observable a, Observable1 (Free t), Observable1 t, Ord1 t, Eq a 104 | ) => Observer -> Forest (TermMatcher t a) -> Forest (TermMatcher t a) 105 | mappendSTM (O _ oo) x y = oo "mergeSTM" mergeSTM (x ++ y) 106 | 107 | mergeSTM _ [] = [] 108 | mergeSTM (O o oo) (a:aa) = 109 | foldr (oo "mergeAlg" mergeAlg) [a] aa 110 | 111 | mergeAlg :: (Observable v, Observable1 t, Observable1 (Free t), Ord1 t, Eq v 112 | ) => Observer -> Tree (TermMatcher t v) -> Forest (TermMatcher t v) -> Forest (TermMatcher t v) 113 | mergeAlg (O o oo) x all = F.minimumBy (compare `on` length) $ 114 | Prelude.map concat (interleave (\y -> oo "mergeAlg'" mergeAlg' x y) (:[]) all) 115 | mergeAlg' ::(Observable v, Observable1 t, Observable1 (Free t), Ord1 t, Eq v 116 | ) => Observer -> Tree (TermMatcher t v) -> Tree (TermMatcher t v) -> Forest (TermMatcher t v) 117 | mergeAlg' (O _ oo) (Node t1 s1) (Node t2 s2) 118 | | t1 == t2 = [Node t1 (oo "STM" mappendSTM s1 s2)] 119 | | s1 == s2 = [Node m s1 | m <- oo "TM" mappendTM t1 t2] 120 | | otherwise = [Node t1 s1, Node t2 s2] 121 | 122 | mappendTM (O _ oo) (Branch b1) (Branch b2) = [Branch (Map.unionWith (oo "STM" mappendSTM) b1 b2)] 123 | mappendTM (O o oo) (Var v1) (Var v2) | v1 == v2 = [Var v1] 124 | mappendTM (O o oo) a b = [a, b] 125 | 126 | instance (Ord1 t, Eq v, Observable v, Observable1 t) => Monoid (TermMatcher t v) where 127 | mempty = Branch mempty 128 | mappend = mappendO nilObserver 129 | 130 | mappendO o a b = 131 | case mappendTM o a b of 132 | [x] -> x 133 | _ -> error "Monoid (TermMatcher t v): cannot resolve ambiguity at top level" 134 | 135 | map :: (Functor f, Ord1 g 136 | ) => (forall a. f a -> g a) -> TermMatcher f v -> TermMatcher g v 137 | map _ (Var v) = Var v 138 | map f (Branch m) = Branch $ Map.map (mapSM f) $ Map.mapKeys (\(Lift1 x) -> Lift1 (f x)) $ m 139 | 140 | mapSM :: (Functor f, Ord1 g 141 | ) => (forall a. f a -> g a) -> SubtermMatcher f v -> SubtermMatcher g v 142 | mapSM f = fmap g where 143 | g (Node tm stm) = Node (Data.Term.Automata.map f tm) (mapSM f stm) 144 | 145 | singleton :: forall t v. FastMatch t v => Term t v -> TermMatcher t v 146 | singleton = foldTerm Var ft where 147 | ft t = Branch (Map.singleton (Lift1 $ fmap (const ()) t) stm) where 148 | stm :: SubtermMatcher t v 149 | stm = F.foldr (\a b -> [Node a b]) mempty t 150 | 151 | insertO :: FastMatch t v => Observer -> Term t v -> TermMatcher t v -> TermMatcher t v 152 | insertO o t m = mappendO o (singleton t) m 153 | 154 | insert :: FastMatch t v => Term t v -> TermMatcher t v -> TermMatcher t v 155 | insert t m = mappend (singleton t) m 156 | 157 | matches :: FastMatch t v => TermMatcher t v -> Term t v -> Bool 158 | matches = matchesO nilObserver 159 | matchesO :: FastMatch t v => Observer -> TermMatcher t v -> Term t v -> Bool 160 | matchesO o tm t = isJust $ evalMEnv (matchesM o tm t) 161 | 162 | matchesM:: forall m f v. 163 | ( FastMatch f v 164 | , MonadPlus m 165 | ) => Observer -> TermMatcher f v -> Term f v -> MEnvT f v m () 166 | matchesM (O o oo) tm t = snd(foldTerm fv ft t) tm 167 | where 168 | -- ft :: f(Term f v, TermMatcher f v -> m()) -> (Term f v, TermMatcher f v -> m()) 169 | ft t = (Impure(fmap fst t), ft' t) 170 | ft' t (Branch m) = 171 | case Map.lookup (Lift1 $ fmap (const()) t) m of 172 | Nothing -> fail "symbol" 173 | Just m' -> oo "submatches" submatches m' (Lift1 $ fmap snd t) 174 | ft' t (Var v) = doVar (Impure $ fmap fst t) v 175 | 176 | -- fv :: v -> (Term f v, TermMatcher f v -> m()) 177 | fv v = (Pure v, fv' v) 178 | fv' v (Var v') = doVar (Pure v) v' 179 | fv' _ _ = fail "var" 180 | 181 | doVar t v = do 182 | contents <- lookupVar v 183 | case contents of 184 | Nothing -> varBind v t 185 | Just t' | t == t' -> return () 186 | _ -> fail "incompatible" 187 | 188 | 189 | submatches o sms ftt = submatchesL o sms (F.toList ftt) 190 | submatchesL _ Done [] = return () 191 | submatchesL _ _ [] = fail "arity/shape" 192 | submatchesL _ Done _ = fail "arity/shape" 193 | submatchesL o sms (t:tt) = do 194 | let trySM (Node this next) = do 195 | t this 196 | submatchesL o next tt 197 | msum $ fmap trySM sms 198 | 199 | -- submatches :: forall t v m. 200 | -- (MonadPlus m, Observable1 m, FastMatch t v 201 | -- ) => Observer -> SubtermMatcher t v -> t(TermMatcher t v -> m()) -> m () 202 | submatches1 (O o oo) sm tt = do 203 | res <- runStateT (T.mapM (oo "matchSubterm" matchSubterm) tt) sm 204 | case res of 205 | (_, Done) -> return () 206 | _ -> fail "arity/shape (too small)" 207 | 208 | where 209 | -- matchSubterm :: Observer -> (TermMatcher t v -> m ()) -> StateT (SubtermMatcher t v) m () 210 | matchSubterm (O o oo) t = do 211 | st <- get 212 | when (null st) $ fail "arity/shape (too big)" 213 | o "msum" msum $ flip Prelude.map (o "st" st) (oo "tryMatchSubterm" tryMatchSubterm) 214 | where 215 | tryMatchSubterm (O o _) (Node this next) = do 216 | lift $ MEnv $ modify (o "menv") 217 | lift $ o "t" t this 218 | put next 219 | 220 | 221 | 222 | -- | Returns true if the term does not match any in the set of terms modelled by the matcher 223 | isNF :: forall t v. FastMatch t v => TermMatcher t v -> Term t v -> Bool 224 | isNFO :: forall t v. FastMatch t v => Observer -> TermMatcher t v -> Term t v -> Bool 225 | isNF = isNFO nilObserver 226 | isNFO o tm t = not (matchesO o tm t) 227 | 228 | -- | Given a TRS, returns a model of the normal forms of the TRS 229 | createMatcher :: FastMatch t v => [Term t v] -> TermMatcher t v 230 | createMatcher = Prelude.foldr insert mempty 231 | createMatcherO :: (FastMatch t v, Observable1 (Free t) 232 | ) => Observer -> [Term t v] -> TermMatcher t v 233 | createMatcherO (O _ oo) = Prelude.foldr (oo "insert" insertO) mempty 234 | 235 | a = term "a" [] 236 | b = term "b" [] 237 | x = var "x" 238 | x1 = var "x1" `asTypeOf` x 239 | x2 = var "x2" `asTypeOf` x 240 | --y = var "y" 241 | f tt = term "f" tt 242 | zero = term "0" [] 243 | s x = term "s" [x] 244 | p x = term "p" [x] 245 | minus a b = term "minus" [a,b] 246 | trs1 = [ a ] 247 | trs2 = [ f [a, a] 248 | , f [b, b] 249 | ] 250 | trs3 = [ f [x, x] ] 251 | trs4 = [ minus x x 252 | , minus zero x 253 | , minus x zero 254 | , minus (s x1) (s x2) 255 | -- , minus (s x) (s y) 256 | ] 257 | --Branch fromList [(Term {id = "minus", args = [(),()]},[Node (VName "x") [Node (VName "x") [],Node Branch (fromList [(Term {id = "0", args = []},[])]) []]])] 258 | 259 | check :: (t ~ Data.Term.Simple.TermF String, v ~ Data.Term.Var.Var 260 | ) => [Term t v] -> Term t v -> Bool 261 | check tt t = isNF (createMatcher tt) t == R.isNF [ t :-> a | t <- tt] t 262 | 263 | test1 = check trs1 (a) 264 | test1' = check trs1 (b) 265 | test1'' = check trs1 (term "b" [x]) 266 | test2 = check trs2 (f [a,b]) 267 | test2' = check trs2 (f [b,b]) 268 | test2'' = check trs2 (f [a,a]) 269 | test3 = check trs3 (f [a,b]) 270 | test3' = check trs3 (f [a,a]) 271 | test3'' = check trs3 (f [b,b]) 272 | test4 = check trs4 (minus zero zero) 273 | test4' = check trs4 (minus (s zero) zero) 274 | test4'' = check trs4 (minus zero (s zero)) 275 | test4''' = check trs4 (minus x1 x2) 276 | test4'''' = check trs4 (s(minus (s x1) (s x2))) 277 | 278 | instance (NFData1 f) => NFData1 (TermMatcher f) where 279 | rnf1 (Var v) = rnf v 280 | rnf1 (Branch m) = rnf m 281 | instance (NFData1 t, NFData v) => NFData (TermMatcher t v) where rnf = rnf1 282 | 283 | instance NFData1 Tree where rnf1 (Node a b) = rnf a `seq` rnf b 284 | instance NFData a => NFData (Tree a) where rnf = rnf1 285 | 286 | instance (Observable1 f) => Observable1 (TermMatcher f) 287 | instance (Observable1 f, Observable a) => Observable(TermMatcher f a) where 288 | observers = observers1 289 | observer = observer1 290 | instance Observable1 Tree 291 | instance Observable a => Observable (Tree a) where 292 | observers = observers1 293 | observer = observer1 294 | -------------------------------------------------------------------------------- /Data/Term/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, UndecidableInstances, ScopedTypeVariables #-} 2 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 3 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE Rank2Types, PolyKinds #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | {-# LANGUAGE CPP #-} 11 | module Data.Term.Base where 12 | 13 | 14 | import Control.Applicative 15 | import Control.Category 16 | import Control.Monad (liftM, MonadPlus(..)) 17 | import Control.Monad.Free (Free(..), foldFree, foldFreeM, mapFree, mapFreeM, evalFree, isPure) 18 | import Control.Monad.Identity (runIdentity) 19 | import Control.Monad.Trans (MonadTrans(..)) 20 | 21 | #ifdef LOGICT 22 | import Control.Monad.Logic (MonadLogic(msplit), LogicT) 23 | #endif 24 | 25 | import Data.Bifunctor 26 | import Data.Bitraversable 27 | import Data.Bifoldable 28 | import Data.Foldable (Foldable(..), toList, msum) 29 | import Data.Monoid 30 | import Data.Traversable as T 31 | 32 | import Data.Id.Family 33 | import Data.Term.Family 34 | import Data.Term.Utils 35 | import Prelude as P hiding (mapM,(.),id) 36 | import Control.Monad.State (runStateT) 37 | import Control.Monad.State (put) 38 | 39 | 40 | -- -------- 41 | -- * Terms 42 | -- -------- 43 | type Term = Free 44 | type TermFor (t :: k) = Term (TermF t) (Var t) 45 | type UnwrappedTermFor t = (TermF t) (TermFor t) 46 | type instance TermF (Term t v) = t 47 | type instance TermF (Term t) = t 48 | type instance Var (Term t v) = v 49 | 50 | -- | Catamorphism over a term 51 | foldTerm :: Functor t => (a -> b) -> (t b -> b) -> Term t a -> b 52 | foldTerm = foldFree 53 | foldTermM :: (Traversable t, Monad m) => (a -> m b) -> (t b -> m b) -> Term t a -> m b 54 | foldTermM = foldFreeM 55 | 56 | -- | Functor from a term structure to another 57 | mapTerm :: (Functor t, Functor t') => (forall a. t a -> t' a) -> Term t a -> Term t' a 58 | mapTerm f = mapFree f 59 | 60 | -- | Destructor 61 | evalTerm :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b 62 | evalTerm = evalFree 63 | 64 | 65 | subterms, properSubterms, directSubterms :: Foldable termF => Term termF var -> [Term termF var] 66 | -- | Get all subterms of a term, including the term itself 67 | subterms t = t : properSubterms t 68 | -- | Get all the subterms of a term, excluding the term itself 69 | properSubterms (Impure t) = P.concat (subterms <$> toList t) 70 | properSubterms _ = [] 71 | -- | Get the direct children of a term 72 | directSubterms (Impure t) = toList t 73 | directSubterms _ = [] 74 | 75 | -- | Map a endomorphism over the subterms of a term 76 | mapSubterms :: Functor t => (Term t v -> Term t v) -> Term t v -> Term t v 77 | mapSubterms f = evalTerm return (Impure . fmap f) 78 | 79 | mapMSubterms :: (Traversable t, Monad m) => (Term t v -> m(Term t v)) -> Term t v -> m(Term t v) 80 | mapMSubterms f = evalTerm (return.return) (liftM Impure . mapM f) 81 | 82 | 83 | -- | Non-deterministically applies a non-deterministic endomorphism over the children of a term 84 | someSubterm :: (Traversable f, MonadPlus m) => (Term f a -> m(Term f a)) -> Term f a -> m (Term f a) 85 | someSubterm f = evalFree (return.return) (msum . liftM2 Impure . interleaveM f) 86 | 87 | -- | Same as 'someSubterm', but the return type includes the position 88 | someSubterm' :: (Traversable f, MonadPlus m) => (Term f a -> m(Term f a)) -> Term f a -> m (Position, Term f a) 89 | someSubterm' f = evalTerm ( return . ([],) . return ) 90 | ( msum 91 | . zipWith (\p -> liftM ([p],)) [1..] 92 | . liftM2 Impure 93 | . interleaveM f) 94 | 95 | -- | Same as 'someSubterm'', but over all the subterms not just the children 96 | someSubtermDeep :: (Traversable t, MonadPlus m) => 97 | (Term t a -> m(Term t a)) -> Term t a -> m (Position, Term t a) 98 | someSubtermDeep f t = (foldTerm (\_ -> mzero) 99 | (\(Note1(pos,Note1(me,subs))) -> 100 | liftM ((pos,) . (\me -> updateAt pos (const me) t)) me 101 | `mplus` msum subs) 102 | . annotateWithPos 103 | . annotate f 104 | ) t 105 | 106 | -- | Collect all the subterms that satisfy a predicate 107 | collect :: (Foldable f, Functor f) => (Term f v -> Bool) -> Term f v -> [Term f v] 108 | collect pred t = [ u | u <- subterms t, pred u] 109 | 110 | -- | Returns all the variables of a term 111 | vars :: (Functor termF, Foldable termF) => Term termF var -> [var] 112 | vars = toList 113 | 114 | -- | True if the term is a variable 115 | isVar :: Term termF var -> Bool 116 | isVar = isPure 117 | 118 | -- | True if the term is linear, i.e. it contains no duplicate variables 119 | isLinear :: (Ord v, Foldable t, Functor t) => Term t v -> Bool 120 | isLinear t = length(snub varst) == length varst where 121 | varst = vars t 122 | 123 | -- ----------- 124 | -- * Positions 125 | -- ----------- 126 | type Position = [Int] 127 | 128 | -- | Returns a list with all the positions in a term 129 | positions :: (Functor f, Foldable f) => Term f v -> [Position] 130 | positions = foldFree (const [[]]) f where 131 | f x = [] : concat (zipWith (\i pp -> map (i:) pp) [1..] (toList x)) 132 | 133 | -- | get subterm at position or fail with error 134 | (!) :: Foldable f => Term f v -> Position -> Term f v 135 | Impure t ! (i:ii) = (toList t !! (i-1)) ! ii 136 | t ! [] = t 137 | _ ! _ = error "(!): invalid position" 138 | 139 | -- | t !? pos returns the deepest subterm at position p and some p' where pos = p.p' 140 | (!?) :: (Monad m, Foldable f) => Term f v -> Position -> m (Term f v, Position) 141 | Impure t !? (i:ii) = do {x <- toList t !!* (i-1); x !? ii} 142 | t !? [] = return (t,[]) 143 | t@Pure{} !? pos = return (t,pos) 144 | 145 | -- | get subterm at position or call @fail@ in @m@ 146 | (!*) :: (Monad m, Foldable f) => Term f v -> Position -> m(Term f v) 147 | Impure t !* (i:ii) = do {x <- toList t !!* (i-1); x !* ii} 148 | t !* [] = return t 149 | _ !* _ = fail "(!*): invalid position" 150 | 151 | infixr 4 !!* 152 | (!!*) :: Monad m => [a] -> Int -> m a 153 | x:_ !!* 0 = return x 154 | _:xx !!* i = xx !!* i - 1 155 | [] !!* _ = fail "!!*: index too large" 156 | 157 | -- | Updates the subterm at the position given 158 | -- A failure to reach the position given results in a runtime error 159 | updateAt :: (Traversable f) => Position -> (Term f v -> Term f v) -> Term f v -> Term f v 160 | updateAt (0:_) _ _ = error "updateAt: 0 is not a position!" 161 | updateAt [] f t = f t 162 | updateAt (i:ii) f (Impure t) = Impure (unsafeZipWithG g [1..] t) 163 | where g j st = if i==j then updateAt ii f st else st 164 | updateAt _ _ _ = error "updateAt: invalid position given" 165 | 166 | 167 | -- | Updates the subterm at the position given, 168 | -- returning a tuple with the new term and the previous contents at that position. 169 | -- Failure is contained inside the monad 170 | updateAt' :: (Traversable f, Monad m) => 171 | Position -> (Term f v -> Term f v) -> Term f v -> m (Term f v, Term f v) 172 | updateAt' pos f = updateAtM pos (return . f) 173 | 174 | -- | Monadic version of @updateAt'@ 175 | updateAtM :: (Traversable f, Monad m) => 176 | Position -> (Term f v -> m(Term f v)) -> Term f v -> m (Term f v, Term f v) 177 | updateAtM pos f t = runStateT (go pos t) t where 178 | go (0:_) _ = fail "updateAt: 0 is not a position!" 179 | go [] t = put t >> lift(f t) 180 | go (i:ii) (Impure t) = Impure `liftM` unsafeZipWithGM g [1..] t 181 | where g j st = if i==j then go ii st else return st 182 | go _ _ = fail "updateAt: invalid position given" 183 | 184 | -- | Tuple a value with a note 185 | newtype WithNote note a = Note (note, a) deriving (Show) 186 | -- | Tuple a functor with a note 187 | newtype WithNote1 note f a = Note1 (note, f a) deriving (Show) 188 | 189 | type instance Id (WithNote n a) = Id a 190 | type instance Id (WithNote1 n f) = Id f 191 | 192 | instance Eq a => Eq (WithNote n a) where Note (_,a) == Note (_,b) = a == b 193 | --instance (Functor f, Eq (Free f a)) => Eq (Free (WithNote1 n f) a) where 194 | -- a == b = f a == f b where f = mapTerm (\(Note1 (_,x)) -> x) 195 | 196 | instance Eq (f a) => Eq ((WithNote1 n f) a) where Note1 (_,x) == Note1 (_,y) = x == y 197 | 198 | instance Ord a => Ord (WithNote n a) where Note (_,a) `compare` Note (_,b) = compare a b 199 | --instance (Functor f, Ord (Free f a)) => Ord (Free (WithNote1 n f) a) where 200 | -- compare a b = f a `compare` f b where f = mapTerm (\(Note1 (_,x)) -> x) 201 | instance Ord (f a) => Ord ((WithNote1 n f) a) where Note1 (_,x) `compare` Note1 (_,y) = compare x y 202 | 203 | instance Functor f => Functor (WithNote1 note f) where fmap f (Note1 (p, fx)) = Note1 (p, fmap f fx) 204 | instance Foldable f => Foldable (WithNote1 note f) where foldMap f (Note1 (_p,fx)) = foldMap f fx 205 | instance Traversable f => Traversable (WithNote1 note f) where traverse f (Note1 (p, fx)) = (Note1 . (,) p) <$> traverse f fx 206 | instance Bifunctor WithNote where bimap f g (Note (n,a)) = Note (f n, g a) 207 | instance Bifoldable WithNote where bifoldMap f g (Note (n,a)) = f n `mappend` g a 208 | instance Bitraversable WithNote where bitraverse f g (Note (n,a)) = (Note.) . (,) <$> f n <*> g a 209 | 210 | -- | Given an annotated term structure, extract the top level note 211 | note :: Term (WithNote1 n t) (WithNote n a) -> n 212 | note (Impure (Note1 (n,_))) = n 213 | note (Pure (Note (n,_))) = n 214 | 215 | -- | Note extract function 216 | noteV :: WithNote n a -> n 217 | noteV (Note (n,_)) = n 218 | 219 | -- | Forgetful functor for annotated terms with annotated variables 220 | dropNote :: Functor t => Free (WithNote1 n t) (WithNote n a) -> Free t a 221 | dropNote = foldTerm (\(Note (_,v)) -> return v) (\(Note1 (_,x)) -> Impure x) 222 | 223 | -- | Forgetful functor for anotated terms 224 | dropNote1 :: Functor t => Free (WithNote1 n t) a -> Free t a 225 | dropNote1 = foldTerm return (\(Note1 (_,x)) -> Impure x) 226 | 227 | -- | Annotates a term tree with the positions 228 | annotateWithPos :: Traversable f => Free f a -> Free (WithNote1 Position f) (WithNote Position a) 229 | annotateWithPos = foldFree (\v -> return $ Note ([],v)) 230 | (Impure . Note1 . ([],) . unsafeZipWithG(\i pp -> mapNote (i:) pp) [1..]) 231 | where 232 | -- TODO replace with Bifunctor instance for WithNote1 233 | mapNote f (Impure(Note1(n,t))) = Impure(Note1(f n, t)) 234 | mapNote f (Pure (Note (pp,v))) = Pure (Note(f pp, v)) 235 | 236 | annotateWithPosV :: Traversable f => Term f v -> Term f (WithNote Position v) 237 | annotateWithPosV= go [] where 238 | go pos = evalFree (\v -> return $ Note (pos,v)) 239 | (\t -> Impure (unsafeZipWithG (\p' -> go (pos ++ [p'])) [1..] t)) -- TODO Remove the append at tail 240 | 241 | occurrences :: (Traversable f, Eq (Term f v)) => Term f v -> Term f v -> [Position] 242 | occurrences sub parent = [ note t | t <- subterms(annotateWithPos parent), dropNote t == sub] 243 | 244 | annotate :: (Traversable f) => (Term f v -> note) -> Term f v -> Term (WithNote1 note f) v 245 | annotate f = foldTerm return (\t -> (Impure . Note1 . (,t) . f . Impure . fmap dropNote1) t) 246 | 247 | annotateM :: (Traversable f, Monad m) => (Term f v -> m note) -> Term f v -> m(Term (WithNote1 note f) v) 248 | annotateM f = foldTermM (return.return) 249 | (\t -> (liftM(Impure . Note1 . (,t)) . f . Impure . fmap dropNote1) t) 250 | 251 | 252 | -- ----- 253 | -- * Ids 254 | -- ----- 255 | type instance Id (Free f) = Id f 256 | type instance Id (Free f v) = Id f 257 | 258 | class HasId1 f where 259 | getId1 :: f a -> Maybe (Id f) 260 | fromId1 :: Id f -> f a 261 | 262 | class HasId a where 263 | getId :: a -> Maybe (Id a) 264 | fromId :: Id a -> a 265 | 266 | instance HasId1 f => HasId (Free f v) where 267 | getId = evalFree (const Nothing) getId1 268 | fromId = Impure . fromId1 269 | 270 | class MapId f where mapId :: (id -> id') -> f id a -> f id' a 271 | mapIdM :: (Applicative m) => (id -> m id') -> f id a -> m(f id' a) 272 | mapId f = runIdentity . mapIdM (pure.f) 273 | 274 | instance Bitraversable f => MapId f where mapIdM f = bitraverse f pure 275 | 276 | -- | Extracts the root symbol if any 277 | rootSymbol :: HasId1 f => Term f v -> Maybe (Id f) 278 | rootSymbol = getId 279 | 280 | -- | Maps an endomorphism over the root symbol 281 | mapRootSymbol :: (Functor (f id), MapId f) => (id -> id) -> Term (f id) v -> Term (f id) v 282 | mapRootSymbol f = evalFree return (Impure . mapId f) 283 | 284 | -- | Functor that maps a morphism over all the symbols 285 | mapTermSymbols :: (Functor (f id), Functor (f id'), MapId f) => (id -> id') -> Term (f id) v -> Term (f id') v 286 | mapTermSymbols f = mapFree (mapId f) 287 | 288 | -- | Kleisli functor that maps a computation over all the symbols 289 | mapTermSymbolsM :: (Traversable (f id), Functor (f id'), MapId f, Applicative t, Monad t) => (id -> t id') -> Term (f id) v -> t(Term (f id') v) 290 | mapTermSymbolsM f = mapFreeM (mapIdM f) 291 | -------------------------------------------------------------------------------- /Data/Term/Family.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, PolyKinds #-} 2 | module Data.Term.Family ( 3 | module Data.Id.Family, 4 | module Data.Rule.Family, 5 | module Data.Term.Family, 6 | module Data.Var.Family 7 | ) where 8 | 9 | import Data.Id.Family 10 | import Data.Rule.Family 11 | import Data.Var.Family 12 | import Data.Set (Set) 13 | import Data.Map (Map) 14 | 15 | type family TermF (t::k) :: * -> * 16 | 17 | type instance TermF (Maybe a) = TermF a 18 | type instance TermF [t] = TermF t 19 | type instance TermF (Set t) = TermF t 20 | type instance TermF (Map k a) = TermF a 21 | 22 | -------------------------------------------------------------------------------- /Data/Term/IOVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# LANGUAGE OverlappingInstances, UndecidableInstances, FlexibleContexts #-} 7 | module Data.Term.IOVar where 8 | 9 | import Control.Applicative 10 | import Control.Arrow 11 | import qualified Control.Exception as CE 12 | import Control.Monad.Env 13 | import Control.Monad.Trans 14 | import Control.Monad.Free 15 | import Control.Monad.Variant 16 | 17 | 18 | import Data.IOStableRef 19 | import qualified Data.Map as Map 20 | import qualified Data.Set as Set 21 | import Data.Var.Family as Family 22 | import Data.Term.Family 23 | import Data.Term.Substitutions 24 | import Data.Traversable as T 25 | import qualified Prelude as P 26 | import Prelude 27 | 28 | import Debug.Hoed.Observe 29 | 30 | newtype IOVar termF = IOVar (IOStableRef( Maybe (Free termF (IOVar termF)))) deriving (Eq,Ord, Show) 31 | 32 | 33 | unifiesIO :: (Unify t, Eq (IOVar t)) => Free t (IOVar t) -> Free t (IOVar t) -> TIO t Bool 34 | unifiesIO t u = (unifyM t u >> return True) `catch` \(_ :: CE.SomeException) -> return False 35 | 36 | matchesIO :: (Unify t, Eq (IOVar t)) => Free t (IOVar t) -> Free t (IOVar t) -> TIO t Bool 37 | matchesIO t u = (matchM t u >> return True) `catch` \(_ :: CE.SomeException) -> return False 38 | 39 | instantiate :: (term ~ TermF m, Var m ~ Either var (IOVar term), Traversable term, MonadVariant m, MonadEnv m) => 40 | Free term var -> m (Free term (IOVar term)) 41 | instantiate t = (liftM.fmap) (\(Right x) -> x) 42 | (freshWith (flip const) 43 | (fmap Left t)) 44 | 45 | getInst :: (Traversable t, Ord var, Observable var, Eq (Free t (IOVar t))) => 46 | Substitution t (Either var (IOVar t)) -> TIO t (Substitution t var) 47 | getInst (unSubst -> s) = do 48 | map0' <- P.mapM (secondM (zonkM (\v -> let Just v' = lookup (Pure v) inversemap in return v'))) map0 49 | return $ fromListSubst map0' 50 | where 51 | map0 = map (fromLeft *** fmap fromRight) (Map.toList s) 52 | inversemap = [(b,a) | (a,b) <- map0] 53 | fromRight = either (error "getInst") id 54 | fromLeft = either id (error "getInst") 55 | secondM f (a,b) = f b >>= \b' -> return (a,b') 56 | 57 | instance Rename (IOVar t) where rename _ = id 58 | 59 | newtype TIO (t :: * -> *) a = TIO {tio::IO a} deriving (Applicative, Functor, Monad, MonadIO) 60 | 61 | catch m h = TIO (CE.catch (tio m) (tio.h)) 62 | 63 | type instance Var (TIO t) = IOVar t 64 | type instance TermF (TIO t) = t 65 | instance Traversable t => MonadEnv (TIO t) where 66 | varBind (IOVar v) t = liftIO $ writeIOStableRef v (Just t) 67 | lookupVar (IOVar v) = liftIO $ readIOStableRef v 68 | 69 | type instance Family.Var (TIO t) = IOVar t 70 | instance MonadVariant (TIO t) where 71 | freshVar = IOVar `liftM` liftIO(newIOStableRef Nothing) 72 | renaming _ = freshVar 73 | 74 | type instance Var (IOVar t) = IOVar t 75 | instance GetVars (IOVar t) where 76 | getVars = Set.singleton 77 | fromVar = id 78 | 79 | instance Observable (IOVar a) where observer = observeOpaque "IOVar" 80 | -------------------------------------------------------------------------------- /Data/Term/Narrowing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE NoMonomorphismRestriction #-} 7 | {-# LANGUAGE FlexibleContexts, FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 10 | 11 | module Data.Term.Narrowing ( 12 | contexts, fill, (|>), 13 | isRNF, 14 | narrow1, narrow1P, narrows, narrow, 15 | narrow1', narrow1P', narrows', narrow', 16 | narrowBasic, narrowsBasic, narrow1Basic, 17 | qNarrow1P, qNarrow1P', 18 | #ifdef LOGICT 19 | innNarrowing, innBnarrowing, 20 | #endif 21 | narrowBounded, narrowBasicBounded, 22 | narrowStepBasic 23 | ) where 24 | 25 | import Control.Applicative 26 | import Control.Arrow 27 | #ifdef LOGICT 28 | import Control.Monad.Logic 29 | #endif 30 | 31 | import Control.Monad 32 | import Control.Monad.Variant 33 | import Data.Term 34 | import Data.Term.Rewriting 35 | import Data.Term.Substitutions 36 | import Data.Term.Rules 37 | import Data.Term.Utils 38 | 39 | import Debug.Hoed.Observe 40 | 41 | import Text.PrettyPrint.HughesPJClass 42 | 43 | -- | Rigid Normal Form 44 | isRNF :: (Ord v, Observable v, Enum v, Rename v, Unify t) => [Rule t v] -> Term t v -> Bool 45 | isRNF rr x = case narrow1 rr x of [] -> True ; _ -> False 46 | 47 | -- ----------- 48 | -- * Contexts 49 | -- ----------- 50 | type Context t v = Term t (Either Hole v) 51 | data Hole = Hole deriving (Eq, Ord, Show) 52 | 53 | instance Pretty Hole where pPrint _ = text "?h" 54 | 55 | instance Functor t => Monoid (Context t v) where 56 | mempty = return (Left Hole) 57 | mappend ct1 ct2 = ct1 >>= f where 58 | f (Left Hole) = ct2 59 | f v = return v 60 | 61 | -- | Fill a hole in a context 62 | fill,(|>) :: Functor t => Context t v -> Term t v -> Term t v 63 | fill ct t = ct >>= f 64 | where f (Left Hole) = t 65 | f (Right v) = return v 66 | 67 | (|>) = fill 68 | 69 | -- | Returns one layer of contexts. 70 | -- That is, a list of direct subterms and the corresponding contexts 71 | -- | forall subterm ctx . (subterm, ctx) <- contexts t ==> ctx |> subterm = t 72 | contexts :: Traversable t => Term t v -> [(Term t v, Context t v, Position)] 73 | contexts t = [ (fmap fromRight t_i, u, [i]) 74 | | i <- [1..length (directSubterms t)] 75 | , (u, t_i) <- updateAt' [i] (const mempty)(fmap Right t) ] 76 | where fromRight (Right x) = x 77 | fromRight _ = error "contexts: the impossible happened" 78 | 79 | -- ------------ 80 | -- * Narrowing 81 | -- ------------ 82 | 83 | {-# INLINE narrowStepBasic #-} 84 | narrowStepBasic :: (Unify t, Ord v, Observable v, MonadPlus m, MonadVariant m, MonadEnv m, Var m ~ v, t ~ TermF m) => 85 | [Rule t v] -> Term t v -> m (Term t v, Position) 86 | narrowStepBasic rr t = go (t, mempty, []) 87 | where go (t, ct,pos) = do { t' <- narrowTop t; return (ct |> t', pos)} 88 | `mplus` 89 | msum [go (t', ct `mappend` ct', pos ++ i) | (t', ct', i) <- contexts t] 90 | narrowTop t = msum$ flip map rr $ \r -> do 91 | guard (not $ isVar t) 92 | lhs :-> rhs <- getFresh r 93 | unifyM lhs t 94 | return rhs 95 | 96 | -- | one step 97 | narrow1 :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m 98 | ) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 99 | narrow1 rr t = second (restrictTo (vars t)) `liftM` narrow1' rr t 100 | 101 | -- | one step, returns the position used 102 | narrow1P :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m ((Term t v, Position), Substitution t v) 103 | narrow1P rr t= second (restrictTo (vars t)) `liftM` narrow1P' rr t 104 | 105 | -- | narrowing to rigid normal form 106 | #ifdef LOGICT 107 | narrow :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadLogic m, Eq (Term t v) 108 | ) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 109 | #else 110 | narrow :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m, Eq (Term t v)) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 111 | #endif 112 | narrow rr t = second (restrictTo (vars t)) `liftM` narrow' rr t 113 | 114 | -- | narrowing transitive closure 115 | narrows :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 116 | narrows rr t = second (restrictTo (vars t)) `liftM` narrows' rr t 117 | 118 | 119 | -- ** Dirty versions 120 | -- These do not trim the substitution before returning 121 | 122 | -- Monad stacking both monadvariant and monadenv. 123 | -- TODO Manually roll for speed. 124 | newtype NarrowingM t v m a = NarrowingM {unNarrowingM :: MVariantT v (MEnvT t v m) a} 125 | deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadVariant) 126 | type instance Var (NarrowingM t v m) = v 127 | type instance TermF (NarrowingM t v m) = t 128 | 129 | deriving instance (Functor t, Foldable t, Ord v, Observable v, Monad m) => MonadEnv (NarrowingM t v m) 130 | 131 | #ifdef LOGICT 132 | -- deriving instance MonadLogic m => MonadLogic (NarrowingM t v m) 133 | instance MonadLogic m => MonadLogic (NarrowingM t v m) where 134 | msplit m = NarrowingM $ (liftM.liftM) f (msplit (unNarrowingM m)) where 135 | f (a,m') = (a, NarrowingM m') 136 | #endif 137 | 138 | run :: (Enum v, Ord v, Observable v, Functor t, Foldable t, Monad m 139 | ) => (Term t v -> NarrowingM t v m a) -> Term t v -> m (a, Substitution t v) 140 | run f t = runMEnv $ runVariantT' freshVars $ unNarrowingM $ f t where 141 | freshVars = [toEnum (1 + maximum ( 0 : map fromEnum (vars t))) ..] 142 | 143 | -- | one step 144 | narrow1' :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 145 | narrow1' rr = liftM (second zonkSubst) . run (narrowStepBasic rr >=> zonkM return . fst) 146 | 147 | -- | one step, returns the position used 148 | narrow1P' :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m ((Term t v, Position), Substitution t v) 149 | narrow1P' rr = liftM (second zonkSubst) . run (narrowStepBasic rr >=> firstM (zonkM return)) 150 | 151 | -- | narrowing to rigid normal form 152 | #ifdef LOGICT 153 | narrow' :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadLogic m, Eq (Term t v)) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 154 | narrow' rr = liftM (second zonkSubst) . run (fixMP(narrowStepBasic rr >=> zonkM return . fst)) 155 | #else 156 | narrow' :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m, Eq (Term t v)) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 157 | narrow' rr = liftM (second zonkSubst) . run (fixM_Eq(narrowStepBasic rr >=> zonkM return . fst)) 158 | #endif 159 | 160 | -- | one or more steps (transitive closure) 161 | narrows' :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 162 | narrows' rr = liftM (second zonkSubst) . run(closureMP(narrowStepBasic rr >=> zonkM return . fst)) 163 | 164 | ------------------------------ 165 | -- * Narrowing under Strategies 166 | -- --------------------------- 167 | -- | Note that this function does not assume that the rules and the term have been renamed apart 168 | qNarrow1P :: ( Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m, Observable1 t 169 | ) => (Term t v -> Bool) -> [Rule t v] -> Term t v -> m ((Term t v, Position), Substitution t v) 170 | qNarrow1P q rr t = second(restrictTo (vars t)) `liftM` qNarrow1P' q rr t 171 | -- | Note that this function does not assume that the rules and the term have been renamed apart 172 | qNarrow1P' :: ( Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m, Observable1 t 173 | ) => (Term t v -> Bool) -> [Rule t v] -> Term t v -> m ((Term t v, Position), Substitution t v) 174 | qNarrow1P' q rr = liftM(second zonkSubst) . run (qNarrowStepBasic q rr >=> firstM(zonkM return)) 175 | 176 | {-# INLINE qNarrowStepBasic #-} 177 | -- Note that this function does not assume that the rules and the term have been renamed apart 178 | qNarrowStepBasic :: (Unify t, Enum v, Ord v, Observable v, Observable1 t, MonadPlus m, MonadVariant m, MonadEnv m, Var m ~ v, t ~ TermF m) => 179 | (Term t v -> Bool) -> [Rule t v] -> Term t v -> m (Term t v, Position) 180 | qNarrowStepBasic isQNF rr t = go (t, mempty, []) 181 | where go (t, ct,pos) = do { t' <- narrowTop t; 182 | return (ct |> t', pos)} 183 | `mplus` 184 | msum [go (t', ct `mappend` ct', pos ++ i) 185 | | (t', ct', i) <- contexts t] 186 | narrowTop t = msum$ flip map rr $ \(lhs :-> rhs) -> do 187 | guard (not $ isVar t) 188 | unifyM lhs t 189 | lhs' <- zonkTermM return lhs 190 | forM_ (directSubterms lhs') (guard . isQNF) 191 | return rhs 192 | 193 | #ifdef LOGICT 194 | -- | Innermost narrowing 195 | innNarrowing :: (Unify t, Ord v, Observable v, Enum v, Rename v, Var m ~ v, MonadLogic m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 196 | innNarrowing rr t = do 197 | (t', s) <- run (fixMP (innStepBasic rr >=> zonkM return)) t 198 | return (t', zonkSubst s) 199 | 200 | -- | Innermost Basic Narrowing 201 | innBnarrowing :: (Unify t, Ord v, Observable v, Enum v, Rename v, MonadLogic m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 202 | innBnarrowing rr t = second (restrictTo (vars t)) `liftM` run go t where go = fixMP (innStepBasic rr) 203 | 204 | -- TODO: Prove that this implementation really fulfills the innermost restriction 205 | innStepBasic :: (Ord v, Observable v, Unify t, TermF m ~ t, Var m ~ v, MonadEnv m, MonadVariant m, MonadLogic m) => [Rule t v] -> Term t v -> m(Term t v) 206 | innStepBasic rr t = do 207 | rr' <- mapM getFresh rr 208 | let go (t, ct) = ifte (msum [go (t, ct`mappend`ct1) | (t, ct1,_) <- contexts t]) -- Try 209 | return -- then return it 210 | ((ct |>) `liftM` narrowTop t) -- else narrow at the top 211 | narrowTop t = msum $ flip map rr' $ \(lhs:->rhs) -> do 212 | guard (not $ isVar t) 213 | unifyM lhs t 214 | return rhs 215 | go (t, mempty) 216 | #endif 217 | 218 | narrowBounded :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => (Term t v -> Bool) -> [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 219 | narrowBounded pred rr t = second (restrictTo (vars t)) `liftM` run go t where 220 | go t = do 221 | t' <- narrowStepBasic rr t >>= zonkM return . fst 222 | if pred t' then go t' else return t' 223 | 224 | -- ** Basic Narrowing 225 | narrow1Basic :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 226 | narrow1Basic = narrow1 227 | 228 | narrowsBasic :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 229 | narrowsBasic rr t = second (restrictTo (vars t)) `liftM` 230 | run (closureMP (liftM fst . narrowStepBasic rr) >=> zonkM return) t 231 | #ifdef LOGICT 232 | narrowBasic :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadLogic m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 233 | narrowBasic rr t = second (restrictTo (vars t)) `liftM` 234 | run (fixMP (liftM fst . narrowStepBasic rr) >=> zonkM return) t 235 | #else 236 | narrowBasic :: (Ord v, Observable v, Enum v, Rename v, Unify t, Eq (Term t v), MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 237 | narrowBasic rr t = second (restrictTo (vars t)) `liftM` 238 | run (fixM_Eq (liftM fst . narrowStepBasic rr) >=> zonkM return) t 239 | #endif 240 | narrowBasicBounded :: (Ord v, Observable v, Enum v, Rename v, Unify t, MonadPlus m) => (Term t v -> Bool) -> [Rule t v] -> Term t v -> m (Term t v, Substitution t v) 241 | narrowBasicBounded pred rr t = second (restrictTo (vars t)) `liftM` run (go >=> zonkM return) t 242 | where 243 | go t = do 244 | t' <- fst `liftM` narrowStepBasic rr t 245 | if pred t' then go t' else return t' 246 | 247 | -------------------------------------------------------------------------------- /Data/Term/Ppr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | module Data.Term.Ppr where 6 | 7 | import Control.Monad.Free 8 | import qualified Data.Map as Map 9 | import Text.PrettyPrint.HughesPJClass as Pretty 10 | import Data.Foldable (Foldable) 11 | import Data.Term hiding (Var) 12 | import qualified Data.Var.Family as Family 13 | import Data.Term.Rules 14 | import Data.Term.Var 15 | import Data.Term.IOVar 16 | import Data.Term.Substitutions 17 | 18 | 19 | instance (Pretty (f(Term f a)), Pretty a) => Pretty (Term f a) where 20 | pPrint (Impure t) = pPrint t 21 | pPrint (Pure a) = pPrint a 22 | 23 | instance Pretty Var where 24 | pPrint (VName v) = text v 25 | pPrint (VAuto v_i) = text "V" <> Pretty.int v_i 26 | 27 | instance Pretty a => Pretty (RuleF a) where 28 | pPrint (l :-> r) = pPrint l <+> text "->" <+> pPrint r 29 | 30 | instance (Pretty a, Pretty(Family.Var a), Ord(Family.Var a) 31 | ) => Pretty (Substitution_ a) where 32 | pPrint = braces . hcat . punctuate comma . map (\(v,t) -> pPrint v <+> equals <+> pPrint t) . Map.toList . unSubst 33 | 34 | instance Pretty (IOVar t) where pPrint = text . show 35 | instance Pretty a => Pretty (EqModulo a) where pPrint = pPrint . eqModulo 36 | -------------------------------------------------------------------------------- /Data/Term/Rewriting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | 6 | module Data.Term.Rewriting ( 7 | isNF, isNFo, 8 | -- * One step 9 | rewrite1, rewrite1', rewrite1p, rewriteStep, 10 | rewrite1O, rewrite1O', rewrite1pO, rewriteStepO, 11 | -- * Big step 12 | rewrites, rewritesO, reduce 13 | ) where 14 | 15 | 16 | #ifdef LOGICT 17 | import Control.Monad.Logic 18 | #endif 19 | 20 | import Data.List 21 | import Data.Foldable as F 22 | 23 | import Control.Monad 24 | import Control.Monad.Free.Extras () 25 | import Control.Monad.Variant 26 | import Data.Term hiding (Rule) 27 | import Data.Term.Rules 28 | import Data.Term.Utils 29 | import Prelude.Extras 30 | 31 | import Debug.Hoed.Observe 32 | 33 | ---------------------------------------- 34 | -- * Rewriting 35 | ---------------------------------------- 36 | {-# INLINABLE isNF #-} 37 | -- | True if the term is a normal form w.r.t. the rules 38 | isNF :: (Match t, Rename v, Ord v, Observable v, Observable1 t, Enum v) => [Rule t v] -> Term t v -> Bool 39 | isNF = isNFo nilObserver 40 | {-# INLINABLE isNFo #-} 41 | -- | True if the term is a normal form w.r.t. the rules 42 | isNFo :: (Match t, Rename v, Ord v, Observable v, Observable1 t, Enum v) => Observer -> [Rule t v] -> Term t v -> Bool 43 | isNFo o rr = null . drop 1 . rewritesO o rr 44 | --isNF rr = not . F.any (\t -> F.any ((`matches` t) . lhs) rr) . subterms 45 | 46 | -- | Rewrite one step 47 | rewrite1 :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => [Rule t v] -> Term t v -> m(Term t v) 48 | rewrite1 = rewrite1O nilObserver 49 | 50 | -- | Rewrite one step 51 | rewrite1O :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => Observer -> [Rule t v] -> Term t v -> m(Term t v) 52 | rewrite1O o rr t = runVariantT' freshvars (snd `liftM` rewriteStepO o rr t) 53 | where freshvars = [toEnum 0 ..] \\ vars t 54 | 55 | -- | Rewrites one step and returns information about the position 56 | rewrite1' :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => [Rule t v] -> Term t v -> m(Position, Term t v) 57 | rewrite1' = rewrite1O' nilObserver 58 | 59 | -- | Rewrites one step and returns information about the position 60 | rewrite1O' :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => Observer -> [Rule t v] -> Term t v -> m(Position, Term t v) 61 | rewrite1O' o rr t = runVariantT' freshvars $ rewriteStepO o rr t 62 | where freshvars = [toEnum 0 ..] \\ vars t 63 | 64 | -- | Rewrites one step at the given position 65 | rewrite1p :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => [Rule t v] -> Term t v -> Position -> m(Term t v) 66 | rewrite1p = rewrite1pO nilObserver 67 | 68 | -- | Rewrites one step at the given position 69 | rewrite1pO :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => Observer -> [Rule t v] -> Term t v -> Position -> m(Term t v) 70 | rewrite1pO o rr t p = liftM fst $ updateAtM p (rewriteTopO o rr) t 71 | 72 | -- | Reflexive, Transitive closure 73 | rewrites :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => [Rule t v] -> Term t v -> m (Term t v) 74 | rewrites = rewritesO nilObserver 75 | -- | Reflexive, Transitive closure 76 | rewritesO :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadPlus m) => Observer -> [Rule t v] -> Term t v -> m (Term t v) 77 | rewritesO o rr t = runVariantT' freshvars $ closureMP (liftM snd . rewriteStepO o rr) t 78 | where freshvars = [toEnum 0 ..] \\ vars t 79 | 80 | -- | Computation to rewrite one step 81 | rewriteStep :: (Ord v, Observable v, Match t, Traversable t, Observable1 t, Rename v, v ~ Var m, MonadVariant m, MonadPlus m 82 | ) => [Rule t v] -> Term t v -> m (Position, Term t v) 83 | rewriteStep rr = rewriteStepO nilObserver rr 84 | 85 | -- | Computation to rewrite one step 86 | rewriteStepO :: (Ord v, Observable v, Match t, Traversable t, Observable1 t, Rename v, v ~ Var m, MonadVariant m, MonadPlus m 87 | ) => Observer -> [Rule t v] -> Term t v -> m (Position, Term t v) 88 | rewriteStepO o rr t = do 89 | rr' <- mapM getFresh rr 90 | someSubtermDeep (rewriteTopO o rr') t 91 | 92 | -- | Computation to rewrite the top term one step 93 | rewriteTopO :: (MonadPlus m, Ord v, Observable v, Observable1 t, Match t 94 | ) => Observer -> [RuleF (Term t v)] -> Term t v -> m (Term t v) 95 | rewriteTopO (O o _) rr t = F.msum $ forEach rr $ \r -> do 96 | let lhs:->rhs = r 97 | case o "match" match lhs t of 98 | Just subst -> return (applySubst subst rhs) 99 | Nothing -> mzero 100 | 101 | #ifdef LOGICT 102 | -- | Normal forms, starting from leftmost outermost 103 | -- Assumes no extra variables in the rhs are present 104 | reduce :: (Ord v, Observable v, Enum v, Rename v, Match t, Traversable t, Observable1 t, MonadLogic m 105 | ) => [Rule t v] -> Term t v -> m (Term t v) 106 | reduce rr t = runVariantT' freshvars $ fixMP (liftM snd . rewriteStep rr) t 107 | where freshvars = [toEnum 0 ..] \\ vars t 108 | #else 109 | -- | Normal forms, starting from leftmost outermost 110 | -- Assumes no extra variables in the rhs are present 111 | reduce :: (Ord v, Observable v, Enum v, Rename v, Eq1 t, Traversable t, Observable1 t, Match t, MonadPlus m 112 | ) => [Rule t v] -> Term t v -> m (Term t v) 113 | reduce rr t = runVariantT' freshvars $ fixM_Eq (liftM snd . rewriteStep rr) t 114 | where freshvars = [toEnum 0 ..] \\ vars t 115 | #endif 116 | -------------------------------------------------------------------------------- /Data/Term/Rules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 2 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} 3 | {-# LANGUAGE OverlappingInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE NoMonomorphismRestriction #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE PatternGuards #-} 9 | {-# LANGUAGE CPP #-} 10 | {-# LANGUAGE DeriveFoldable #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE ConstraintKinds #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | 15 | {-| This module works with an abstract notion of rule. 16 | 17 | A rule is a set of terms (generally a pair) which must 18 | be treated as a whole. Concrete examples include 19 | term rewriting rules and prolog clauses. 20 | 21 | To do this the module provides 22 | generalizations of the unify, match, equiv, fresh and vars 23 | operations which work with sets of terms. 24 | -} 25 | module Data.Term.Rules 26 | (RuleF(..), Rule, RuleFor, left, right, HasRules(..), swapRule, IsTRS(..), 27 | Signature(..), Signature, 28 | mapSignature, allSymbols, arities, HasSignature(..), 29 | getArity, getArities, getConstructorSymbols, getDefinedSymbols, getAllSymbols, 30 | isConstructorTerm, isRootDefined, isDuplicating, collectIds, 31 | GetVars(..), 32 | GetUnifier(..), getUnifier, unifies', equiv', equiv2', getUnifierMdefault, 33 | GetMatcher(..), getMatcher, matches', getMatcherMdefault, 34 | GetFresh(..), getFresh, getVariant, getFreshMdefault 35 | ) where 36 | 37 | 38 | import Control.Applicative.Compose 39 | import Control.DeepSeq 40 | import Control.DeepSeq.Extras 41 | import Control.Monad.Free 42 | 43 | import Data.Foldable (Foldable, foldMap, toList) 44 | 45 | import Data.Maybe 46 | 47 | 48 | import qualified Data.Traversable as T 49 | import Data.Map (Map) 50 | import qualified Data.Map as Map 51 | import Data.Set (Set) 52 | import qualified Data.Set as Set 53 | import Data.Term.Substitutions 54 | import Control.Monad.Variant 55 | import Prelude.Extras 56 | 57 | import Data.Term hiding (Rule) 58 | 59 | 60 | 61 | import qualified Data.Id.Family as Family 62 | import qualified Data.Rule.Family as Family 63 | 64 | import Debug.Hoed.Observe 65 | 66 | -- ---------------- 67 | -- * Concrete rules 68 | -- ---------------- 69 | infix 1 :-> 70 | data RuleF a = (:->) {lhs,rhs::a} deriving (Eq, Ord, Show) 71 | instance Eq1 RuleF where (==#) = (==) 72 | instance Functor RuleF where fmap f (l :-> r) = f l :-> f r 73 | instance Foldable RuleF where foldMap f (l :-> r) = f l `mappend` f r 74 | instance Traversable RuleF where traverse f (l :-> r) = (:->) <$> f l <*> f r 75 | instance GetFresh a => GetFresh (RuleF a) where getFreshM = getFreshMdefault 76 | instance GetVars t => GetVars (RuleF t) where getVars = foldMap getVars 77 | instance Applicative RuleF where 78 | pure x = x :-> x 79 | (fa :-> fb) <*> (a :-> b) = fa a :-> fb b 80 | instance (Eq v, Unify t) => GetUnifier (Rule t v) where getUnifierM = getUnifierMdefault 81 | instance (Eq v, Match t) => GetMatcher (Rule t v) where getMatcherM = getMatcherMdefault 82 | type instance Var (RuleF a) = Var a 83 | type instance TermF (RuleF a) = TermF a 84 | type instance Id (RuleF a) = Id a 85 | 86 | instance NFData1 RuleF where 87 | rnf1 (a :-> b) = rnf a `seq` rnf b `seq` () 88 | instance NFData a => NFData (RuleF a) where rnf = rnf1 89 | 90 | type Rule t v = RuleF (Term t v) 91 | type RuleFor (t :: k) = Rule (TermF t) (Var t) 92 | 93 | {-# RULES "rules/tRS" forall x. tRS (rules x) = x #-} 94 | {-# RULES "tRS/rules" forall x. rules (tRS x) = x #-} 95 | 96 | 97 | class HasRules trs where 98 | rules :: trs -> [Family.Rule trs] 99 | class HasRules trs => IsTRS trs where tRS :: [Family.Rule trs] -> trs 100 | 101 | type instance Family.Rule (RuleF a) = RuleF a 102 | 103 | instance HasRules (RuleF a) where rules = (:[]) 104 | instance HasRules a => HasRules [a] where rules = foldMap rules 105 | instance HasRules a => HasRules (Set a) where rules = foldMap rules . toList 106 | instance HasRules a => HasRules (Map k a) where rules = foldMap rules . Map.elems 107 | 108 | instance IsTRS [Rule t v] where tRS = id 109 | 110 | swapRule :: RuleF a -> RuleF a 111 | swapRule (l :-> r) = r :-> l 112 | 113 | left,right :: (a -> a) -> RuleF a -> RuleF a 114 | 115 | left f (l :-> r) = f l :-> r 116 | right f (l :-> r) = l :-> f r 117 | 118 | -- --------------------- 119 | -- * Signatures 120 | -- --------------------- 121 | data Signature id = Sig {constructorSymbols, definedSymbols :: Map id Int} 122 | deriving (Eq, Ord, Show) 123 | 124 | instance Foldable Signature where 125 | foldMap f Sig{..} = 126 | foldMap f (Map.keys constructorSymbols) `mappend` foldMap f (Map.keys definedSymbols) 127 | 128 | type instance Family.Id (Signature id) = id 129 | 130 | instance Ord id => Monoid (Signature id) where 131 | mempty = Sig mempty mempty 132 | mappend (Sig c1 s1) (Sig c2 s2) = Sig c s where 133 | c = mappend c1 c2 `Map.difference` s 134 | s = mappend s1 s2 135 | 136 | instance Ord id => HasSignature (Signature id) where 137 | getSignature = id 138 | 139 | instance NFData1 Signature where 140 | rnf1 (Sig cc dd) = rnf cc `seq` rnf dd `seq` () 141 | 142 | instance NFData a => NFData (Signature a) where rnf = rnf1 143 | 144 | class HasSignature l where 145 | getSignature :: Ord (Family.Id l) => l -> Signature (Family.Id l) 146 | 147 | instance (HasId1 t, Foldable t, Ord(Id t)) => HasSignature (Term t v) where 148 | getSignature t = Sig{ definedSymbols = Map.empty 149 | , constructorSymbols = all } 150 | where 151 | all = Map.fromList [(f,length (directSubterms t)) 152 | | t <- subterms t 153 | , Just f <- [rootSymbol t]] 154 | 155 | instance (HasSignature a, Foldable f, Ord(Id (f a)), Id (f a) ~ Id a 156 | ) => HasSignature (f a) where 157 | getSignature = foldMap getSignature 158 | 159 | instance (HasId a, HasSignature a) => HasSignature (RuleF a) where 160 | getSignature (l :-> r) 161 | | Just d <- getId l 162 | = all `mappend` mempty { definedSymbols = Map.singleton d (getArity all d) } 163 | | otherwise 164 | = all 165 | where 166 | all = foldMap getSignature [l,r] 167 | 168 | instance (HasSignature [a]) => HasSignature (Set a) where getSignature = getSignature . toList 169 | instance HasSignature [a] => HasSignature (Map k a) where getSignature = getSignature . Map.elems 170 | 171 | mapSignature :: (Ord id, Ord id') => (id -> id') -> Signature id -> Signature id' 172 | mapSignature f (Sig cc dd) = Sig (Map.mapKeys f cc) (Map.mapKeys f dd) 173 | 174 | allSymbols :: Ord id => Signature id -> Set id 175 | allSymbols s = Map.keysSet(definedSymbols s) `mappend` Map.keysSet (constructorSymbols s) 176 | 177 | arities Sig{..} = constructorSymbols `mappend` definedSymbols 178 | 179 | getDefinedSymbols, getConstructorSymbols, getAllSymbols :: ( Ord (Family.Id l), HasSignature l) => l -> Set (Family.Id l) 180 | getArities :: ( Ord (Family.Id sig), HasSignature sig) => sig -> Map (Family.Id sig) Int 181 | getArity :: ( Ord (Family.Id sig), HasSignature sig) => sig -> Family.Id sig -> Int 182 | 183 | getDefinedSymbols = Map.keysSet . definedSymbols . getSignature 184 | getConstructorSymbols = Map.keysSet . constructorSymbols . getSignature 185 | getAllSymbols = allSymbols . getSignature 186 | 187 | getArities sig = constructorSymbols `mappend` definedSymbols 188 | where Sig{..} = getSignature sig 189 | getArity l f = fromMaybe (error ("getArity: symbol not in signature")) 190 | (Map.lookup f constructorSymbols `mplus` Map.lookup f definedSymbols) 191 | where Sig{..} = getSignature l 192 | 193 | isConstructorTerm :: ( Functor t, Foldable t, HasId1 t, HasSignature sig 194 | , Family.Id t ~ Family.Id sig 195 | , Ord(Family.Id sig) 196 | ) => sig -> Term t v -> Bool 197 | isConstructorTerm sig t = (`Set.member` getConstructorSymbols sig) `all` collectIds t 198 | 199 | isRootDefined :: ( HasId1 t, HasSignature sig 200 | , Family.Id t ~ Family.Id sig 201 | , Ord (Family.Id sig) 202 | ) => sig -> Term t v -> Bool 203 | isRootDefined sig t 204 | | Just id <- rootSymbol t = id `Set.member` getDefinedSymbols sig 205 | | otherwise = False 206 | 207 | isDuplicating :: (GetVars t, Ord (Var t)) => RuleF t -> Bool 208 | isDuplicating (l :-> r) = any (\(v,occurrences) -> occurrences > occurrences_in_l v) 209 | (Map.toList $ vars_r) 210 | where 211 | count xx = Map.fromListWith (+) [(x,1::Int) | x <- xx] 212 | vars_r = count $ toList (getVars r) 213 | vars_l = count $ toList (getVars l) 214 | occurrences_in_l v = fromMaybe 0 $ Map.lookup v vars_l 215 | 216 | 217 | collectIds :: (Functor t, Foldable t, HasId1 t) => Term t v -> [Family.Id t] 218 | collectIds = catMaybes . foldTerm (const [Nothing]) (\t -> getId1 t : concat (toList t)) 219 | 220 | -- ------------- 221 | -- * Unification 222 | -- ------------- 223 | 224 | getUnifier :: (GetUnifier t, Observable (Var t), Ord (Var t), Functor(TermF t), Foldable(TermF t) 225 | ) => t -> t -> Maybe (SubstitutionFor t) 226 | getUnifier t u = fmap zonkSubst $ execMEnv (getUnifierM t u) 227 | 228 | unifies' :: (Observable(Var t), Ord (Var t), GetUnifier t, Functor(TermF t), Foldable(TermF t) 229 | ) => t -> t -> Bool 230 | unifies' s t = isJust (getUnifier s t) 231 | 232 | class GetUnifier t where 233 | getUnifierM :: (MonadEnv m, Var t ~ Var m, TermF t ~ TermF m, Ord (Var t)) => t -> t -> m () 234 | 235 | instance (Eq var, Unify f) => GetUnifier (Term f var) where 236 | getUnifierM = unifyM 237 | instance (GetUnifier t) => GetUnifier [t] where 238 | getUnifierM = getUnifierMdefault 239 | instance GetUnifier t => GetUnifier (Set t) where 240 | getUnifierM a b = getUnifierMdefault (toList a) (toList b) 241 | 242 | getUnifierMdefault :: (Ord (Var t), GetUnifier t, MonadEnv m, Match f, 243 | TermF m ~ TermF t, Var m ~ Var t) => 244 | f t -> f t -> m () 245 | getUnifierMdefault t u = do 246 | constraints <- T.sequence (getUnifierM <$> Compose(Just t) <*> Compose(Just u)) 247 | when (not $ isJust $ decompose constraints) $ fail "structure mismatch" 248 | return () 249 | 250 | -- ------------ 251 | -- * Matching 252 | -- ------------ 253 | 254 | getMatcher :: (GetMatcher t, Observable (Var t), Ord (Var t), Functor (TermF t), Foldable(TermF t) 255 | ) => t -> t -> Maybe (SubstitutionFor t) 256 | getMatcher t u = execMEnv (getMatcherM t u) 257 | 258 | matches' :: (Observable (Var t), Ord (Var t), GetMatcher t, Functor (TermF t), Foldable(TermF t) 259 | ) => t -> t -> Bool 260 | matches' s t = isJust (getMatcher s t) 261 | 262 | class GetMatcher t 263 | where getMatcherM :: (MonadEnv m, Var t ~ Var m, TermF t ~ TermF m) => t -> t -> m () 264 | 265 | instance (Eq var, Match f) => GetMatcher (Term f var) where 266 | getMatcherM = matchM 267 | instance (GetMatcher t) => GetMatcher [t] where 268 | getMatcherM = getMatcherMdefault 269 | instance (GetMatcher t) => GetMatcher (Set t) where 270 | getMatcherM a b = getMatcherMdefault (toList a) (toList b) 271 | 272 | getMatcherMdefault :: (Match f, GetMatcher t, MonadEnv m, 273 | TermF t ~ TermF m, Var t ~ Var m) => 274 | f t -> f t -> m () 275 | getMatcherMdefault t u = do 276 | constraints <- T.sequence(getMatcherM <$> Compose(Just t) <*> Compose(Just u)) 277 | when (not $ isJust $ decompose constraints) $ fail "structure mismatch" 278 | return () 279 | 280 | 281 | -- ---------------------------- 282 | -- * Equivalence up to renaming 283 | -- ---------------------------- 284 | --instance (Ord v, Enum v, Ord (Term t v), GetUnifier t v thing, GetVars v thing, GetFresh t v thing) => 285 | instance (v ~ Var thing, Enum v, Rename v, Ord v, Observable v, 286 | Traversable (TermF thing), 287 | GetMatcher thing, GetVars thing, GetFresh thing) => 288 | Eq (EqModulo thing) where 289 | EqModulo t1 == EqModulo t2 = t1 `equiv2'` t2 290 | 291 | equiv' :: (var ~ Var t, Ord var, Enum var, Rename var, Observable var, 292 | Traversable (TermF t), Ord (TermFor t), 293 | GetMatcher t, GetVars t, GetFresh t) => t -> t -> Bool 294 | equiv' t u = maybe False isRenaming (getMatcher (getVariant t u) u) 295 | equiv2' t u = let t' = getVariant t u in matches' t' u && matches' u t' 296 | 297 | instance (Ord v, Rename v, Enum v, Observable v, Unify t, Ord (Term t v)) => Eq (EqModulo (Rule t v)) where 298 | EqModulo t1 == EqModulo t2 = t1 `equiv'` t2 299 | 300 | instance (Ord v, Rename v, Enum v, Observable v, Unify t, Ord (Term t v)) => Ord (EqModulo (Rule t v)) where 301 | t1 `compare` t2 = if t1 == t2 then EQ else compare (eqModulo t1) (eqModulo t2) 302 | 303 | 304 | -- ------------------ 305 | -- * Other instances 306 | -- ------------------ 307 | instance Observable1 RuleF where observer1 (l :-> r) = send "(:->)" (return (:->) << l << r) 308 | instance Observable a => Observable (RuleF a) where 309 | observers = observers1 310 | observer = observer1 311 | -------------------------------------------------------------------------------- /Data/Term/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances, OverlappingInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | module Data.Term.Simple (TermF(..), Term1, constant, term, termId) where 8 | 9 | import Control.Applicative.Compose 10 | import Control.DeepSeq 11 | import Control.DeepSeq.Extras 12 | import Control.Monad.Free 13 | import Data.Bifunctor 14 | import Data.Char (isAlpha) 15 | import Data.Foldable (msum) 16 | import Data.Term.Substitutions 17 | import Prelude.Extras 18 | import Text.PrettyPrint.HughesPJClass 19 | 20 | import qualified Data.Id.Family as Family 21 | import Data.Term hiding (TermF) 22 | 23 | import Debug.Hoed.Observe 24 | 25 | data TermF id f = Term {id::id, args::[f]} deriving (Eq,Ord,Show,Generic,Generic1) 26 | type Term1 id = Free (TermF id) 27 | 28 | instance Eq id => Eq1 (TermF id) where (==#) = (==) 29 | instance Ord id => Ord1 (TermF id) where compare1 = compare 30 | instance Show id => Show1 (TermF id) where showsPrec1 = showsPrec 31 | 32 | type instance Family.Id (TermF id) = id 33 | 34 | term :: id -> [Term1 id a] -> Term1 id a 35 | term f = Impure . Term f 36 | 37 | constant :: id -> Term1 id a 38 | constant f = term f [] 39 | 40 | termId :: MonadPlus m => Term1 id a -> m id 41 | termId = foldFree (const mzero) f where 42 | f (Term f tt) = return f `mplus` Data.Foldable.msum tt 43 | 44 | instance (Eq id) => Applicative (Maybe :+: TermF id) where 45 | pure _ = Compose Nothing 46 | Compose(Just(Term a ff)) <*> Compose(Just(Term b xx)) 47 | | a == b = Compose $ Just $ Term a (zipWith ($) ff xx) 48 | _ <*> _ = Compose Nothing 49 | 50 | -- Specific instance for TermF, only for efficiency 51 | instance Ord id => Unify (TermF id) where 52 | {-# SPECIALIZE instance Unify (TermF String) #-} 53 | unifyM = unifyF where 54 | unifyF t s = do 55 | t' <- find' t 56 | s' <- find' s 57 | case (t', s') of 58 | (Pure vt, Pure vs) -> when(vt /= vs) $ varBind vt s' 59 | (Pure vt, _) -> varBind vt s' 60 | (_, Pure vs) -> varBind vs t' 61 | (Impure t, Impure s) -> zipTermM_ unifyF t s 62 | zipTermM_ f (Term f1 tt1) (Term f2 tt2) | f1 == f2 = zipWithM_ f tt1 tt2 63 | | otherwise = fail "structure mismatch" 64 | 65 | instance Ord id => HasId1 (TermF id) where 66 | getId1 (Term id _) = Just id 67 | fromId1 id = Term id [] 68 | 69 | instance MapId TermF where 70 | mapIdM f (Term id tt) = (`Term` tt) <$> f id 71 | 72 | instance (Pretty a, Pretty id) => Pretty (TermF id a) where 73 | pPrint (Term n []) = pPrint n 74 | pPrint (Term n [x,y]) | not (any isAlpha $ show $ pPrint n) = pPrint x <+> pPrint n <+> pPrint y 75 | pPrint (Term n tt) = pPrint n <> parens (hcat$ punctuate comma$ map pPrint tt) 76 | 77 | instance Pretty a => Pretty (TermF String a) where 78 | pPrint (Term n []) = text n 79 | pPrint (Term n [x,y]) | not (any isAlpha n) = pPrint x <+> text n <+> pPrint y 80 | pPrint (Term n tt) = text n <> parens (hcat$ punctuate comma $ map pPrint tt) 81 | 82 | -- Functor boilerplate 83 | -- -------------------- 84 | instance Functor (TermF id) where 85 | fmap f (Term a tt) = Term a (fmap f tt) 86 | instance Foldable (TermF id) where 87 | foldMap f (Term _ tt) = foldMap f tt 88 | instance Traversable (TermF id) where 89 | traverse f (Term a tt) = Term a `fmap` traverse f tt 90 | 91 | instance Bifunctor TermF where 92 | bimap f g (Term id tt) = Term (f id) (fmap g tt) 93 | 94 | instance Observable id => Observable1 (TermF id) 95 | 96 | instance NFData id => NFData1 (TermF id) where 97 | rnf1 (Term id tt) = rnf id `seq` rnf tt 98 | -------------------------------------------------------------------------------- /Data/Term/Substitutions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE ViewPatterns #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE GADTs #-} 11 | {-# LANGUAGE PatternSynonyms #-} 12 | {-# LANGUAGE InstanceSigs #-} 13 | {-# LANGUAGE DeriveFoldable, DeriveTraversable #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 17 | {-# LANGUAGE DeriveGeneric #-} 18 | {-# LANGUAGE GADTs #-} 19 | 20 | module Data.Term.Substitutions where 21 | 22 | import Control.Applicative 23 | import Control.Applicative.Compose 24 | import Control.DeepSeq 25 | import Control.Monad (MonadPlus, join, when) 26 | import Control.Monad (liftM) 27 | import Control.Monad.Cont (MonadTrans, lift) 28 | import Control.Monad.Env 29 | import Control.Monad.Free (Free(..)) 30 | import Control.Monad.Logic (LogicT, LogicT, MonadLogic, msplit) 31 | import Control.Monad.State (StateT, get, put, evalStateT, execStateT, runStateT) 32 | import Control.Monad.Variant 33 | import Data.Foldable (toList) 34 | import Data.List ((\\)) 35 | import Data.Map (Map) 36 | import qualified Data.Map as Map 37 | import Data.Maybe (isJust) 38 | import Data.Monoid 39 | import Data.Set (Set) 40 | import qualified Data.Set as Set 41 | import Data.Term.Base 42 | import Data.Term.Family 43 | import Data.Traversable (mapM) 44 | import qualified Data.Traversable as T 45 | import Prelude hiding (mapM) 46 | import Prelude.Extras 47 | 48 | import Debug.Hoed.Observe 49 | import Debug.Hoed.Observe.Instances 50 | 51 | -- --------------- 52 | -- * Variables 53 | -- --------------- 54 | 55 | -- | The class of functions for getting the variables of a value 56 | class GetVars t where 57 | getVars :: Ord (Var t) => t -> Set (Var t) 58 | fromVar :: Var t -> t 59 | 60 | instance (Functor termF, Foldable termF, Ord var) => GetVars (Term termF var) where 61 | getVars t@Impure{} = (Set.fromList . toList) t 62 | getVars (Pure x) = Set.singleton x 63 | fromVar = Pure 64 | 65 | -- type instance Var (f t) = Var t 66 | instance GetVars t => GetVars [t] where 67 | getVars = foldMap getVars 68 | fromVar x = [fromVar x] 69 | instance GetVars t => GetVars (Set t) where 70 | getVars = foldMap getVars 71 | fromVar x = Set.singleton (fromVar x) 72 | instance GetVars t => GetVars (Maybe t) where 73 | getVars = foldMap getVars 74 | fromVar x = Just (fromVar x) 75 | 76 | instance (Var a ~ Var (t a), GetVars a, Applicative t, Foldable t) => GetVars (t a) where 77 | getVars = foldMap getVars 78 | fromVar x = pure (fromVar x) 79 | 80 | -- instance (GetVars t var, Foldable f, Foldable g) => GetVars (g(f t)) var where getVars = (foldMap.foldMap) getVars 81 | 82 | -- | The class of computations that get a fresh variant of a value 83 | class GetFresh thing where 84 | getFreshM :: (TermF thing ~ TermF m, Var thing ~ Var m, Traversable (TermF thing), MonadEnv m, MonadVariant m) => thing -> m thing 85 | 86 | instance (Traversable termF) => GetFresh (Term termF var) where getFreshM = fresh 87 | instance (Ord a, GetFresh a) => GetFresh (Set a) where getFreshM = liftM Set.fromList . getFreshM . Set.toList 88 | instance GetFresh t => GetFresh [t] where getFreshM = getFreshMdefault 89 | 90 | -- | Default implementation of getFresh for traversable structures 91 | getFreshMdefault :: (Traversable t, GetFresh a, MonadVariant m, MonadEnv m, Var a ~ Var m, term ~ TermF a, term ~ TermF m, Traversable term) => t a -> m (t a) 92 | getFreshMdefault = T.mapM getFreshM 93 | 94 | -- | Returns a MonadVariant computation that produces a fresh variant of a value 95 | getFresh :: (MonadVariant m, Observable (Var m), Ord (Var m), GetFresh thing, Traversable (TermF thing), Var thing ~ Var m) => 96 | thing -> m thing 97 | getFresh t = evalMEnv (getFreshM t) 98 | 99 | -- | Returns a locally fresh variant of a value 100 | getVariant :: ( v ~ Var t, v ~ Var t' 101 | , Ord v, Observable v, Enum v, Rename v, GetFresh t, GetVars t', Traversable (TermF t)) => t -> t' -> t 102 | getVariant u t = runVariant' ([toEnum 0..] \\ Set.toList (getVars t)) (getFresh u) 103 | 104 | 105 | -- --------------- 106 | -- * Substitutions 107 | -- --------------- 108 | 109 | data Substitution_ a where 110 | Subst :: Observable(Var a) => {unSubst :: !(Map (Var a) a)} -> Substitution_ a 111 | 112 | type Substitution t v = Substitution_(Term t v) 113 | type SubstitutionFor t = Substitution (TermF t) (Var t) 114 | 115 | type instance Var (Substitution_ t) = Var t 116 | 117 | instance (GetVars t, Observable (Var t)) => GetVars (Substitution_ t) where 118 | getVars = foldMap getVars . unSubst 119 | fromVar v = let t = fromVar v in Subst (Map.singleton v t) 120 | 121 | -- | Smart constructor 122 | subst :: Observable(Var a) => Map (Var a) a -> Substitution_ a 123 | subst = Subst 124 | 125 | -- | Functor over substitutions 126 | mapSubst f = liftSubst (fmap f) 127 | 128 | deriving instance (Eq a, Eq (Var a)) => Eq (Substitution_ a) 129 | deriving instance (Ord a, Ord (Var a)) => Ord (Substitution_ a) 130 | deriving instance (Show a, Show (Var a)) => Show (Substitution_ a) 131 | 132 | instance (NFData a, NFData(Var a)) => NFData (Substitution_ a) where 133 | rnf = rnf . unSubst 134 | 135 | -- | Append composes two substitutions s. t. 136 | -- > (s1 `mappend` s2) `applyS` t = s1 `applyS` s2 `applyS` t 137 | instance (a ~ Var (t a), Ord a, Monad t, Observable a) => Monoid (Substitution_ (t a)) where 138 | mappend s1 s2 = liftSubst2 Map.union (applySubst s2 `mapSubst` s1) s2 139 | mempty = subst mempty 140 | 141 | -- | Lifts a function over substitutions 142 | liftSubst :: (Observable(Var a), Observable(Var b)) => 143 | (Map (Var a) a -> Map (Var b) b) -> 144 | Substitution_ a -> Substitution_ b 145 | liftSubst f (unSubst -> e) = subst (f e) 146 | 147 | -- | Lifts a function over substitutions 148 | liftSubst2 f (unSubst -> e) (unSubst -> b) = subst (f e b) 149 | 150 | -- | Look up a variable contents 151 | lookupSubst :: (Ord(Var a)) => 152 | Var a -> Substitution_ a -> Maybe a 153 | lookupSubst v (unSubst -> m) = Map.lookup v m 154 | 155 | -- | Apply a substitution over a term variables 156 | applySubst :: (Ord a, Monad t, a ~ Var(t a) 157 | ) => Substitution_ (t a) -> t a -> (t a) 158 | applySubst s = (>>= f) where 159 | f v = case lookupSubst v s of 160 | Nothing -> return v 161 | Just t' -> t' 162 | 163 | -- | Returns the set of variables assigned by the substitution 164 | domain :: (Ord(Var t)) => Substitution_ t -> Set (Var t) 165 | domain = Map.keysSet . unSubst 166 | 167 | -- | Returns the multiset of terms in the codomain of the substitution 168 | codomain :: () => Substitution_ t -> [t] 169 | codomain = Map.elems . unSubst 170 | 171 | -- | Restrict a substitution 172 | restrictTo :: (Ord(Var t), Observable(Var t) 173 | ) => [Var t] -> Substitution_ t -> Substitution_ t 174 | restrictTo vv = liftSubst f where 175 | f e = Map.intersectionWith const e (Map.fromDistinctAscList (zip vv (repeat undefined))) 176 | 177 | isEmpty :: (Ord(Var t)) => Substitution_ t -> Bool 178 | isEmpty (unSubst -> m) = Map.null m 179 | 180 | -- | Construct a substitution from an association list 181 | fromListSubst :: (Ord (Var term), Observable(Var term) 182 | ) => [(Var term,term)] -> Substitution_ term 183 | fromListSubst = subst . Map.fromList 184 | 185 | -- | Fixpoint application of a substitution over a term with pure mapping of variables 186 | zonkTerm :: (v ~ Var (t v), Ord v, Monad t 187 | ) => Substitution_ (t v) -> (v -> v') -> t v -> t v' 188 | zonkTerm subst fv = (>>= f) where 189 | f v = case lookupSubst v subst of 190 | Nothing -> return (fv v) 191 | Just t -> zonkTerm subst fv t 192 | 193 | -- | Fixpoint application of a substitution over a term with effectful variable mapping 194 | zonkTermM :: (termF ~ TermF m, var ~ Var m, Traversable termF, Ord var, MonadEnv m) => 195 | (var -> m var') -> Term termF var -> m(Term termF var') 196 | zonkTermM fv = liftM join . mapM f where 197 | f v = do val <- lookupVar v 198 | case val of 199 | Nothing -> Pure `liftM` fv v 200 | Just t -> zonkTermM fv t 201 | 202 | -- | Fixpoint of a substitution 203 | zonkSubst :: (v ~ Var(t v), Ord v, Monad t, Observable v 204 | ) => Substitution_ (t v) -> Substitution_ (t v) 205 | zonkSubst s = liftSubst (Map.map (zonkTerm s id)) s 206 | 207 | -- | True if the substitution is a renaming, i.e. it maps variables to variables 208 | isRenaming :: (Foldable termF, Functor termF, Ord var, Ord (Term termF var) 209 | ) => Substitution termF var -> Bool 210 | isRenaming (unSubst -> subst) = all isVar (Map.elems subst) && isBijective (Map.mapKeysMonotonic return subst) 211 | where 212 | -- isBijective :: Ord k => Map.Map k k -> Bool 213 | isBijective rel = -- cheap hackish bijectivity check. 214 | -- Ensure that the relation is injective and its inverse is too. 215 | -- The sets of variables must be disjoint too 216 | -- Actually there should be no need to check the inverse 217 | -- since this is a Haskell Map and hence the domain contains no duplicates 218 | Set.size elemsSet == Map.size rel && 219 | Map.keysSet rel `Set.intersection` elemsSet == Set.empty 220 | where 221 | elemsSet = Set.fromList(Map.elems rel) 222 | 223 | instance Observable1 Substitution_ where 224 | observer1 (Subst s) = send "Subst" (return Subst << s) 225 | 226 | instance Observable a => Observable (Substitution_ a) where 227 | observer = observer1 228 | observers = observers1 229 | 230 | -- -------------------------------------- 231 | -- ** Environments: handling substitutions 232 | -- -------------------------------------- 233 | 234 | newtype MEnvT t (v :: *) (m :: * -> *) a = MEnv {unMEnv ::StateT (Substitution_ (Term t v)) m a} 235 | deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadTrans) 236 | 237 | type instance Var (MEnvT t v m) = v 238 | type instance TermF (MEnvT t v m) = t 239 | 240 | instance (Monad m, Foldable t, Functor t, Ord v, Observable v) => MonadEnv (MEnvT t v m) where 241 | varBind v t = do {e <- MEnv get; MEnv $ put (liftSubst (Map.insert v t) e)} 242 | lookupVar t = MEnv get >>= \s -> return(lookupSubst t s) 243 | 244 | instance (v ~ Var m, Rename v, MonadVariant m) => MonadVariant (MEnvT t v m) where 245 | -- type MonadVariant.Var (MEnvT t v m) = MonadVariant.Var m 246 | freshVar = lift freshVar 247 | 248 | #ifdef LOGICT 249 | --deriving instance MonadLogic m => MonadLogic (MEnvT t v m) 250 | instance MonadLogic m => MonadLogic (MEnvT t v m) where 251 | msplit m = MEnv $ (liftM.liftM) f (msplit (unMEnv m)) where 252 | f (a,m') = (a, MEnv m') 253 | 254 | instance (Functor (TermF m), MonadEnv m) => MonadEnv (LogicT m) where 255 | varBind = (lift.) . varBind 256 | lookupVar = lift . lookupVar 257 | #endif 258 | 259 | execMEnv :: (Foldable t, Functor t, Ord v, Observable v, Monad m) => MEnvT t v m a -> m (Substitution t v) 260 | evalMEnv :: (Foldable t, Functor t, Ord v, Observable v, Monad m) => MEnvT t v m a -> m a 261 | runMEnv :: (Foldable t, Functor t, Ord v, Observable v, Monad m) => MEnvT t v m a -> m (a, Substitution t v) 262 | 263 | execMEnv = (`execStateT` subst mempty) . unMEnv 264 | 265 | evalMEnv = (`evalStateT` subst mempty) . unMEnv 266 | 267 | runMEnv = (`runStateT` subst mempty) . unMEnv 268 | 269 | 270 | instance Monad m => Observable1 (MEnvT t v m) where 271 | observer1 comp p = do 272 | res <- comp 273 | send "" (return return << res) p 274 | 275 | instance (Observable a, Monad m) => Observable (MEnvT t v m a) where 276 | observer = observer1 277 | observers = observers1 278 | 279 | -- instance (Monad m, Functor t, Ord v) => MonadEnv (StateT (Substitution t v, a) m) where 280 | -- type TermF (StateT (Substitution t v, a) m) = t 281 | -- type Var (StateT (Substitution t v, a) m) = v 282 | -- varBind v = withFst . varBind v 283 | -- lookupVar = withFst . lookupVar 284 | 285 | -- ------------------------------------ 286 | -- * Unification (without occurs check) 287 | -- ------------------------------------ 288 | -- | True if two terms unify with each other (no occurrs check) 289 | unifies :: forall termF var. (Unify termF, Ord var, Observable var) => Term termF var -> Term termF var -> Bool 290 | unifies t u = isJust (unify t u) 291 | 292 | -- | Returns a substitution s.t. @\sigma(t) = \sigms(u)@ if it exists 293 | unify :: (Unify termF, Ord var, Observable var) => Term termF var -> Term termF var -> Maybe (Substitution termF var) 294 | 295 | unify t u = fmap zonkSubst (execMEnv (unifyM t u)) 296 | 297 | -- | The class of unifiable terms 298 | class (Traversable termF, Match termF) => Unify termF 299 | where unifyM :: (MonadEnv m, Ord (Var m), TermF m ~ termF) => Term termF (Var m) -> Term termF (Var m) -> m () 300 | 301 | -- Generic instance 302 | instance (Match termF) => Unify termF where 303 | -- | A computation for unifying two terms in an environment. 304 | -- Instances should use Monadic fail to denote failure 305 | unifyM :: forall m. (MonadEnv m, Ord(Var m), TermF m ~ termF) => 306 | Term termF (Var m) -> Term termF (Var m) -> m () 307 | unifyM t s = do 308 | t' <- find' t 309 | s' <- find' s 310 | unifyOne t' s' 311 | where 312 | unifyOne :: Term termF (Var m) -> Term termF (Var m) -> m () 313 | unifyOne (Pure vt) s@(Pure vs) = when (vt /= vs) $ varBind vt s 314 | unifyOne (Pure vt) s = varBind vt s 315 | unifyOne t (Pure vs) = varBind vs t 316 | unifyOne (Impure t) (Impure s)= do 317 | constraints <- T.sequence(unifyM <$> Compose(Just t) <*> Compose(Just s)) 318 | when (not $ isJust $ decompose constraints) $ fail "structure mismatch" 319 | return () 320 | 321 | 322 | {- | Occurs function, to roll your own unification with occurs check. 323 | To do this, declare your custom instance of Unify as follows 324 | 325 | > instance (Traversable termF, Eq (termF ())) => Unify termF where 326 | > unifyM t s = do 327 | > t' <- find' t 328 | > s' <- find' s 329 | > unifyOne t' s' 330 | > where 331 | > unifyOne (Pure vt) s@(Pure vs) = when (vt /= vs) $ varBind vt s 332 | > unifyOne (Pure vt) s = vt `occursIn` s' >>= \occ -> if occ then fail "occurs" else varBind vt s 333 | > unifyOne t (Pure vs) = vs `occursIn` t' >>= \occ -> if occ then fail "occurs" else varBind vs t 334 | > unifyOne t s = zipFree_ unifyM t s 335 | -} 336 | 337 | occursIn :: (Ord (Var m), Traversable (TermF m), MonadEnv m) => Var m -> Term (TermF m) (Var m) -> m Bool 338 | occursIn v t = do 339 | t' <- zonkM return t 340 | return (v `Set.member` Set.fromList (vars t')) 341 | 342 | -- ---------- 343 | -- * Matching 344 | -- ---------- 345 | {-# INLINABLE matches #-} 346 | -- | True if there is a substitution such that \sigma(t) = u 347 | matches :: forall termF var. (Ord var, Observable var, Match termF) => Term termF var -> Term termF var -> Bool 348 | matches t u = isJust (match t u) 349 | 350 | {-# INLINABLE match #-} 351 | -- | Returns a substitution s.t. @ \sigma(t) = u @ 352 | match :: (Ord var, Match termF, Observable var 353 | ) => Term termF var -> Term termF var -> Maybe(Substitution termF var) 354 | match t u = execMEnv (matchM t u) 355 | 356 | type Match term = (Applicative (Maybe :+: term), Traversable term, Eq1 term) 357 | 358 | type instance TermF (Maybe :+: m) = TermF m 359 | type instance Var (Maybe :+: m) = Var m 360 | 361 | deriving instance (Foldable f, Foldable g) => Foldable (f :+: g) 362 | deriving instance (Traversable f, Traversable g) => Traversable (f :+: g) 363 | 364 | {-# INLINABLE matchM #-} 365 | -- A monadic computation that tries to match two terms in an environment. 366 | matchM :: forall m. (Eq (Var m), Match(TermF m), MonadEnv m 367 | ) => TermFor m -> TermFor m -> m () 368 | matchM t s = do 369 | matchOne t s 370 | where 371 | matchOne :: TermFor m -> TermFor m -> m () 372 | matchOne Impure{} Pure{} = fail "match: structure mismatch" 373 | matchOne (Pure v) u = do 374 | contents <- lookupVar v 375 | case contents of 376 | Just v' -> when (v' /= u) $ fail "incompatible" 377 | Nothing -> varBind v u 378 | matchOne (Impure t) (Impure u) = do 379 | constraints <- T.sequence(matchM <$> Compose(Just t) <*> Compose(Just u)) 380 | when (not $ isJust $ decompose constraints) $ fail "structure mismatch" 381 | return() 382 | 383 | 384 | -- ----------------------------- 385 | -- ** Equivalence up to renaming 386 | -- ----------------------------- 387 | {-# INLINABLE equiv #-} 388 | -- | Equivalence up to renaming (using one match) 389 | equiv :: forall termF var. 390 | (Ord var, Observable var, Rename var, Enum var, Ord (Term termF var), Unify termF) => Term termF var -> Term termF var -> Bool 391 | equiv t u = t == u || maybe False isRenaming (match (variant t u) u) 392 | 393 | {-# INLINABLE equiv2 #-} 394 | -- | Equivalence up to renaming (using two matches) 395 | equiv2 :: (Rename var, Ord var, Observable var, Enum var, Unify termF) => Term termF var -> Term termF var -> Bool 396 | equiv2 t u = let t' = variant t u in matches t' u && matches u t' 397 | 398 | newtype EqModulo a = EqModulo {eqModulo::a} 399 | instance (Ord v, Observable v, Rename v, Enum v, Unify t, Ord (Term t v)) => Eq (EqModulo (Term t v)) where 400 | EqModulo t1 == EqModulo t2 = t1 `equiv2` t2 401 | 402 | instance (Ord v, Observable v, Rename v, Enum v, Unify t, Ord (Term t v)) => Ord (EqModulo (Term t v)) where 403 | t1 `compare` t2 = if t1 == t2 then EQ else compare (eqModulo t1) (eqModulo t2) 404 | 405 | -- -------------------------------- 406 | -- * Variants of terms and rules 407 | -- -------------------------------- 408 | -- | A computation that returns a fresh variant of a term obtained using 'renaming' 409 | fresh :: (v ~ Var m, Traversable (TermF m), MonadEnv m, MonadVariant m) => 410 | Term (TermF m) v -> m (Term (TermF m) v) 411 | fresh = go where 412 | go = liftM join . T.mapM f 413 | f v = do 414 | mb_v' <- lookupVar v 415 | case mb_v' of 416 | Nothing -> do {v' <- renaming v; varBind v (return v'); return (return v')} 417 | Just v' -> return v' 418 | 419 | -- | As 'fresh' but using the given rename function instead of the 'Rename' class 420 | freshWith :: (Traversable (TermF m), MonadEnv m, MonadVariant m) => 421 | (Var m -> Var m -> Var m) -> TermFor m -> m (TermFor m) 422 | freshWith fv = go where 423 | go = liftM join . T.mapM f 424 | f v = do 425 | mb_v' <- lookupVar v 426 | case mb_v' of 427 | Nothing -> do {v' <- fv v `liftM` freshVar; varBind v (return v'); return (return v')} 428 | Just (Pure v') -> return (Pure v') 429 | 430 | -- | Statically checked renaming of a term 431 | freshWith' :: (Rename var, Observable var, Observable var', Ord var', Ord var, var' ~ Var m, Traversable t, MonadVariant m) => 432 | (var -> var' -> var') -> Term t var -> m (Term t var') 433 | freshWith' fv t = variantsWith Right $ evalMEnv $ (getRight <$$> freshWith fv' (fmap Left t)) 434 | where 435 | fv' (Left v) (Right v') = Right (fv v v') 436 | (<$$>) = fmap . fmap 437 | getRight(Right x) = x 438 | 439 | -- | Given two terms @t@ and @u@, returns a fresh variant of @t@ which shares no variables with @u@ 440 | variant :: forall v t t'. (Ord v, Observable v, Rename v, Enum v, Functor t', Foldable t', Traversable t) => Term t v -> Term t' v -> Term t v 441 | variant u t = runVariant' ([toEnum 0..] \\ vars t) (evalMEnv(fresh u)) 442 | 443 | -------------------------------------------------------------------------------- /Data/Term/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Data.Term.Utils where 4 | 5 | import Control.Monad hiding (mapM) 6 | import Data.Foldable 7 | import Data.Traversable as T 8 | import Control.Monad.Trans (MonadTrans,lift) 9 | import Control.Monad.Identity(Identity(..)) 10 | import Control.Monad.State(StateT(..), MonadState, get, put, modify, evalStateT) 11 | #ifdef LOGICT 12 | import Control.Monad.Logic (MonadLogic, ifte) 13 | #endif 14 | import qualified Data.Set as Set 15 | 16 | import Prelude hiding (mapM) 17 | 18 | size :: Foldable f => f a -> Int 19 | size = length . toList 20 | 21 | -- | Monadic version of interleave 22 | interleaveM :: (Monad m, Traversable t) => (a -> m a) -> t a -> [m (t a)] 23 | interleaveM f x = liftM T.sequence (interleave f return x) 24 | 25 | -- | Using the analogy of functors as containers, 26 | -- the @interleave f def@ of the functor carrying {x,y,z...} 27 | -- is the list of containers 28 | -- [ {f x, def y, def z}, {def f, g y, def z}, {def f, def g, f z}] 29 | 30 | interleave :: (Traversable f) => (a -> b) -> (a -> b) -> f a -> [f b] 31 | interleave f def x = [unsafeZipWithG (indexed f i) [0..] x | i <- [0..size x - 1]] 32 | where indexed f i j x = if i==j then f x else def x 33 | 34 | unsafeZipWithGM :: (Traversable t1, Traversable t2, Monad m) => 35 | (a -> b -> m c) -> t1 a -> t2 b -> m (t2 c) 36 | unsafeZipWithGM f t1 t2 = evalStateT (mapM zipG' t2) (toList t1) 37 | where zipG' y = do (x:xx) <- get 38 | put xx 39 | lift (f x y) 40 | 41 | unsafeZipWithG :: (Traversable t1, Traversable t2) => (a -> b -> c) -> t1 a -> t2 b -> t2 c 42 | unsafeZipWithG f x y = runIdentity $ unsafeZipWithGM (\x y -> return (f x y)) x y 43 | 44 | liftM2 :: (Monad m1, Monad m2) => (a -> b) -> m1(m2 a) -> m1(m2 b) 45 | liftM2 = liftM.liftM 46 | 47 | third :: (c -> c') -> (a,b,c) -> (a,b,c') 48 | third f (a,b,c) = (a,b,f c) 49 | 50 | firstM :: Monad m => (a -> m a') -> (a,b) -> m (a',b) 51 | firstM f (x,y) = do { x' <- f x; return (x',y)} 52 | 53 | secondM :: Monad m => (b -> m b') -> (a,b) -> m (a,b') 54 | secondM f (x,y) = do { y' <- f y; return (x,y')} 55 | 56 | forEach :: [a] -> (a -> b) -> [b] 57 | forEach = flip map 58 | 59 | snub :: Ord a => [a] -> [a] 60 | snub = go Set.empty where 61 | go _ [] = [] 62 | go acc (x:xx) = if x `Set.member` acc then go acc xx else x : go (Set.insert x acc) xx 63 | 64 | -- ------------------------ 65 | -- Fixed points and similar 66 | -- ------------------------ 67 | -- | transitive closure 68 | closureMP :: MonadPlus m => (a -> m a) -> (a -> m a) 69 | closureMP f x = return x `mplus` (f x >>= closureMP f) 70 | 71 | #ifdef LOGICT 72 | -- | least fixed point of a backtracking computation 73 | fixMP :: MonadLogic m => (a -> m a) -> (a -> m a) 74 | fixMP f x = ifte (f x) (fixMP f) (return x) 75 | #endif 76 | 77 | -- | least fixed point of a monadic function, using Eq comparison 78 | fixM_Eq :: (Monad m, Eq a) => (a -> m a) -> a -> m a 79 | fixM_Eq f = go (0::Int) where 80 | go i prev_result = do 81 | x <- f prev_result 82 | if x == prev_result then return x 83 | else go (i+1) x 84 | 85 | ---------------------- 86 | -- With... 87 | {-# INLINE with #-} 88 | {-# INLINE withSnd #-} 89 | {-# INLINE withFst #-} 90 | with :: (Monad m, MonadTrans t1, MonadState s (t1 m), MonadState s2 (t2 m)) => 91 | (s -> s2) -> 92 | (s2 -> s -> s) -> 93 | (t2 m a -> s2 -> m (a,s2)) -> t2 m a -> t1 m a 94 | with gets puts run m = do 95 | s <- gets `liftM` get 96 | (res,s') <- lift $ run m s 97 | modify (puts s') 98 | return res 99 | 100 | withFst :: (MonadState (s, b) (t1 m), MonadTrans t1, Monad m) => StateT s m a -> t1 m a 101 | withFst = with fst (\x' (_,y) -> (x',y)) runStateT 102 | withSnd :: (MonadState (b, s) (t1 m), MonadTrans t1, Monad m) => StateT s m a -> t1 m a 103 | withSnd = with snd (\y' (x,_) -> (x,y')) runStateT 104 | -------------------------------------------------------------------------------- /Data/Term/Var.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module Data.Term.Var where 4 | 5 | import Control.Monad.Free 6 | import Control.Monad.Variant (Rename(..)) 7 | import Control.DeepSeq 8 | 9 | import Data.Term.Substitutions 10 | import qualified Data.Var.Family as Family 11 | import qualified Data.Set as Set 12 | 13 | import Debug.Hoed.Observe 14 | 15 | data Var = VName String | VAuto Int deriving (Eq, Ord, Show, Generic) 16 | 17 | instance Enum Var where 18 | fromEnum (VAuto i) = i 19 | fromEnum (VName _) = 0 20 | toEnum = VAuto 21 | 22 | var :: Functor f => String -> Free f Var 23 | var = return . VName 24 | 25 | var' :: Functor f => Int -> Free f Var 26 | var' = return . VAuto 27 | 28 | instance Rename Var where rename _ = id 29 | 30 | type instance Family.Var Var = Var 31 | instance GetVars Var where getVars = Set.singleton 32 | instance Observable Var 33 | 34 | instance NFData Var where rnf (VName s) = rnf s ; rnf(VAuto i) = rnf i 35 | -------------------------------------------------------------------------------- /Data/Term/Variables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} 3 | 4 | module Data.Term.Variables where 5 | 6 | import Control.Monad.Env 7 | import Control.Monad.State 8 | import Control.Monad.Variant (MonadVariant, Rename, runVariant') 9 | import qualified Control.Monad.Variant as MonadVariant 10 | import Data.Foldable 11 | import Data.List 12 | import Data.Monoid 13 | import Data.Set (Set) 14 | import qualified Data.Set as Set 15 | import Data.Term.Base 16 | import Data.Traversable as T 17 | 18 | import Data.Term.MEnv 19 | import Data.Term.Family 20 | import Data.Var.Family 21 | -------------------------------------------------------------------------------- /Data/Var/Family.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies,PolyKinds #-} 2 | module Data.Var.Family where 3 | 4 | import Data.Set (Set) 5 | import Data.Map (Map) 6 | 7 | type family Var (t :: k) 8 | 9 | type instance Var (Maybe a) = Var a 10 | type instance Var [t] = Var t 11 | type instance Var (Set t) = Var t 12 | type instance Var (Map k t) = Var t 13 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Term 2 | ----- 3 | 4 | Term Rewriting library based on the Free monad representation of terms. 5 | 6 | Providing, for any representation of terms, generic 7 | - matching 8 | - unification 9 | - equality up to renaming 10 | - rewriting 11 | - innermost rewriting (work in progress) 12 | - narrowing 13 | - basic narrowing 14 | - narrowing on demand 15 | 16 | author: Pepe Iborra 17 | maintainer: pepeiborra@gmail.com 18 | homepage: http://github.com/pepeiborra/term 19 | 20 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /narradar-term.cabal: -------------------------------------------------------------------------------- 1 | name: narradar-term 2 | version: 0.3.4 3 | Cabal-Version: >= 1.2.3 4 | build-type: Simple 5 | license: PublicDomain 6 | author: Pepe Iborra 7 | maintainer: pepeiborra@gmail.com 8 | homepage: http://github.com/pepeiborra/term 9 | description: terms, matching, unification, rewriting and narrowing 10 | synopsis: Term Rewriting Systems 11 | category: Data 12 | stability: experimental 13 | 14 | Flag transformers 15 | default: False 16 | 17 | Flag logict 18 | default: True 19 | 20 | Library 21 | buildable: True 22 | build-depends: base > 4, containers, mtl > 2, pretty, control-monad-free > 0.5, control-monad-free-extras, bifunctors, applicative-extras, prelude-extras, deepseq, deepseq-extras, hoed-mini, hoed-extras 23 | 24 | if flag(logict) 25 | build-depends: logict 26 | cpp-options: -DLOGICT 27 | 28 | extensions: UndecidableInstances, OverlappingInstances, ScopedTypeVariables, 29 | MultiParamTypeClasses, FunctionalDependencies, 30 | FlexibleInstances, TypeSynonymInstances, 31 | GeneralizedNewtypeDeriving 32 | 33 | exposed-modules: 34 | Control.Monad.Env 35 | Control.Monad.Variant 36 | Data.Term, 37 | Data.Term.Base, 38 | Data.Id.Family, 39 | Data.Term.Family, 40 | Data.Var.Family, 41 | Data.Rule.Family, 42 | Data.Term.Substitutions, 43 | Data.Term.Rules, 44 | Data.Term.Simple, 45 | Data.Term.Var, 46 | Data.Term.IOVar, 47 | Data.Term.Rewriting, 48 | Data.Term.Narrowing, 49 | Data.Term.Ppr, 50 | Data.Term.Automata 51 | -- Data.Term.Annotated, 52 | -- Data.Term.Annotated.Ppr, 53 | -- Data.Term.Annotated.Rules, 54 | -- Data.Term.Annotated.Rewriting, 55 | -- Data.Term.Annotated.Narrowing, 56 | 57 | 58 | other-modules: 59 | Data.Term.Utils, 60 | Data.IOStableRef 61 | 62 | ghc-options: -Wall -fno-warn-name-shadowing 63 | ghc-prof-options: -fprof-auto 64 | -------------------------------------------------------------------------------- /test.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Free 2 | import Data.Term 3 | import Data.Term.Simple 4 | import Data.Term.IOVar 5 | 6 | main = do 7 | let (v0:v1:v2:v3:v4:v5:v6:v7:v8:v9:_) = map var' [0..] 8 | t1 = f(v0,f(v1, f(v2, f(v3, f(v4, f(v5, f(v6, f(v7, f(v8, f(v9,v9)))))))))) 9 | t2 = f(f(v0,v0), f(f(v1,v1), f(f(v2,v2), f(f(v3,v3), f(f(v4,v4), f(f(v5,v5), 10 | f(f(v6,v6), f(f(v7,v7), f(f(v8,v8), f(v9,v9)))))))))) 11 | sol1 = unifies t1 t2 12 | 13 | (v0:v1:v2:v3:v4:v5:v6:v7:v8:v9:_) <- replicateM 10 (liftM Pure freshVar) 14 | let t1 = f(v0,f(v1, f(v2, f(v3, f(v4, f(v5, f(v6, f(v7, f(v8, f(v9,v9)))))))))) 15 | t2 = f(f(v0,v0), f(f(v1,v1), f(f(v2,v2), f(f(v3,v3), f(f(v4,v4), f(f(v5,v5), 16 | f(f(v6,v6), f(f(v7,v7), f(f(v8,v8), f(v9,v9)))))))))) 17 | sol2 <- unifiesIO t1 t2 18 | print sol1 19 | print sol2 20 | 21 | 22 | f (a1,a2) = term "f" [a1,a2] 23 | varsIO = undefined --------------------------------------------------------------------------------