interpretive-schemer/scm.hs

{-
interpretive-scheme --- Scheme interpreter inspired by a Haskell joke
Copyright © 2018 Alex Vong <alexvong1995@gmail.com>

This file is part of interpretive-scheme.

interpretive-scheme is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or (at
your option) any later version.

interpretive-scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with interpretive-scheme.  If not, see <http://www.gnu.org/licenses/>.
-}

module Main where
import Prelude hiding (error,
                       exp,
                       fail,
                       getLine,
                       null,
                       pred,
                       print,
                       putStr,
                       putStrLn,
                       read,
                       readFile,
                       reverse,
                       seq)
import qualified Prelude as P (getLine, putStr, putStrLn, readFile)
import Data.Functor (($>))
import qualified Control.Applicative as CA (liftA2)
import Control.Monad (join)
import qualified System.IO as SI (isEOF)
import System.Directory (Permissions, readable)
import System.Directory as SD (doesFileExist, getPermissions)
import qualified Data.IORef as DI
import Text.Parsec hiding (Error, ParseError, newline, noneOf, oneOf)
import qualified Text.Parsec as TP (ParseError, noneOf, oneOf)
import Text.Parsec.String

type IO'Ref = DI.IORef
type Parse'Error = TP.ParseError

data SCM = Bool Bool
         | Integer Integer
         | String String
         | Identifier String

         | Nil
         | Pair SCM SCM

         | Primitive'Procedure String (SCM -> SCM -> IO SCM)
         | Compound'Procedure SCM SCM SCM

         | End'of'File

         | Binding SCM (IO'Ref SCM)

         | Empty'Frame
         | Frame SCM SCM

         | Empty'Environment
         | Environment (IO'Ref SCM) SCM

         | Error String

put'str :: String -> IO ()
put'str = P.putStr

put'str'ln :: String -> IO ()
put'str'ln = P.putStrLn

get'line :: IO String
get'line = P.getLine

read'file :: String -> IO String
read'file = P.readFile

is'eof :: IO Bool
is'eof = SI.isEOF

does'file'exist :: String -> IO Bool
does'file'exist = SD.doesFileExist

get'permissions :: String -> IO Permissions
get'permissions = SD.getPermissions

new'io'ref :: a -> IO (IO'Ref a)
new'io'ref = DI.newIORef

read'io'ref :: IO'Ref a -> IO a
read'io'ref = DI.readIORef

write'io'ref :: IO'Ref a -> a -> IO ()
write'io'ref = DI.writeIORef

modify'io'ref ::IO'Ref a -> (a -> a) -> IO ()
modify'io'ref = DI.modifyIORef

lift'a2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
lift'a2 = CA.liftA2

none'of :: String -> Parser Char
none'of = TP.noneOf

one'of :: String -> Parser Char
one'of = TP.oneOf

(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) = lift'a2 (:)

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.).(.)

(..:) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
(..:) = (.).(.).(.)

put'ln :: IO ()
put'ln = put'str'ln ""

put'ln'str'ln :: String -> IO ()
put'ln'str'ln str = put'ln *> put'str'ln str

is'file'readable :: String -> IO Bool
is'file'readable str = readable <$> get'permissions str

skip'spaces :: Parser ()
skip'spaces = spaces

skip'eof :: Parser ()
skip'eof = skip'spaces *> eof

read'bool :: Parser SCM
read'bool = char '#' *>
            ((char 't' $> Bool True) <|>
             (char 'f' $> Bool False))

read'0'to'9 :: Parser Integer
read'0'to'9 = (char '0' $> 0) <|>
              (char '1' $> 1) <|>
              (char '2' $> 2) <|>
              (char '3' $> 3) <|>
              (char '4' $> 4) <|>
              (char '5' $> 5) <|>
              (char '6' $> 6) <|>
              (char '7' $> 7) <|>
              (char '8' $> 8) <|>
              (char '9' $> 9)

read'integer'aps :: Integer -> Parser Integer
read'integer'aps accum = (((+ (accum * 10)) <$> read'0'to'9) >>=
                           read'integer'aps) <|>
                         pure accum

read'integer :: Parser SCM
read'integer = read'0'to'9 >>= fmap Integer . read'integer'aps

read'escape'sequence :: Parser Char
read'escape'sequence = char '\\' *>
                       (char '"' <|> char '\\')

read'string :: Parser SCM
read'string = char '"' *>
              (String <$> many (none'of "\"\\" <|> read'escape'sequence)) <*
              char '"'

read'letter :: Parser Char
read'letter = letter

read'special'initial :: Parser Char
read'special'initial = one'of "!$%&*/:<=>?^_~"

read'initial :: Parser Char
read'initial = read'letter <|> read'special'initial

read'digit :: Parser Char
read'digit = digit

read'special'subsequent :: Parser Char
read'special'subsequent = one'of "+-.@"

read'subsequent :: Parser Char
read'subsequent = read'initial <|> read'digit <|> read'special'subsequent

read'peculiar'identifier :: Parser String
read'peculiar'identifier = string "+" <|> string "-" <|> string "..."

read'identifier :: Parser SCM
read'identifier = Identifier <$>
                  ((read'initial <:> many read'subsequent) <|>
                   read'peculiar'identifier)

read'atom :: Parser SCM
read'atom = read'bool <|> read'integer <|> read'string <|> read'identifier

read'list'aps :: SCM -> Parser SCM
read'list'aps accum = skip'spaces >>
                      ((char ')' $> accum) <|>
                       ((Pair <$> read'scm <*> pure accum) >>= read'list'aps))

read'list :: Parser SCM
read'list = read'list'aps Nil

make'quote :: SCM -> SCM
make'quote text'of'quotation = Pair (Identifier "quote") text'of'quotation

read'quoted'scm :: Parser SCM
read'quoted'scm = string "'" *>
                  (make'quote <$> (Pair <$> read'scm <*> pure Nil))

lookup'first'error :: SCM -> Maybe SCM
lookup'first'error args =
  case args of
    Nil -> Nothing
    Error _ -> Just $ args
    Pair (Error str) _ -> Just $ Error str
    Pair _ rest -> lookup'first'error rest
    _ -> Just $ Error $ "Not a list: LOOKUP-FIRST-ERROR " ++ print'scm args

error :: String -> SCM -> SCM
error str args =
  case args of
    Nil -> Error str
    Error _ -> args
    Pair _ _ ->
      case lookup'first'error args of
        Nothing -> Error $ print'pair'aps str args
        Just scm -> case scm of
                      Error _ -> scm
                      _ -> Error $ "Not an error: ERROR " ++ print'scm args
    _ -> Error $ "Not a list: ERROR " ++ print'scm args

fail :: String -> SCM -> SCM
fail str val = error str (Pair val Nil)

reverse'aps :: SCM -> SCM -> SCM
reverse'aps accum ls = case ls of
                         Nil -> accum
                         Pair first rest -> reverse'aps (Pair first accum) rest
                         _ -> fail "Not a list: REVERSE-APS" ls

reverse :: SCM -> SCM
reverse = reverse'aps Nil

read'scm :: Parser SCM
read'scm = skip'spaces *>
           (read'atom <|>
            read'quoted'scm <|>
            (char '(' *> (reverse <$> read'list)))

read'from'string :: String -> SCM
read'from'string str = case parse (read'scm <* skip'eof) "scm" str of
                         Left err -> Error $ show err
                         Right val -> val

wrap'begin :: String -> String
wrap'begin str = "(begin" ++ str ++ ")"

read'from'file :: SCM -> IO SCM
read'from'file scm =
  case scm of
    String str ->
      does'file'exist str >>=
      \pred -> if pred
               then is'file'readable str >>=
                    \pred' ->
                      if pred'
                      then read'from'string . wrap'begin <$> read'file str
                      else pure $ fail "Not readable: READ-FROM-FILE" scm
               else pure $ fail "Not a file: READ-FROM-FILE" scm
    _ -> pure $ fail "Not a string: READ-FROM-FILE" scm

read :: IO SCM
read = is'eof >>=
       \pred -> if pred
                then pure End'of'File
                else read'from'string <$> get'line

list'of'values'aps :: SCM -> SCM -> SCM -> SCM -> IO SCM
list'of'values'aps exps global'env env accum =
  case exps of
    Nil -> pure $ accum
    Pair first rest -> (Pair <$> eval first global'env env <*> pure accum) >>=
                       list'of'values'aps rest global'env env
    _ -> pure $ fail "Not a list: LIST-OF-VALUES-APS" exps

list'of'values :: SCM -> SCM -> SCM -> IO SCM
list'of'values exps global'env env =
  reverse <$> list'of'values'aps exps global'env env Nil

scan'variable :: SCM -> SCM -> SCM -> Maybe SCM
scan'variable var val frame =
  case frame of
    Empty'Frame -> Nothing
    Frame (Binding (Identifier str) val') first'enclosing'frame ->
      case var of
        Identifier str' -> if str == str'
                           then Just $ Binding (Identifier str) val'
                           else scan'variable var val first'enclosing'frame
        _ -> Just $ fail "Not an identifier: SCAN-VARIABLE" var
    _ -> Just $ fail "Not a frame: SCAN-VARIABLE" frame

add'binding'to'first'frame :: SCM -> SCM -> SCM -> IO SCM
add'binding'to'first'frame var val env =
  case env of
    Environment first'frame _ ->
      ((Frame <$>
        (Binding <$> pure var <*> new'io'ref val) <*>
        read'io'ref first'frame) >>=
       write'io'ref first'frame) $>
      Nil
    Empty'Environment ->
      pure $ fail "Empty environment: ADD-BINDING-TO-FIRST-FRAME" env
    _ -> pure $ fail "Not an environment: ADD-BINDING-TO-FIRST-FRAME" env

define'variable :: SCM -> SCM -> SCM -> IO SCM
define'variable var val env =
  case env of
    Environment first'frame _ ->
      read'io'ref first'frame >>=
      \frame -> case scan'variable var val frame of
                  Nothing -> add'binding'to'first'frame var val env
                  Just (Binding _ val') -> write'io'ref val' val $> Nil
                  Just scm -> pure $ fail "Not a binding: DEFINE-VARIABLE" scm
    Empty'Environment ->
      pure $ fail "Empty environment: DEFINE-VARIABLE" env
    _ -> pure $ fail "Not an environment: DEFINE-VARIABLE" env

eval :: SCM -> SCM -> SCM -> IO SCM
eval exp global'env env =
  case env of
    Environment _ _ ->
      case exp of
        Bool _ -> pure exp
        Integer _ -> pure exp
        String _ -> pure exp
        Identifier _ -> lookup'variable'value exp env
        Pair (Identifier "quote") (Pair text'of'quotation Nil) ->
          pure text'of'quotation
        Pair (Identifier "define") definition ->
          eval'definition
          (definition'variable definition)
          (definition'value definition)
          global'env
          env
        (Pair
         (Identifier "if")
         (Pair predicate (Pair consequent (Pair alternative Nil)))) ->
          eval'if predicate consequent alternative global'env env
        Pair (Identifier "lambda") (Pair parameters body) ->
          pure $ Compound'Procedure parameters body env
        Pair (Identifier "begin") actions ->
          eval'sequence actions global'env env
        Pair (Identifier "cond") clauses ->
          eval (cond'to'if clauses) global'env env
        Pair (Identifier "and") clauses -> eval'and clauses global'env env
        Pair (Identifier "or") clauses -> eval'or clauses global'env env
        Pair (Identifier "let") (Pair bindings body) ->
          eval (let'to'combination bindings body) global'env env
        Pair (Identifier "let*") (Pair bindings body) ->
          eval (let'star'to'nested'lets bindings body) global'env env
        Pair operator operands ->
          join (apply <$>
                eval operator global'env env <*>
                list'of'values operands global'env env <*>
                pure global'env)
        _ -> pure $ fail "Unknown expression type: EVAL" exp
    _ -> pure $ fail "Not an environment: EVAL" env

definition'variable :: SCM -> SCM
definition'variable exp =
  case exp of
    Pair (Identifier str) _ -> Identifier str
    Pair (Pair first _) _ -> first
    _ -> fail "Unknown expression type: DEFINITION-VARIABLE" exp

make'lambda :: SCM -> SCM -> SCM
make'lambda parameters body =
  Pair (Identifier "lambda") (Pair parameters body)

definition'value :: SCM -> SCM
definition'value exp =
  case exp of
    Pair (Identifier _) (Pair value Nil) -> value
    Pair (Pair _ parameters) body -> make'lambda parameters body
    _ -> fail "Unknown expression type: DEFINITION-VALUE" exp

eval'definition :: SCM -> SCM -> SCM -> SCM -> IO SCM
eval'definition variable value global'env env =
  eval value global'env env >>=
  \scm -> case scm of
            Error _ -> pure scm
            _ -> define'variable variable scm env

eval'if :: SCM -> SCM -> SCM -> SCM -> SCM -> IO SCM
eval'if predicate consequent alternative global'env env =
  eval predicate global'env env >>=
  \pred -> case pred of
             Error _ -> pure pred
             Bool False -> eval alternative global'env env
             _ -> eval consequent global'env env

eval'sequence :: SCM -> SCM -> SCM -> IO SCM
eval'sequence exps global'env env =
  case exps of
    Nil -> pure Nil
    Pair exp Nil -> eval exp global'env env
    Pair first'exp rest'exps ->
      eval first'exp global'env env >>=
      \scm -> case scm of
                Error str -> pure $ Error str
                _ -> eval'sequence rest'exps global'env env
    _ -> pure $ fail "Not a list: EVAL-SEQUENCE" exps

make'if :: SCM -> SCM -> SCM -> SCM
make'if predicate consequent alternative =
  Pair
  (Identifier "if")
  (Pair predicate (Pair consequent (Pair alternative Nil)))

make'begin :: SCM -> SCM
make'begin seq = Pair (Identifier "begin") seq

cond'to'if :: SCM -> SCM
cond'to'if exp =
  case exp of
    Nil -> Pair (Identifier "quote") (Pair Nil Nil)
    Pair (Pair (Identifier "else") actions) Nil -> make'begin actions
    Pair (Pair (Identifier "else") _) _ ->
      fail "ELSE clause isn't last: COND->IF" exp
    Pair (Pair predicate actions) rest ->
      make'if predicate (make'begin actions) (cond'to'if rest)
    _ -> fail "Not a list: COND->IF" exp

eval'and :: SCM -> SCM -> SCM -> IO SCM
eval'and clauses global'env env =
  case clauses of
    Nil -> pure $ Bool True
    Pair scm Nil -> eval scm global'env env
    Pair first rest -> eval first global'env env >>=
                       \pred -> case pred of
                                  Error _ -> pure pred
                                  Bool False -> pure $ Bool False
                                  _ -> eval'and rest global'env env
    _ -> pure $ fail "Not a list: EVAL-AND" clauses

eval'or :: SCM -> SCM -> SCM -> IO SCM
eval'or clauses global'env env =
  case clauses of
    Nil -> pure $ Bool False
    Pair scm Nil -> eval scm global'env env
    Pair first rest -> eval first global'env env >>=
                       \pred -> case pred of
                                  Bool False -> eval'or rest global'env env
                                  _ -> pure pred
    _ -> pure $ fail "Not a list: EVAL-OR" clauses

map'first'aps :: SCM -> SCM -> SCM
map'first'aps accum ls =
  case ls of
    Nil -> accum
    Pair (Pair first _) rest -> map'first'aps (Pair first accum) rest
    Pair scm _ -> fail "Not a list with length >= 1: MAP-FIRST-APS" scm
    _ -> fail "Not a list: MAP-FIRST-APS" ls

map'first :: SCM -> SCM
map'first = reverse . map'first'aps Nil

map'second'aps :: SCM -> SCM -> SCM
map'second'aps accum ls =
  case ls of
    Nil -> accum
    Pair (Pair _  (Pair second _)) rest ->
      map'second'aps (Pair second accum) rest
    Pair scm _ -> fail "Not a list with length >= 2: MAP-SECOND-APS" scm
    _ -> fail "Not a list: MAP-SECOND-APS" ls

map'second :: SCM -> SCM
map'second = reverse . map'second'aps Nil

let'to'combination :: SCM -> SCM -> SCM
let'to'combination bindings body =
  Pair (make'lambda (map'first bindings) body) (map'second bindings)

make'let :: SCM -> SCM -> SCM
make'let bindings body = Pair (Identifier "let") (Pair bindings body)

let'star'to'nested'lets :: SCM -> SCM -> SCM
let'star'to'nested'lets bindings body =
  case bindings of
    Nil -> make'let Nil body
    Pair first rest ->
      make'let (Pair first Nil) (Pair (let'star'to'nested'lets rest body) Nil)
    _ -> fail "Not a list: LET*->NESTED-LETS" bindings

make'frame'aps :: SCM -> SCM -> SCM -> IO SCM
make'frame'aps vars vals accum =
  case vars of
    Nil ->
      case vals of
        Nil -> pure accum
        Pair _ _ ->
          pure $ fail "Too many arguments supplied: MAKE-FRAME-APS" vals
        _ -> pure $ fail "Not a list: MAKE-FRAME-APS" vals
    Pair first'var rest'vars ->
      case vals of
        Pair first'val rest'vals ->
          (Frame <$>
           (Binding <$> pure first'var <*> new'io'ref first'val) <*>
           pure accum) >>=
          make'frame'aps rest'vars rest'vals
        Nil -> pure $ fail "Too few arguments supplied: MAKE-FRAME-APS" vals
        _ -> pure $ fail "Not a list: MAKE-FRAME-APS" vals
    _ -> pure $ fail "Not a list: MAKE-FRAME-APS" vars

make'frame :: SCM -> SCM -> IO SCM
make'frame vars vals = make'frame'aps vars vals Empty'Frame

extend'environment :: SCM -> SCM -> SCM -> IO SCM
extend'environment vars vals base'env =
  make'frame vars vals >>=
  \frame -> case frame of
              Error _ -> pure frame
              _ -> Environment <$> new'io'ref frame <*> pure base'env

lookup'binding'variable'value :: SCM -> SCM -> Maybe (IO SCM)
lookup'binding'variable'value var binding =
  case binding of
    Binding (Identifier str) val ->
      case var of
        Identifier str' -> if str == str'
                           then Just $ read'io'ref val
                           else Nothing
        _ -> Just $
             pure $
             fail "Not an identifier: LOOKUP-BINDING-VARIABLE-VALUE" var
    _ -> Just $
         pure $
         fail "Not a binding: LOOKUP-BINDING-VARIABLE-VALUE" binding

lookup'frame'variable'value :: SCM -> SCM -> Maybe (IO SCM)
lookup'frame'variable'value var frame =
  case frame of
    Empty'Frame -> Nothing
    Frame first'binding enclosing'frame ->
      case lookup'binding'variable'value var first'binding of
        Nothing -> lookup'frame'variable'value var enclosing'frame
        scm -> scm
    _ -> Just $ pure $ fail "Not a frame: LOOKUP-FRAME-VARIABLE-VALUE" frame

lookup'variable'value :: SCM -> SCM -> IO SCM
lookup'variable'value var env =
  case env of
    Empty'Environment ->
      pure $ fail "Unbound variable: LOOKUP-VARIABLE-VALUE" var
    Environment first'frame enclosing'environment ->
      read'io'ref first'frame >>=
      \frame -> case lookup'frame'variable'value var frame of
                  Nothing -> lookup'variable'value var enclosing'environment
                  Just scm -> scm
    _ -> pure $ fail "Not an environment: LOOKUP-VARIABLE-VALUE" env

apply :: SCM -> SCM -> SCM -> IO SCM
apply proc args global'env =
  case lookup'first'error args of
    Nothing -> case proc of
                 Primitive'Procedure _ primitive'implementation ->
                   primitive'implementation args global'env
                 Compound'Procedure parameters body env ->
                   apply'compound'procedure parameters body args global'env env
                 _ -> pure $ fail "Unknown procedure type: APPLY" proc
    Just scm -> case scm of
                  Error _ -> pure scm
                  _ -> pure $ fail "Not an error: APPLY" scm

bind'parameters :: SCM -> SCM -> SCM -> IO SCM
bind'parameters parameters args env =
  case parameters of
    Identifier _ ->
      extend'environment (Pair parameters Nil) (Pair args Nil) env
    Pair _ _ -> extend'environment parameters args env
    Nil -> extend'environment parameters args env
    _ -> pure $ fail "Unknown parameter type: BIND-PARAMETERS" parameters

apply'compound'procedure :: SCM -> SCM -> SCM -> SCM -> SCM -> IO SCM
apply'compound'procedure parameters body args global'env env =
  bind'parameters parameters args env >>=
  \env' -> case env' of
            Error _ -> pure env'
            _ -> eval'sequence body global'env env'

plus :: SCM -> SCM -> SCM
plus a b = case a of
             Integer a' -> case b of
                             Integer b' -> Integer $ a' + b'
                             _ -> fail "Not an integer: +" b
             _ -> fail "Not an integer: +" a

minus :: SCM -> SCM -> SCM
minus a b = case a of
              Integer a' -> case b of
                              Integer b' -> Integer $ a' - b'
                              _ -> fail "Not an integer: -" b
              _ -> fail "Not an integer: -" a

times :: SCM -> SCM -> SCM
times a b = case a of
              Integer a' -> case b of
                              Integer b' -> Integer $ a' * b'
                              _ -> fail "Not an integer: *" b
              _ -> fail "Not an integer: *" a

quotient :: SCM -> SCM -> SCM
quotient a b =
  case a of
    Integer a' -> case b of
                    Integer 0 -> fail "Division by zero: QUOTIENT" b
                    Integer b' -> Integer $ quot a' b'
                    _ -> fail "Not an integer: QUOTIENT" b
    _ -> fail "Not an integer: QUOTIENT" a

remainder :: SCM -> SCM -> SCM
remainder a b =
  case a of
    Integer a' -> case b of
                    Integer 0 -> fail "Division by zero: REMAINDER" b
                    Integer b' -> Integer $ rem a' b'
                    _ -> fail "Not an integer: REMAINDER" b
    _ -> fail "Not an integer: REMAINDER" a

is'integer :: SCM -> SCM
is'integer scm = case scm of
                   Integer _ -> Bool True
                   _ -> Bool False

integer'equal :: SCM -> SCM -> SCM
integer'equal a b = case a of
                      Integer a' -> case b of
                                      Integer b' -> Bool $ a' == b'
                                      _ -> fail "Not an integer: =" b
                      _ -> fail "Not an integer: =" a

less :: SCM -> SCM -> SCM
less a b = case a of
             Integer a' -> case b of
                             Integer b' -> Bool $ a' < b'
                             _ -> fail "Not an integer: <" b
             _ -> fail "Not an integer: <" a

greater :: SCM -> SCM -> SCM
greater a b = case a of
                Integer a' -> case b of
                                Integer b' -> Bool $ a' > b'
                                _ -> fail "Not an integer: >" b
                _ -> fail "Not an integer: >" a

less'or'equal :: SCM -> SCM -> SCM
less'or'equal a b = case a of
                      Integer a' -> case b of
                                      Integer b' -> Bool $ a' <= b'
                                      _ -> fail "Not an integer: <=" b
                      _ -> fail "Not an integer: <=" a

greater'or'equal :: SCM -> SCM -> SCM
greater'or'equal a b = case a of
                         Integer a' -> case b of
                                         Integer b' -> Bool $ a' >= b'
                                         _ -> fail "Not an integer: >=" b
                         _ -> fail "Not an integer: >=" a

string'is'equal :: SCM -> SCM -> SCM
string'is'equal a b = case a of
                        String a' -> case b of
                                       String b' -> Bool $ a' == b'
                                       _ -> fail "Not a string: STRING=?" b
                        _ -> fail "Not a string: STRING=?" a

string'append :: SCM -> SCM -> SCM
string'append a b = case a of
                      String a' -> case b of
                                     String b' -> String $ a' ++ b'
                                     _ -> fail "Not a string: STRING-APPEND" b
                      _ -> fail "Not a string: STRING-APPEND" a

string'length'aps :: Integer -> String -> Integer
string'length'aps accum str = case str of
                                "" -> accum
                                _:str' -> string'length'aps (accum + 1) str'

string'length :: SCM -> SCM
string'length str = case str of
                      String str' -> Integer $ string'length'aps 0 str'
                      _ -> fail "Not a string: STRING-APPEND" str

string'drop :: SCM -> SCM -> SCM
string'drop str start =
  case str of
    String str' ->
      case start of
        Integer start' ->
          if start' == 0
          then str
          else if start' > 0
               then case str' of
                      _:str'' ->
                        string'drop (String str'') (Integer (start' - 1))
                      "" -> fail "String too short: STRING-DROP" str
               else fail "Negative index: STRING-DROP" start
        _ -> fail "Not an integer: STRING-DROP" start
    _ -> fail "Not a string: STRING-DROP" str

string'reverse'aps :: String -> String -> String
string'reverse'aps accum str' = case str' of
                                  "" -> accum
                                  chr:str -> string'reverse'aps (chr:accum) str

string'reverse :: SCM -> SCM
string'reverse str = case str of
                       String str' -> String $ string'reverse'aps "" str'
                       _ -> fail "Not a string: STRING-REVERSE" str

string'drop'right :: SCM -> SCM -> SCM
string'drop'right str end =
  string'reverse (string'drop (string'reverse str) end)

substring :: SCM -> SCM -> SCM -> SCM
substring str start end =
  string'drop'right (string'drop str start) (minus (string'length str) end)

is'string :: SCM -> SCM
is'string scm = case scm of
                  String _ -> Bool True
                  _ -> Bool False

string'to'symbol :: SCM -> SCM
string'to'symbol str = case str of
                         String str' -> Identifier str'
                         _ -> fail "Not a string: STRING->SYMBOL" str

symbol'to'string :: SCM -> SCM
symbol'to'string sym = case sym of
                         Identifier str -> String str
                         _ -> fail "Not a symbol: SYMBOL->STRING" sym

is'symbol :: SCM -> SCM
is'symbol scm = case scm of
                  Identifier _ -> Bool True
                  _ -> Bool False

car :: SCM -> SCM
car scm = case scm of
            Pair first _ -> first
            _ -> fail "Not a pair: CAR" scm

cdr :: SCM -> SCM
cdr scm = case scm of
            Pair _ rest -> rest
            _ -> fail "Not a pair: CDR" scm

cons :: SCM -> SCM -> SCM
cons = Pair

is'null :: SCM -> SCM
is'null scm = case scm of
                Nil -> Bool True
                _ -> Bool False

is'pair :: SCM -> SCM
is'pair scm = case scm of
                Pair _ _ -> Bool True
                _ -> Bool False

is'boolean :: SCM -> SCM
is'boolean scm = case scm of
                   Bool _ -> Bool True
                   _ -> Bool False

is'eof'object :: SCM -> SCM
is'eof'object scm = case scm of
                      End'of'File -> Bool True
                      _ -> Bool False

eof'object :: SCM
eof'object = End'of'File

is'primitive'procedure :: SCM -> SCM
is'primitive'procedure scm = case scm of
                               Primitive'Procedure _ _ -> Bool True
                               _ -> Bool False

is'compound'procedure :: SCM -> SCM
is'compound'procedure scm = case scm of
                              Compound'Procedure _ _ _ -> Bool True
                              _ -> Bool False

is'environment :: SCM -> SCM
is'environment scm = case scm of
                       Environment _ _ -> Bool True
                       Empty'Environment -> Bool True
                       _ -> Bool False

error' :: SCM -> SCM -> SCM
error' args' _ = case args' of
                   Nil -> fail "Too few arguments supplied: ERROR" args'
                   Pair scm args -> case scm of
                                      String str -> error str args
                                      _ -> fail "Not a string: ERROR" scm
                   _ -> fail "Not a list: ERROR" args'

const'nil :: SCM -> SCM
const'nil scm = case scm of
                  Error _ -> scm
                  _ -> Nil

load :: SCM -> SCM -> IO SCM
load args global'env =
  case args of
    Pair scm Nil -> const'nil <$> join (eval <$>
                                        read'from'file scm <*>
                                        pure global'env <*>
                                        pure global'env)
    Pair _ _ -> pure $ fail "Too many arguments supplied: LOAD" args
    Nil -> pure $ fail "Too few arguments supplied: LOAD" args
    _ -> pure $ fail "Not a list: LOAD" args

interaction'environment :: SCM -> SCM -> IO SCM
interaction'environment args global'env =
  case args of
    Nil -> pure global'env
    Pair _ _ ->
      pure $ fail "Too many arguments supplied: INTERACTION-ENVIRONMENT" args
    _ -> pure $ fail "Not a list: INTERACTION-ENVIRONMENT" args

eval' :: SCM -> SCM -> IO SCM
eval' args global'env =
  case args of
    Pair exp (Pair env Nil) -> eval exp global'env env
    Pair _ _ -> pure $ fail "Too many/few arguments supplied: EVAL" args
    Nil -> pure $ fail "Too few arguments supplied: EVAL" args
    _ -> pure $ fail "Not a list: EVAL" args

apply' :: SCM -> SCM -> IO SCM
apply' args' global'env =
  case args' of
    Pair proc (Pair args Nil) -> apply proc args global'env
    Pair _ _ -> pure $ fail "Too many/few arguments supplied: APPLY" args'
    Nil -> pure $ fail "Too few arguments supplied: APPLY" args'
    _ -> pure $ fail "Not a list: APPLY" args'

write :: SCM -> IO SCM
write scm = put'str (print'scm scm) $> Nil

display :: SCM -> IO SCM
display scm = case scm of
                String str -> put'str str $> Nil
                _ -> put'str (print'scm scm) $> Nil

newline :: IO SCM
newline = put'ln $> Nil

apply'nullary'operator :: (IO SCM) -> SCM -> SCM -> IO SCM
apply'nullary'operator proc args _ =
  case args of
    Nil -> proc
    Pair _ _ ->
      pure $ fail "Too many arguments supplied: APPLY-NULLARY-OPERATOR" args
    _ -> pure $ fail "Not a list: APPLY-NULLARY-OPERATOR" args

apply'unary'operator :: (SCM -> IO SCM) -> SCM -> SCM -> IO SCM
apply'unary'operator proc args _ =
  case args of
    Pair scm Nil -> proc scm
    Pair _ _ ->
      pure $ fail "Too many arguments supplied: APPLY-UNARY-OPERATOR" args
    Nil -> pure $ fail "Too few arguments supplied: APPLY-UNARY-OPERATOR" args
    _ -> pure $ fail "Not a list: APPLY-UNARY-OPERATOR" args

apply'binary'operator :: (SCM -> SCM -> IO SCM) -> SCM -> SCM -> IO SCM
apply'binary'operator proc args _ =
  case args of
    Pair a (Pair b Nil) -> proc a b
    Pair _ _ ->
      pure $ fail "Too many/few arguments supplied: APPLY-BINARY-OPERATOR" args
    Nil -> pure $ fail "Too few arguments supplied: APPLY-BINARY-OPERATOR" args
    _ -> pure $ fail "Not a list: APPLY-BINARY-OPERATOR" args

apply'ternary'operator :: (SCM -> SCM -> SCM -> IO SCM) -> SCM -> SCM -> IO SCM
apply'ternary'operator proc args _ =
  case args of
    Pair a (Pair b (Pair c Nil)) -> proc a b c
    Pair _ _ ->
      pure $
      fail "Too many/few arguments supplied: APPLY-TERNARY-OPERATOR" args
    Nil ->
      pure $ fail "Too few arguments supplied: APPLY-TERNARY-OPERATOR" args
    _ -> pure $ fail "Not a list: APPLY-TERNARY-OPERATOR" args

primitive'procedures :: [(String, SCM -> SCM -> IO SCM)]
primitive'procedures =
  [("+", apply'binary'operator (pure .: plus)),
   ("-", apply'binary'operator (pure .: minus)),
   ("*", apply'binary'operator (pure .: times)),
   ("quotient", apply'binary'operator (pure .: quotient)),
   ("remainder", apply'binary'operator (pure .: remainder)),
   ("integer?", apply'unary'operator (pure . is'integer)),
   ("=", apply'binary'operator (pure .: integer'equal)),
   ("<", apply'binary'operator (pure .: less)),
   (">", apply'binary'operator (pure .: greater)),
   ("<=", apply'binary'operator (pure .: less'or'equal)),
   (">=", apply'binary'operator (pure .: greater'or'equal)),
   ("string=?", apply'binary'operator (pure .: string'is'equal)),
   ("string-append", apply'binary'operator (pure .: string'append)),
   ("string-length", apply'unary'operator (pure . string'length)),
   ("substring", apply'ternary'operator (pure ..: substring)),
   ("string?", apply'unary'operator (pure . is'string)),
   ("string->symbol", apply'unary'operator (pure . string'to'symbol)),
   ("symbol->string", apply'unary'operator (pure . symbol'to'string)),
   ("symbol?", apply'unary'operator (pure . is'symbol)),
   ("car", apply'unary'operator (pure . car)),
   ("cdr", apply'unary'operator (pure . cdr)),
   ("cons", apply'binary'operator (pure .: cons)),
   ("null?", apply'unary'operator (pure . is'null)),
   ("pair?", apply'unary'operator (pure . is'pair)),
   ("boolean?", apply'unary'operator (pure . is'boolean)),
   ("eof-object?", apply'unary'operator (pure . is'eof'object)),
   ("eof-object", apply'nullary'operator (pure eof'object)),
   ("primitive-procedure?", apply'unary'operator
     (pure . is'primitive'procedure)),
   ("compound-procedure?", apply'unary'operator
     (pure . is'compound'procedure)),
   ("environment?", apply'unary'operator (pure . is'environment)),
   ("error", pure .: error'),
   ("read", apply'nullary'operator read),
   ("load", load),
   ("interaction-environment", interaction'environment),
   ("eval", eval'),
   ("apply", apply'),
   ("write", apply'unary'operator write),
   ("display", apply'unary'operator display),
   ("newline", apply'nullary'operator newline)]

build'frame'aps :: [(String, SCM -> SCM -> IO SCM)] -> SCM -> IO SCM
build'frame'aps alist accum =
  case alist of
    [] -> pure accum
    (name, proc):rest -> (Frame <$>
                           (Binding <$>
                             pure (Identifier name) <*>
                             new'io'ref (Primitive'Procedure name proc)) <*>
                           pure accum) >>=
                         build'frame'aps rest

build'frame :: [(String, SCM -> SCM -> IO SCM)] -> IO SCM
build'frame alist = build'frame'aps alist Empty'Frame

initial'env :: IO SCM
initial'env = Environment <$>
              (build'frame primitive'procedures >>= new'io'ref) <*>
              pure Empty'Environment

print'positive'aps :: String -> Integer -> String
print'positive'aps accum n =
  case n of
    0 -> "0" ++ accum
    1 -> "1" ++ accum
    2 -> "2" ++ accum
    3 -> "3" ++ accum
    4 -> "4" ++ accum
    5 -> "5" ++ accum
    6 -> "6" ++ accum
    7 -> "7" ++ accum
    8 -> "8" ++ accum
    9 -> "9" ++ accum
    _ ->  print'positive'aps (print'positive'aps accum (mod n 10)) (div n 10)

print'positive :: Integer -> String
print'positive = print'positive'aps ""

print'negative :: Integer -> String
print'negative n = "(- " ++ print'positive (- n) ++ ")"

print'integer :: Integer -> String
print'integer n
  | n > 0 = print'positive n
  | n < 0 = print'negative n
  | otherwise = "0"

print'string'elements'aps :: String -> String -> String
print'string'elements'aps accum str' = case str' of
                                         "" -> accum
                                         chr:str -> print'string'elements'aps
                                                    (accum ++ case [chr] of
                                                                "\"" -> "\\\""
                                                                "\\" -> "\\\\"
                                                                str'' -> str'')
                                                    str

print'string'elements :: String -> String
print'string'elements = print'string'elements'aps ""

print'string :: String -> String
print'string str = "\"" ++ print'string'elements str ++ "\""

print'pair'aps :: String -> SCM -> String
print'pair'aps accum scm =
  case scm of
    Pair first rest -> print'pair'aps (accum ++ " " ++ print'scm first) rest
    Nil -> accum
    scm' -> accum ++ " . " ++ print'scm scm'

print'scm :: SCM -> String
print'scm scm =
  case scm of
    Bool True -> "#t"
    Bool False -> "#f"

    Integer n -> print'integer n
    String str -> print'string str
    Identifier str -> str

    Nil -> "()"
    Pair first rest -> print'pair'aps ("(" ++ print'scm first) rest ++ ")"

    Primitive'Procedure name _ -> "#[primitive-procedure " ++ name ++ "]"
    Compound'Procedure parameters _ _ ->
      "#[compound-procedure " ++ print'scm parameters ++ "]"

    End'of'File -> "#[the-end-of-file]"

    Binding _ _ -> "#[binding]"

    Empty'Frame -> "#[the-empty-frame]"
    Frame _ _ -> "#[frame]"

    Empty'Environment -> "#[the-empty-environment]"
    Environment _ _ -> "#[environment]"

    Error str -> str

prepend'semicolons'aps :: String -> String -> String
prepend'semicolons'aps accum str' = case str' of
                                      "" -> accum
                                      chr:str -> prepend'semicolons'aps
                                                 (accum ++ case [chr] of
                                                             "\n" -> "\n;;; "
                                                             str'' -> str'')
                                                 str

prepend'semicolons :: String -> String
prepend'semicolons = prepend'semicolons'aps ";;; "

print :: SCM -> IO ()
print scm = case scm of
              Error _ -> put'ln'str'ln ";;; Eval error:" *>
                         put'str'ln (prepend'semicolons (print'scm scm))
              _ -> put'ln'str'ln ";;; Eval value:" *>
                   put'str'ln (print'scm scm)

driver'loop :: SCM -> IO ()
driver'loop env =
  put'ln'str'ln ";;; Eval input:" >>
  read >>=
  \scm ->
    case scm of
      End'of'File -> put'ln'str'ln ";;; Eval morituri te salutant."
      _ -> join (eval <$> pure scm <*> pure env <*> pure env) >>= print >>
           driver'loop env

main :: IO ()
main = initial'env >>= driver'loop