{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.SmartCheck.Types
  ( SubT(..)
  , subT
  , Result(..)
  , SubTypes(..)
  , Idx(..)
  , Subst(..)
  , Replace(..)
  , errorMsg
  -- ** For constructing new instances of `SubTypes`
  , gst
  , grc
  , gtc
  , gsf
--  , gsz
  ) where

import GHC.Generics
import Data.Tree
import Data.Typeable
import Control.Applicative
import Control.Monad (ap)

-- For instances
import Data.Word
import Data.Int
import Data.Ratio
import Data.Complex

import qualified Test.QuickCheck as Q

-------------------------------------------------------------------------------

-- | Nominally, a list for value generalization indexes and existential
-- generalization.
data Replace a = Replace { unVals :: [a], unConstrs :: [a] }
  deriving (Show, Read, Eq)

--------------------------------------------------------------------------------
-- Result type
--------------------------------------------------------------------------------

-- | Possible results of iterateArb.
data Result a =
    BaseType      -- ^ Base type. Won't analyze.
  | FailedPreCond -- ^ Couldn't satisfy the precondition of a QuickCheck
                  --   property
  | FailedProp    -- ^ Failed the property---either we expect failure and it
                  --   passes or we expect to pass it and we fail.
  | Result a      -- ^ Satisfied it, with the satisfying value.
  deriving (Show, Read, Eq)

instance Functor Result where
  fmap _ BaseType      = BaseType
  fmap _ FailedPreCond = FailedPreCond
  fmap _ FailedProp    = FailedProp
  fmap f (Result a)    = Result (f a)

instance Monad Result where
  return a            = Result a
  BaseType      >>= _ = BaseType
  FailedPreCond >>= _ = FailedPreCond
  FailedProp    >>= _ = FailedProp
  Result a      >>= f = f a

instance Applicative Result where
 pure  = return
 (<*>) = ap

-------------------------------------------------------------------------------
-- Indexing
-------------------------------------------------------------------------------

-- | Index into a Tree/Forest, where level is the depth from the root and column
-- is the distance d is the dth value on the same level.  Thus, all left-most
-- nodes are in column 0.  This is a "matrix view" of tree-structured data.
data Idx = Idx { level :: Int, column :: Int }
  deriving Eq

instance Show Idx where
  show (Idx l c) = foldr1 (++) ["Idx ", show l, " ", show c]

-- | Keep or substitue a value in the tree.
data Subst = Keep | Subst
  deriving (Show, Eq, Read)

-- | Sort in order of depth first then left to right.
instance Ord Idx where
  compare (Idx l0 c0) (Idx l1 c1) | l0 < l1 = LT
                                  | l0 > l1 = GT
                                  | c0 < c1 = LT
                                  | c0 > c1 = GT
                                  | True    = EQ

-------------------------------------------------------------------------------
-- User-defined subtypes of data
-------------------------------------------------------------------------------

data SubT = forall a. (Q.Arbitrary a, SubTypes a)
          => SubT { unSubT :: a }

subT :: (Q.Arbitrary a, SubTypes a) => a -> SubT
subT = SubT

-- Would require SubT to derive Eq.
-- instance Eq SubT where
--   SubT a == SubT b = cast a == Just b

instance Show SubT where
  show (SubT t) = show t

-- | This class covers algebraic datatypes that can be transformed into Trees.
-- subTypes is the main method, placing values into trees.
--
-- for a datatype with constructors A and C,
--
-- > subTypes (A (C 0) 1)
-- > [Node {rootLabel = C 0, subForest = []}]
--
class (Q.Arbitrary a, Show a, Typeable a) => SubTypes a where
  -----------------------------------------------------------
  -- | Turns algebraic data into a forest representation.
  subTypes :: a -> Forest SubT
  default subTypes :: (Generic a, GST (Rep a))
                   => a -> Forest SubT
  subTypes = gst . from
  -----------------------------------------------------------
  -- | Base types (e.g., Int, Char) aren't analyzed.
  baseType :: a -> Bool
  baseType _ = False
  -----------------------------------------------------------
  -- | Generically replace child i in m with value s.  A total function: returns
  -- Nothing if you try to replace a child with an ill-typed child s.  (Returns
  -- Just (the original data) if your index is out of bounds).
  replaceChild :: Typeable b => a -> Forest Subst -> b -> Maybe a
  default replaceChild :: (Generic a, GST (Rep a), Typeable b)
                       => a -> Forest Subst -> b -> Maybe a
  replaceChild a forest b = fmap to $ grc (from a) forest b
  -----------------------------------------------------------
  -- | Get the string representation of the constructor.
  toConstr :: a -> String
  default toConstr :: (Generic a, GST (Rep a)) => a -> String
  toConstr = gtc . from
  -----------------------------------------------------------
  -- | showForest generically shows a value while preserving its structure (in a
  -- Tree).  Always returns either a singleton list containing the tree (a
  -- degenerate forest) or an empty list for baseTypes.  An invariant is that
  -- the shape of the tree produced by showForest is the same as the one
  -- produced by subTypes.
  showForest :: a -> Forest String
  default showForest :: (Generic a, GST (Rep a))
                     => a -> Forest String
  showForest = gsf . from
  -----------------------------------------------------------

-------------------------------------------------------------------------------
-- Generic representation
-------------------------------------------------------------------------------

class GST f where
  -- Names are abbreviations of the corresponding method names above.
  gst :: f a -> Forest SubT
  grc :: Typeable b => f a -> Forest Subst -> b -> Maybe (f a)
  gtc :: f a -> String
  gsf :: f a -> Forest String
  gsz :: f a -> Int

instance GST U1 where
  gst U1 = []
  grc _ _ _ = Nothing
  gtc U1 = ""
  gsf U1 = []
  gsz U1 = 0

instance (GST a, GST b) => GST (a :*: b) where
  gst (a :*: b) = gst a ++ gst b

  grc (a :*: b) forest c =
    case forest of
      []    -> Just (a :*: b)
      ls    -> do let (x,y) = splitAt (gsz a) ls
                  left  <- grc a x c
                  right <- grc b y c
                  return $ left :*: right

  gtc (a :*: b) = gtc a ++ gtc b
  gsf (a :*: b) = gsf a ++ gsf b
  gsz (a :*: b) = gsz a + gsz b

instance (GST a, GST b) => GST (a :+: b) where
  gst (L1 a) = gst a
  gst (R1 b) = gst b

  grc (L1 a) forest c = grc a forest c >>= return . L1
  grc (R1 a) forest c = grc a forest c >>= return . R1

  gtc (L1 a) = gtc a
  gtc (R1 a) = gtc a

  gsf (L1 a) = gsf a
  gsf (R1 a) = gsf a

  gsz (L1 a) = gsz a
  gsz (R1 a) = gsz a

-- Constructor meta-information
instance (Constructor c, GST a) => GST (M1 C c a) where
  gst (M1 a) = gst a
  grc (M1 a) forest c = grc a forest c >>= return . M1
  gtc = conName

  gsf m@(M1 a) = [ Node (conName m) (gsf a) ]

  gsz (M1 a) = gsz a

-- All the other meta-information (selector, module, etc.)
instance GST a => GST (M1 i k a) where
  gst (M1 a) = gst a
  grc (M1 a) forest c = grc a forest c >>= return . M1
  gtc (M1 a) = gtc a
  gsf (M1 a) = gsf a
  gsz (M1 a) = gsz a

instance (Show a, Q.Arbitrary a, SubTypes a, Typeable a) => GST (K1 i a) where
  gst (K1 a) = if baseType a
                 then [ Node (subT a) [] ]
                 else [ Node (subT a) (subTypes a) ]

  grc (K1 a) forest c =
    case forest of
      []                  -> Just (K1 a)
      (Node Keep  _  : _) -> Just (K1 a)
      (Node Subst [] : _) -> fmap K1 (cast c)
      (Node Subst ls : _) -> replaceChild a ls c >>= return . K1

  gtc _ = ""

  gsf (K1 a) = if baseType a then [ Node (show a) [] ] else showForest a

  gsz _ = 1

-------------------------------------------------------------------------------
-- We cover the instances supported by QuickCheck:
-- http://hackage.haskell.org/packages/archive/QuickCheck/2.4.2/doc/html/Test-QuickCheck-Arbitrary.html

instance SubTypes Bool    where baseType _    = True
instance SubTypes Char    where baseType _    = True
instance SubTypes Double  where baseType _    = True
instance SubTypes Float   where baseType _    = True
instance SubTypes Int     where baseType _    = True
instance SubTypes Integer where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Int8    where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Int16   where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Int32   where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Int64   where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Word    where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Word8   where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Word16  where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Word32  where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes Word64  where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance SubTypes ()      where baseType _    = True
instance ( Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes [a]
instance (Integral a, Q.Arbitrary a, SubTypes a, Typeable a)
  => SubTypes (Ratio a)   where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance (RealFloat a, Q.Arbitrary a, SubTypes a, Typeable a)
  => SubTypes (Complex a) where
  subTypes _    = []
  baseType _    = True
  replaceChild  = replaceChild'
  toConstr      = toConstr'
  showForest    = showForest'
instance (Q.Arbitrary a, SubTypes a, Typeable a) => SubTypes (Maybe a)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
         , Q.Arbitrary b, SubTypes b, Typeable b)
         => SubTypes (Either a b)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
         , Q.Arbitrary b, SubTypes b, Typeable b)
         => SubTypes (a, b)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
         , Q.Arbitrary b, SubTypes b, Typeable b
         , Q.Arbitrary c, SubTypes c, Typeable c)
         => SubTypes (a, b, c)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
         , Q.Arbitrary b, SubTypes b, Typeable b
         , Q.Arbitrary c, SubTypes c, Typeable c
         , Q.Arbitrary d, SubTypes d, Typeable d)
         => SubTypes (a, b, c, d)
instance ( Q.Arbitrary a, SubTypes a, Typeable a
         , Q.Arbitrary b, SubTypes b, Typeable b
         , Q.Arbitrary c, SubTypes c, Typeable c
         , Q.Arbitrary d, SubTypes d, Typeable d
         , Q.Arbitrary e, SubTypes e, Typeable e)
         => SubTypes (a, b, c, d, e)

-------------------------------------------------------------------------------
-- Helpers

-- These should never be directly called.  We provide compatible instances anyway.
toConstr' :: Show a => a -> String
toConstr' = show

replaceChild' :: (Typeable a, Typeable b)
              => a -> Forest Subst -> b -> Maybe a
replaceChild' a []                 _ = Just a
replaceChild' a (Node Keep  _ : _) _ = Just a
replaceChild' _ (Node Subst _ : _) b = cast b

showForest' :: Show a => a -> Forest String
showForest' _ = []

-------------------------------------------------------------------------------

errorMsg :: String -> a
errorMsg loc = error $ "SmartCheck error: unexpected error in " ++ loc
    ++ ".  Please file a bug report at "
    ++ "<https://github.com/leepike/SmartCheck/issues>."

-------------------------------------------------------------------------------


{-# LANGUAGE RankNTypes #-}

module Val
  ( -- * Val and support types
    Val (..), Symbol, Port(..)
  , Number (..), RealNumber (..)
  , LispErr (..), isTerminationError
  , Primitive (..)
  , Macro (..)
  , Builtin, InTail, Arity (..)

    -- * Utilities for 'Val's
  , truthy, isConstant
  , makePrimitive
  , showArity, usePluralForArity, testArity
  , symbolName, symbolAsString

    -- * Re-export Text type
  , T.Text, T.pack, T.unpack

    -- * Basic handling and construction of lists
  , getList, getListOrError, testCircularList
  , isListSH, requireList, makeMutableList, makeImmutableList
  , consSSS, makeImproperMutableList, makeImproperImmutableList

    -- * Freezing lists for evaluation
  , FrozenList (..), freezeList, lintFrozenList

    -- * Direct handling of pairs
  , carPR, cdrPR, carPS, cdrPS
  , setCarSSS, setCdrSSS, pairSH

    -- * Vectors
  , vectorSH
  , makeVector, makeByteVector

    -- * Test for immutable data
  , isImmutablePair, isImmutable

    -- * Making and working with Numbers
  , makeBignum, makeFlonum, makeRatnum
  , approxToRatnum, realInexact
  , getExactInteger, isExactZero
  , numberSH, complexSH, realSH, rationalSH, integerSH
  , implicitRealConversion, implicitNumericConversion

    -- * Showing 'Val' in IO
  , showValIO
  ) where

import Types
import EvaluationMonad
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Bits (shiftL, bit)
import Data.Complex (Complex((:+)), magnitude)
import Data.IORef (readIORef) -- for show in IO
import Data.Foldable (foldrM)
import Data.Ratio ((%), numerator, denominator)
import qualified Data.Text as T
import Data.Word (Word8)

import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import Data.Maybe (fromMaybe)
import System.Mem.StableName (makeStableName)

import GHC.Float (Floating(..))

makePrimitive :: Primitive -> Val
makePrimitive (Prim name arity func) = Primitive arity func name

-- | Is this 'Val' truthy?
truthy :: Val -> Bool
truthy (Bool False) = False
truthy _ = True

-- | Is this 'Val' an atomic constant?
isConstant :: Val -> Bool
isConstant Number{} = True
isConstant Bool{}   = True
isConstant Char{}   = True
isConstant Nil{}    = True
isConstant _        = False

-------------------------------------------------------------------------------
--
-- Pure 'Val' instances. You probably don't want to use these, but they are
-- ocassionally useful in the test suite etc. Be careful!
--
-------------------------------------------------------------------------------

-- | 'show' a 'Val'. This almost certainly isn't what you want;
-- it's a good escape hatch if you need a pure way to display a 'Val'
-- but it doesn't display unicode characters in strings properly,
-- can't display anything mutable, and loops on cyclic immutable data.
showVal :: Val -> ShowS
showVal (Symbol s) = showString $ T.unpack $ symbolName s
showVal (Number n) = shows n
showVal (String _s) = showString "<can't show mutable string>"
showVal (IString s) = shows s
showVal (Char c)   = showString "#\\" . showString (case c of
    ' '  -> "space"
    '\t' -> "tab"
    '\n' -> "newline"
    '\r' -> "carriage-return"
    _    -> [c])
showVal (Bool True) = showString "#t"
showVal (Bool False) = showString "#f"
showVal Port{} = showString "#<port>"
showVal Undefined = showString "#<undefined>"
showVal (Primitive arity _ name) = shows fakeClosure
  where
    fakeClosure = Closure fakeArgs fakeVarargs [] [] (Just name)
    (fakeArgs, fakeVarargs) = case arity of
      Exactly n     -> (replicate n "_", Nothing)
      Between lo hi -> (fakeBetween lo hi, Nothing)
      AtLeast n     -> (replicate n "_", Just "_")
    fakeBetween lo hi =
      let reqs = replicate lo "_"
          numOpts = hi - lo
          opts = replicate numOpts "[_]"
      in reqs ++ opts

showVal Continuation{} = showString "#<cont>"
showVal (Closure [] (Just varargs) _body _env name) =
      showString "#<procedure "
    . showString (symbolAsString $ fromMaybe "lambda" name)
    . showChar ' ' . showString (symbolAsString varargs)
    . showChar '>'
showVal (Closure args varargs _body _env name) =
      showString "#<procedure "
      . displayName . showChar ' '
      . showParen True (displayArgs . displayVarargs)
      . showChar '>'
  where
    displayName = showString $ symbolAsString $ fromMaybe "lambda" name
    displayArgs = showString $ unwords $ map symbolAsString args
    displayVarargs = case varargs of
        Nothing  -> id
        Just arg -> showString " . " . showString (symbolAsString arg)
showVal (PrimMacro _ _ name) = showString $ "#<macro "
                                            ++ symbolAsString name
                                            ++ ">"
showVal Pair{} = showString "<can't show mutable pair>"
showVal p@IPair{} = showParen True $ showDList $ fromList p
  where
    fromList :: Val -> ([Val], Val)
    fromList (IPair c d) =
      first (c:) $ fromList d
    fromList obj = ([], obj)

    first f (a, b) = (f a, b)

    showDList (vs, v) = unwordsList vs . case v of
      Nil -> id
      obj -> showString " . " . shows obj

showVal Vector{} = showString "<can't show mutable vector>"
showVal (IVector v) = showChar '#' . showParen True (unwordsList (V.toList v))
showVal (IByteVector v) = showString "#u8" . showParen True (showBytes (U.toList v))
  where showBytes [] = id
        showBytes [b] = shows b
        showBytes (b:bs) = shows b . showChar ' ' . showBytes bs
showVal Nil = showString "()"
showVal EOF = showString "#<eof>"
showVal (Error msg irritants) =
  showString "#<error: "
  . prefix (T.unpack msg)
  . intercalateS " " (map shows irritants)
  . showChar '>'
  where prefix "" = showString ""
        prefix s  = showString s . showChar ' '
showVal (Exception err) = showString $ "#<exception: " ++ showErr err ++ ">"

showVal (MultipleValues vs) =
    showString "#<values: "
  . unwordsList vs
  . showChar '>'

-- | This instance can't show mutable things.
instance Show Val where
    showsPrec _ v s = showVal v s

-- | Doesn't display exactness indicators and always uses base 10.
instance Show Number where
  show (Real r) = show r
  show (Complex (r :+ i)) = show r ++ sign ++ show i ++ "i"
    where sign = if i < 0 then "" else "+"

showErr :: LispErr -> String
showErr (UnboundVar message varname)
  = message ++ " unbound symbol: " ++ symbolAsString varname
showErr (EvaluateDuringInit name)
  = symbolAsString name ++ " referred to itself during initialization"
showErr (SetImmutable tyname) = "can't set immutable " ++ tyname
showErr (BadSpecialForm form) = "bad form: " ++ show form
showErr (NotFunction message func)    = message ++ ": " ++ show func
showErr (NumArgs expected found)      = "expected " ++ showArity expected
    ++ " arg" ++ (if usePluralForArity expected then "s" else "")
    ++ ", found values " ++ show found
showErr (TypeMismatch expected found) = "invalid type: expected " ++ expected
    ++ ", found " ++ show found
showErr CircularList                  = "circular list"
showErr EmptyBody                     = "attempt to define function with no body"
showErr (Parser parseErr)             = parseErr
showErr (Condition _ obj)             = show obj
showErr (Default message)             = message
showErr Quit                          = "quit invoked"

-- | This instance can't show internal values with mutable pairs and will
-- likely be removed soon instead of maintaining it. If you want to turn an
-- error into a string, you should use 'showErrIO' in Primitives.WriteLib.
instance Show LispErr where show = ("Error: " ++ ) . showErr

intercalateS :: String -> [ShowS] -> ShowS
intercalateS sep = go
  where go []     = id
        go [s]    = s
        go (s:ss) = s . showString sep . go ss

unwordsList :: [Val] -> ShowS
unwordsList = intercalateS " " . map shows

showArity :: Arity -> String
showArity (Exactly n) = show n
showArity (AtLeast n) = "at least " ++ show n
showArity (Between i j) = unwords ["between", show i, "and", show j]

usePluralForArity :: Arity -> Bool
usePluralForArity (Exactly 1) = False
usePluralForArity (AtLeast 1) = False
usePluralForArity _ = True

-- | Test an 'Arity' against the length of a list, reporting an error
-- if the arity is not satisfied.
--
-- More efficient than using 'length'.
testArity :: Arity -> [Val] -> EM ()
testArity (Exactly n0) vs0
  | n0 < 0 = panic "negative exact arity"
  | otherwise = check $ cmpLength n0 vs0
  where
    check EQ = pure ()
    check _  = throwError $ NumArgs (Exactly n0) vs0
testArity (AtLeast n0) vs0 = check $ cmpLength n0 vs0
  where
    check GT = throwError $ NumArgs (AtLeast n0) vs0
    check _  = pure ()
testArity a@(Between lo hi) vs0 = check (cmpLength lo vs0) (cmpLength hi vs0)
  where
    check GT _ = raise
    check _ LT = raise
    check _ _  = pure ()
    raise = throwError $ NumArgs a vs0

cmpLength :: Int -> [a] -> Ordering
cmpLength 0 [] = EQ
cmpLength _ [] = GT
cmpLength 0 (_:_) = LT
cmpLength n (_:vs) = cmpLength (n-1) vs

{- Note: [List Operation Efficiency]
There's some low-hanging fruit here for optimizing list operations.
Primarily, most operations end up walking the structure more than once.
'testCircularList' walks the whole list (in the event that the list is
not circular) since it terminates when it sees a cdr that isn't a Pair.
But then 'flattenFiniteList' also walks the whole list, to flatten it,
and is always called separately from 'testCircularList'. Notably,
'isListSH' currently tests, then flattens to check the ending. But then
'getList' calls 'isListSH', then flattens to get the list! So 'getList'
ends up walking the whole structure 3 times.

I think the most frequently-called function here should end up being
'freezeList'
-}

-- | Flatten a Scheme list into a Haskell list.
--
-- If the Scheme value is not a list (in the sense of 'list?')
-- then 'Nothing' is returned. Otherwise, 'Just' the contents of the
-- list are returned.
getList :: Val -> EM (Maybe [Val])
getList v = do
  b <- isListSH v
  if b
    then Just . fst <$> flattenFiniteList v
    else return Nothing

-- | 'getList', but if the object is not a list, a type error is raised
-- instead of returning 'Nothing'.
getListOrError :: Val -> EM [Val]
getListOrError v = do
  mlst <- getList v
  case mlst of
    Nothing  -> throwError $ TypeMismatch "list" v
    Just lst -> return lst

-- | Represents a (shallow copy of a) Scheme list at the Haskell level.
-- Objects inside the list can be mutated as normal but the car/cdr
-- Refs that would be needed to mutate the shape of the list itself
-- are not present. This is useful for implementing Scheme syntax;
-- for example the first thing `eval` does is freeze its input.
--
-- Invariants:
--
--  (1) The Haskell lists in FrozenLists are always finite (unchecked)
--  (2) FNotList never contains 'Nil', a 'Pair', or an 'IPair'.
--      See Note: [Freezing Nil].
data FrozenList
  = FList [Val]
  | FDottedList [Val] Val
  | FNotList Val

lintFrozenList :: FrozenList -> EM ()
lintFrozenList fl = lintAssert "FNotList contains Nil or a pair" $ pure $
  case fl of
    FNotList Nil     -> False
    FNotList Pair{}  -> False
    FNotList IPair{} -> False
    _ -> True

{- Note: [Freezing Nil]
There are multiple possible representations of any frozen list that represents
a list. True lists can be represented with either FList or FDottedList
or FNotList (where the 'Val's in the last two cases are pairs). The empty list,
'Nil', can be represented as both 'FList []' and 'FNotList Nil'.

Invariant (2) of 'FrozenList' resolve the ambiguities. All lists should be
represented as frozen lists, as expected, meaning that lists can't appear in
'FNotList'. This is perfectly sane.

However, 'Nil' is a bit of a corner case. 'Nil' is the only list that is
self-evaluating. In most cases where we freeze a list, we care more about the
fact that 'Nil' is a list than the fact that it's self-evaluating.
In fact, the only place where we _do_ care that it's self evaluating is in
'eval'! So we always freeze 'Nil' as 'FList []', and we check the special
case in 'eval'.
-}

-- | Get an immutable Haskell representation of a Scheme list.
-- This is useful for core operations like `eval`, which can evaluate
-- a Scheme list by freezing it and then evaluating the frozen list instead.
-- Attempting to freeze a circular list raises a CircularList error.
--
-- If the object is not a list, it is returned unchanged in an
-- 'FNotList'.
--
-- The 'FrozenList' is linted before it is returned, so it is not necessary
-- to immediately lint it again.
freezeList :: Val -> EM FrozenList
freezeList v = do
  requireFiniteList v
  (lst, dot) <- flattenFiniteList v
  let flist = case (lst, dot) of
        ([], Nil) -> FList []
        ([], obj) -> FNotList obj
        (xs, Nil) -> FList xs
        (xs, obj) -> FDottedList xs obj
  lintFrozenList flist
  return flist

-- | Require that a Scheme value is not a circular list.
-- Circular data structures that are not lists may or may not be detected.
-- If the value is a circular list, a CircularList error is raised.
requireFiniteList :: Val -> EM ()
requireFiniteList v = whenM (testCircularList v) (throwError CircularList)

-- | Test if a Scheme value is a circular list.
testCircularList :: Val -> EM Bool
testCircularList v = next v >>= \case
    Nothing   -> pure False
    Just node -> lift2 go (pure $ Just node) (next node)
  where
    -- Floyd's Algorithm
    go :: Maybe Val -> Maybe Val -> EM Bool
    go tortoise hare
      | Just t <- tortoise
      , Just h <- hare
      = ifM ((==) <$> liftIO (makeStableName t) <*> liftIO (makeStableName h))
            (return True)
            (lift2 go (next t) (next2 h))
      | otherwise = return False

    -- takes a val and returns the cdr if it is a pair, else Nothing
    next p@Pair{}  = Just <$> cdrPS p
    next p@IPair{} = Just <$> cdrPS p
    next _ = pure Nothing

    next2 = runMaybeT . (next' >=> next')
      where next' = MaybeT . next

    lift2 f x y = do
      xv <- x
      yv <- y
      f xv yv

-- | Flatten a _finite_ Scheme list into an init/improper tail pair.
-- A result of (init, tl) means that "(init . tl)" is an external
-- representation of the input object.
--
-- See 'freezeList', which wraps this function and further converts
-- the pair to a proper Scheme object.
flattenFiniteList :: Val -> EM ([Val], Val)
flattenFiniteList p@Pair{} = do
  hd <- carPS p
  ~(tl, dot) <- cdrPS p >>= flattenFiniteList
  return (hd:tl, dot)
flattenFiniteList p@IPair{} = do
  car <- carPS p
  cdr <- cdrPS p
  ~(tl, dot) <- flattenFiniteList cdr
  return (car:tl, dot)

flattenFiniteList other = return ([], other)

-- | Make a freshly-allocated mutable Scheme list containing
-- the given values.
makeMutableList :: [Val] -> EM Val
makeMutableList = foldrM consSSS Nil

-- | Make a freshly-allocated, mutable, improper Scheme list containing
-- the given values.
makeImproperMutableList :: [Val] -- ^ the "proper" part of the list
                        -> Val   -- ^ the improper tail
                        -> EM Val
makeImproperMutableList prop improp = foldrM consSSS improp prop

-- | Make a freshly-allocated _immutable_ Scheme list containing
-- the given values.
--
-- Unless you're working on the parser, you want 'makeMutableList'
-- instead of this.
makeImmutableList :: [Val] -> Val
makeImmutableList = foldr immutableCons Nil

-- | Make a freshly allocated, immutable, improper Scheme list.
--
-- You probably don't actually want this function.
-- See 'makeImproperMutableList' and 'makeImmutableList'.
makeImproperImmutableList :: [Val] -> Val -> Val
makeImproperImmutableList prop improp = foldr immutableCons improp prop

-- | Primitive list? operation.
--
-- See page 42 of the r7rs report:
-- "By definition, all lists have finite length
-- and are terminated by the empty list."
isListSH :: Val -> EM Bool
isListSH v = callCC $ \exit -> do
  whenM (testCircularList v) $ exit False
  (_, tl) <- flattenFiniteList v
  case tl of
    Nil -> return True
    _   -> return False

-- | Primitive cons operation.
consSSS :: Val -> Val -> EM Val
consSSS car cdr = Pair <$> newRef car <*> newRef cdr

-- | Primitive cons operation for immutable lists.
--
-- In an ideal world, this function would perform linting to check that
-- the car and cdr are immutable objects. Unfortunately, that would require
-- access to the repl 'Opts' in the parser (the only place this function
-- should be used) which are currently (12/10/2020) not available. As the
-- language grows, they will probably become available eventually, at which
-- point this unfortunate issue should be patched.
--
-- Unless you're working on the parser, you really shouldn't use this function!
immutableCons :: Val -> Val -> Val
immutableCons = IPair

carPR :: Val -> Ref Val
carPR (Pair c _d) = c
carPR _ = panic "carPR: not a mutable pair"

cdrPR :: Val -> Ref Val
cdrPR (Pair _c d) = d
cdrPR _ = panic "cdrPR: not a mutable pair"

carPS :: MonadIO m => Val -> m Val
carPS p@Pair{} = liftIO $ readIORef $ carPR p
carPS (IPair car _) = pure car
carPS _ = panic "carPS: not a pair"
{-# SPECIALIZE carPS :: Val -> EM Val #-}

cdrPS :: MonadIO m => Val -> m Val
cdrPS p@Pair{} = liftIO $ readIORef $ cdrPR p
cdrPS (IPair _ cdr) = pure cdr
cdrPS _ = panic "cdrPS: not a pair"
{-# SPECIALIZE cdrPS :: Val -> EM Val #-}

setCarSSS :: Val -> Val -> EM Val
setCarSSS (Pair c _d) v = do
  writeRef c v
  return v
setCarSSS IPair{} _ = throwError $ SetImmutable "pair"
setCarSSS v _ = throwError $ TypeMismatch "pair" v

setCdrSSS :: Val -> Val -> EM Val
setCdrSSS (Pair _c d) v = do
  writeRef d v
  return v
setCdrSSS IPair{} _ = throwError $ SetImmutable "pair"
setCdrSSS v _ = throwError $ TypeMismatch "pair" v

-- | Require that the given Val is a list. Otherwise, raises a 'TypeError'.
requireList :: Val -> EM ()
requireList v =
  whenM (not <$> isListSH v) $ throwError $ TypeMismatch "list" v

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM b t f = b >>= \b' -> if b' then t else f

whenM :: Monad m => m Bool -> m () -> m ()
whenM test thing = ifM test thing (pure ())

-- | Test if a given Scheme object is an immutable pair.
isImmutablePair :: Val -> Bool
isImmutablePair IPair{} = True
isImmutablePair _ = False

-- | Test if a given Scheme object is immutable.
--
-- Specifically, we mean that an object is "immutable" if it can be output
-- by the parser. That means the type is not a reference, or its constructor's
-- name starts with I.
--
-- Most objects qualify; 'Pair', 'Vector', 'U8Vector', and 'String' do
-- not.
isImmutable :: Val -> Bool
isImmutable Pair{}   = False
isImmutable Vector{} = False
isImmutable String{} = False
isImmutable _ = True

makeBignum :: Integer -> Val
makeBignum = Number . Real . Bignum

makeFlonum :: Double -> Val
makeFlonum = Number . Real . Flonum

makeRatnum :: Integer -> Integer -> Val
makeRatnum x y = Number $ Real $ Ratnum (x % y)

approxToRatnum :: Double -> Val
approxToRatnum = Number . Real . Ratnum . toRational

getExactInteger :: Val -> Maybe Integer
getExactInteger v = case v of
  Number (Real (Bignum i)) -> return i
  Number (Real (Flonum _)) -> Nothing
  Number (Real (Ratnum r)) -> case denominator r of
    1 -> return $ numerator r
    _ -> Nothing
  Number (Complex (r :+ i)) -> case i of
    Bignum 0 -> getExactInteger (Number (Real r))
    Flonum _ -> Nothing
    Ratnum z -> if z == 0 then getExactInteger (Number (Real r)) else Nothing
    _notNplusZeroI -> Nothing
  _other -> Nothing

mkNumericTypecheck :: (Number -> Bool) -> Val -> Bool
mkNumericTypecheck p = f
  where f (Number n) = p n
        f _notNumber = False
{-# INLINE mkNumericTypecheck #-}

numberSH, complexSH, realSH, rationalSH, integerSH :: Val -> Bool
numberSH = mkNumericTypecheck $ const True
complexSH = numberSH -- see note on p35 of r7rs paper
realSH = mkNumericTypecheck $ \case
  Real{} -> True
  Complex (_r :+ i)
    | i == 0    -> True
    | otherwise -> False
rationalSH = mkNumericTypecheck test
  where
    test (Real (Flonum f))
      | isInfinite f || isNaN f = False
    test Real{} = True -- truncated real numbers are always rational!
    test (Complex (r :+ i))
      | i == 0 = test $ Real r
      | otherwise = False
integerSH = mkNumericTypecheck test
  where
    test (Real x) = x == round x -- (==)@RealNumber is Scheme =
    test (Complex (r :+ i))
      | i == 0 = test $ Real r
      | otherwise = False

implicitNumericConversion :: Number -> Number -> (Number, Number)
implicitNumericConversion (Real x) (Real y) = (Real x, Real y)
implicitNumericConversion x y = (asComplex x, asComplex y)
  where
    asComplex :: Number -> Number
    asComplex (Real r) = Complex (r :+ 0)
    asComplex (Complex c) = Complex c

-- | Perform an implicit Scheme conversion of two numbers.
--
-- The "order" of numeric types is bignum < ratnum < flonum.
-- The lesser argument will be casted upwards to match the greater one.
-- The returned Numbers are guaranteed to use the same Number constructor.
implicitRealConversion :: RealNumber -> RealNumber -> (RealNumber, RealNumber)
implicitRealConversion = work
  where
    work x@Flonum{} y = (x, Flonum $ asFlonum y)
    work x y@Flonum{} = (Flonum $ asFlonum x, y)
    work x@Ratnum{} y = (x, asRatnum y)
    work x y@Ratnum{} = (asRatnum x, y)
    work x y = (x, y) -- both Bignum

    asRatnum (Ratnum r) = Ratnum r
    asRatnum (Bignum n) = Ratnum (n % 1)
    asRatnum Flonum{} = error "implicitRealConversion.asRatnum: impossible flonum"

pairSH :: Val -> Bool
pairSH Pair{}  = True
pairSH IPair{} = True
pairSH _ = False

vectorSH :: Val -> Bool
vectorSH Vector{} = True
vectorSH IVector{} = True
vectorSH _ = False

makeVector :: [Val] -> Val
makeVector = IVector . V.fromList

makeByteVector :: [Word8] -> Val
makeByteVector = IByteVector . U.fromList

-- | Show a 'Val' in IO. This function loops forever
-- on cyclic data; it's morally equivalent to write-simple.
-- However we don't use it to _implement_ write-simple
-- because we can 't do the linting that we want to do
-- since we aren't in EM. This is mostly just a temporary
-- (12/10/2020) thing so that we can look at values until
-- write-simple/write-shared are implemented (in 'MonadIO',
-- preferably).
--
-- TODO: it should be good to get rid of this now.
showValIO :: Val -> IO String
showValIO = fmap ($ "") . showsValIO

-- | ShowS version of 'showValIO'.
showsValIO :: Val -> IO ShowS
showsValIO p@Pair{}  = showParen True <$> showsListIO p
showsValIO p@IPair{} = showParen True <$> showsListIO p
showsValIO s = pure $ shows s

showsListIO :: Val -> IO ShowS
-- only accepts pairs
showsListIO (Pair c d) = do
  car <- readIORef c
  showsCar <- showsValIO car
  (showsCar .) <$> (readIORef d >>= showsListIO1)
-- we're in IO, so have to forego linting here.
showsListIO (IPair car cdr) = do
    showsCar <- showsValIO car
    (showsCar .) <$> showsListIO1 cdr
showsListIO _notPair = error "showsListIO: not a list"

-- | 'showsListIO', but puts a space before showing
-- the next object. If the next object is 'Nil' (i.e., we're done)
-- then no space is printed.
--
-- This is suitable for printing objects in lists other than the first.
showsListIO1 :: Val -> IO ShowS
showsListIO1 p@Pair{}  = (showString " " .) <$> showsListIO p
showsListIO1 p@IPair{} = (showString " " .) <$> showsListIO p
showsListIO1 Nil = pure id
showsListIO1 dot = (showString " . " .) <$> showsValIO dot

-------------------------------------------------------------------------------
-- Numeric Class Instances for Number
-------------------------------------------------------------------------------

type Binop a = a -> a -> a
type Monop a = a -> a

{- HLINT ignore "Redundant lambda" -}
mkRealNumberBinop :: (forall a. Num a => Binop a)
                  -> Binop RealNumber
mkRealNumberBinop op = \x y -> case implicitRealConversion x y of
  (Bignum a, Bignum b) -> Bignum (a `op` b)
  (Ratnum a, Ratnum b) -> Ratnum (a `op` b)
  (Flonum a, Flonum b) -> Flonum (a `op` b)
  _ -> error "mkRealNumberBinop: implicitRealConversion failure"
{-# INLINE mkRealNumberBinop #-}

{- HLINT ignore "Redundant lambda" -}
mkRealNumberMonop :: (forall a. Num a => Monop a)
                  -> Monop RealNumber
mkRealNumberMonop op = \case
  Bignum a -> Bignum (op a)
  Ratnum a -> Ratnum (op a)
  Flonum a -> Flonum (op a)
{-# INLINE mkRealNumberMonop #-}

{- HLINT ignore "Redundant lambda" -}
mkNumberBinop :: (forall a. Num a => Binop a)
              -> Binop Number
mkNumberBinop op = \x y -> case implicitNumericConversion x y of
  (Real a, Real b) -> Real (a `op` b)
  (Complex w, Complex z) -> Complex (w `op` z)
  _ -> panic " mkNumberBinop: implicitNumericConversion failure"
{-# INLINE mkNumberBinop #-}

{- HLINT ignore "Redundant lambda" -}
mkNumberMonop :: (forall a. Num a => Monop a)
              -> Monop Number
mkNumberMonop op = \case
  Real n -> Real $ op n
  Complex c -> Complex $ op c
{-# INLINE mkNumberMonop #-}

realNumberPlus, realNumberSub, realNumberTimes :: Binop RealNumber
realNumberPlus  = mkRealNumberBinop (+)
realNumberSub   = mkRealNumberBinop (-)
realNumberTimes x y
  | isExactZero (Real x) || isExactZero (Real y) = Bignum 0
  | otherwise = mkRealNumberBinop (*) x y

realNumberNegate, realNumberAbs, realNumberSignum :: Monop RealNumber
realNumberNegate = mkRealNumberMonop negate
realNumberAbs    = mkRealNumberMonop abs
realNumberSignum = mkRealNumberMonop signum

numberTimes :: Binop Number
numberTimes x y
  | isExactZero x || isExactZero y = 0
  | otherwise = mkNumberBinop (*) x y

isExactZero :: Number -> Bool
isExactZero (Real (Bignum 0)) = True
isExactZero (Real (Ratnum 0)) = True
isExactZero (Complex (r :+ i)) = isExactZero (Real r) && isExactZero (Real i)
isExactZero _          = False
{-# INLINABLE isExactZero #-}

instance Num RealNumber where
  (+) = realNumberPlus
  (-) = realNumberSub
  (*) = realNumberTimes
  negate = realNumberNegate
  abs    = realNumberAbs
  signum = realNumberSignum
  fromInteger = Bignum

instance Num Number where
  (+) = mkNumberBinop (+)
  (-) = mkNumberBinop (-)
  (*) = numberTimes -- checks for exact zeroes
  negate = mkNumberMonop negate
  abs    = mkNumberMonop abs
  signum = mkNumberMonop signum
  fromInteger = Real . Bignum

asFlonum :: RealNumber -> Double
asFlonum (Bignum i) = fromInteger i
asFlonum (Ratnum r) = fromRational r
asFlonum (Flonum f) = f

realInexact :: RealNumber -> RealNumber
realInexact = Flonum . asFlonum

flonumPredicate :: (Double -> Bool) -> RealNumber -> Bool
flonumPredicate p = applyPred
  where applyPred (Flonum f) = p f
        applyPred _notFlonum = False
{-# INLINE flonumPredicate #-}

-- | Implementation of 'scaleFloat' for Number. Does the right thing
-- without converting where possible. Bignums are converted to Ratnums
-- if the power is negative.
--
-- realNumberScale p n returns 0 if p is negative and n is 0. This is the
-- same behavior as scaleFloat for Float/Double and gives correct
-- results for Complex divison.
realNumberScale :: Int -> RealNumber -> RealNumber
realNumberScale p (Flonum f) = Flonum (scaleFloat p f)
realNumberScale p bigOrRat
  | p < 0 = case bigOrRat of
    Bignum 0 -> Bignum 0
    Ratnum 0 -> Bignum 0 -- simplify. No cost to doing this because a
                         -- rational would need to be deconstructed to do
                         -- the next step anyway.
    _notZero -> bigOrRat * recip (Bignum (bit $ negate p))
  | otherwise = case bigOrRat of
    Bignum i -> Bignum (i `shiftL` p)
    Ratnum r -> Ratnum (r * (2 ^ p))
    Flonum{} -> error "realNumberScale: impossible flonum"

instance RealFloat RealNumber where
  floatRadix  = floatRadix  . asFlonum
  floatDigits = floatDigits . asFlonum
  floatRange  = floatRange  . asFlonum
  decodeFloat = decodeFloat . asFlonum
  encodeFloat s e = Flonum (encodeFloat s e)
  exponent (Flonum f) = exponent f
  exponent _bigOrRat  = 0
  significand = Flonum . significand . asFlonum
  scaleFloat = realNumberScale
  isNaN = flonumPredicate isNaN
  isInfinite = flonumPredicate isInfinite
  isDenormalized = flonumPredicate isDenormalized
  isNegativeZero = flonumPredicate isNegativeZero
  -- Bignums are not IEEE floating-point numbers!
  isIEEE = flonumPredicate isIEEE
  atan2 x y = Flonum (atan2 (asFlonum x) (asFlonum y))

mkRoundingMode :: Integral b
               => (forall a. RealFrac a => a -> b)
               -> RealNumber -> b
mkRoundingMode mode = applyMode
  where applyMode (Bignum i) = fromInteger i -- no rounding to do
        applyMode (Ratnum r) = mode r
        applyMode (Flonum f) = mode f
{-# INLINE mkRoundingMode #-}

instance RealFrac RealNumber where
  properFraction (Bignum a) = (fromInteger a, 0)
  properFraction (Ratnum r) = let (n, f) = properFraction r
                              in  (n, Ratnum f)
  properFraction (Flonum f) = let (n, f') = properFraction f
                              in  (n, Flonum f')

  truncate = mkRoundingMode truncate
  round    = mkRoundingMode round
  ceiling  = mkRoundingMode ceiling
  floor    = mkRoundingMode floor

instance Real RealNumber where
  toRational (Bignum i) = i % 1
  toRational (Ratnum r) = r
  toRational (Flonum f) = toRational f

floatingOp :: Monop Double -> Monop RealNumber
floatingOp f n = Flonum (f (asFlonum n))
{-# INLINE floatingOp #-}

instance Floating RealNumber where
  pi = Flonum pi
  exp = floatingOp exp
  log = floatingOp log
  sqrt = floatingOp sqrt
  sin = floatingOp sin
  cos = floatingOp cos
  tan = floatingOp tan
  asin = floatingOp asin
  acos = floatingOp acos
  atan = floatingOp atan
  sinh = floatingOp sinh
  cosh = floatingOp cosh
  tanh = floatingOp tanh
  asinh = floatingOp asinh
  acosh = floatingOp acosh
  atanh = floatingOp atanh
  log1p = floatingOp log1p
  expm1 = floatingOp expm1
  log1pexp = floatingOp log1pexp
  log1mexp = floatingOp log1mexp

  x ** Bignum y = x ^^ y
  x ** y = Flonum (asFlonum x ** asFlonum y)
  logBase x y = Flonum (logBase (asFlonum x) (asFlonum y))

realPart :: Number -> RealNumber
realPart (Real r) = r
realPart (Complex (x:+_)) = x
inf, nan :: RealNumber
inf = Flonum $ 1/0
nan = Flonum $ 0/0

numberIsInfinite :: Number -> Bool
numberIsInfinite (Real r) = isInfinite r
numberIsInfinite (Complex (x:+y)) = isInfinite x || isInfinite y

-- | This works for sin, cos, tan, sinh, cosh, and tanh,
-- which all have real results wherever they are defined
-- on the real line.
--
-- It does not work for inverse trig functions, hence the name.
forwardTrigFunction :: (forall a. Floating a => Monop a)
                    -> Monop Number
forwardTrigFunction f = \case
  Real r    -> Real (f r)
  Complex z -> Complex (f z)

instance Floating Number where
  pi = Real pi

  exp (Real r) = Real (exp r)
  exp (Complex (x:+y)) = Complex $ expx * cos y :+ expx * sin y
    where expx = exp x

  log (Real r)
    | r < 0 || isNegativeZero r = Complex $ log (abs r) :+ pi
    | otherwise = Real $ log r
  log (Complex z@(x:+y)) = Complex $ log (magnitude z) :+ atan2 y x

  x ** y
    | isExactZero y = Real 1
    | isExactZero x = case compare (realPart y) 0 of
      GT -> Real 0
      LT -> Real inf
      EQ -> Real nan
    | numberIsInfinite x = case compare (realPart y) 0 of
      GT -> Real inf
      LT -> Real 0
      EQ -> Real nan
      -- note that exp and log give real results when applied
      -- to real arguments, when possible.
  Real x ** Real (Bignum y) = Real (x ** Bignum y)
  Real x ** Real y | x >= 0 = Real (x ** y)
  x ** y = exp (log x * y)

  sqrt z | isExactZero z = 0
  sqrt (Real r)
    | r >= 0    = Real $ sqrt r
    | otherwise = Complex $ 0 :+ sqrt (-r)
  sqrt (Complex z) = Complex $ sqrt z

  sin = forwardTrigFunction sin
  cos = forwardTrigFunction cos
  tan = forwardTrigFunction tan

  sinh = forwardTrigFunction sinh
  cosh = forwardTrigFunction cosh
  tanh = forwardTrigFunction tanh

  -- redefine these functions to use our definition of log which behaves
  -- correctly at -0. Otherwise they are copies of Data.Complex.
  asin (Real r)
    | r >= -1 && r <= 1 = Real $ asin r
    | otherwise = asin (Complex (r :+ 0))
  asin z@(Complex (x:+y)) = Complex $ y' :+ (-x')
    where Complex (x':+y') = log (iz + sqrt (1 - z * z))
          -- take care to use log @Number and not @(Complex RealNumber)
          iz = Complex ((-y) :+ x)

  acos (Real r)
    | r >= -1 && r <= 1 = Real $ acos r
    | otherwise = acos (Complex (r :+ 0))
  acos z = Complex $ y'' :+ (-x'')
    where Complex (x'':+y'') = log (z + Complex ((-y'):+x'))
          Complex (x':+y')   = sqrt (1 - z * z)

  atan (Real r) = Real $ atan r
  atan z@(Complex (x:+y)) = Complex $ y':+(-x')
    where Complex (x':+y') = log (z' / sqrt (1 + z * z))
          z' = Complex ((1-y) :+ x)

  asinh z = log (z + sqrt (1 + z*z))
  -- see comment in Data.Complex:
  -- essentially, don't use the formula with a division because it is
  -- undefined when z = -1.
  acosh z = log (z + sqrt (z+1) * sqrt (z-1))
  atanh z = 0.5 * log ((1+z) / (1-z))

  log1p (Real r)
    | abs r < 0.5 = Real (log1p r)
    | otherwise = Real (log (1 + r))
  log1p x@(Complex (a :+ b))
    | abs a < 0.5 && abs b < 0.5 =
      let u = 2*a + a*a + b*b
      in Complex $ log1p (u/(1 + sqrt(u+1))) :+ atan2 (1+a) b
    | otherwise = log (1 + x)

  expm1 (Real r) = Real (expm1 r)
  expm1 x@(Complex (a :+ b))
    | a*a + b*b < 1 =
      let u = expm1 a
          v = sin (b/2)
          w = -2*v*v
      in Complex $ (u*w + u + w) :+ (u+1)*sin b
    | otherwise = exp x - 1

-- distinct from numberDiv
realNumberDivide :: Binop RealNumber
realNumberDivide x y = case implicitRealConversion x y of
  (Bignum a, Bignum b) -> Ratnum (a % b)
  (Ratnum a, Ratnum b) -> Ratnum (a / b)
  (Flonum a, Flonum b) -> Flonum (a / b)
  _ -> error "realNumberDivide: implicitRealConversion failure"

realNumberRecip :: Monop RealNumber
realNumberRecip (Bignum i) = Ratnum (1 % i)
realNumberRecip (Ratnum r) = Ratnum (recip r)
realNumberRecip (Flonum f) = Flonum (recip f)

numberDivide :: Binop Number
numberDivide x y = case implicitNumericConversion x y of
  (Real a, Real b) -> Real (a / b)
  (Complex a, Complex b) -> Complex (a / b)
  _ -> error "numberDivide: implicitNumericConversion failure"

numberRecip :: Monop Number
numberRecip (Real r)    = Real (recip r)
numberRecip (Complex z) = Complex (recip z)

instance Fractional RealNumber where
  (/) = realNumberDivide
  recip = realNumberRecip
  fromRational = Ratnum

instance Fractional Number where
  (/) = numberDivide
  recip = numberRecip
  fromRational = Real . Ratnum

realNumberCompare :: RealNumber -> RealNumber -> Ordering
realNumberCompare = (<=>) where
  Flonum f <=> Flonum g = f `compare` g
  Flonum f <=> bigOrRat
    | isInfinite f = f `compare` 0
    | otherwise    = r1 `compare` r2
    -- note that we make the fp number exact instead of making the
    -- exact number fp. This is critical. An example from the R7RS
    -- paper is: let big be (exp 2 1000). Assume big is exact and
    -- that inexact numbers are IEEE doubles [they are]. Then
    -- (= (inexact big) (+ big 1)) should be #f, but if inexact
    -- conversion is used, it will be #t.
    where r1 = toRational f
          r2 = case bigOrRat of
            Bignum i -> i % 1
            Ratnum r -> r
            Flonum{} -> error "realNumberCompare.<=>: impossible flonum"
  bigOrRat <=> n@Flonum{} = case n <=> bigOrRat of
    LT -> GT
    EQ -> EQ
    GT -> LT
  Bignum i <=> Bignum j = i `compare` j
  Bignum i <=> Ratnum r = (i % 1) `compare` r
  Ratnum r <=> Bignum i = r `compare` (i % 1)
  Ratnum r <=> Ratnum s = r `compare` s

-- | Number is not really an Integral type, since it's possible it has
-- a floating-point backing. Here's what we do:
-- 1) toInteger truncates
-- 2) quotRem uses Number division unless both arguments are Bignums.

-- This instance exists mostly so that the rounding modes from RealFrac
-- can be used with RealNumbers.
instance Integral RealNumber where
  toInteger (Bignum i) = i
  toInteger (Ratnum r) = truncate r
  toInteger (Flonum f) = truncate f

  quotRem (Bignum x) (Bignum y) = let (q, r) = quotRem x y
                                  in (Bignum q, Bignum r)
  quotRem x y = (x / y, 0)

instance Ord RealNumber where
  compare = realNumberCompare

-- | 'Enum' essentially does not have any of the laws you might expect
-- it to have; for types that are not also Bounded, it is lawless.
-- This is a useful-ish instance which generally behaves as expected
-- and which is needed to give the Integral instance.
instance Enum RealNumber where
  succ (Bignum i) = Bignum (succ i)
  succ (Ratnum r) = Ratnum (succ r)
  succ (Flonum f) = Flonum (succ f)
  pred (Bignum i) = Bignum (pred i)
  pred (Ratnum r) = Ratnum (pred r)
  pred (Flonum f) = Flonum (pred f)
  toEnum i = Bignum (toEnum i)
  fromEnum (Bignum i) = fromEnum i
  fromEnum (Ratnum r) = fromEnum r
  fromEnum (Flonum f) = fromEnum f
  -- The rest of the functions are omitted because they are not used
  -- and it is not clear what the 'correct' implementations are for
  -- Scheme Numbers.


-- |
-- Module      : Foreign.CUDA.Solver.Internal.C2HS
-- Copyright   : [2017] Trevor L. McDonell
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Foreign.CUDA.Solver.Internal.C2HS (

  -- * Conversion between C and Haskell types
  cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum,

  -- * Composite marshalling functions
  withComplex,
  peekIntConv, peekFloatConv,

) where

-- system
import Control.Monad
import Data.Complex
import Foreign
import Foreign.C
import Foreign.Storable.Complex ()

-- Conversions -----------------------------------------------------------------
--

-- | Integral conversion
--
{-# INLINE cIntConv #-}
cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

-- | Floating conversion
--
{-# INLINE [1] cFloatConv #-}
cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac
-- As this conversion by default goes via `Rational', it can be very slow...
{-# RULES
  "cFloatConv/Float->Float"    forall (x::Float).  cFloatConv x = x;
  "cFloatConv/Double->Double"  forall (x::Double). cFloatConv x = x;
  "cFloatConv/Float->CFloat"   forall (x::Float).  cFloatConv x = CFloat x;
  "cFloatConv/CFloat->Float"   forall (x::Float).  cFloatConv CFloat x = x;
  "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x;
  "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x
 #-}

-- | Obtain C value from Haskell 'Bool'.
--
{-# INLINE cFromBool #-}
cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

-- | Obtain Haskell 'Bool' from C value.
--
{-# INLINE cToBool #-}
cToBool :: (Eq a, Num a) => a -> Bool
cToBool  = toBool

-- | Convert a C enumeration to Haskell.
--
{-# INLINE cToEnum #-}
cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

-- | Convert a Haskell enumeration to C.
--
{-# INLINE cFromEnum #-}
cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum

-- | Marshalling of complex numbers
--
{-# INLINE withComplex #-}
withComplex :: Storable a => Complex a -> (Ptr () -> IO b) -> IO b
withComplex c f = with c (f . castPtr)

-- | Marshalling of numerals
--
{-# INLINE peekIntConv #-}
peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b
peekIntConv = liftM cIntConv . peek

{-# INLINE peekFloatConv #-}
peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b
peekFloatConv = liftM cFloatConv . peek


{-# LANGUAGE NamedFieldPuns, TemplateHaskell #-}

module School.App.Test.FileTransformer
( fileTransformerTest ) where

import Conduit ((.|), await, liftIO, runConduit, sinkList)
import qualified Data.ByteString.Lazy as BL
import Control.Applicative (liftA2)
import Data.Default.Class (def)
import Data.Function (on)
import Numeric.LinearAlgebra ((?), Matrix, R)
import School.App.FileTransformer
import School.FileIO.AppIO (runAppIO)
import School.FileIO.FileApp (fileApp)
import School.FileIO.FileType (FileType(..), toExtension)
import School.FileIO.FileHeader (FileHeader(..))
import School.FileIO.Source (source)
import School.TestUtils (assertRight, dummyMatrix)
import School.Types.DataType (DataType(..))
import School.Types.Error (Error)
import School.Utils.Either (isLeft, isRight)
import System.Directory (removeFile)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, run)

inFileName :: FileType -> FilePath
inFileName fType = "test/data/matrix3x3."
                ++ toExtension fType

inFileNameTwice :: DataType -> FileType -> FilePath
inFileNameTwice DBL64B fType = "test/data/matrix3x3Twice."
                            ++ toExtension fType
inFileNameTwice INT32B fType = "test/data/matrix3x3Twice_INT32B."
                            ++ toExtension fType
inFileNameTwice INT08B fType = "test/data/matrix3x3Twice_INT08B."
                            ++ toExtension fType

header3x3 :: FileHeader
header3x3 = FileHeader { dataType = DBL64B
                         , cols = 3
                         , rows = 3
                         }

testFile :: FileType -> String
testFile fType = "test." ++ toExtension fType

fileEq :: FilePath -> FilePath -> IO Bool
fileEq = liftA2 (==) `on` BL.readFile

readMat :: FileHeader
        -> FilePath
        -> PropertyM IO (Either Error
                                (Maybe (Matrix R)))
readMat header path = run . runAppIO . runConduit $
  source header path .| await

readDoubleList :: FileHeader
               -> FilePath
               -> PropertyM IO (Either Error
                                       [Double])
readDoubleList header path = run . runAppIO . runConduit $
  source header path .| sinkList

prop_copy :: FileType -> Property
prop_copy fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , outFileOpt = testFile fType
                    , outFileTypeOpt = Just fType
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isRight result
  equal <- liftIO $ fileEq (inFileName fType) (testFile fType)
  liftIO $ removeFile (testFile fType)
  assert equal

prop_copy_guess_filetypes :: FileType -> Property
prop_copy_guess_filetypes fType = monadicIO $ do
  let options = def { inFileOpt = (inFileName fType)
                    , outFileOpt = (testFile fType)
                    }
  result <-liftIO . runAppIO $ fileApp options
  assert $ isRight result
  equal <- liftIO $ fileEq (inFileName fType) (testFile fType)
  liftIO $ removeFile (testFile fType)
  assert equal

prop_copy_add_extension :: FileType -> Property
prop_copy_add_extension fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , outFileOpt = "test"
                    , outFileTypeOpt = Just fType
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isRight result
  equal <- liftIO $ fileEq (inFileName fType) (testFile fType)
  liftIO $ removeFile (testFile fType)
  assert equal

prop_skip_rows :: FileType -> Property
prop_skip_rows fType = monadicIO $ do
  let outHeader = header3x3 { rows = 1 }
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , outFileOpt = testFile fType
                    , outFileTypeOpt = Just fType
                    , skipRowsOpt = Just 2
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isRight result
  let check = Just $ dummyMatrix 3 3 ? [2]
  readRes <- readMat outHeader (testFile fType)
  liftIO $ removeFile (testFile fType)
  assertRight (== check) readRes

prop_skip_too_many_rows :: FileType -> Property
prop_skip_too_many_rows fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , skipRowsOpt = Just 4
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isLeft result

prop_limit_extent :: FileType -> Property
prop_limit_extent fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , nRowsOpt = Just 2
                    , outFileOpt = testFile fType
                    }
  result <-liftIO . runAppIO $ fileApp options
  assert $ isRight result
  let check = Just $ dummyMatrix 3 3 ? [0, 1]
  let outHeader = header3x3 { rows = 2 }
  readRes <- readMat outHeader (testFile fType)
  liftIO $ removeFile (testFile fType)
  assertRight (== check) readRes

prop_skip_and_limit :: FileType -> Property
prop_skip_and_limit fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , nRowsOpt = Just 1
                    , skipRowsOpt = Just 1
                    , outFileOpt = testFile fType
                    }
  result <-liftIO . runAppIO $ fileApp options
  assert $ isRight result
  let check = Just $ dummyMatrix 3 3 ? [1]
  let outHeader = header3x3 { rows = 1 }
  readRes <- readMat outHeader (testFile fType)
  liftIO $ removeFile (testFile fType)
  assertRight (== check) readRes

prop_limit_too_many_rows :: FileType -> Property
prop_limit_too_many_rows fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just fType
                    , nRowsOpt = Just 4
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isLeft result

prop_limit_and_skip_too_many :: FileType -> Property
prop_limit_and_skip_too_many fType = monadicIO $ do
  let options = def { inFileOpt = inFileName fType
                    , inFileTypeOpt = Just SM
                    , nRowsOpt = Just 3
                    , skipRowsOpt = Just 1
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isLeft result

inFileType :: FileType -> DataType -> FilePath
inFileType fType DBL64B = "test/data/matrix3x3."
                       ++ toExtension fType
inFileType fType INT32B = "test/data/matrix3x3_INT32B."
                       ++ toExtension fType
inFileType fType INT08B = "test/data/matrix3x3_INT08B."
                       ++ toExtension fType

legalConversion :: DataType -> DataType -> Bool
legalConversion INT08B _ = True
legalConversion INT32B INT32B = True
legalConversion INT32B DBL64B = True
legalConversion DBL64B DBL64B = True
legalConversion _ _ = False

prop_convert_data_type :: FileType -> DataType -> DataType -> Property
prop_convert_data_type fType tIn tOut = monadicIO $ do
  let options = def { inFileOpt = inFileType fType tIn
                    , inDataTypeOpt = tIn
                    , inFileTypeOpt = Just fType
                    , outDataTypeOpt = Just tOut
                    , outFileOpt = testFile fType
                    , outFileTypeOpt = Just fType
                    }
  result <- liftIO . runAppIO $ fileApp options
  if legalConversion tIn tOut
    then do
      assert $ isRight result
      let inHeader = header3x3 { dataType = tIn }
      let outHeader = header3x3 { dataType = tOut }
      inRes <- readDoubleList inHeader (inFileType fType tIn)
      outRes <- readDoubleList outHeader (testFile fType)
      liftIO $ removeFile (testFile fType)
      assert $ inRes == outRes
    else assert $ isLeft result

prop_convert_file_type :: FileType -> FileType -> DataType -> Property
prop_convert_file_type fTypeIn fTypeOut dType = monadicIO $ do
  let options = def { inFileOpt = inFileType fTypeIn dType
                    , inDataTypeOpt = dType
                    , inFileTypeOpt = Just fTypeIn
                    , outFileOpt = testFile fTypeOut
                    , outFileTypeOpt = Just fTypeOut
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isRight result
  let header = header3x3 { dataType = dType }
  inRes <- readDoubleList header (inFileType fTypeIn dType)
  outRes <- readDoubleList header (testFile fTypeOut)
  liftIO $ removeFile (testFile fTypeOut)
  assert $ inRes == outRes

prop_convert_both_types :: FileType -> FileType -> DataType -> DataType -> Property
prop_convert_both_types fTypeIn fTypeOut tIn tOut = monadicIO $ do
  let options = def { inFileOpt = inFileType fTypeIn tIn
                    , inDataTypeOpt = tIn
                    , inFileTypeOpt = Just fTypeIn
                    , outDataTypeOpt = Just tOut
                    , outFileOpt = testFile fTypeOut
                    , outFileTypeOpt = Just fTypeOut
                    }
  result <- liftIO . runAppIO $ fileApp options
  if legalConversion tIn tOut
    then do
      assert $ isRight result
      let inHeader = header3x3 { dataType = tIn }
      let outHeader = header3x3 { dataType = tOut }
      inRes <- readDoubleList inHeader (inFileType fTypeIn tIn)
      outRes <- readDoubleList outHeader (testFile fTypeOut)
      liftIO $ removeFile (testFile fTypeOut)
      assert $ inRes == outRes
    else assert $ isLeft result

prop_copy_twice :: FileType -> Property
prop_copy_twice fType = monadicIO $ do
  let options = def { inFileOpt = inFileNameTwice DBL64B fType
                    , inFileTypeOpt = Just fType
                    , outFileOpt = testFile fType
                    , outFileTypeOpt = Just fType
                    }
  result <- liftIO . runAppIO $ fileApp options
  assert $ isRight result
  let header = header3x3 { rows = 6 }
  inRes <- readDoubleList header (inFileNameTwice DBL64B fType)
  outRes <- readDoubleList header (testFile fType)
  liftIO $ removeFile (testFile fType)
  assert $ inRes == outRes

prop_convert_data_twice :: FileType -> DataType -> DataType -> Property
prop_convert_data_twice fType tIn tOut = monadicIO $ do
  let options = def { inFileOpt = inFileNameTwice tIn fType
                    , inDataTypeOpt = tIn
                    , inFileTypeOpt = Just fType
                    , outDataTypeOpt = Just tOut
                    , outFileOpt = testFile fType
                    , outFileTypeOpt = Just fType
                    }
  result <- liftIO . runAppIO $ fileApp options
  if legalConversion tIn tOut
    then do
      assert $ isRight result
      let inHeader = header3x3 { dataType = tIn }
      let outHeader = header3x3 { dataType = tOut }
      inRes <- readDoubleList inHeader (inFileNameTwice tIn fType)
      outRes <- readDoubleList outHeader (testFile fType)
      liftIO $ removeFile (testFile fType)
      assert $ inRes == outRes
    else do
      liftIO $ removeFile (testFile fType)
      assert $ isLeft result

fileTransformerTest :: TestTree
fileTransformerTest = $(testGroupGenerator)


--
-- Copyright (c) 2009-2011, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Frontend.Eq
where

import qualified Prelude as P

import Data.Int
import Data.Word
import Data.Complex

import Feldspar.Prelude
import Feldspar.Core.Types
import Feldspar.Core.Constructs
import Feldspar.Core.Constructs.Eq

infix 4 ==
infix 4 /=

-- | Redefinition of the standard 'P.Eq' class for Feldspar
class (Type a) => Eq a
  where
    (==) :: Data a -> Data a -> Data Bool
    (==) = sugarSymF Equal
    (/=) :: Data a -> Data a -> Data Bool
    (/=) = sugarSymF NotEqual

instance Eq ()
instance Eq Bool
instance Eq Float
instance Eq Double
instance Eq Word8
instance Eq Word16
instance Eq Word32
instance Eq Word64
instance Eq WordN
instance Eq Int8
instance Eq Int16
instance Eq Int32
instance Eq Int64
instance Eq IntN

instance (Eq a, Eq b)                               => Eq (a,b)
instance (Eq a, Eq b, Eq c)                         => Eq (a,b,c)
instance (Eq a, Eq b, Eq c, Eq d)                   => Eq (a,b,c,d)
instance (Eq a, Eq b, Eq c, Eq d, Eq e)             => Eq (a,b,c,d,e)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)       => Eq (a,b,c,d,e,f)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a,b,c,d,e,f,g)

instance (Eq a, RealFloat a) => Eq (Complex a)


module LispVal where

import Control.Monad.Cont (liftIO, liftM)
import Control.Monad.Error.Class (MonadError, catchError)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Data.Complex (Complex)
import Data.IORef
import GHC.IO.Handle.Types (Handle)
import Text.ParserCombinators.Parsec (ParseError)

instance Show LispVal where show = showVal

data LispVal
  = Atom String
  | List [LispVal]
  | DottedList [LispVal] LispVal
  | Number Integer
  | Float Float
  | Rational Rational
  | Complex (Complex Float)
  | String String
  | Character String
  | Bool Bool
  | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
  | Func
      { params :: [String],
        vararg :: Maybe String,
        body :: [LispVal],
        closure :: Environment
      }
  | IOFunc ([LispVal] -> IOThrowsError LispVal)
  | Port Handle

showVal :: LispVal -> String
showVal (List contents) = "(" ++ wordsList contents ++ ")"
showVal (DottedList x xs) = "(" ++ wordsList x ++ " . " ++ showVal xs ++ ")"
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Float contents) = show contents
showVal (Rational contents) = show contents
showVal (Complex contents) = show contents
showVal (Character contents) = show contents
showVal (Bool True) = "True"
showVal (Bool False) = "False"
showVal (PrimitiveFunc _) = "<primitive>"
showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =
  "(lambda (" ++ unwords (map show args)
    ++ ( case varargs of
           Nothing -> ""
           Just arg -> " . " ++ arg
       )
    ++ ") ...)"
showVal (Port _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"

type IOThrowsError = ExceptT LispError IO

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runExceptT (trapError action) >>= return . extractValue

type ThrowsError = Either LispError

instance Show LispError where show = showError

data LispError
  = NumArgs Integer [LispVal]
  | TypeMismatch String LispVal
  | Parser ParseError
  | BadSpecialForm String LispVal
  | NotFunction String String
  | UnboundVar String String
  | Default String

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

trapError :: (MonadError a m, Show a) => m String -> m String
trapError action = catchError action (return . show)

showError :: LispError -> String
showError (UnboundVar message varName) = message ++ ": " ++ varName
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) =
  "Expected " ++ show expected
    ++ " args; found values "
    ++ wordsList found
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected
    ++ ", found "
    ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
showError _ = "Error"

wordsList :: [LispVal] -> String
wordsList = unwords . map showVal

type Environment = IORef [(String, IORef LispVal)]

getVar :: Environment -> String -> IOThrowsError LispVal
getVar envRef var = do
  env <- liftIO $ readIORef envRef
  maybe
    (throwError $ UnboundVar "Getting an unbound variable" var)
    (liftIO . readIORef)
    (lookup var env)

setVar :: Environment -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value = do
  env <- liftIO $ readIORef envRef
  maybe
    (throwError $ UnboundVar "Setting an unbound variable" var)
    (liftIO . (flip writeIORef value))
    (lookup var env)
  return value

defineVar :: Environment -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
  alreadyDefined <- liftIO $ isBound envRef var
  if alreadyDefined
    then setVar envRef var value >> return value
    else liftIO $ do
      valueRef <- newIORef value
      env <- readIORef envRef
      writeIORef envRef ((var, valueRef) : env)
      return value

bindVars :: Environment -> [(String, LispVal)] -> IO Environment
bindVars envRef binds = readIORef envRef >>= extendEnv binds >>= newIORef
  where
    extendEnv binds' env = liftM (++ env) (mapM addBind binds')
    addBind (var, value) = do
      ref <- newIORef value
      return (var, ref)

isBound :: Environment -> String -> IO Bool
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var

nullEnv :: IO Environment
nullEnv = newIORef []


{- |

Module      :  Numeric.GSL
Copyright   :  (c) Alberto Ruiz 2006-7
License     :  GPL-style

Maintainer  :  Alberto Ruiz (aruiz at um dot es)
Stability   :  provisional
Portability :  uses -fffi and -fglasgow-exts

This module reexports all available GSL functions.

The GSL special functions are in the separate package hmatrix-special.

-}

module Numeric.GSL (
  module Numeric.GSL.Integration
, module Numeric.GSL.Differentiation
, module Numeric.GSL.Fourier
, module Numeric.GSL.Polynomials
, module Numeric.GSL.Minimization
, module Numeric.GSL.Root
, module Numeric.GSL.ODE
, module Numeric.GSL.Fitting
, module Data.Complex
, setErrorHandlerOff
) where

import Numeric.GSL.Integration
import Numeric.GSL.Differentiation
import Numeric.GSL.Fourier
import Numeric.GSL.Polynomials
import Numeric.GSL.Minimization
import Numeric.GSL.Root
import Numeric.GSL.ODE
import Numeric.GSL.Fitting
import Data.Complex

-- | This action removes the GSL default error handler (which aborts the program), so that
-- GSL errors can be handled by Haskell (using Control.Exception) and ghci doesn't abort.
foreign import ccall unsafe "GSL/gsl-aux.h no_abort_on_error" setErrorHandlerOff :: IO ()


{-# LANGUAGE ExistentialQuantification #-}

module Main where

import           System.Environment
import           System.IO
import           Control.Monad
import           Control.Monad.Except
import           Numeric
import           Data.Ratio
import           Data.Complex
import           Data.Array
import           Data.IORef
import           Text.ParserCombinators.Parsec
                                         hiding ( spaces )

data LispVal =
    Atom String
    | List [LispVal]
    | DottedList [LispVal] LispVal
    | Vector (Array Int LispVal)
    | Number Integer
    | Float Double
    | Ratio Rational
    | Complex (Complex Double)
    | String String
    | Character Char
    | Bool Bool
    | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
    | Func {
        params :: [String],
        vararg :: Maybe String,
        body :: [LispVal],
        closure :: Env
    }
    | IOFunc ([LispVal] -> IOThrowsError LispVal)
    | Port Handle
    -- deriving Eq

unwordList :: [LispVal] -> String
unwordList = unwords . map showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom   name    ) = name
showVal (Number num     ) = show num
showVal (Bool   True    ) = "#t"
showVal (Bool   False   ) = "#f"
showVal (List   contents) = "(" ++ unwordList contents ++ ")"
showVal (DottedList head tail) =
    "(" ++ unwordList head ++ " . " ++ showVal tail ++ ")"
showVal (Character     char) = show char
showVal (PrimitiveFunc _   ) = "<primitive>"
showVal (Func { params = args, vararg = varargs, body = body, closure = env })
    = "(lambda ("
        ++ unwords (map show args)
        ++ (case varargs of
               Nothing  -> ""
               Just arg -> " . " ++ arg
           )
        ++ ") ...)"
showVal (Port   _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"

instance Show LispVal where
    show = showVal

data LispError =
    NumArgs Integer [LispVal]
    | TypeMismatch String LispVal
    | Parser ParseError
    | BadSpecialForm String LispVal
    | NotFunction String String
    | UnboundVar String String
    | Default String

showError :: LispError -> String
showError (UnboundVar     message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form   ) = message ++ ": " ++ show form
showError (NotFunction    message func   ) = message ++ ": " ++ show func
showError (NumArgs expected found) =
    "Expected " ++ show expected ++ " args; found values " ++ unwordList found
showError (TypeMismatch expected found) =
    "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser  parseErr) = "Parse error at " ++ show parseErr
showError (Default message ) = message

instance Show LispError where
    show = showError

type ThrowsError = Either LispError

trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

escapedChars :: Parser Char
escapedChars = do
    char '\\'
    x <- oneOf "\\\"nrt"
    return $ case x of
        '\\' -> x
        '"'  -> x
        'n'  -> '\n'
        'r'  -> '\r'
        't'  -> '\t'

parseString :: Parser LispVal
parseString = do
    char '"'
    x <- many $ escapedChars <|> noneOf "\"\\"
    char '"'
    return $ String x

parseBool :: Parser LispVal
parseBool = do
    _ <- char '#'
    (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))

parseAtom :: Parser LispVal
parseAtom = do
    first <- letter <|> symbol
    rest  <- many (letter <|> digit <|> symbol)
    return $ Atom (first : rest)

parseDecimal1 :: Parser LispVal
parseDecimal1 = many1 digit >>= (return . Number . read)

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
    try $ string "#d"
    x <- many1 digit
    (return . Number . read) x

hex2digit :: String -> Integer
hex2digit = fst . head . readHex

parseHex :: Parser LispVal
parseHex = do
    try $ string "#x"
    x <- many1 hexDigit
    (return . Number . hex2digit) x

oct2digit :: String -> Integer
oct2digit x = fst $ readOct x !! 0

parseOct :: Parser LispVal
parseOct = do
    try $ string "#o"
    x <- many1 octDigit
    (return . Number . oct2digit) x

bin2digit :: String -> Integer
bin2digit = bin2digit' 0
  where
    bin2digit' digitInt "" = digitInt
    bin2digit' digitInt (x : xs) =
        let old = 2 * digitInt + (if x == '0' then 0 else 1)
        in  bin2digit' old xs

parseBin :: Parser LispVal
parseBin = do
    try $ string "#b"
    x <- many1 (oneOf "01")
    (return . Number . bin2digit) x

parseNumber :: Parser LispVal
parseNumber =
    parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin

parseCharacter :: Parser LispVal
parseCharacter = do
    try $ string "#\\"
    value <- try (string "newline" <|> string "space") <|> do
        x <- anyChar
        notFollowedBy alphaNum
        return [x]
    return $ Character $ case value of
        "space"   -> ' '
        "newline" -> '\n'
        otherwise -> value !! 0

parseFloat :: Parser LispVal
parseFloat = do
    x <- many1 digit
    char '.'
    y <- many1 digit
    (return . Float . fst . head . readFloat) (x ++ "." ++ y)

parseRatio :: Parser LispVal
parseRatio = do
    x <- many1 digit
    char '/'
    y <- many1 digit
    (return . Ratio) ((read x) % (read y))

toDouble :: LispVal -> Double
toDouble (Float  f) = f
toDouble (Number n) = fromIntegral n

parseComplex :: Parser LispVal
parseComplex = do
    x <- (try parseFloat <|> parseNumber)
    char '+'
    y <- (try parseFloat <|> parseNumber)
    char 'i'
    (return . Complex) (toDouble x :+ toDouble y)

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ DottedList head tail

parseVector :: Parser LispVal
parseVector = do
    arrayValues <- sepBy parseExpr spaces
    return $ Vector $ listArray (0, length arrayValues - 1) arrayValues

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
    char '`'
    x <- parseExpr
    return $ List [Atom "quasiquote", x]

parseUnQuote :: Parser LispVal
parseUnQuote = do
    char ','
    x <- parseExpr
    return $ List [Atom "unquote", x]

parseExpr :: Parser LispVal
parseExpr =
    parseAtom
        <|> parseString
        <|> try parseFloat
        <|> try parseRatio
        <|> try parseComplex
        <|> try parseNumber
        <|> try parseBool
        <|> try parseCharacter
        <|> parseQuoted
        <|> parseQuasiQuoted
        <|> parseUnQuote
        <|> try
                (do
                    string "#("
                    x <- parseVector
                    char ')'
                    return x
                )
        <|> do
                char '('
                x <- try parseList <|> parseDottedList
                char ')'
                return x

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

numericBinop
    :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op []            = throwError $ NumArgs 2 []
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params        = Number . foldl1 op <$> mapM unpackNum params

unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) =
    let parsed = reads n
    in  if null parsed
            then throwError $ TypeMismatch "number" $ String n
            else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum     = throwError $ TypeMismatch "number" notNum

unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number n) = return $ show n
unpackStr (Bool   b) = return $ show b
unpackStr notString  = throwError $ TypeMismatch "string" notString

unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool  = throwError $ TypeMismatch "boolean" notBool

unaryOp :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
unaryOp f [v]    = return $ f v
unaryOp f []     = throwError $ NumArgs 1 []
unaryOp f params = throwError $ NumArgs 1 params

symbolp :: LispVal -> LispVal
symbolp (Atom _) = Bool True
symbolp _        = Bool False

stringp :: LispVal -> LispVal
stringp (String _) = Bool True
stringp _          = Bool False

numberp :: LispVal -> LispVal
numberp (Number _) = Bool True
numberp _          = Bool False

boolp :: LispVal -> LispVal
boolp (Bool _) = Bool True
boolp _        = Bool False

listp :: LispVal -> LispVal
listp (List _        ) = Bool True
listp (DottedList _ _) = Bool True
listp _                = Bool False

symbol2string :: LispVal -> LispVal
symbol2string (Atom s) = String s
symbol2string _        = String ""

string2symbol :: LispVal -> LispVal
string2symbol (String s) = Atom s
string2symbol _          = Atom ""

boolBinop
    :: (LispVal -> ThrowsError a)
    -> (a -> a -> Bool)
    -> [LispVal]
    -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
    then throwError $ NumArgs 2 args
    else do
        left  <- unpacker $ args !! 0
        right <- unpacker $ args !! 1
        return $ Bool $ left `op` right

numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal
numBoolBinop = boolBinop unpackNum

strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal
strBoolBinop = boolBinop unpackStr

boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = boolBinop unpackBool

car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)        ] = return x
car [DottedList (x : xs) _] = return x
car [badArg               ] = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList

cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)        ] = return $ List xs
cdr [DottedList [_     ] x] = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg               ] = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList

cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []            ] = return $ List [x1]
cons [x , List xs            ] = return $ List $ x : xs
cons [x , DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2                 ] = return $ DottedList [x1] x2
cons badArgList                = throwError $ NumArgs 2 badArgList

eqv :: [LispVal] -> ThrowsError LispVal
eqv [Bool   arg1, Bool arg2  ] = return $ Bool $ arg1 == arg2
eqv [Number arg1, Number arg2] = return $ Bool $ arg1 == arg2
eqv [String arg1, String arg2] = return $ Bool $ arg1 == arg2
eqv [Atom   arg1, Atom arg2  ] = return $ Bool $ arg1 == arg2
eqv [DottedList xs x, DottedList ys y] =
    eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [List arg1, List arg2] =
    return $ Bool $ (length arg1 == length arg2) && all eqvPair (zip arg1 arg2)
  where
    eqvPair (x1, x2) = case eqv [x1, x2] of
        Left  err        -> False
        Right (Bool val) -> val
eqv [_, _]     = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList

data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)

unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
    do
            unpacked1 <- unpacker arg1
            unpacked2 <- unpacker arg2
            return $ unpacked1 == unpacked2
        `catchError` (const $ return False)

equal :: [LispVal] -> ThrowsError LispVal
equal [(List arg1), (List arg2)] =
    return $ Bool $ (length arg1 == length arg2) && all equalPair
                                                        (zip arg1 arg2)
  where
    equalPair (x1, x2) = case equal [x1, x2] of
        Left  err        -> False
        Right (Bool val) -> val
equal [(DottedList xs x), (DottedList ys y)] =
    equal [List $ xs ++ [x], List $ ys ++ [y]]
equal [arg1, arg2] = do
    primitiveEquals <- fmap or $ mapM
        (unpackEquals arg1 arg2)
        [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
    eqvEquals <- eqv [arg1, arg2]
    return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

stringLen :: [LispVal] -> ThrowsError LispVal
stringLen [(String s)] = return $ Number $ fromIntegral $ length s
stringLen [notString ] = throwError $ TypeMismatch "string" notString
stringLen badArgList   = throwError $ NumArgs 1 badArgList

stringRef :: [LispVal] -> ThrowsError LispVal
stringRef [(String s), (Number k)]
    | length s < k' + 1 = throwError $ Default "Out of bound error"
    | otherwise         = return $ Character $ s !! k'
    where k' = fromIntegral k
stringRef [(String s), notNum] = throwError $ TypeMismatch "number" notNum
stringRef [notString , _     ] = throwError $ TypeMismatch "string" notString
stringRef badArgList           = throwError $ NumArgs 2 badArgList

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives =
    [ ("+"             , numericBinop (+))
    , ("-"             , numericBinop (-))
    , ("*"             , numericBinop (*))
    , ("/"             , numericBinop div)
    , ("mod"           , numericBinop mod)
    , ("quotient"      , numericBinop quot)
    , ("remainder"     , numericBinop rem)
    , ("symbol?"       , unaryOp symbolp)
    , ("string?"       , unaryOp stringp)
    , ("number?"       , unaryOp numberp)
    , ("bool?"         , unaryOp boolp)
    , ("list?"         , unaryOp listp)
    , ("symbol->string", unaryOp symbol2string)
    , ("string->symbol", unaryOp string2symbol)
    , ("="             , numBoolBinop (==))
    , ("<"             , numBoolBinop (<))
    , (">"             , numBoolBinop (>))
    , ("/="            , numBoolBinop (/=))
    , (">="            , numBoolBinop (>=))
    , ("<="            , numBoolBinop (<=))
    , ("&&"            , boolBoolBinop (&&))
    , ("||"            , boolBoolBinop (||))
    , ("string=?"      , strBoolBinop (==))
    , ("string<?"      , strBoolBinop (<))
    , ("string>?"      , strBoolBinop (>))
    , ("string<=?"     , strBoolBinop (<=))
    , ("string>=?"     , strBoolBinop (>=))
    , ("car"           , car)
    , ("cdr"           , cdr)
    , ("cons"          , cons)
    , ("eq?"           , eqv)
    , ("eqv?"          , eqv)
    , ("equal?"        , equal)
    , ("string-length" , stringLen)
    , ("string-ref"    , stringRef)
    ]

applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args)     = apply func args

makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode

closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _           = return $ Bool False

readProc :: [LispVal] -> IOThrowsError LispVal
readProc []          = readProc [Port stdin]
readProc [Port port] = liftIO (hGetLine port) >>= liftThrows . readExpr

writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj]            = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)

readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = fmap String $ liftIO $ readFile filename

load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList

readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename

ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives =
    [ ("apply"            , applyProc)
    , ("open-input-file"  , makePort ReadMode)
    , ("open-output-file" , makePort WriteMode)
    , ("close-input-port" , closePort)
    , ("close-output-port", closePort)
    , ("read"             , readProc)
    , ("write"            , writeProc)
    , ("read-contents"    , readContents)
    , ("read-all"         , readAll)
    ]

primitiveBindings :: IO Env
primitiveBindings =
    nullEnv
        >>= (  flip bindVars
            $  map (makeFunc IOFunc)        ioPrimitives
            ++ map (makeFunc PrimitiveFunc) primitives
            )
    where makeFunc constructor (var, func) = (var, constructor func)

apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
apply (PrimitiveFunc func) args = liftThrows $ func args
apply (Func params varargs body closure) args =
    if num params /= num args && varargs == Nothing
        then throwError $ NumArgs (num params) args
        else
            (liftIO $ bindVars closure $ zip params args)
            >>= bindVarArgs varargs
            >>= evalBody
  where
    remainingArgs = drop (length params) args
    num           = toInteger . length
    evalBody env = liftM last $ mapM (eval env) body
    bindVarArgs arg env = case arg of
        Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
        Nothing      -> return env
apply (IOFunc func) args = func args

type Env = IORef [(String, IORef LispVal)]

nullEnv :: IO Env
nullEnv = newIORef []

type IOThrowsError = ExceptT LispError IO

liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left  err) = throwError err
liftThrows (Right val) = return val

runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runExceptT (trapError action) >>= return . extractValue

isBound :: Env -> String -> IO Bool
isBound envRef var =
    readIORef envRef >>= return . maybe False (const True) . lookup var

getVar :: Env -> String -> IOThrowsError LispVal
getVar envRef var = do
    env <- liftIO $ readIORef envRef
    maybe (throwError $ UnboundVar "Getting an unbound variable" var)
          (liftIO . readIORef)
          (lookup var env)

setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value = do
    env <- liftIO $ readIORef envRef
    maybe (throwError $ UnboundVar "Setting an unbound variable" var)
          (liftIO . (flip writeIORef value))
          (lookup var env)
    return value

defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
    alreadyDefined <- liftIO $ isBound envRef var
    if alreadyDefined
        then setVar envRef var value >> return value
        else liftIO $ do
            valueRef <- newIORef value
            env      <- readIORef envRef
            writeIORef envRef ((var, valueRef) : env)
            return value

bindVars :: Env -> [(String, LispVal)] -> IO Env
bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
  where
    extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
    addBinding (var, value) = do
        ref <- newIORef value
        return (var, ref)

makeFunc varargs env params body =
    return $ Func (map showVal params) varargs body env
makeNormalFunc = makeFunc Nothing
makeVarArgs = makeFunc . Just . showVal

eval :: Env -> LispVal -> IOThrowsError LispVal
eval env val@(String _                             ) = return val
eval env val@(Number _                             ) = return val
eval env val@(Bool   _                             ) = return val
eval env (    Atom   id                            ) = getVar env id
eval env (    List   [Atom "quote", val]           ) = return val
eval env (    List   [Atom "if", pred, conseq, alt]) = do
    result <- eval env pred
    case result of
        Bool True  -> eval env conseq
        Bool False -> eval env alt
        otherwise  -> throwError $ TypeMismatch "boolean" otherwise
eval env form@(List (Atom "cond" : clauses)) = if null clauses
    then throwError $ BadSpecialForm "no true clause in cond expression: " form
    else case head clauses of
        List [Atom "else", expr] -> eval env expr
        List [test, expr] ->
            eval env $ List
                [Atom "if", test, expr, List (Atom "cond" : tail clauses)]
        _ -> throwError $ BadSpecialForm "ill-formed cond expression" form
-- eval env form@(List (Atom "case" : key : clauses)) =
--     if null clauses
--         then throwError $ BadSpecialForm "no true clause in case expression: " form
--         else case head clauses of
--             List (Atom "else" : exprs) -> mapM (eval env) exprs >>= return . last
--             List ((List datums) : exprs) ->
--                 do
--                     result <- eval env key
--                     equality <- liftThrows $ mapM (\x -> eqv [result, x]) datums
--                     if Bool True `elem` equality
--                         then mapM (eval env) exprs >>= return . last
--                         else eval env $ List (Atom "case" : key : tail clauses)
--             _ -> throwError $ BadSpecialForm "ill-formed case expression" form
eval env (List [Atom "set!", Atom var, form]) =
    eval env form >>= setVar env var
eval env (List [Atom "define", Atom var, form]) =
    eval env form >>= defineVar env var
eval env (List (Atom "define" : List (Atom var : params) : body)) =
    makeNormalFunc env params body >>= defineVar env var
eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body))
    = makeVarArgs varargs env params body >>= defineVar env var
eval env (List (Atom "lambda" : List params : body)) =
    makeNormalFunc env params body
eval env (List (Atom "lambda" : DottedList params varargs : body)) =
    makeVarArgs varargs env params body
eval env (List (Atom "lambda" : varargs@(Atom _) : body)) =
    makeVarArgs varargs env [] body
eval env (List [Atom "load", String filename]) =
    load filename >>= liftM last . mapM (eval env)
eval env (List (func : args)) = do
    func    <- eval env func
    argVals <- mapM (eval env) args
    apply func argVals
eval env badForm =
    throwError $ BadSpecialForm "Unrecognized special form" badForm

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
    Left  err -> throwError $ Parser err
    Right val -> return val

readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)

flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout

readPrompt :: String -> IO String
readPrompt prompt = flushStr prompt >> getLine

evalString :: Env -> String -> IO String
evalString env expr =
    runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env

evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr = evalString env expr >>= putStrLn

runOne :: [String] -> IO ()
runOne args = do
    env <- primitiveBindings
        >>= flip bindVars [("args", List $ map String $ drop 1 args)]
    (runIOThrows $ liftM show $ eval
            env
            (List [Atom "load", String (args !! 0)])
        )
        >>= hPutStrLn stderr

until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
until_ pred prompt action = do
    result <- prompt
    if pred result
        then return ()
        else action result >> until_ pred prompt action

runRepl :: IO ()
runRepl =
    primitiveBindings
        >>= until_ (== "quit") (readPrompt "Lisp>>> ")
        .   evalAndPrint

main :: IO ()
main = do
    args <- getArgs
    if null args then runRepl else runOne $ args