-- L05A Monads 
import Test.QuickCheck
import Parsing -- extention of RefactoredParser from last week
import Data.Char

-- Monad recap: sequence
sequence' [] = return []
sequence' (i:is) = i >>= \a -> 
                     is >>= \as ->    
                        return $ a:as

i1 = sequence [getLine, takeWhile (/= '\n') `fmap` (readFile "L05A.hs"), getLine]

i2 :: Gen [[Bool]]
i2 = sequence [vectorOf n arbitrary | n <- [0..3]]




-- Parser as a Monad.
-- First a recap: Using >->, chain, and >*>
blist = do 
    char '{'  
    ds <- chain digit (char ',') 
    char '}' 
    return (map digitToInt ds)

-- >*> is >>=, >-> is >>
prop_blist s = 
 parse blist ("{1,2,3,4}" ++ s) == Just ([1,2,3,4], s)






-----------------------------------------
{--- Example of another Monad: Maybe
-- from the Prelude:
 instance Monad Maybe where
    return         = Just

    Nothing  >>= f = Nothing
    (Just x) >>= f = f x

-----------------------------------------}

type CarReg = String ; type PNr = String  
type Name = String   ; type Address = String

carRegister :: [(CarReg,PNr)]
carRegister
 = [("FYN 433","850219-1234"),
    ("GYN 434","850219-1234"),
    ("JBD 007","750408-0909")]

nameRegister :: [(PNr,Name)]
nameRegister 
 = [("750408-0909","Dave")
   ,("850219-1234","Bob") 
   ,("890929-C234","Pierre")]             

addressRegister :: [((Name,PNr),Address)]
addressRegister = 
  [(("Dave","750408-0909"),"42 Streetgatan\n Askim")
  ,(("Bob","850219-1234") ,"1 Chalmers Av\n Gothenburg") ]

billingAddress :: CarReg -> Maybe (Name, Address)
-- given a registration number, 
-- returns the name and address of owner, if defined. 

billingAddress car = case lookup car carRegister of
               Nothing -> Nothing
               Just pn -> case lookup pn nameRegister of 
                    Nothing -> Nothing
                    Just name -> 
                       case lookup (name,pn) addressRegister of
                               Nothing -> Nothing 
                               Just addr -> Just (name,addr)


-- Monadic style:
billingAddress' car = lookup car carRegister >>= \pn -> 
               do 
                name <- lookup pn nameRegister
                addr <- lookup (name,pn) addressRegister
                return (name,addr)
test' = do 
     return 32
     x <- Nothing
     return 42


-- The fail function gives an error by default
test = do putStrLn "hello"
          "42" <- getLine
          putStrLn "World"




----------------
type Stack = [Int]

newtype StackOp a = StackOp (Stack -> (a,Stack))

run :: StackOp a -> Stack -> (a,Stack) 
run (StackOp f) s = f s

pop :: StackOp Int
pop = StackOp $ \(x:xs) -> (x,xs) -- can fail

push :: Int -> StackOp ()
push i = StackOp $ \s -> ((),i:s)

add :: StackOp ()
add = StackOp $ \(x:y:xs) -> ((),x+y:xs) -- can fail

emptyStack = []

-- (>>=) :: StackOp a -> (a -> StackOp b) -> StackOp b
instance Monad StackOp
  where return n = StackOp $ \s -> (n,s)
        sop >>= f  = StackOp $ \s -> 
                           let (i,s') = run sop s
                           in run (f i) s'
swap' :: StackOp ()
swap' = StackOp $ \s -> 
          let (a,s') = run pop s
              (b,s'') = run pop s'
              (_,s''') = run (push a) s''
          in  run (push b) s'''
swap = do 
     a <- pop
     b <- pop
     push a
     push b