basic applicative parser

applicative-parse.hs

module Parser1 where

-- | On importe uniquement quelques types de base, quelques fonctions
-- et quelques opérateurs habituels

import Prelude ( String, Maybe(..), Char, Int, Show(..),
                 fmap, fst, read,
                 splitAt, length, span, elem,
                 ($), (.), (==), (+), (*) )


-- | Le type parser, un simple alias
type Parser a = String -> Maybe (a, String)

-- | La fonction utilitaire pour utiliser un Parser sur une String
parseWith :: Parser a -> String -> Maybe a
parseWith p s = fmap fst $ p s

-- | le couple en tant que foncteur (utilitaire)
mapFst :: (a -> b) -> (a, c) -> (b, c)
mapFst f (x,y) = (f x, y)

-- | Parser est un foncteur avec son map, ici en infix
(<$>) :: (a -> b) -> Parser a -> Parser b
f <$> p =  fmap (mapFst f) . p

-- | Parser est pointé avec pure
pureParser :: a -> Parser a
pureParser x = \s -> Just (x, s)

-- | On définit le combinateur apply
(<*>) :: Parser (a -> b) -> Parser a -> Parser b
p1 <*> p2 = \s -> case p1 s of
  Just (f, s') -> f <$> p2 $ s'
  Nothing -> Nothing

-- | Ignore left
(*>) :: Parser a -> Parser b -> Parser b
p1 *> p2 = pureParser (\_ x -> x) <*> p1 <*> p2
        
-- | Ignore right
(<*) :: Parser a -> Parser b -> Parser a
p1 <* p2 = pureParser (\x _ -> x) <*> p1 <*> p2

-- | Alternative
(<|>) :: Parser a -> Parser a -> Parser a
p1 <|> p2 = \s ->  case p1 s of
  Nothing -> p2 s
  x -> x



-- | C'est tout pour la librairie du parseur. Quelques parseurs
-- élémentaires de strings maintenant
  
string :: String -> Parser String
string l = \s -> let (f,rst) = splitAt (length l) s in
  if f == l then Just (l, rst) else Nothing

spaces :: Parser String
spaces = \s -> case span (== ' ') s of
  ([],_) -> Nothing
  x      -> Just x

char :: Char -> Parser Char
char c = \s -> case s of
  (h:tl) -> if h == c then Just (c,tl) else Nothing
  _      -> Nothing

readInt :: Parser Int
readInt = \s -> case span (\c -> elem c "0123456789") s of
  ([],_)       -> Nothing
  (digits, s') -> Just (read digits, s')

paren :: Parser a -> Parser a
paren p = char '(' *> p <* char ')'


-- | On va maintenant utiliser tout ça pour parser notre structure de
-- donnée qui suit

data Expr = Const Int
          | Add Expr Expr
          | Mul Expr Expr
          deriving (Show)
                   
-- | évaluation de l'arbre
eval :: Expr -> Int
eval (Const i) = i
eval (Add x y) = eval x + eval y
eval (Mul x y) = eval x * eval y

-- | Quelques parseurs simples propres à notre structure 
const :: Parser Expr
const = Const <$> readInt

-- | Tout d'abord, un parseur très simple pour la notation prefix avec
-- parenthèses. 

parsePrefix :: String -> Maybe Int
parsePrefix s = fmap eval $ parseWith expr s
  where
    expr = const <|> add <|> mul
    add  = sexpr2 "+" Add
    mul  = sexpr2 "*" Mul

    sexpr2 name cons = paren $ string name *> spaces *> (cons <$> expr <~> expr)

    p1 <~> p2 = p1 <*> (spaces *> p2)

testPrefix :: Maybe Int
testPrefix = parsePrefix "(+ 56 (* 28 45))"


-- | Parseur un peu plus compliqué maintenant pour la notation infix

parseInfix :: String -> Maybe Int
parseInfix s = fmap eval $ parseWith expr s
  where 
    expr = add <|> term
    term = mul <|> factor
    factor = paren expr <|> const
    add = infixOp Add term "+" expr
    mul = infixOp Mul factor "*" (mul <|> factor)
    infixOp cons l op r = cons <$> (l <* spaces <* string op <* spaces) <*> r


testInfix :: Maybe Int
testInfix = parseInfix "3 + 3 + 2 * 2 * 2 + 3 + 3"