hw2-monads.hs

import Data.Char (isDigit)

data Month = January | February | March | April | May | June
           | July | August | September | October | November | December
           deriving (Show)

data DSTType =
     DayV Integer
   | MonthV Month
   | Year Integer
   | Constant
   deriving (Show)

-- First we'll define a generic parser, it will take
-- a string and maybe return a token of type `a`
-- along with the rest of the string, or it will fail and
-- return Nothing
-- (We wrap this in a newtype instead of simply doing 
--  `type Parser a = String -> Maybe (a, String)` due 
--  to some technical limitations with Haskell's type system)
newtype Parser a = Parser { getP :: String -> Maybe (a, String) }
-- DateParser is a specific type of parser whose tokens are 
-- of type DSTType
type DateParser = Parser [DSTType]

-- In order to define a Monad, our class needs to be an instance
-- of Applicative and Functor. 
-- You can skip straight to the Monad definition.
instance Functor Parser where
    fmap f (Parser p) = Parser $ \s -> case (p s) of
                                    Nothing -> Nothing
                                    Just (tok, s') -> Just (f tok, s') 
instance Applicative Parser where
    pure value = Parser $ \s -> Just(value, s)
    (<*>) (Parser p1) (Parser p2) = Parser $ \s -> case (p1 s) of
                                        Nothing -> Nothing
                                        Just (f, s') -> case (p2 s') of
                                            Just (val, s'') -> 
                                                Just (f val, s'')

-- Now we'll define a Monad for the Parser type:
instance Monad Parser where
    -- Our pure return will be a parser that simply returns a value
    -- as a token and doesn't consume the string at all.
    -- As an example, when we do:
    --
    -- alwaysReturnJanuary :: DateParser
    -- alwaysReturnJanuary = return ([MonthV January])
    --
    -- alwaysReturnJanuary "someString" => Just ([MonthV January], "someString")
    return value = Parser $ \s -> Just (value, s)

    -- Next up, the bind operator. We will start with an initial parser,
    -- run it on the string. This provides us with some token and the
    -- rest of the string, we will then bind `f` on the token and
    -- use it to parse the rest of the string.
    (>>=) initial f = Parser $ \s ->
                                case (getP initial) s of
                                    Nothing -> Nothing
                                    (Just (tok, s1)) ->
                                        getP (f tok) s1

-- Define a special operator `>>>` that combines two parsers
(>>>) :: Parser [a] -> Parser [a] -> Parser [a]
(>>>) p1 p2 = do
    tok1 <- p1
    tok2 <- p2
    return (tok1 ++ tok2)

throwError :: Parser a
throwError = Parser $ \s -> Nothing

try :: Parser a -> Parser a -> Parser a
try p1 p2 = Parser $ \s ->
    case (getP p1) s of 
        (Just val) -> return val
        Nothing    -> (getP p2) s

-- First lets define a Parser that reads n characters
-- from the stream
nChars :: Int -> Parser String
nChars n = Parser $ \s ->
    if (length s) < n then Nothing else Just ((take n s), drop n s)

-- We will now define a Parser that parses n digits
digits :: Int -> Parser Integer
digits n = do
    rawDigits <- nChars n
    if (all isDigit rawDigits)
        then return (read rawDigits)
        else throwError

-- Using these primitive definitions, we can now define every other parser
year :: DateParser
year = do
    num <- digits 4 `try` digits 3 `try` digits 2
    return [(Year num)]

day :: DateParser
day = do
    num <- digits 2 `try` digits 1
    return [(DayV num)]

constant :: String -> DateParser
constant str = do
    rawChars <- nChars (length str)
    if rawChars == str
        then return []
        else throwError

namedDay :: DateParser
namedDay = constant "Monday" `try` constant "Tuesday" `try` constant "Wednesday" `try` 
            constant "Thursday" `try` constant "Friday" `try` constant "Saturday" `try` 
            constant "Sunday"

constantWithValue :: String -> DSTType -> DateParser
constantWithValue str val = do
    constant str
    return [val]

-- (Metaprogramming would be useful here)
january = constantWithValue "January" (MonthV January);       february = constantWithValue "February" (MonthV February)
march = constantWithValue "March" (MonthV March);             april = constantWithValue "April" (MonthV April)
may = constantWithValue "May" (MonthV May);                   june = constantWithValue "June" (MonthV June)
july = constantWithValue "July" (MonthV July);                august = constantWithValue "August" (MonthV August)
september = constantWithValue "September" (MonthV September); october = constantWithValue "October" (MonthV October)
november = constantWithValue "November" (MonthV November);    december = constantWithValue "December" (MonthV December)

namedMonth :: DateParser
namedMonth = january `try` february `try` march `try` april `try`
                may `try` june `try` july `try` august `try` september `try`
                october `try` november `try` december

-- Example of how to construct a larger parser:
longDate :: DateParser
longDate = namedDay >>> constant ", " >>> namedMonth >>> constant " " >>> 
            day >>> constant ", " >>> year

-- (getP longDate) "Monday, June 15, 2009"