module NonDetType where 

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 Decls = [(String, Expr)] -}
type Decl = (String, Expr)

data Expr = Const Value | Let Decl Expr | Var String  
          | Lambda String Expr | App Expr Expr | If Expr Expr Expr 
          | Try Expr Expr
          | Letrec Decl Expr | Amb Expr Expr | Fail Expr
          {- | Uniq Expr -}
            deriving Show

data List a = Cons a (List a) | Failure String    deriving Show

nil :: List a
nil = Failure ""

hdL :: List a -> a
hdL (Cons a _) = a

tlL :: List a -> List a
tlL (Cons _ as) = as

showL (Cons a (Cons b cs)) = showValue a ++ " or " ++ showL (Cons b cs)
showL (Cons a _)           = showValue a
showL (Failure str)        = "Failure: " ++ str			

append :: List a -> List a -> List a
(Cons x xs) `append` ys = Cons x (xs `append` ys)
(Failure s) `append` (Failure "") = Failure s
(Failure s) `append` ys = ys

type M a = List a

unitM :: a -> M a
unitM a = Cons a nil

bindM :: M a -> (a -> M b) -> M b
(Cons x xs) `bindM` k = k x `append` (xs `bindM` k)
(Failure m) `bindM` k = Failure m

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 e = unitM (\ a -> mfixU e `bindM` \ v -> v a) `bindM` \ v ->
          e v

tryM :: List a -> List a -> List a
tryM (Failure _) ys = ys
tryM xs _           = xs