{-|
Module: Main
Description: Entrypoint
Author: gatlin@niltag.net

This module sets up a simple interpreter that reads in expressions, does type
analysis, evaluates them to results or exceptions, prints, and loops.

Honestly it isn't supposed to be that thrilling.
-}

module Main where
import Control.Monad.Free (Free(..))
import Control.Comonad.Cofree (Cofree(..))
import Control.Monad.Except (throwError)
import Control.Monad.Trans (liftIO)
import Control.Monad ((>=>))
import Data.Text (pack)
import qualified Data.Map as M
import Text.Show.Unicode (uprint, ushow)

import System.Console.Haskeline
  ( runInputT
  , defaultSettings
  , getInputLine
  , outputStrLn )

import CESKM (evaluate)
import Parser (parseSexpr, Result, IResult(..))
import Syntax
  ( sexprToCbpv
  , annotate
  , SExpr(..) )
import Types

-- | Acts on a line of input from the REPL.
-- Accumulates partial results until parsing terminates definitively.
process
  :: String
  -> Maybe (Result (Free SExpr ()))
  -> IO (Maybe (Result (Free SExpr ())))
process :: String
-> Maybe (Result (Free SExpr ()))
-> IO (Maybe (Result (Free SExpr ())))
process String
line Maybe (Result (Free SExpr ()))
mK = case Maybe (Result (Free SExpr ())) -> Text -> Result (Free SExpr ())
parseSexpr Maybe (Result (Free SExpr ()))
mK (String -> Text
pack String
line) of
  Fail Text
_ [String]
_ String
error_message -> String -> IO ()
forall a. Show a => a -> IO ()
uprint String
error_message IO ()
-> IO (Maybe (Result (Free SExpr ())))
-> IO (Maybe (Result (Free SExpr ())))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Result (Free SExpr ()))
-> IO (Maybe (Result (Free SExpr ())))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Result (Free SExpr ()))
forall a. Maybe a
Nothing
  p :: Result (Free SExpr ())
p@(Partial Text -> Result (Free SExpr ())
_) -> Maybe (Result (Free SExpr ()))
-> IO (Maybe (Result (Free SExpr ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result (Free SExpr ()) -> Maybe (Result (Free SExpr ()))
forall a. a -> Maybe a
Just Result (Free SExpr ())
p)
  Done Text
_ Free SExpr ()
s_expr -> do
    Cofree Cbpv ()
exp <- (Free SExpr () -> IO (Cofree SExpr ())
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Show a) =>
Free f a -> m (Cofree f ())
annotate (Free SExpr () -> IO (Cofree SExpr ()))
-> (Cofree SExpr () -> IO (Cofree Cbpv ()))
-> Free SExpr ()
-> IO (Cofree Cbpv ())
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Free Cbpv String -> IO (Free Cbpv String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Free Cbpv String -> IO (Free Cbpv String))
-> (Cofree SExpr () -> Free Cbpv String)
-> Cofree SExpr ()
-> IO (Free Cbpv String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree SExpr () -> Free Cbpv String
sexprToCbpv (Cofree SExpr () -> IO (Free Cbpv String))
-> (Free Cbpv String -> IO (Cofree Cbpv ()))
-> Cofree SExpr ()
-> IO (Cofree Cbpv ())
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Free Cbpv String -> IO (Cofree Cbpv ())
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Show a) =>
Free f a -> m (Cofree f ())
annotate) Free SExpr ()
s_expr
    Type
ty_info <- case Frame -> Cofree Cbpv () -> Either String Type
typecheck Frame
forall a. Monoid a => a
mempty Cofree Cbpv ()
exp of
      Left String
err -> do
        String -> IO ()
forall a. Show a => a -> IO ()
uprint String
err
        Type -> IO Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> IO Type) -> Type -> IO Type
forall a b. (a -> b) -> a -> b
$ String -> Type
TCon String
""
      Right Type
ty_info -> Type -> IO Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty_info
    Type -> IO ()
forall a. Show a => a -> IO ()
uprint Type
ty_info
    case Cofree Cbpv () -> Either String (Value, [String])
evaluate Cofree Cbpv ()
exp of
      Left String
error_message -> String -> IO ()
forall a. Show a => a -> IO ()
uprint String
error_message
      Right (Value
result, [String]
logs) -> Value -> IO ()
forall a. Show a => a -> IO ()
uprint Value
result
    Maybe (Result (Free SExpr ()))
-> IO (Maybe (Result (Free SExpr ())))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Result (Free SExpr ()))
forall a. Maybe a
Nothing

main :: IO ()
IO ()
main = Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings (Maybe (Result (Free SExpr ())) -> InputT IO ()
forall {m :: * -> *}.
(MonadIO m, MonadMask m) =>
Maybe (Result (Free SExpr ())) -> InputT m ()
loop Maybe (Result (Free SExpr ()))
forall a. Maybe a
Nothing) where
  loop :: Maybe (Result (Free SExpr ())) -> InputT m ()
loop Maybe (Result (Free SExpr ()))
mK = do
    Maybe String
minput <- String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine (String
-> (Result (Free SExpr ()) -> String)
-> Maybe (Result (Free SExpr ()))
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"‽> " (String -> Result (Free SExpr ()) -> String
forall a b. a -> b -> a
const String
".. ") Maybe (Result (Free SExpr ()))
mK)
    case Maybe String
minput of
      Maybe String
Nothing -> String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn String
"Goodbye."
      Just String
input -> do
        Maybe (Result (Free SExpr ()))
res <- IO (Maybe (Result (Free SExpr ())))
-> InputT m (Maybe (Result (Free SExpr ())))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Result (Free SExpr ())))
 -> InputT m (Maybe (Result (Free SExpr ()))))
-> IO (Maybe (Result (Free SExpr ())))
-> InputT m (Maybe (Result (Free SExpr ())))
forall a b. (a -> b) -> a -> b
$ String
-> Maybe (Result (Free SExpr ()))
-> IO (Maybe (Result (Free SExpr ())))
process (String
input String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ") Maybe (Result (Free SExpr ()))
mK
        Maybe (Result (Free SExpr ())) -> InputT m ()
loop Maybe (Result (Free SExpr ()))
res