Extestation and humanification

3 files changed, 70 insertions, 40 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index 3a1b0c1..65db990 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -137,14 +137,12 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env) rec conf = ca
                   <> (show e')
                   <> "\n*> "
                   <> (show reduced)
-                  <> (if likeTernary reduced -- TODO: Also sugar string/char
-                       then "\t(" <> (show $ ternaryToDecimal reduced) <> ")"
-                       else ""
-                     )
+                  <> " "
+                  <> (humanifyExpression reduced)
                 where reduced = reduce e'
             )
           >> rec s conf
-  Test e1 e2 ->
+  Test e1 e2 -> if (evalTests conf) then
     let (res, _) = evalTest e1 e2 (Environment []) `runState` env
     in  case res of
           Left err -> print (ContextualError err (Context inp (nicePath conf))) >> pure s
@@ -157,6 +155,7 @@ evalInstruction (ContextualInstruction instr inp) s@(EnvState env) rec conf = ca
               lhs = reduce e1'
               rhs = reduce e2'
           _ -> rec s conf
+    else rec s conf
   _ -> rec s conf
 evalInstruction instr s rec conf = evalInstruction (ContextualInstruction instr "<unknown>") s rec conf
 
@@ -175,14 +174,20 @@ evalMainFunc (Environment env) arg = do
   e <- lookup "main" (map fst env)
   pure $ reduce $ Application e arg
 
-evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
-evalFile path wr conv = do
-  EnvState env <- loadFile path (EvalConf { isRepl = False, nicePath = path, evalPaths = [] })
+evalFileConf :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> IO ()
+evalFileConf path wr conv conf = do
+  EnvState env <- loadFile path conf
   arg          <- encodeStdin
   case evalMainFunc env arg of
     Nothing  -> print $ ContextualError (UndeclaredFunction "main") (Context "" path)
     Just e -> wr $ conv e
 
+evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
+evalFile path wr conv = evalFileConf path wr conv (EvalConf { isRepl = False, evalTests = True, nicePath = path, evalPaths = [] })
+
+evalYolo :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
+evalYolo path wr conv = evalFileConf path wr conv (EvalConf { isRepl = False, evalTests = False, nicePath = path, evalPaths = [] })
+
 exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
 exec path rd conv = do
   f <- rd path
@@ -197,8 +202,8 @@ repl s =
     )
     >>= (\case -- TODO: Add non-parser error support for REPL
           Nothing   -> return ()
-          Just line -> do
-            s' <- (liftIO $ eval [line] s (EvalConf { isRepl = True, nicePath = "<repl>", evalPaths = [] }))
+          Just line -> do -- TODO: Use -y in repl for YOLO lifestyle
+            s' <- (liftIO $ eval [line] s (EvalConf { isRepl = True, evalTests = True, nicePath = "<repl>", evalPaths = [] }))
             lift (StrictState.put s')
             repl s'
         )
@@ -239,11 +244,13 @@ usage = do
   putStrLn "-B\tcompile path to ASCII-BLC"
   putStrLn "-e\texecute path as binary-BLC"
   putStrLn "-E\texecute path as ASCII-BLC"
+  putStrLn "-y\tdisable execution of tests - YOLO"
   putStrLn "-*\tshow this help"
   putStrLn "<default>\texecute path as text-bruijn"
 
 evalMain :: IO ()
 evalMain = do
+  -- TODO: use actual args parser
   args <- getArgs
   case args of
     []           -> runRepl
@@ -254,6 +261,7 @@ evalMain = do
     ["-e", path] ->
       exec path (try . Byte.readFile) (fromBitString . Bit.bitString)
     ["-E", path] -> exec path (try . readFile) id
+    ["-y", path] -> evalYolo path putStr humanifyExpression
     ['-' : _]    -> usage
-    [path   ]    -> evalFile path putStr decodeStdout
+    [path   ]    -> evalFile path putStr humanifyExpression
     _            -> usage
diff --git a/src/Helper.hs b/src/Helper.hs
index d653319..6626598 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -104,6 +104,7 @@ type EnvDef = (String, Expression)
 -- TODO: Add EvalConf to EnvState?
 data EvalConf = EvalConf
   { isRepl    :: Bool
+  , evalTests :: Bool
   , nicePath  :: String
   , evalPaths :: [String]
   }
@@ -145,34 +146,45 @@ charToExpression ch = encodeByte $ Bit.toList $ Bit.bitString $ C.pack [ch]
 
 encodeStdin :: IO Expression
 encodeStdin = do
-  putStrLn "Waiting for stdin eof"
   bytes <- Byte.getContents
   pure $ encodeBytes bytes
 
-unlistify :: Expression -> [Expression]
-unlistify (Abstraction (Abstraction (Bruijn 0))) = []
+unlistify :: Expression -> Maybe [Expression]
+unlistify (Abstraction (Abstraction (Bruijn 0))) = Just []
 unlistify (Abstraction (Application (Application (Bruijn 0) e) es)) =
-  e : (unlistify es)
-unlistify _ = error "invalid"
+  (:) <$> Just e <*> (unlistify es)
+unlistify _ = Nothing
 
-decodeByte :: Expression -> [Bool]
-decodeByte (Abstraction (Abstraction (Bruijn 0))) = []
+decodeByte :: Expression -> Maybe [Bool]
+decodeByte (Abstraction (Abstraction (Bruijn 0))) = Just []
 decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 0)))) es))
-  = False : (decodeByte es)
+  = (:) <$> Just False <*> (decodeByte es)
 decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 1)))) es))
-  = True : (decodeByte es)
-decodeByte _ = error "invalid" -- TODO: Better errors using Maybe
-
-decodeStdout :: Expression -> String
-decodeStdout e = C.unpack $ Byte.concat $ map
-  (Bit.realizeBitStringStrict . Bit.fromList . decodeByte)
-  (unlistify e)
+  = (:) <$> Just True <*> (decodeByte es)
+decodeByte _ = Nothing
+
+decodeStdout :: Expression -> Maybe String
+decodeStdout e = do
+  u <- unlistify e
+  pure $ C.unpack $ Byte.concat $ map
+    (\m -> case decodeByte m of
+      Just b  -> Bit.realizeBitStringStrict $ Bit.fromList b
+      Nothing -> Byte.empty
+    )
+    u
 
 ---
 
-likeTernary :: Expression -> Bool
-likeTernary (Abstraction (Abstraction (Abstraction (Abstraction _)))) = True
-likeTernary _ = False
+-- TODO: Expression -> Maybe Char is missing
+maybeHumanifyExpression :: Expression -> Maybe String
+maybeHumanifyExpression e = ternaryToDecimal e <|> decodeStdout e
+
+humanifyExpression :: Expression -> String
+humanifyExpression e = case maybeHumanifyExpression e of
+  Nothing -> ""
+  Just h  -> h
+
+---
 
 -- Dec to Bal3 in Bruijn encoding: reversed application with 0=>0; 1=>1; T=>2; end=>3
 -- e.g. 0=0=[[[[3]]]]; 2=1T=[[[[2 (0 3)]]]] -5=T11=[[[[0 (0 (2 3))]]]]
@@ -184,17 +196,20 @@ decimalToTernary n =
   gen n' =
     Application (Bruijn $ fromIntegral $ mod n' 3) (gen $ div (n' + 1) 3)
 
-ternaryToDecimal :: Expression -> Integer
-ternaryToDecimal e = sum $ zipWith (*) (resolve e) (iterate (* 3) 1)
+ternaryToDecimal :: Expression -> Maybe String
+ternaryToDecimal e = do
+  res <- resolve e
+  return $ show $ (sum $ zipWith (*) res (iterate (* 3) 1) :: Integer)
  where
-  multiplier (Bruijn 0) = 0
-  multiplier (Bruijn 1) = 1
-  multiplier (Bruijn 2) = (-1)
-  multiplier _          = 0 -- ??
-  resolve' (Application x@(Bruijn _) (Bruijn 3)) = [multiplier x]
+  multiplier (Bruijn 0) = Just 0
+  multiplier (Bruijn 1) = Just 1
+  multiplier (Bruijn 2) = Just (-1)
+  multiplier _          = Nothing
+  resolve' (Application x@(Bruijn _) (Bruijn 3)) =
+    (:) <$> multiplier x <*> Just []
   resolve' (Application x@(Bruijn _) xs@(Application _ _)) =
-    (multiplier x) : (resolve' xs)
-  resolve' _ = [0]
+    (:) <$> (multiplier x) <*> (resolve' xs)
+  resolve' _ = Nothing
   resolve (Abstraction (Abstraction (Abstraction (Abstraction n)))) =
     resolve' n
-  resolve _ = [0]
+  resolve _ = Nothing
diff --git a/src/Parser.hs b/src/Parser.hs
index 1d889d3..4237db7 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -73,9 +73,16 @@ parseNumeral = do
   number :: Parser Integer
   number = ap sign nat
 
+specialEscape :: Parser Char
+specialEscape =
+  choice (zipWith (\c r -> r <$ char c) "bnfrt\\\"/" "\b\n\f\r\t\\\"/")
+
 parseString :: Parser Expression
 parseString = do
-  str <- between (char '\"') (char '\"') (some $ satisfy (`notElem` "\"\\"))
+  str <- between
+    (char '\"')
+    (char '\"')
+    (some $ (char '\\' *> specialEscape) <|> (satisfy (`notElem` "\"\\")))
   pure (stringToExpression str) <?> "string"
 
 parseChar :: Parser Expression