diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Eval.hs | 22 | ||||
| -rw-r--r-- | src/Helper.hs | 4 | ||||
| -rw-r--r-- | src/Parser.hs | 19 | ||||
| -rw-r--r-- | src/Reducer.hs | 11 |
4 files changed, 51 insertions, 5 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 6af1959..223a43a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -131,6 +131,24 @@ evalPrefix :: Identifier -> Expression -> Environment -> EvalState (Failable Expression) evalPrefix p e = evalExp $ Application (Function p) e +evalQuote :: Expression -> Environment -> EvalState (Failable Expression) +evalQuote f sub = evalExp f sub >>= \case + Left e -> pure $ Left e + Right f' -> pure $ Right $ quotify f' + where + base l r = Abstraction $ Abstraction $ Abstraction $ Application l r + quotify (Abstraction e) = base (Bruijn 0) (quotify e) + quotify (Application l r) = + base (Application (Bruijn 1) (quotify l)) (quotify r) + quotify (Bruijn i) = base (Bruijn 2) (decimalToUnary $ fromIntegral i) + quotify (Unquote e) = quotify e + quotify _ = invalidProgramState + +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' + evalExp :: Expression -> Environment -> EvalState (Failable Expression) evalExp idx@(Bruijn _ ) = const $ pure $ Right idx evalExp ( Function fun) = evalFun fun @@ -138,6 +156,8 @@ evalExp ( Abstraction e ) = evalAbs e evalExp ( Application f g) = evalApp f g evalExp ( MixfixChain es ) = evalMixfix es evalExp ( Prefix p e ) = evalPrefix p e +evalExp ( Quote e ) = evalQuote e +evalExp ( Unquote e ) = evalUnquote e evalDefinition :: Identifier -> Expression -> Environment -> EvalState (Failable Expression) @@ -290,7 +310,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case putStrLn $ toBinary red pure s Jot str -> do - let e = fromJot str + let e = fromJot str let (res, _) = evalExp e (Environment M.empty) `runState` env case res of Left err -> print err diff --git a/src/Helper.hs b/src/Helper.hs index 83bf95d..df1918b 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -135,7 +135,7 @@ instance Show Mixfix where show (MixfixExpression e) = show e -- TODO: Remove Application and replace with Chain (renaming of MixfixChain) -data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression +data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression | Quote Expression | Unquote Expression deriving (Ord, Eq, Generic, NFData) instance Show Expression where @@ -156,6 +156,8 @@ instance Show Expression where . foldr1 (\x y -> x . showString " " . y) (map shows ms) . showString "\ESC[33m)\ESC[0m" showsPrec _ (Prefix p e) = shows p . showString " " . shows e + showsPrec _ (Quote e ) = showString "\ESC[36m`\ESC[0m" . shows e + showsPrec _ (Unquote e ) = showString "\ESC[36m,\ESC[0m" . shows e data Command = Input String | Watch String | Import String String | Test Expression Expression | ClearState | Time Expression | Length Expression | Blc Expression | Jot String deriving (Show) diff --git a/src/Parser.hs b/src/Parser.hs index aee282b..57d6f58 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -42,9 +42,10 @@ mathematicalArrow = satisfy isMathematicalOperator -- "'" can't be in special chars because of 'c' char notation and prefixation -- "." can't be in special chars because of namespaced functions and UFCS syntax +-- "," can't be in special chars because of unquote specialChar :: Parser Char specialChar = - oneOf "!?*@,:;+-_#$%^&<>/\\|{}~=" + oneOf "!?*@:;+-_#$%^&<>/\\|{}~=" <|> mathematicalOperator <|> mathematicalArrow @@ -177,6 +178,18 @@ parseMixfix = do operatorAsMixfix = MixfixOperator . MixfixFunction <$> some mixfixSome singletonAsMixfix = MixfixExpression <$> parseSingleton +parseQuote :: Parser Expression +parseQuote = do + _ <- char '`' <?> "quote start" + e <- parseSingleton + pure $ Quote e + +parseUnquote :: Parser Expression +parseUnquote = do + _ <- char ',' <?> "unquote start" + e <- parseSingleton + pure $ Unquote e + parsePrefix :: Parser Expression parsePrefix = do p <- prefixOperator @@ -189,7 +202,9 @@ parseSingleton = parseBruijn <|> try parseNumeral <|> parseString - <|> parseChar + <|> try parseChar + <|> parseQuote + <|> parseUnquote <|> parseAbstraction <|> try parseFunction <|> parsePrefix diff --git a/src/Reducer.hs b/src/Reducer.hs index f5c1b7a..820cc04 100644 --- a/src/Reducer.hs +++ b/src/Reducer.hs @@ -2,6 +2,7 @@ -- based on the RKNL abstract machine module Reducer ( reduce + , unsafeReduce ) where import Control.Concurrent.MVar @@ -10,6 +11,7 @@ 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] @@ -37,7 +39,8 @@ toRedex = convertWorker (NameGen 1) [] in Rapp lhs rhs convertWorker _ ns (Bruijn i) = Rvar $ Num (if i < 0 || i >= length ns then i else ns !! i) - convertWorker _ _ _ = invalidProgramState + convertWorker g ns (Unquote e) = convertWorker g ns e + convertWorker _ _ _ = invalidProgramState fromRedex :: Redex -> Expression fromRedex = convertWorker [] @@ -106,3 +109,9 @@ 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 |