Refactored Helper.hs

1 files changed, 3 insertions, 409 deletions

diff --git a/src/Helper.hs b/src/Helper.hs
index 5f5adf6..c6b466b 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -1,30 +1,15 @@
 -- MIT License, Copyright (c) 2022 Marvin Borner
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 module Helper where
 
 import           Control.DeepSeq                ( NFData )
 import qualified Control.Monad.State           as S
 import           Data.Array
-import qualified Data.BitString                as Bit
-import qualified Data.ByteString.Lazy          as Byte
-import qualified Data.ByteString.Lazy.Char8    as C
-import           Data.Char
-import           Data.List
+import           Data.List                      ( intercalate )
 import qualified Data.Map                      as M
-import           Data.Maybe                     ( fromMaybe
-                                                , isNothing
-                                                )
 import           GHC.Generics                   ( Generic )
-import           GHC.Real                       ( denominator
-                                                , numerator
-                                                )
-import           Numeric                        ( showFFloatAlt )
-import           Text.Megaparsec
 
 invalidProgramState :: a
 invalidProgramState = error "invalid program state"
@@ -46,80 +31,6 @@ printContext (Context inp path) = p $ lines inp
   p (l : ls) =
     p [l] <> nearText <> intercalate "\n" (map ("  | " ++) $ take 3 ls) <> "\n"
 
-errPrefix :: String
-errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m "
-
-okPrefix :: String
-okPrefix = "\ESC[102m\ESC[30m OK \ESC[0m "
-
-data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | PassedTest Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String | OptimizerError String
-
-instance Show Error where
-  show (ContextualError err ctx) = show err <> "\n" <> printContext ctx
-  show (SuggestSolution err sol) =
-    show err <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant " <> sol
-  show (SyntaxError err) =
-    errPrefix <> "invalid syntax\n\ESC[105m\ESC[30mnear\ESC[0m " <> err
-  show (UndefinedIdentifier ident) =
-    errPrefix <> "undefined identifier " <> show ident
-  show (UnmatchedMixfix ks ms) =
-    errPrefix
-      <> "couldn't find matching mixfix for "
-      <> intercalate "" (map show ks)
-      <> "\n\ESC[105m\ESC[30mnear\ESC[0m "
-      <> unwords (map show ms)
-  show (InvalidIndex err) = errPrefix <> "invalid index " <> show err
-  show (PassedTest exp1 exp2) =
-    okPrefix <> "test passed: " <> show exp1 <> " = " <> show exp2
-  show (FailedTest exp1 exp2 red1 red2) =
-    errPrefix
-      <> "test failed: "
-      <> show exp1
-      <> " = "
-      <> show exp2
-      <> "\n      reduced to "
-      <> show red1
-      <> " = "
-      <> show red2
-  show (ImportError    path) = errPrefix <> "invalid import " <> show path
-  show (OptimizerError msg ) = errPrefix <> "optimizer failed: " <> msg
-
-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 MixfixIdentifierKind = MixfixSome String | MixfixNone
   deriving (Ord, Eq, Generic, NFData)
 
@@ -185,30 +96,8 @@ data Command = Input String | Watch String | Import String String | Test Express
 data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
   deriving (Show)
 
-data ArgMode = ArgEval | ArgEvalBblc | ArgEvalBlc | ArgDumpBblc | ArgDumpBlc
-
-data Args = Args
-  { _argMode     :: ArgMode
-  , _argNoTests  :: Bool
-  , _argVerbose  :: Bool
-  , _argOptimize :: Bool
-  , _argToTarget :: String
-  , _argReducer  :: String
-  , _argPath     :: Maybe String
-  }
-
-data EvalConf = EvalConf
-  { _isRepl    :: Bool
-  , _isVerbose :: Bool
-  , _evalTests :: Bool
-  , _optimize  :: Bool
-  , _nicePath  :: String
-  , _path      :: String
-  , _evalPaths :: [String]
-  , _toTarget  :: String
-  , _reducer   :: String
-  , _hasArg    :: Bool
-  }
+defaultFlags :: ExpFlags
+defaultFlags = ExpFlags { _isImported = False }
 
 newtype ExpFlags = ExpFlags
   { _isImported :: Bool
@@ -231,83 +120,6 @@ newtype EnvCache = EnvCache
 
 type EvalState = S.State Environment
 
-argsToConf :: Args -> EvalConf
-argsToConf args = EvalConf { _isRepl    = isNothing $ _argPath args
-                           , _isVerbose = _argVerbose args
-                           , _evalTests = not $ _argNoTests args
-                           , _optimize  = _argOptimize args
-                           , _path      = path
-                           , _nicePath  = path
-                           , _evalPaths = []
-                           , _toTarget  = _argToTarget args
-                           , _reducer   = _argReducer args
-                           , _hasArg    = False
-                           }
-  where path = fromMaybe "" (_argPath args)
-
-defaultFlags :: ExpFlags
-defaultFlags = ExpFlags { _isImported = False }
-
----
-
-listify :: [Expression] -> Expression
-listify [] = Abstraction (Abstraction (Bruijn 0))
-listify (e : es) =
-  Abstraction (Application (Application (Bruijn 0) e) (listify es))
-
-binarify :: [Expression] -> Expression
-binarify = foldr Application (Bruijn 2)
-
-encodeByte :: [Bool] -> Expression
-encodeByte bits = Abstraction $ Abstraction $ Abstraction $ binarify
-  (map encodeBit bits)
- where
-  encodeBit False = Bruijn 0
-  encodeBit True  = Bruijn 1
-
--- TODO: There must be a better way to do this :D
-encodeBytes :: Byte.ByteString -> Expression
-encodeBytes bytes = listify $ map
-  (encodeByte . Bit.toList . Bit.bitStringLazy . Byte.pack . (: []))
-  (Byte.unpack bytes)
-
-stringToExpression :: String -> Expression
-stringToExpression = encodeBytes . C.pack
-
-charToExpression :: Char -> Expression
-charToExpression ch = encodeByte $ Bit.toList $ Bit.bitStringLazy $ C.pack [ch]
-
-encodeStdin :: IO Expression
-encodeStdin = encodeBytes <$> Byte.getContents
-
-unlistify :: Expression -> Maybe [Expression]
-unlistify (Abstraction (Abstraction (Bruijn 0))) = Just []
-unlistify (Abstraction (Application (Application (Bruijn 0) e) es)) =
-  (:) <$> Just e <*> unlistify es
-unlistify _ = Nothing
-
-unpairify :: Expression -> Maybe [Expression]
-unpairify (Abstraction (Application (Application (Bruijn 0) e1) e2)) =
-  Just (e1 : [e2])
-unpairify _ = Nothing
-
-decodeByte :: Expression -> Maybe [Bool]
-decodeByte (Abstraction (Abstraction (Abstraction es))) = decodeByte es
-decodeByte (Application (Bruijn 0) es) = (:) <$> Just False <*> decodeByte es
-decodeByte (Application (Bruijn 1) es) = (:) <$> Just True <*> decodeByte es
-decodeByte (Bruijn 2                 ) = Just []
-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.realizeBitStringLazy $ Bit.fromList b
-      Nothing -> Byte.empty
-    )
-    u
-
 ---
 
 -- from reddit u/cgibbard
@@ -335,221 +147,3 @@ matchingFunctions e (Environment env) =
   intercalate ", " $ map (functionName . fst) $ M.toList $ M.filter
     (\EnvDef { _exp = e' } -> e == e')
     env
-
--- TODO: Show binary as char if in ascii range (=> + humanify strings)
--- TODO: Show list as pair if not ending with empty
-maybeHumanifyExpression :: Expression -> Maybe String
-maybeHumanifyExpression e =
-  unaryToDecimal e
-    <|> binaryToChar e
-    <|> binaryToString e
-    <|> ternaryToString e
-    <|> rationalToString e
-    <|> realToString e
-    <|> complexToString e
-    <|> humanifyString e
-    <|> humanifyList e
-    <|> humanifyPair e
-    <|> humanifyMeta e
-
-humanifyExpression :: Expression -> String
-humanifyExpression e = fromMaybe "" (maybeHumanifyExpression e)
-
-humanifyMeta :: Expression -> Maybe String
-humanifyMeta e = ("`" <>) <$> go e
- where
-  go (Abstraction (Abstraction (Abstraction (Application (Bruijn 0) t)))) =
-    go t >>= (\a -> pure $ "[" <> a <> "]")
-  go (Abstraction (Abstraction (Abstraction (Application (Application (Bruijn 1) a) b))))
-    = go a >>= \l -> go b >>= \r -> pure $ "(" <> l <> " " <> r <> ")"
-  go (Abstraction (Abstraction (Abstraction (Application (Bruijn 2) n)))) =
-    fmap show (unaryToDecimal' n)
-  go _ = Nothing
-
-humanifyList :: Expression -> Maybe String
-humanifyList e = do
-  es <- unlistify e
-  let conv x = fromMaybe (show x) (maybeHumanifyExpression x)
-      m = map conv es
-  pure $ "{" <> intercalate ", " m <> "}"
-
-humanifyString :: Expression -> Maybe String
-humanifyString e = do
-  es  <- unlistify e
-  str <- mapM binaryToChar' es
-  pure $ "\"" <> str <> "\""
-
-humanifyPair :: Expression -> Maybe String
-humanifyPair e = do
-  es <- unpairify e
-  let conv x = fromMaybe (show x) (maybeHumanifyExpression x)
-      m = map conv es
-  pure $ "<" <> intercalate " : " m <> ">"
-
----
-
-floatToRational :: Rational -> Expression
-floatToRational f = Abstraction
-  (Application (Application (Bruijn 0) (decimalToTernary p))
-               (decimalToTernary $ q - 1)
-  )
- where
-  p = numerator f
-  q = denominator f
-
-floatToReal :: Rational -> Expression
-floatToReal = Abstraction . floatToRational
-
-floatToComplex :: Rational -> Rational -> Expression
-floatToComplex r i = Abstraction $ Abstraction $ Application
-  (Application (Bruijn 0) (Application (floatToReal r) (Bruijn 1)))
-  (Application (floatToReal i) (Bruijn 1))
-
--- 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 (1 3)]]]] -5=T11=[[[[1 (1 (2 3))]]]]
-decimalToTernary :: Integer -> Expression
-decimalToTernary n =
-  Abstraction $ Abstraction $ Abstraction $ Abstraction $ gen n
- where
-  gen 0 = Bruijn 3
-  gen n' =
-    Application (Bruijn $ fromIntegral $ mod n' 3) (gen $ div (n' + 1) 3)
-
--- Decimal to binary encoding
-decimalToBinary :: Integer -> Expression
-decimalToBinary n | n < 0     = decimalToBinary 0
-                  | otherwise = Abstraction $ Abstraction $ Abstraction $ gen n
- where
-  gen 0  = Bruijn 2
-  gen n' = Application (Bruijn $ fromIntegral $ mod n' 2) (gen $ div n' 2)
-
--- Decimal to unary (church) encoding
-decimalToUnary :: Integer -> Expression
-decimalToUnary n | n < 0     = decimalToUnary 0
-                 | otherwise = Abstraction $ Abstraction $ gen n
- where
-  gen 0  = Bruijn 0
-  gen n' = Application (Bruijn 1) (gen (n' - 1))
-
--- Decimal to de Bruijn encoding
-decimalToDeBruijn :: Integer -> Expression
-decimalToDeBruijn n | n < 0     = decimalToDeBruijn 0
-                    | otherwise = gen n
- where
-  gen 0  = Abstraction $ Bruijn $ fromInteger n
-  gen n' = Abstraction $ gen (n' - 1)
-
-unaryToDecimal :: Expression -> Maybe String
-unaryToDecimal e = (<> "u") . show <$> unaryToDecimal' e
-
-unaryToDecimal' :: Expression -> Maybe Integer
-unaryToDecimal' e = do
-  res <- resolve e
-  return (sum res :: Integer)
- where
-  multiplier (Bruijn 1) = Just 1
-  multiplier _          = Nothing
-  resolve' (Bruijn 0) = Just []
-  resolve' (Application x@(Bruijn _) (Bruijn 0)) =
-    (:) <$> multiplier x <*> Just []
-  resolve' (Application x@(Bruijn _) xs@(Application _ _)) =
-    (:) <$> multiplier x <*> resolve' xs
-  resolve' _ = Nothing
-  resolve (Abstraction (Abstraction n)) = resolve' n
-  resolve _                             = Nothing
-
-binaryToChar :: Expression -> Maybe String
-binaryToChar e = show <$> binaryToChar' e
-
-binaryToChar' :: Expression -> Maybe Char
-binaryToChar' e = do
-  n <- binaryToDecimal e
-  if n > 31 && n < 127 || n == 10 then Just $ chr $ fromIntegral n else Nothing
-
-binaryToString :: Expression -> Maybe String
-binaryToString e = (<> "b") . show <$> binaryToDecimal e
-
-binaryToDecimal :: Expression -> Maybe Integer
-binaryToDecimal e = do
-  res <- resolve e
-  return (sum $ zipWith (*) res (iterate (* 2) 1) :: Integer)
- where
-  multiplier (Bruijn 0) = Just 0
-  multiplier (Bruijn 1) = Just 1
-  multiplier _          = Nothing
-  resolve' (Bruijn 2) = Just []
-  resolve' (Application x@(Bruijn _) (Bruijn 2)) =
-    (:) <$> multiplier x <*> Just []
-  resolve' (Application x@(Bruijn _) xs@(Application _ _)) =
-    (:) <$> multiplier x <*> resolve' xs
-  resolve' _ = Nothing
-  resolve (Abstraction (Abstraction (Abstraction n))) = resolve' n
-  resolve _ = Nothing
-
-ternaryToString :: Expression -> Maybe String
-ternaryToString e = (<> "t") . show <$> ternaryToDecimal e
-
-ternaryToDecimal :: Expression -> Maybe Integer
-ternaryToDecimal e = do
-  res <- resolve e
-  return (sum $ zipWith (*) res (iterate (* 3) 1) :: Integer)
- where
-  multiplier (Bruijn 0) = Just 0
-  multiplier (Bruijn 1) = Just 1
-  multiplier (Bruijn 2) = Just (-1)
-  multiplier _          = Nothing
-  resolve' (Bruijn 3) = Just []
-  resolve' (Application x@(Bruijn _) (Bruijn 3)) =
-    (:) <$> multiplier x <*> Just []
-  resolve' (Application x@(Bruijn _) xs@(Application _ _)) =
-    (:) <$> multiplier x <*> resolve' xs
-  resolve' _ = Nothing
-  resolve (Abstraction (Abstraction (Abstraction (Abstraction n)))) =
-    resolve' n
-  resolve _ = Nothing
-
-rationalToString :: Expression -> Maybe String
-rationalToString (Abstraction (Application (Application (Bruijn 0) a) b)) = do
-  n <- ternaryToDecimal a
-  d <- ternaryToDecimal b
-  Just
-    $  show n
-    <> "/"
-    <> show (d + 1)
-    <> " (approx. "
-    <> showFFloatAlt (Just 8)
-                     (fromIntegral n / fromIntegral (d + 1) :: Double)
-                     ""
-    <> ")"
-rationalToString _ = Nothing
-
-realToString :: Expression -> Maybe String
-realToString (Abstraction e) = rationalToString e
-realToString _               = Nothing
-
-complexToString :: Expression -> Maybe String
-complexToString (Abstraction (Abstraction (Application (Application (Bruijn 0) (Abstraction (Application (Application (Bruijn 0) lr) rr))) (Abstraction (Application (Application (Bruijn 0) li) ri)))))
-  = do
-    nlr <- ternaryToDecimal lr
-    drr <- ternaryToDecimal rr
-    nli <- ternaryToDecimal li
-    dri <- ternaryToDecimal ri
-    Just
-      $  show nlr
-      <> "/"
-      <> show (drr + 1)
-      <> " + "
-      <> show nli
-      <> "/"
-      <> show (dri + 1)
-      <> "i"
-      <> " (approx. "
-      <> showFFloatAlt (Just 8)
-                       (fromIntegral nlr / fromIntegral (drr + 1) :: Double)
-                       ""
-      <> "+"
-      <> showFFloatAlt (Just 8)
-                       (fromIntegral nli / fromIntegral (dri + 1) :: Double)
-                       ""
-      <> "i)"
-complexToString _ = Nothing