79 lines
3.1 KiB
Plaintext
79 lines
3.1 KiB
Plaintext
module Language.Bergamot.Unifier where
|
|
|
|
import Prelude
|
|
|
|
import Language.Bergamot.Rules (Metavariable, ProofTree(..), Rule(..), instantiate)
|
|
import Language.Bergamot.Syntax (Expr, IntVar)
|
|
|
|
import Control.Plus (class Plus, empty)
|
|
import Control.Apply (lift2)
|
|
import Control.Alt (class Alt)
|
|
import Control.Alternative (class Alternative)
|
|
import Control.MonadPlus (class MonadPlus)
|
|
import Control.Monad.Reader.Class (class MonadReader, class MonadAsk, local, ask, asks)
|
|
import Control.Monad.Logic.Class (class MonadLogic, msplit, interleave)
|
|
import Control.Monad.Unify.Class (class MonadUnify, unify, reify)
|
|
import Control.Monad.Reader.Trans (ReaderT, runReaderT)
|
|
import Control.Monad.Unify.Trans (UnifyT(..), runUnifyT)
|
|
import Control.Monad.Logic.Trans (SFKT, runSFKTOnce)
|
|
import Control.Monad.State.Trans (StateT(..), runStateT)
|
|
import Data.Traversable (traverse, oneOf)
|
|
import Data.Tuple (fst)
|
|
import Data.Newtype (class Newtype, un, over2)
|
|
import Data.Maybe (Maybe)
|
|
import Data.Bifunctor (rmap)
|
|
|
|
type UnifierEnv = { rules :: Array (Rule Metavariable), fuel :: Int }
|
|
newtype Unifier a = MkUnifier (UnifyT IntVar Expr (ReaderT UnifierEnv (SFKT Maybe)) a)
|
|
|
|
derive instance Newtype (Unifier a) _
|
|
derive newtype instance Functor Unifier
|
|
derive newtype instance Apply Unifier
|
|
derive newtype instance Applicative Unifier
|
|
derive newtype instance Alt Unifier
|
|
derive newtype instance Plus Unifier
|
|
derive newtype instance Alternative Unifier
|
|
derive newtype instance Bind Unifier
|
|
derive newtype instance Monad Unifier
|
|
derive newtype instance MonadPlus Unifier
|
|
derive newtype instance MonadUnify IntVar Expr Unifier
|
|
|
|
-- >:(
|
|
instance MonadAsk UnifierEnv Unifier where
|
|
ask = MkUnifier $ MkUnifyT ask
|
|
|
|
-- >:(
|
|
instance MonadReader UnifierEnv Unifier where
|
|
local f m = MkUnifier $ MkUnifyT $ StateT $ \s -> local f (runStateT (un MkUnifyT $ un MkUnifier m) s)
|
|
|
|
-- >:(
|
|
instance MonadLogic Unifier where
|
|
msplit m = MkUnifier $ MkUnifyT $ map (map (rmap (MkUnifier <<< MkUnifyT))) $ msplit $ un MkUnifyT $ un MkUnifier m
|
|
interleave = over2 MkUnifier (over2 MkUnifyT interleave)
|
|
|
|
spend :: forall a. Unifier a -> Unifier a
|
|
spend m = do
|
|
n <- asks _.fuel
|
|
if n > 0 then local (_ { fuel = n - 1}) m else empty
|
|
|
|
match :: Array (Rule Metavariable) -> Expr IntVar -> Unifier (ProofTree IntVar)
|
|
match rs e = oneOf $ map (matchSingle e) rs
|
|
where
|
|
matchSingle e' rule = spend $ do
|
|
MkRule {head, tail} <- instantiate rule
|
|
_ <- unify e' head
|
|
witnesses <- traverse (match rs) tail
|
|
pure $ MkProofTree { claim: e, rule: rule, witnesses: witnesses }
|
|
|
|
reifyProofTree :: ProofTree IntVar -> Unifier (ProofTree IntVar)
|
|
reifyProofTree (MkProofTree {claim, rule, witnesses}) = do
|
|
claim' <- reify claim
|
|
witnesses' <- traverse reifyProofTree witnesses
|
|
pure $ MkProofTree $ { claim: claim', rule: rule, witnesses: witnesses' }
|
|
|
|
query :: Expr Metavariable -> Unifier (ProofTree IntVar)
|
|
query e = (join $ lift2 match (asks _.rules) (instantiate e)) >>= reifyProofTree
|
|
|
|
runUnifier :: forall a. Array (Rule Metavariable) -> Unifier a -> Maybe a
|
|
runUnifier rs m = runSFKTOnce (fst <$> (runReaderT (runUnifyT $ un MkUnifier m) { rules: rs, fuel: 10 }))
|