aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorMarvin Borner2023-09-22 00:39:53 +0200
committerMarvin Borner2023-09-22 00:39:53 +0200
commit6a451b6cad18a5b4ba60b6017dbfaa4ab707db8a (patch)
tree6e13d6c502dbb1e89bf596c393ab27f33d4a9ee5 /src
parent1f985159c3ca5d15a2229a495b2c15a5a1af2dd6 (diff)
Minor improvements
Sorry, don't exactly know and don't care. Just some things I apparently didn't commit
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs45
-rw-r--r--src/Eval.hs15
-rw-r--r--src/Helper.hs28
-rw-r--r--src/Parser.hs7
4 files changed, 66 insertions, 29 deletions
diff --git a/src/Binary.hs b/src/Binary.hs
index 79d3fb6..3f77d4a 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -4,13 +4,10 @@ module Binary
, fromBinary
, toBitString
, fromBitString
+ , fromJot
) where
-import Data.Binary ( decode
- , encode
- )
import qualified Data.BitString as Bit
-import Data.Word ( Word8 )
import Helper
toBinary :: Expression -> String
@@ -38,30 +35,34 @@ fromBinary' inp = case inp of
fromBinary :: String -> Expression
fromBinary = fst . fromBinary'
--- 1 byte indicating bit-padding at end + n bytes filled with bits
--- TODO: technically only 1 nibble is needed (use other nibble for versioning/sth?)
toBitString :: String -> Bit.BitString
-toBitString str = Bit.concat
- [ Bit.bitStringLazy $ encode (fromIntegral $ length str `mod` 8 :: Word8)
- , Bit.fromList $ map
- (\case
- '0' -> False
- '1' -> True
- _ -> invalidProgramState
- )
- str
- ]
+toBitString = Bit.fromList . map
+ (\case
+ '0' -> False
+ '1' -> True
+ _ -> invalidProgramState
+ )
fromBitString :: Bit.BitString -> String
-fromBitString bits =
+fromBitString =
map
(\case
False -> '0'
True -> '1'
)
- $ Bit.toList
- $ Bit.take (Bit.length bits - fromIntegral (pad bits))
- $ Bit.drop 8 bits
+ . Bit.toList
+
+---
+
+fromJot :: String -> Expression
+fromJot = worker . reverse
where
- pad :: Bit.BitString -> Word8
- pad = decode . Bit.realizeBitStringLazy . Bit.take 8
+ s = Function $ NormalFunction "s"
+ k = Function $ NormalFunction "k"
+ worker ('0' : xs) = Application (Application (worker xs) s) k
+ worker ('1' : xs) = Application s (Application k (worker xs))
+ -- worker ('1' : xs) = Abstraction
+ -- (Abstraction (Application (worker xs) (Application (Bruijn 1) (Bruijn 0))))
+ worker _ = Abstraction (Bruijn 0)
+
+
diff --git a/src/Eval.hs b/src/Eval.hs
index d887a62..6af1959 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -285,10 +285,23 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case
case res of
Left err -> print err
Right e' -> do
- red <- reduce e'
putStrLn $ toBinary e'
+ red <- reduce e'
putStrLn $ toBinary red
pure s
+ Jot str -> do
+ let e = fromJot str
+ let (res, _) = evalExp e (Environment M.empty) `runState` env
+ case res of
+ Left err -> print err
+ Right e' -> do
+ print e
+ print e'
+ print $ length $ toBinary e'
+ red <- reduce e'
+ print red
+ print $ length $ toBinary red
+ pure s
Time e -> do
start <- getTime Monotonic
let (res, _) = evalExp e (Environment M.empty) `runState` env
diff --git a/src/Helper.hs b/src/Helper.hs
index f760597..d47fc2a 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -1,10 +1,9 @@
-- MIT License, Copyright (c) 2022 Marvin Borner
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
--- extensions above are only used because of printBundle from megaparsec
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Helper where
@@ -42,7 +41,9 @@ printContext (Context inp path) = p $ lines inp
errPrefix :: String
errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m "
+
data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String
+
instance Show Error where
show (ContextualError err ctx) = show err <> "\n" <> printContext ctx
show (SuggestSolution err sol) =
@@ -69,6 +70,7 @@ instance Show Error where
<> " = "
<> show red2
show (ImportError path) = errPrefix <> "invalid import " <> show path
+
type Failable = Either Error
-- Modified from megaparsec's errorBundlePretty
@@ -107,28 +109,35 @@ printBundle ParseErrorBundle {..} =
data MixfixIdentifierKind = MixfixSome String | MixfixNone
deriving (Ord, Eq, Generic, NFData)
+
instance Show MixfixIdentifierKind where -- don't colorize (due to map)
show (MixfixSome e) = e
show _ = "…"
+
data Identifier = NormalFunction String | MixfixFunction [MixfixIdentifierKind] | PrefixFunction String | NamespacedFunction String Identifier
deriving (Ord, Eq, Generic, NFData)
+
functionName :: Identifier -> String
functionName = \case
NormalFunction f -> f
MixfixFunction is -> intercalate "" $ map show is
PrefixFunction p -> p <> "‣"
NamespacedFunction n f -> n <> functionName f
+
instance Show Identifier where
show ident = "\ESC[95m" <> functionName ident <> "\ESC[0m"
data Mixfix = MixfixOperator Identifier | MixfixExpression Expression
deriving (Ord, Eq, Generic, NFData)
+
instance Show Mixfix where
show (MixfixOperator i) = show i
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
deriving (Ord, Eq, Generic, NFData)
+
instance Show Expression where
showsPrec _ (Bruijn x) =
showString "\ESC[91m" . shows x . showString "\ESC[0m"
@@ -147,8 +156,10 @@ 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
-data Command = Input String | Watch String | Import String String | Test Expression Expression | ClearState | Time Expression | Length Expression | Blc Expression
+
+data Command = Input String | Watch String | Import String String | Test Expression Expression | ClearState | Time Expression | Length Expression | Blc Expression | Jot String
deriving (Show)
+
data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
deriving (Show)
@@ -158,21 +169,26 @@ data EvalConf = EvalConf
, _nicePath :: String
, _evalPaths :: [String]
}
+
newtype ExpFlags = ExpFlags
{ _isImported :: Bool
}
- deriving Show
+ deriving (Show)
+
data EnvDef = EnvDef
{ _exp :: Expression
, _sub :: Environment
, _flags :: ExpFlags
}
deriving Show
+
newtype Environment = Environment (M.Map Identifier EnvDef)
- deriving Show
+ deriving (Show)
+
newtype EnvCache = EnvCache
{ _imported :: M.Map String Environment
}
+
type EvalState = S.State Environment
defaultConf :: String -> EvalConf
diff --git a/src/Parser.hs b/src/Parser.hs
index 470c18f..aee282b 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -289,6 +289,12 @@ parseBlc = do
e <- parseExpression
pure $ Blc e
+parseJot :: Parser Command
+parseJot = do
+ _ <- string ":jot" <* sc <?> "jot binary string"
+ str <- some $ noneOf "\r\n"
+ pure $ Jot str
+
parseClearState :: Parser Command
parseClearState = do
_ <- string ":free" <?> "free instruction"
@@ -356,5 +362,6 @@ parseReplLine =
<|> (Commands . (: []) <$> try parseTime)
<|> (Commands . (: []) <$> try parseLength)
<|> (Commands . (: []) <$> try parseBlc)
+ <|> (Commands . (: []) <$> try parseJot)
<|> (Commands . (: []) <$> try parseClearState)
<|> try parseEvaluate