{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Language.Bs.Expr where

import Data.String (String)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Show
import Protolude hiding (show)
import qualified Text.PrettyPrint.Leijen.Text as PP
import Text.PrettyPrint.Leijen.Text hiding ((<$>))

type Ctx = Map Text Expr

data Env = Env {env :: Ctx, fenv :: Ctx}
  deriving (Eq)

newtype Eval a = Eval {unEval :: ReaderT Env IO a}
  deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)

data IFunc = IFunc {fn :: [Expr] -> Eval Expr}
  deriving (Typeable)

instance Eq IFunc where
  (==) _ _ = False

data Expr
  = Atom Text
  | List [Expr]
  | Numb Integer
  | Tape Text
  | IFun IFunc -- TODO: call this Kern
  | Func IFunc Env
  | Bool Bool
  | Nil
  deriving (Typeable, Eq)

instance Show Expr where
  show = T.unpack . ppexpr

data LispErrorType
  = NumArgs Integer [Expr]
  | LengthOfList Text Int
  | ExpectedList Text
  | ParseError String
  | TypeMismatch Text Expr
  | BadSpecialForm Text
  | NotFunction Expr
  | UnboundVar Text
  | Default Expr
  | ReadFileError Text
  deriving (Typeable)

data LispError = LispError Expr LispErrorType

instance Show LispErrorType where
  show = T.unpack . ppexpr

instance Show LispError where
  show = T.unpack . ppexpr

instance Exception LispErrorType

instance Exception LispError

ppexpr :: Pretty a => a -> Text
ppexpr x = PP.displayTStrict (PP.renderPretty 1.0 70 (pretty x))

--prettyList :: [Doc] -> Doc
--prettyList = encloseSep lparen rparen PP.space

instance Pretty Expr where
  pretty v =
    case v of
      Atom a ->
        textStrict a
      List ls ->
        prettyList $ fmap pretty ls
      Numb n ->
        integer n
      Tape t ->
        textStrict "\"" <> textStrict t <> textStrict "\""
      IFun _ ->
        textStrict "<internal function>"
      Func _ _ ->
        textStrict "<lambda function>"
      Bool True ->
        textStrict "#t"
      Bool False ->
        textStrict "#f"
      Nil ->
        textStrict "'()"

instance Pretty LispErrorType where
  pretty err = case err of
    NumArgs i args ->
      textStrict "number of arguments"
        <$$> textStrict "expected"
        <+> textStrict (T.pack $ show i)
        <$$> textStrict "received"
        <+> textStrict (T.pack $ show $ length args)
    LengthOfList txt i ->
      textStrict "length of list in:"
        <+> textStrict txt
        <$$> textStrict "length:"
        <+> textStrict (T.pack $ show i)
    ParseError txt ->
      textStrict "cannot parse expr:"
        <+> textStrict (T.pack txt)
    TypeMismatch txt expr ->
      textStrict "type mismatch:"
        <$$> textStrict txt
        <$$> pretty expr
    BadSpecialForm txt ->
      textStrict "bad special form:"
        <$$> textStrict txt
    NotFunction expr ->
      textStrict "not a function"
        <$$> pretty expr
    UnboundVar txt ->
      textStrict "unbound variable:"
        <$$> textStrict txt
    Default _ ->
      textStrict "default error"
    ReadFileError txt ->
      textStrict "error reading file:"
        <$$> textStrict txt
    ExpectedList txt ->
      textStrict "expected list:"
        <$$> textStrict txt

instance Pretty LispError where
  pretty (LispError expr typ) =
    textStrict "error evaluating:"
      <$$> indent 4 (pretty expr)
      <$$> pretty typ