Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 132 lines (106 sloc) 3.5 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
{-# LANGUAGE RecordWildCards, ViewPatterns, DeriveFunctor, FlexibleInstances #-}
import Control.Applicative
import Control.Monad (MonadPlus(..), guard)
import Control.Monad.Fix (fix)
import Data.Char (isDigit, digitToInt, isSpace)

data Result d a
  = Pure a -- we didn't consume anything and can backtrack
  | Commit d a -- we consumed input
  | Fail String Bool -- we failed with a flag indicating if we have consumed input
  deriving Functor

newtype Rat d a = Rat { runRat :: d -> Result d a }
  deriving Functor

instance Applicative (Rat d) where
  pure a = Rat $ \ _ -> Pure a
  Rat mf <*> Rat ma = Rat $ \ d -> case mf d of
    Pure f -> fmap f (ma d)
    Fail s c -> Fail s c
    Commit d' f -> case ma d' of
      Pure a -> Commit d' (f a)
      Fail s _ -> Fail s True
      Commit d'' a -> Commit d'' (f a)

instance Alternative (Rat d) where
  Rat ma <|> Rat mb = Rat $ \ d -> case ma d of
    Fail _ False -> mb d
    x -> x
  empty = Rat $ \ _ -> Fail "empty" False

instance Monad (Rat d) where
  return a = Rat $ \_ -> Pure a
  Rat m >>= k = Rat $ \d -> case m d of
    Pure a -> runRat (k a) d
    Commit d' a -> case runRat (k a) d' of
      Pure b -> Commit d' b
      Fail s _ -> Fail s True
      commit -> commit
    Fail s c -> Fail s c
  fail s = Rat $ \ _ -> Fail s False

instance MonadPlus (Rat d) where
  mplus = (<|>)
  mzero = empty

try :: Rat d a -> Rat d a
try (Rat m) = Rat $ \d -> case m d of
  Fail s _ -> Fail s False
  x -> x

(</>) :: Rat d a -> Rat d a -> Rat d a
p </> q = try p <|> q
infixl 3 </>

class Stream d where
  anyChar :: Rat d Char

instance Stream [Char] where
  anyChar = Rat $ \s -> case s of
    (x:xs) -> Commit xs x
    [] -> Fail "EOF" False

whiteSpace :: Stream d => Rat d ()
whiteSpace = () <$ many (satisfy isSpace)

phrase :: Stream d => Rat d a -> Rat d a
phrase m = whiteSpace *> m <* eof

notFollowedBy :: Rat d a -> Rat d ()
notFollowedBy (Rat m) = Rat $ \d -> case m d of
  Fail{} -> Pure ()
  _ -> Fail "unexpected" False

eof :: Stream d => Rat d ()
eof = notFollowedBy $ anyChar

satisfy :: Stream d => (Char -> Bool) -> Rat d Char
satisfy p = try $ do
  x <- anyChar
  x <$ guard (p x)

char :: Stream d => Char -> Rat d Char
char c = satisfy (c ==)

lexeme :: Stream d => Rat d a -> Rat d a
lexeme m = m <* whiteSpace

symbol :: Stream d => Char -> Rat d Char
symbol c = lexeme (char c)

digit :: Stream d => Rat d Int
digit = digitToInt <$> satisfy isDigit

data D = D
  { _add :: Result D Int
  , _mult :: Result D Int
  , _primary :: Result D Int
  , _decimal :: Result D Int
  , anyCharD :: Result D Char
  }

-- makeRat ''D should output:
add, mult, primary, decimal :: Rat D Int
add = Rat _add
mult = Rat _mult
primary = Rat _primary
decimal = Rat _decimal

dv :: d -> (d -> b) -> b
dv d f = f d

instance Stream D where
  anyChar = Rat anyCharD

parse :: String -> D
parse s = fix $ \d -> let
  Rat (dv d -> _add) = (+) <$> mult <* symbol '+' <*> add </> mult
  Rat (dv d -> _mult) = (*) <$> primary <* symbol '*' <*> mult </> primary
  Rat (dv d -> _primary) = symbol '(' *> add <* symbol ')' </> decimal
  Rat (dv d -> _decimal) = foldl (\b a -> b * 10 + a) 0 <$> lexeme (some digit)
  anyCharD = case s of
    (x:xs) -> Commit (parse xs) x
    [] -> Fail "EOF" False
  in D { .. }

eval :: String -> Int
eval s = case runRat (whiteSpace *> add <* eof) (parse s) of
  Pure a -> a
  Commit _ a -> a
  _ -> error "Parse error"
Something went wrong with that request. Please try again.