module STType where 

type MyState = (Value, Value)
type ST a = MyState -> (a, MyState)

unitST :: a -> ST a
unitST a = \ s -> (a, s)

bindST :: ST a -> (a -> ST b) -> ST b
m `bindST` k = \ s0 -> let (a, s1) = m s0 in k a s1

type M a = ST a

unitM = unitST
bindM = bindST

--     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

setX :: Value -> M Value
setX v = \ (x, y) -> (Unit, (v, y)) 

setY :: Value -> M Value
setY v = \ (x, y) -> (Unit, (x, v))

getX :: M Value  
getX   = \ (x, y) -> (x, (x, y))

getY :: M Value  
getY   = \ (x, y) -> (y, (x, y))

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      = ""


-- STのテスト
factAux :: ST Value
factAux = getY               `bindM` \ (Num n) ->
          if n>0 then
            getX             `bindM` \ (Num p) ->
            setX (Num (n*p)) `bindM` \ _ ->
            setY (Num (n-1)) `bindM` \ _ ->
            factAux
          else
            getX
          

fact   :: Double -> ST Double
fact n = setX (Num 1) `bindM` \ _ -> 
         setY (Num n) `bindM` \ _ ->
         factAux      `bindM` \ (Num r) ->
         unitM r

factRun = fst (fact 10 (Unit, Unit))  -- 3628800.0

-- Exprの抽象構文
type Decl = (String, Expr)

data Expr = Const Value | Let Decl Expr | Var String  
          | Lambda String Expr | App Expr Expr | If Expr Expr Expr 
          | Letrec Decl Expr
          | GetX | SetX Expr | GetY | SetY Expr
          | While Expr Expr | Begin [Expr] 
            deriving Show