diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 3 | ||||
| -rw-r--r-- | src/Reducer.hs | 14 | ||||
| -rw-r--r-- | src/Reducer/HigherOrder.hs | 40 | ||||
| -rw-r--r-- | src/Reducer/ION.hs | 3 | ||||
| -rw-r--r-- | src/Reducer/RKNL.hs | 8 |
5 files changed, 52 insertions, 16 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 2e9746d..5091b49 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -7,6 +7,7 @@ import Binary import Control.Concurrent import Control.DeepSeq ( deepseq ) import Control.Exception +import Control.Monad ( when ) import Control.Monad.State import qualified Control.Monad.State.Strict as StrictState import qualified Data.BitString as Bit @@ -148,7 +149,7 @@ evalQuote f sub = evalExp f sub >>= \case evalUnquote :: Expression -> Environment -> EvalState (Failable Expression) evalUnquote f sub = evalExp f sub >>= \case Left e -> pure $ Left e - Right f' -> pure $ Right $ Unquote $ unsafeReduce f' -- TODO: REMOVE UNSAFE + Right f' -> pure $ Right $ Unquote $ reduceNoIO f' evalExp :: Expression -> Environment -> EvalState (Failable Expression) evalExp idx@(Bruijn _ ) = const $ pure $ Right idx diff --git a/src/Reducer.hs b/src/Reducer.hs index 3be8306..31ed3da 100644 --- a/src/Reducer.hs +++ b/src/Reducer.hs @@ -1,18 +1,20 @@ -- MIT License, Copyright (c) 2024 Marvin Borner module Reducer ( reduce - , unsafeReduce + , reduceNoIO ) where import Helper +import qualified Reducer.HigherOrder as HigherOrder import qualified Reducer.ION as ION import qualified Reducer.RKNL as RKNL reduce :: EvalConf -> Expression -> IO Expression reduce conf e = case _reducer conf of - "RKNL" -> RKNL.reduce e - "ION" -> pure $ ION.reduce e - _ -> error "Invalid reducer" + "RKNL" -> RKNL.reduce e + "ION" -> pure $ ION.reduce e + "HigherOrder" -> pure $ HigherOrder.reduce e + _ -> error "Invalid reducer" -unsafeReduce :: Expression -> Expression -unsafeReduce = RKNL.unsafeReduce +reduceNoIO :: Expression -> Expression +reduceNoIO = HigherOrder.reduce diff --git a/src/Reducer/HigherOrder.hs b/src/Reducer/HigherOrder.hs new file mode 100644 index 0000000..91378b7 --- /dev/null +++ b/src/Reducer/HigherOrder.hs @@ -0,0 +1,40 @@ +-- MIT License, Copyright (c) 2024 Marvin Borner +-- Slightly modified version of Tromp's AIT/Lambda.lhs reducer implementation +module Reducer.HigherOrder + ( reduce + ) where + +import Helper + +data HigherOrder = HigherOrderBruijn Int | HigherOrderAbstraction (HigherOrder -> HigherOrder) | HigherOrderApplication HigherOrder HigherOrder +data NamedTerm = NamedVariable Int | NamedAbstraction Int NamedTerm | NamedApplication NamedTerm NamedTerm + +app :: HigherOrder -> HigherOrder -> HigherOrder +app (HigherOrderAbstraction f) = f +app f = HigherOrderApplication f + +eval :: Expression -> HigherOrder +eval = go [] + where + go env (Bruijn x ) = env !! x + go env (Abstraction e ) = HigherOrderAbstraction $ \x -> go (x : env) e + go env (Application e1 e2) = app (go env e1) (go env e2) + go _ _ = invalidProgramState + +toNamedTerm :: HigherOrder -> NamedTerm +toNamedTerm = go 0 + where + go _ (HigherOrderBruijn i) = NamedVariable i + go d (HigherOrderAbstraction f) = + NamedAbstraction d $ go (d + 1) (f (HigherOrderBruijn d)) + go d (HigherOrderApplication e1 e2) = NamedApplication (go d e1) (go d e2) + +resolveExpression :: NamedTerm -> Expression +resolveExpression = resolve [] + where + resolve vs (NamedVariable i ) = Bruijn $ vs !! i + resolve vs (NamedAbstraction v t) = Abstraction $ resolve (v : vs) t + resolve vs (NamedApplication l r) = Application (resolve vs l) (resolve vs r) + +reduce :: Expression -> Expression +reduce = resolveExpression . toNamedTerm . eval diff --git a/src/Reducer/ION.hs b/src/Reducer/ION.hs index 9154bd8..5eb959b 100644 --- a/src/Reducer/ION.hs +++ b/src/Reducer/ION.hs @@ -147,7 +147,8 @@ rules ch vm = case chr' ch of let parentVal = load (load (sp vm1 + 1) vm1 + 1) vm1 let (a, vm2) = app (ord 'f') (load (sp vm1) vm1) vm1 lazy 0 (wor a) (wor parentVal) (store (sp vm2) parentVal vm2) - _ -> error $ "invalid combinator " ++ show ch + '\0' -> store (sp vm) (arg' 1 vm) vm + _ -> error $ "invalid combinator " ++ show ch where lvm n f g = lazy n f g vm eval :: VM -> VM diff --git a/src/Reducer/RKNL.hs b/src/Reducer/RKNL.hs index 9513e38..5aa6ca1 100644 --- a/src/Reducer/RKNL.hs +++ b/src/Reducer/RKNL.hs @@ -2,7 +2,6 @@ -- based on the RKNL abstract machine module Reducer.RKNL ( reduce - , unsafeReduce ) where import Control.Concurrent.MVar @@ -11,7 +10,6 @@ import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Maybe ( fromMaybe ) import Helper -import System.IO.Unsafe ( unsafePerformIO ) -- TODO: AAH type Store = Map Int Box type Stack = [Redex] @@ -109,9 +107,3 @@ reduce e = do forEachState (loadTerm redex) transition >>= \case Cconf _ [] v -> pure $ fromRedex v _ -> invalidProgramState - --- TODO: AAAAAAAAAAAAAAAAH remove this --- (probably not thaaat bad) -{-# NOINLINE unsafeReduce #-} -unsafeReduce :: Expression -> Expression -unsafeReduce = unsafePerformIO . reduce |