{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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