fork download 
  1. import Control.Concurrent
  2. import Control.Monad
  3.  
  4. data Knob = Turned | Unturned
  5. data ExtensionDoor e = Opened Knob e | Closed Knob e
  6.  
  7. class Door a where
  8.   createDoor :: IO a
  9.   isOpen, isClose, canBeOpened :: a -> IO Bool
  10.   pull, push, knobTurn, knobUnturn :: a -> IO ()
  11.  
  12.   isClose door = return . not =<< (isOpen door)
  13.  
  14. type Ordinary = ()
  15. newtype OrdinaryDoor = OrdinaryDoor (MVar (ExtensionDoor Ordinary))
  16.  
  17. instance Door (OrdinaryDoor) where
  18.   createDoor = do
  19.     m <- newMVar (Closed Unturned ())
  20.     return (OrdinaryDoor m)
  21.   isOpen (OrdinaryDoor m) = do
  22.     door <- takeMVar m
  23.     putMVar m door
  24.     return $ case door of
  25.       Opened _ _-> True
  26.       _ -> False
  27.  
  28.   canBeOpened (OrdinaryDoor m) = do
  29.     door <- takeMVar m
  30.     putMVar m door
  31.     return $ case door of
  32.       Closed Turned _ -> True
  33.       _ -> False
  34.  
  35.   pull (OrdinaryDoor m) = do
  36.     _ <- takeMVar m
  37.     putMVar m (Closed Unturned ())
  38.  
  39.   push (OrdinaryDoor m) = do
  40.     door <- takeMVar m
  41.     putMVar m $ case door of
  42.       Closed Turned _ -> Opened Unturned ()
  43.       _ -> door
  44.  
  45.   knobTurn (OrdinaryDoor m) = do
  46.     door <- takeMVar m
  47.     putMVar m $ case door of
  48.       Closed Unturned _ -> Closed Turned ()
  49.       Opened Unturned _ -> Opened Turned ()
  50.       _ -> door
  51.  
  52.   knobUnturn (OrdinaryDoor m) = do
  53.     door <- takeMVar m
  54.     putMVar m $ case door of
  55.       Closed Turned _ -> Closed Unturned ()
  56.       _ -> door
  57.  
  58.  
  59. test1 :: IO ()
  60. test1 = do
  61.   door <- createDoor :: IO OrdinaryDoor
  62.   putStrLn "door is a Door"
  63.  
  64.   knobTurn door 
  65.   putStrLn . ("knobTurn door; canBeOpened door => " ++) . show =<< canBeOpened door
  66.  
  67.   knobUnturn door
  68.   putStrLn . ("knobUnturn door; canBeOpened door => " ++) . show =<< canBeOpened door
  69.  
  70.   push door
  71.   putStrLn . ("push door; isOpen door => " ++) . show =<< isOpen door
  72.  
  73.   knobTurn door
  74.   push door
  75.   putStrLn . ("knobTurn door; push door; isOpen door => " ++) . show =<< isOpen door
  76.  
  77.   pull door
  78.   putStrLn . ("push door; isOpen door => " ++) . show =<< isOpen door
  79.   putStrLn . ("canBeOpened door => " ++) . show =<< canBeOpened door
  80.  
  81. main :: IO ()
  82. main = test1
  83.  
Success #stdin #stdout 0s 8388607KB
comments (?)
stdin 
Standard input is empty
stdout 
door is a Door
knobTurn door; canBeOpened door => True
knobUnturn door; canBeOpened door => False
push door; isOpen door => False
knobTurn door; push door; isOpen door => True
push door; isOpen door => False
canBeOpened door => False
https://ideone.com/E7lfRB
language:
Haskell (ghc 8.4.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!