module ErrType where

data Err a = Success a | Failure String   deriving Show
             
showErr :: Err Value -> String
showErr (Success a)   = showValue a
showErr (Failure str) = "Error: "++str

unitErr :: a -> Err a
unitErr a = Success a 

bindErr :: Err a -> (a -> Err b) -> Err b
m `bindErr` k = case m of 
                  Success a -> k a
                  Failure str   -> Failure str

type M a = Err a

unitM :: a -> M a
unitM a = unitErr a

bindM :: M a -> (a -> M b) -> M b 
m `bindM` k = m `bindErr` k

failM :: String -> M a
failM message = Failure message

--     by Daniel P. Friedman and Amr Sabry
mfixU :: ((a -> M b) -> M (a -> M b)) -> M (a -> M b)
mfixU f = f (\ a -> mfixU f `bindM` \ v -> v a)

tryM :: M a -> M a -> M a
tryM m1 m2 = case m1 of 
               Success v -> Success v
               Failure _ -> m2 

data Value = Num Double | Bool Bool | Str String | Char Char 
           | Fun (Value -> M Value) | Pair Value Value | Unit

-- Value値を表示するために必要
instance Show Value where 
  showsPrec p (Num d)  = showParen (p>8) (showString "Num " . shows d)
  showsPrec p (Bool b) = showParen (p>8) (showString "Bool " . shows b)
  showsPrec p (Str d)  = showParen (p>8)
                         (showString "Str " . showChar '"' . showString d. showChar '"')
  showsPrec p (Char c) = showParen (p>8) (showChar '\'' . showChar c . showChar '\'')
  showsPrec p (Fun f)  = showParen (p>8) (showString "Fun <function>")
  showsPrec p (Pair v1 v2) = showParen (p>8) (showChar '(' . showsPrec 0 v1 .
                                              showString ", " . showsPrec 0 v2 .
                                              showChar ')')
  showsPrec p Unit     = showString "Unit"

showValue (Num d)   = show d
showValue (Bool b)  = show b
showValue (Str str) = str
showValue (Char c)  = [c]
showValue (Fun _)   = "<function>"
showValue (Pair v1 v2) = "("++show v1++", "++show v2++")"
showValue Unit      = ""

-- Exprの抽象構文
type Decl = (String, Expr)
data Expr = Const Value | Var String | If Expr Expr Expr
          | Let Decl Expr | Letrec Decl Expr
          | Lambda String Expr | App Expr Expr
          | Try Expr Expr | Fail Expr deriving Show