Context, errors and IO

3 files changed, 121 insertions, 41 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index e4f2676..7cf598b 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -41,10 +41,10 @@ loadFile path conf = do
   f <- try $ readFile path :: IO (Either IOError String)
   case f of
     Left exception ->
-      print (exception :: IOError) >> pure (EnvState $ Environment [])
+      print (ContextualError (ImportError $ show (exception :: IOError)) (Context "" (nicePath conf))) >> pure (EnvState $ Environment [])
     Right f' -> eval (filter (not . null) $ split "\n\n" f')
                        (EnvState $ Environment [])
-                       (EvalConf { isRepl = False, evalPaths = (path : (evalPaths conf)) })
+                       (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) })
 
 evalVar :: String -> Environment -> Program (Failable Expression)
 evalVar var (Environment sub) = state $ \env@(Environment e) ->
@@ -103,13 +103,13 @@ evalInstruction
   -> (EnvState -> EvalConf -> IO EnvState)
   -> EvalConf
   -> IO EnvState
-evalInstruction instr s@(EnvState env) rec conf = case instr of
-  Define name e sub inp -> do
+evalInstruction (ContextualInstruction instr inp) s@(EnvState env) rec conf = case instr of
+  Define name e sub -> do
     EnvState subEnv <- evalSubEnv sub s conf
     let
       (res, env') = evalDefine name e subEnv `runState` env
      in  case res of
-          Left  err -> print (ContextualError err inp) >> pure s -- don't continue
+          Left  err -> print (ContextualError err (Context inp (nicePath conf))) >> pure s -- don't continue
           Right _   -> if isRepl conf
             then (putStrLn $ name <> " = " <> show e)
               >> return (EnvState env')
@@ -119,8 +119,8 @@ evalInstruction instr s@(EnvState env) rec conf = case instr of
     lib           <- getDataFileName path -- TODO: Use actual lib directory
     exists        <- doesFileExist lib
     actual        <- pure $ if exists then lib else path
-    if (actual `elem` evalPaths conf) then (print (ImportError path) >> pure s) else do
-      EnvState env' <- loadFile actual conf
+    if (actual `elem` evalPaths conf) then (print (ContextualError (ImportError path) (Context inp (nicePath conf))) >> pure s) else do
+      EnvState env' <- loadFile actual (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error
       let prefix | null namespace   = takeBaseName path ++ "."
                  | namespace == "." = ""
                  | otherwise        = namespace ++ "."
@@ -147,7 +147,7 @@ evalInstruction instr s@(EnvState env) rec conf = case instr of
   Test e1 e2 ->
     let (res, _) = evalTest e1 e2 (Environment []) `runState` env
     in  case res of
-          Left err -> print err >> pure s
+          Left err -> print (ContextualError err (Context inp (nicePath conf))) >> pure s
           Right (Test e1' e2') ->
             when
                 (lhs /= rhs)
@@ -158,6 +158,7 @@ evalInstruction instr s@(EnvState env) rec conf = case instr of
               rhs = reduce e2'
           _ -> rec s conf
   _ -> rec s conf
+evalInstruction instr s rec conf = evalInstruction (ContextualInstruction instr "<unknown>") s rec conf
 
 eval :: [String] -> EnvState -> EvalConf -> IO EnvState
 eval []   s _ = return s
@@ -165,7 +166,7 @@ eval [""] s _ = return s
 eval (block : bs) s conf =
   handleInterrupt (putStrLn "<aborted>" >> return s)
     $ case parse blockParser "" block of
-        Left  err   -> print (SyntaxError $ errorBundlePretty err) >> eval bs s conf
+        Left  err   -> print (ContextualError (SyntaxError $ printBundle err) (Context "" (nicePath conf))) >> eval bs s conf
         Right instr -> evalInstruction instr s (eval bs) conf
   where blockParser = if isRepl conf then parseReplLine else parseBlock 0
 
@@ -176,10 +177,10 @@ evalMainFunc (Environment env) arg = do
 
 evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
 evalFile path wr conv = do
-  EnvState env <- loadFile path (EvalConf { isRepl = False, evalPaths = [] })
+  EnvState env <- loadFile path (EvalConf { isRepl = False, nicePath = path, evalPaths = [] })
   arg          <- encodeStdin
   case evalMainFunc env arg of
-    Nothing  -> print $ ContextualError (UndeclaredFunction "main") path
+    Nothing  -> print $ ContextualError (UndeclaredFunction "main") (Context "" path)
     Just e -> wr $ conv e
 
 exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
@@ -197,7 +198,7 @@ repl s =
     >>= (\case -- TODO: Add non-parser error support for REPL
           Nothing   -> return ()
           Just line -> do
-            s' <- (liftIO $ eval [line] s (EvalConf { isRepl = True, evalPaths = [] }))
+            s' <- (liftIO $ eval [line] s (EvalConf { isRepl = True, nicePath = "<repl>", evalPaths = [] }))
             lift (StrictState.put s')
             repl s'
         )
@@ -254,5 +255,5 @@ evalMain = do
       exec path (try . Byte.readFile) (fromBitString . Bit.bitString)
     ["-E", path] -> exec path (try . readFile) id
     ['-' : _]    -> usage
-    [path   ]    -> evalFile path print id
+    [path   ]    -> evalFile path putStrLn decodeStdout
     _            -> usage
diff --git a/src/Helper.hs b/src/Helper.hs
index 821e68c..160ca9a 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -1,27 +1,43 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+-- these extensions are only used because of printBundle from megaparsec
+
 module Helper where
 
-import           Control.Monad.State
+import qualified Control.Monad.State           as S
 import qualified Data.BitString                as Bit
 import qualified Data.ByteString               as Byte
 import           Data.List
+import           Text.Megaparsec
+
+data Context = Context
+  { ctxInput :: String
+  , ctxPath  :: String
+  }
 
-printContext :: String -> String
-printContext str = p $ lines str
+printContext :: Context -> String
+printContext (Context inp ""  ) = printContext (Context inp "<unknown>")
+printContext (Context inp path) = p $ lines inp
  where
-  p [l] = "in \"" <> l <> "\"\n"
+  withinText = "\ESC[42mwithin\ESC[0m "
+  inText     = "\ESC[44min\ESC[0m "
+  nearText   = "\ESC[45mnear\ESC[0m\n"
+  p []  = withinText <> show path <> "\n"
+  p [l] = inText <> show l <> "\n" <> withinText <> show path <> "\n"
   p (l : ls) =
     (p [l])
-      <> "near\n"
+      <> nearText
       <> (intercalate "\n" $ map ("  | " ++) $ take 3 $ ls)
       <> "\n"
-  p _ = ""
 
 errPrefix :: String
 errPrefix = "\ESC[41mERROR\ESC[0m "
-data Error = SyntaxError String | UndeclaredFunction String | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error String | ImportError String
+data Error = SyntaxError String | UndeclaredFunction String | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | ImportError String
 instance Show Error where
   show (ContextualError err ctx) = show err <> "\n" <> (printContext ctx)
-  show (SyntaxError err        ) = errPrefix <> "invalid syntax\nnear " <> err
+  show (SyntaxError err) =
+    errPrefix <> "invalid syntax\n\ESC[45mnear\ESC[0m " <> err
   show (UndeclaredFunction func) =
     errPrefix <> "undeclared function " <> show func
   show (InvalidIndex err) = errPrefix <> "invalid index " <> show err
@@ -38,9 +54,43 @@ instance Show Error where
   show (ImportError path) = errPrefix <> "invalid import " <> show path
 type Failable = Either Error
 
+-- Modified from megaparsec's errorBundlePretty
+printBundle
+  :: forall s e
+   . (VisualStream s, TraversableStream s, ShowErrorComponent e)
+  => ParseErrorBundle s e
+  -> String
+printBundle ParseErrorBundle {..} =
+  let (r, _) = foldl f (id, bundlePosState) bundleErrors in drop 1 (r "")
+ where
+  f :: (ShowS, PosState s) -> ParseError s e -> (ShowS, PosState s)
+  f (o, !pst) e = (o . (outChunk ++), pst')
+   where
+    (msline, pst') = reachOffset (errorOffset e) pst
+    epos           = pstateSourcePos pst'
+    outChunk       = "\n\n" <> offendingLine <> (init $ parseErrorTextPretty e)
+    offendingLine  = case msline of
+      Nothing -> ""
+      Just sline ->
+        let pointer    = "^"
+            rpadding   = replicate rpshift ' '
+            rpshift    = unPos (sourceColumn epos) - 2
+            lineNumber = (show . unPos . sourceLine) epos
+            padding    = replicate (length lineNumber + 1) ' '
+        in  padding
+              <> "|\n"
+              <> "  | "
+              <> sline
+              <> "\n"
+              <> padding
+              <> "|  "
+              <> rpadding
+              <> pointer
+              <> "\n"
+
 data Expression = Bruijn Int | Variable String | Abstraction Expression | Application Expression Expression
   deriving (Ord, Eq)
-data Instruction = Define String Expression [Instruction] String | Evaluate Expression | Comment | Import String String | Test Expression Expression
+data Instruction = Define String Expression [Instruction] | Evaluate Expression | Comment | Import String String | Test Expression Expression | ContextualInstruction Instruction String
   deriving (Show)
 instance Show Expression where
   show (Bruijn      x  ) = "\ESC[91m" <> show x <> "\ESC[0m"
@@ -53,10 +103,11 @@ type EnvDef = (String, Expression)
 -- TODO: Add EvalConf to EnvState?
 data EvalConf = EvalConf
   { isRepl    :: Bool
+  , nicePath  :: String
   , evalPaths :: [String]
   }
 data Environment = Environment [(EnvDef, Environment)]
-type Program = State Environment
+type Program = S.State Environment
 
 instance Semigroup Environment where
   (Environment e1) <> (Environment e2) = Environment $ e1 <> e2
@@ -73,21 +124,42 @@ listify [] = Abstraction (Abstraction (Bruijn 0))
 listify (e : es) =
   Abstraction (Application (Application (Bruijn 0) e) (listify es))
 
-encodeByte :: Bit.BitString -> Expression
-encodeByte bits = listify (map encodeBit (Bit.toList bits))
+encodeByte :: [Bool] -> Expression
+encodeByte bits = listify (map encodeBit bits)
  where
   encodeBit False = Abstraction (Abstraction (Bruijn 0))
   encodeBit True  = Abstraction (Abstraction (Bruijn 1))
 
+-- TODO: There must be a better way to do this :D
 encodeBytes :: Byte.ByteString -> Expression
-encodeBytes bytes =
-  listify (map (encodeByte . Bit.from01List . (: [])) (Byte.unpack bytes))
+encodeBytes bytes = listify $ map
+  (encodeByte . Bit.toList . Bit.bitString . Byte.pack . (: []))
+  (Byte.unpack bytes)
 
 encodeStdin :: IO Expression
 encodeStdin = do
   bytes <- Byte.getContents
   pure $ encodeBytes bytes
 
+unlistify :: Expression -> [Expression]
+unlistify (Abstraction (Abstraction (Bruijn 0))) = []
+unlistify (Abstraction (Application (Application (Bruijn 0) e) es)) =
+  e : (unlistify es)
+unlistify _ = error "invalid"
+
+decodeByte :: Expression -> [Bool]
+decodeByte (Abstraction (Abstraction (Bruijn 0))) = []
+decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 0)))) es))
+  = False : (decodeByte es)
+decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 1)))) es))
+  = True : (decodeByte es)
+decodeByte _ = error "invalid"
+
+decodeStdout :: Expression -> String
+decodeStdout e = show $ Byte.concat $ map
+  (Bit.realizeBitStringStrict . Bit.fromList . decodeByte)
+  (unlistify e)
+
 ---
 
 likeTernary :: Expression -> Bool
diff --git a/src/Parser.hs b/src/Parser.hs
index c759c76..5d62ab0 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -92,7 +92,10 @@ parseExpression = do
   pure e <?> "expression"
 
 parseEvaluate :: Parser Instruction
-parseEvaluate = Evaluate <$> parseExpression
+parseEvaluate = do
+  inp <- getInput
+  e   <- parseExpression
+  pure $ ContextualInstruction (Evaluate e) inp
 
 parseDefine :: Int -> Parser Instruction
 parseDefine lvl = do
@@ -103,7 +106,7 @@ parseDefine lvl = do
   -- TODO: Fix >1 sub-defs
   subs <-
     (try $ newline *> (many (parseBlock (lvl + 1)))) <|> (try eof >> return [])
-  pure $ Define var e subs inp
+  pure $ ContextualInstruction (Define var e subs) inp
 
 parseReplDefine :: Parser Instruction
 parseReplDefine = do
@@ -111,7 +114,7 @@ parseReplDefine = do
   var <- defIdentifier
   _   <- string " = "
   e   <- parseExpression
-  pure $ Define var e [] inp
+  pure $ ContextualInstruction (Define var e []) inp
 
 parseComment :: Parser ()
 parseComment = do
@@ -121,30 +124,34 @@ parseComment = do
 
 parseImport :: Parser Instruction
 parseImport = do
+  inp  <- getInput
   _    <- string ":import " <?> "import"
   path <- importPath
   ns   <- (try $ sc *> namespace) <|> (eof >> return "")
-  pure $ Import (path ++ ".bruijn") ns
+  pure $ ContextualInstruction (Import (path ++ ".bruijn") ns) inp
 
 parsePrint :: Parser Instruction
 parsePrint = do
-  _ <- string ":print " <?> "print"
-  e <- parseExpression
-  pure $ Evaluate e
+  inp <- getInput
+  _   <- string ":print " <?> "print"
+  e   <- parseExpression
+  pure $ ContextualInstruction (Evaluate e) inp
 
 parseTest :: Parser Instruction
 parseTest = do
-  _  <- string ":test " <?> "test"
-  e1 <- parseExpression
-  _  <- string "= " -- TODO: Disallow missing space (non-trivial)
-  e2 <- parseExpression
-  pure $ Test e1 e2
+  inp <- getInput
+  _   <- string ":test " <?> "test"
+  e1  <- parseExpression
+  _   <- string "= " -- TODO: Disallow missing space (non-trivial)
+  e2  <- parseExpression
+  pure $ ContextualInstruction (Test e1 e2) inp
 
 parseCommentBlock :: Parser Instruction
 parseCommentBlock = do
-  _ <- sepEndBy1 parseComment newline
+  inp <- getInput
+  _   <- sepEndBy1 parseComment newline
   eof
-  return Comment
+  return $ ContextualInstruction Comment inp
 
 -- TODO: Add comment/test [Instruction] parser and combine with (this) def block?
 parseDefBlock :: Int -> Parser Instruction