mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-09-11 19:47:31 +03:00
105 lines
2.2 KiB
Haskell
105 lines
2.2 KiB
Haskell
{-# LANGUAGE RankNTypes #-}
|
|
|
|
import Control.Monad
|
|
|
|
type Name = String
|
|
|
|
data ExprP a
|
|
= VarP a
|
|
| GlobalP Name
|
|
| AppP (ExprP a) (ExprP a)
|
|
| LamP (a -> ExprP a)
|
|
| LitP Char
|
|
| EffectP a
|
|
|
|
data Value
|
|
= VChar Char
|
|
| VFun (Value -> Value)
|
|
| VEffect (IO Value)
|
|
| VUnit
|
|
|
|
instance Show Value where
|
|
show (VChar x) = show x
|
|
show (VUnit) = "()"
|
|
show (VFun _) = "<<function>>"
|
|
show (VEffect {}) = "<<effect>>"
|
|
|
|
newtype Expr = Expr { unExpr :: forall a . ExprP a }
|
|
|
|
fromVFun :: Value -> (Value -> Value)
|
|
fromVFun val = case val of
|
|
VFun f -> f
|
|
_ -> error "not a function"
|
|
|
|
fromVChar :: Value -> Char
|
|
fromVChar val = case val of
|
|
VChar n -> n
|
|
_ -> error "not a char"
|
|
|
|
fromVEff :: Value -> (IO Value)
|
|
fromVEff val = case val of
|
|
VEffect f -> f
|
|
_ -> error "not an effect"
|
|
|
|
lam :: (Value -> Value) -> Value
|
|
lam = VFun
|
|
|
|
unary :: (Value -> Value) -> Value
|
|
unary f = lam $ \a -> f a
|
|
|
|
binary :: (Value -> Value -> Value) -> Value
|
|
binary f = lam $ \a ->
|
|
lam $ \b -> f a b
|
|
|
|
prim :: Name -> Value
|
|
prim op = case op of
|
|
"putChar#" -> unary $ \x ->
|
|
VEffect $ do
|
|
putChar (fromVChar x)
|
|
return VUnit
|
|
|
|
"getChar#" -> VEffect $ do
|
|
val <- getChar
|
|
return (VChar val)
|
|
|
|
"bindIO#" -> binary $ \x y -> bindIO x y
|
|
"returnIO#" -> unary $ \x -> returnIO x
|
|
"thenIO#" -> binary $ \x y -> thenIO x y
|
|
|
|
bindIO :: Value -> Value -> Value
|
|
bindIO (VEffect f) (VFun g) = VEffect (f >>= fromVEff . g)
|
|
|
|
thenIO :: Value -> Value -> Value
|
|
thenIO (VEffect f) (VEffect g) = VEffect (f >> g)
|
|
|
|
returnIO :: Value -> Value
|
|
returnIO a = VEffect $ return a
|
|
|
|
eval :: Expr -> Value
|
|
eval e = ev (unExpr e) where
|
|
ev (LamP f) = VFun(ev . f)
|
|
ev (AppP e1 e2) = fromVFun (ev e1) (ev e2)
|
|
ev (LitP n) = VChar n
|
|
ev (EffectP v) = v
|
|
ev (VarP v) = v
|
|
ev (GlobalP op) = prim op
|
|
|
|
gets, puts, bind, seqn :: ExprP a
|
|
gets = GlobalP "getChar#"
|
|
puts = GlobalP "putChar#"
|
|
bind = GlobalP "bindIO#"
|
|
seqn = GlobalP "thenIO#"
|
|
|
|
run :: Expr -> IO ()
|
|
run f = void (fromVEff (eval f))
|
|
|
|
|
|
example1 :: IO ()
|
|
example1 = run $ Expr (AppP (AppP bind gets) puts)
|
|
|
|
example2 :: IO ()
|
|
example2 = run $ Expr $ foldr1 seq (str "Hello Haskell!\n")
|
|
where
|
|
seq a b = AppP (AppP seqn a) b
|
|
str xs = fmap (\c -> AppP puts (LitP c)) xs
|