gistfile1.hs

{-# LANGUAGE InstanceSigs #-}

import Control.Applicative
import Control.Monad

newtype Expr a = Expr { unExpr :: a }

instance Functor Expr where
    fmap f c = Expr $ f (eval c)

instance Applicative Expr where
    pure :: a -> Expr a
    pure = Expr

    (<*>) :: Expr (a -> b) -> Expr a -> Expr b
    f <*> x = Expr $ (eval f) (eval x)

instance Monad Expr where
    return :: a -> Expr a
    return  = pure

    (>>=) :: Expr a -> (a -> Expr b) -> Expr b
    m >>= k = k $ unExpr m

eval :: Expr a -> a
eval = unExpr

compile :: Expr a -> a
compile = eval

unroll :: [Expr a] -> Expr [a]
unroll (e:xs) = do
    tail <- unroll xs
    return $ eval e : tail
unroll [] = return []

square :: Int -> Int
square x = x * x

power :: Int -> Expr (Int -> Int)
power n
    | 0 <- n =
        return $ \x -> 1
    | 0 <- mod n 2 = do
        k <- power (n `div` 2)
        return $ square . k
    | otherwise = do
        k <- power (n-1)
        return $ \x -> x * k x

{-
fun pow n x =
    if n = 0 then
        <1>
    else
        <~x * ~(pow (n-1) x)>

cube = <fn y => ~(pow 3 <y>)>
-}
pow :: Int -> Expr (Int -> Int)
pow n
    = if n == 0 then return $ \x -> 1
      else do k <- pow (n-1)
              return $ \x -> x * k x

cube = pow 3

member :: Eq a => [a] -> Expr (a -> Bool)
member (x:xs) = do
    member' <- member xs
    return $ \v -> case x == v of
        True  -> True
        False -> member' v
member [] = return $ \v -> False

back :: (Expr a -> Expr b) -> Expr (a -> b)
back f =
    -- <\x-> ~(f <x>)>
    undefined

forth :: Expr (a -> b) -> Expr a -> Expr b
forth = (<*>)


main = do
    putStrLn $ show $ eval $ (+) <$> pure 3 <*> pure 4
    putStrLn $ show $ eval $ pure (\x -> x + x) <*> pure 3
    putStrLn $ show $ eval (power 3) 2
    putStrLn $ show $ eval (pow 3) 4

    putStrLn $ show $ eval (member [1, 2, 3, 4::Int]) 2
    putStrLn $ show $ eval (member [1, 2, 3, 4::Int]) 5