111 lines
3.9 KiB
Haskell
111 lines
3.9 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Interpreter where
|
|
|
|
import Data.Function
|
|
import qualified Data.Map as M
|
|
|
|
{- VAM 2P, done the lazy way -}
|
|
data StrTable =
|
|
StrTable Int (M.Map Int String)
|
|
|
|
data Datum
|
|
= Atom Int -- unifies a constant
|
|
| Struct (Int, Int) -- unifies a structure with arity
|
|
-- | VoidVar -- unifies with anything
|
|
-- | LocalVar Int -- unifies with a local variable (possibly making a new one when it's not in use yet)
|
|
-- | Ref Int -- unifies with the referenced value on the heap (not to be used in code)
|
|
deriving (Show, Eq, Ord)
|
|
|
|
data Instr
|
|
= U Datum -- something unifiable
|
|
| NoGoal -- trivial goal
|
|
| Goal -- we start a new goal, set up backtracking etc
|
|
| Call -- all seems okay, call the goal
|
|
| LastCall -- tail call the goal
|
|
| Cut -- remove all alternative clauses of the current goal
|
|
deriving (Show)
|
|
|
|
type Code = [Instr]
|
|
|
|
type Alts = [(Code, Code)] -- clauses to try and the corresponding goals to restore
|
|
|
|
data GolAlts =
|
|
GA Code Alts -- goal + choicepoints
|
|
deriving (Show)
|
|
|
|
type Defs = M.Map (Int, Int) [Code]
|
|
|
|
data Interp =
|
|
Interp
|
|
{ defs :: Defs -- global definitions for lookup
|
|
, hed :: Code -- current head
|
|
, gol :: GolAlts -- current goal with local choicepoints
|
|
, stk :: [GolAlts] -- stack of caller GolAlts
|
|
}
|
|
deriving (Show)
|
|
|
|
prove :: Code -> Defs -> Either (Interp, String) Bool
|
|
prove g ds =
|
|
let i0 = Interp {defs = ds, hed = g, gol = GA [LastCall] [], stk = []}
|
|
run (Left x) = x
|
|
run (Right x) = run $ proveStep Right Left x
|
|
in run (Right i0)
|
|
|
|
{- this gonna need Either String Bool for errors later -}
|
|
proveStep :: (Interp -> a) -> (Either (Interp, String) Bool -> a) -> Interp -> a
|
|
proveStep c f i = go i
|
|
where
|
|
ifail msg = f $ Left (i, msg)
|
|
withDef f
|
|
| Just d <- defs i M.!? f = ($ d)
|
|
| otherwise = const $ ifail $ "no definition: " ++ show f
|
|
{- Backtracking: try a fallback clause, restoring goal -}
|
|
backtrack i@Interp {gol = GA _ ((s, gs):as)} = c i {hed = s, gol = GA gs as}
|
|
{- B: no next clause, pop stack and continue backtracking at the caller -}
|
|
backtrack i@Interp {gol = GA _ [], stk = GA g ss:sss} =
|
|
backtrack i {hed = error "failed hed", gol = GA g ss, stk = sss}
|
|
{- B: we ran out of possibilities and there's nothing else to backtrack. No solution found. -}
|
|
backtrack i@Interp {gol = GA _ [], stk = []} = f (Right False)
|
|
{- Unification -}
|
|
go i@Interp {hed = (U a:hs), gol = GA (U b:gs) ss} -- unify constants
|
|
= unify a b
|
|
where
|
|
uok = c i {hed = hs, gol = GA gs ss}
|
|
unify (Atom a) (Atom b)
|
|
| a == b = uok
|
|
unify (Struct a) (Struct b)
|
|
| a == b = uok
|
|
unify _ _ = backtrack i
|
|
{- Resolution: Final success -}
|
|
go i@Interp {hed = [NoGoal], gol = GA [LastCall] _, stk = []} =
|
|
f (Right True)
|
|
{- R: Goal succeeded; continue at parent frame -}
|
|
go i@Interp { hed = [NoGoal]
|
|
, gol = GA [LastCall] _
|
|
, stk = GA (Goal:U (Struct f):gs) ss:sss
|
|
} =
|
|
withDef f $ \(hs:ohs) ->
|
|
c i {hed = hs, gol = GA gs (map (, gs) ohs ++ ss), stk = sss}
|
|
{- R: Start matching next goal -}
|
|
go i@Interp { hed = [NoGoal]
|
|
, gol = GA (Call:Goal:U (Struct f):gs) ss
|
|
} =
|
|
withDef f $ \(hs:ohs) ->
|
|
c i {hed = hs, gol = GA gs (map (, gs) ohs ++ ss)}
|
|
{- R: Goal head matching succeeded, make a normal call -}
|
|
go i@Interp { hed = (Goal:U (Struct f):ngs)
|
|
, gol = GA (Call:gs) ss
|
|
, stk = sss
|
|
} =
|
|
withDef f $ \(hs:ohs) ->
|
|
c i {hed = hs, gol = GA ngs (map (, ngs) ohs), stk = GA gs ss : sss}
|
|
{- R: Successful match continued by tail call -}
|
|
go i@Interp { hed = (Goal:U (Struct f):ngs)
|
|
, gol = GA [LastCall] ss
|
|
} =
|
|
withDef f $ \(hs:ohs) ->
|
|
c i {hed = hs, gol = GA ngs (map (, ngs) ohs ++ ss)}
|
|
{- The End -}
|
|
go _ = ifail "impossible instruction combo"
|