content: {-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}
  
  -- Simple expression parser
  -- (uses do-notation and operators)
  
  module Main(main) where
  
  import Control.Arrow
  import Control.Category
  import Data.Char
  import Prelude hiding (id, (.))
  
  -- Parsers
  
  class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
          symbol :: s -> a b String
  
  data Sym s = Sym { token :: s, value :: String }
  
  -- Simple backtracking instance
  
  newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])
  
  instance Category (BTParser s) where
          id = BTParser $ \a ss -> [(a, ss)]
          BTParser f . BTParser g = BTParser $ \b ss ->
                  [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']
  
  instance Arrow (BTParser s) where
          arr f = BTParser $ \a ss -> [(f a, ss)]
          first (BTParser f) = BTParser $ \(b,d) ss ->
                  [((c,d), ss') | (c,ss') <- f b ss]
  
  instance ArrowZero (BTParser s) where
          zeroArrow = BTParser $ \b ss -> []
  
  instance ArrowPlus (BTParser s) where
          BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss
  
  instance (Eq s, Show s) => ArrowParser s (BTParser s) where
          symbol s = BTParser $ \b ss ->
                  case ss of
                  Sym s' v:ss' | s' == s -> [(v, ss')]
                  _ -> []
  
  runBTParser :: BTParser s () c -> [Sym s] -> c
  runBTParser (BTParser parser) syms =
          head [c | (c, []) <- parser () syms]
  
  -- Expressions
  
  data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
          deriving (Show, Eq, Ord)
  
  type ExprParser = BTParser ESym
  type ExprSym = Sym ESym
  
  -- The grammar
  
  expr :: ExprParser () Int
  expr = proc () -> do
                  x <- term -< ()
                  expr' -< x
  
  expr' :: ExprParser Int Int
  expr' = proc x -> do
                  returnA -< x
          <+> do
                  (|(symbol Plus)|)
                  y <- term -< ()
                  expr' -< x + y
          <+> do
                  (|(symbol Minus)|)
                  y <- term -< ()
                  expr' -< x - y
  
  term :: ExprParser () Int
  term = proc () -> do
                  x <- factor -< ()
                  term' -< x
  
  term' :: ExprParser Int Int
  term' = proc x -> do
                  returnA -< x
          <+> do
                  (|(symbol Mult)|)
                  y <- factor -< ()
                  term' -< x * y
          <+> do
                  (|(symbol Div)|)
                  y <- factor -< ()
                  term' -< x `div` y
  
  factor :: ExprParser () Int
  factor = proc () -> do
                  v <- (|(symbol Number)|)
                  returnA -< read v::Int
          <+> do
                  (|(symbol Minus)|)
                  v <- factor -< ()
                  returnA -< -v
          <+> do
                  (|(symbol LPar)|)
                  v <- expr -< ()
                  (|(symbol RPar)|)
                  returnA -< v
  
  -- Lexical analysis
  
  lexer :: String -> [ExprSym]
  lexer [] = []
  lexer ('(':cs) = Sym LPar "(":lexer cs
  lexer (')':cs) = Sym RPar ")":lexer cs
  lexer ('+':cs) = Sym Plus "+":lexer cs
  lexer ('-':cs) = Sym Minus "-":lexer cs
  lexer ('*':cs) = Sym Mult "*":lexer cs
  lexer ('/':cs) = Sym Div "/":lexer cs
  lexer (c:cs)
          | isSpace c = lexer cs
          | isDigit c = Sym Number (c:w):lexer cs'
          | otherwise = Sym Unknown [c]:lexer cs
                  where (w,cs') = span isDigit cs
  
  parse = runBTParser expr . lexer
  
  main = do
          print (parse "1+2*(3+4)")
          print (parse "3*5-17/3+4")
  