Parsec - Parser Combinators

> :script /tmp/parsecHelpers.hs 
apply :: Parser a -> String -> Either P.ParseError a
run :: Show a => Parser a -> String -> IO ()
... 
>

import Text.Parsec.String (Parser)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import qualified Text.Parsec.Char as PC

import Control.Monad (void)

import Data.Either (isRight, isLeft)

import Test.HUnit     

:set -XFlexibleContexts

:{
apply :: Parser a -> String -> Either P.ParseError a
apply p s =  P.parse p "" s
:}

:{
applyOpt :: Parser a -> String -> Maybe a
applyOpt p s = case P.parse p "" s of
               Left _  -> Nothing
               Right a -> Just a
:}                 


:{
run :: Show a => Parser a -> String -> IO ()
run p str =
    case P.parse p "" str of
      Left err  -> do putStrLn "Parser Error"
                      print err
      Right res -> print res
:} 

-- Parse single letter char
:{
pLetter :: Parser Char
pLetter = P.letter 
:}

-- Parse single char
:{ 
pChar :: Char -> Parser Char
pChar x = P.char x
:}

-- Parse single digit char
:{
pDigit :: Parser Char
pDigit = P.digit
:}

-- Parse string 
:{
pStr :: String -> Parser String
pStr str = P.string str 
:}

-- Parse letter surrounded by parenthesis.

:{
pParenLetter :: Parser Char
pParenLetter = do
  P.char '('     -- Consume input '(' and discard result 
  s <- P.letter  -- Consume the letter input and save it to s.
  P.char ')'     -- Consume input ')' and discard result
  return s       -- Set parser result to s 
:}  

:{
pParenLetter2 :: Parser Char
pParenLetter2 = 
  P.char '(' >>= \_ ->     
  P.letter   >>= \s -> 
  P.char ')' >>= \_ ->    
  return s       
:}  


:{
pParenLetter3 :: Parser Char
pParenLetter3 = 
  P.char '(' >>
  P.letter   >>= \s -> 
  P.char ')' >>
  return s       
:}  

--- Parser Choice
:{
pChoice1 :: Parser String
pChoice1 = P.string "hello world"
       <|> P.try (P.string "world")
       <|> P.try (P.string "Haskell")
       <|> P.try (P.string "ocaml")
:}


:{
pIdentifier1 :: Parser String
pIdentifier1 = do
  x  <- P.letter
  xs <- P.many (P.letter <|> P.try P.digit)
  return $ x:xs
:}


:{
pNumStr :: Parser String
pNumStr = P.many1 P.digit
:}          

:{
pNum1 :: Parser Int
pNum1 = do
  s <- P.many1 P.digit
  return $ read s   
:}   


:{
pNum2 :: Parser Int
pNum2 = fmap read $ P.many1 P.digit
     -- read <$> P.many P.digit
:}         


:{
pTrue :: Parser Bool
pTrue = P.string "true" >> return True
:}

:{
pFalse :: Parser Bool
pFalse = P.string "false" >> return False
:}


:{ 
pCsvRow1 :: Parser [Int]
pCsvRow1 = P.sepBy pCell (pChar ',')
    where
      pCell = do
        P.spaces
        num <- pNum1
        P.spaces
        return num

:}

:{
pLetter :: Parser Char
pLetter = P.letter 
:}

apply :: Parser a -> String -> Either P.ParseError a

> apply pLetter "1"
Left (line 1, column 1):
unexpected "1"
expecting letter
it :: Either P.ParseError Char

> apply pLetter ""
Left (line 1, column 1):
unexpected end of input
expecting letter
it :: Either P.ParseError Char
> 

> apply pLetter "2323"
Left (line 1, column 1):
unexpected "2"
expecting letter
it :: Either P.ParseError Char


> run pLetter "a"
'a'
it :: ()

run :: Show a => Parser a -> String -> IO ()

> run pLetter "aa"
'a'
it :: ()
> run pLetter "1aa"
Parser Error
(line 1, column 1):
unexpected "1"
expecting letter
it :: ()

> run pLetter " aa"
Parser Error
(line 1, column 1):
unexpected " "
expecting letter
it :: ()
>

:set -XFlexibleContexts

import Text.Parsec.String (Parser)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import qualified Text.Parsec.Char as PC

import Control.Monad (void, forever)
import Data.Either (isRight, isLeft)  

:{
run :: Show a => Parser a -> String -> IO ()
run p str =
    case P.parse p "" str of
      Left err  -> do putStrLn "Parser Error"
                      print err
      Right res -> print res
:} 


:{
pInt :: Parser Int
pInt = P.try pPos <|> pNeg
  where

    -- Parse positive number
    pPos = do 
      s <- P.many1 P.digit 
      return $ read s

    -- Parse negative number 
    pNeg = do
      P.char '-'
      n <- pPos
      return (-n)
:}


:{
-- | Parse float point numbers
-- |
pFloat :: Parser Double
pFloat = pNan
   <|> P.try pInfPlus
   <|> P.try pInfNeg
   <|> P.try (read <$> pExp)
   <|> P.try (read <$> pDot)
   <|> P.try (read <$> pNDot)       
    where
    -- Float point constants 
    pNan     = P.string "nan" >> return (read "NaN")
    pInfPlus = P.string "inf" >> return (read "Infinity")
    pInfNeg  = P.string "-inf" >> return (read "-Infinity")

    -- Parse positive number
    pPos = do 
      s <- P.many1 P.digit 
      return s

    -- Parse negative number 
    pNeg = do
      P.char '-'
      s <- pPos
      return $ "-" ++ s

    -- Parse number without dot like 200 or -435
    pNDot = P.try pPos <|> pNeg

    -- Parse number with dot
    pDot = do
      num1 <- P.try pPos <|> pNeg
      P.char '.'
      num2 <- pPos
      return $ num1 ++ "." ++ num2

    -- Parse number with format 10e3 20.23e5
    pExp = do
      num1 <- P.try pDot <|> pNDot
      P.oneOf "eE" -- e or E
      num2 <- pNDot
      return $ num1 ++ "E" ++ num2

:}

> run pInt "20023"
20023
it :: ()
> run pInt "-20023"
-20023

> run pInt "223 "
223
it :: ()
> run pInt "223 asa"
223

> run (pInt <* P.eof) "-223"
-223
it :: ()
> run (pInt <* P.eof) "223"
223
it :: ()
> run (pInt <* P.eof) "223 "
Parser Error
(line 1, column 4):
unexpected ' '
expecting digit or end of input
it :: ()
> 

> mapM_ (run pFloat) ["inf", "nan", "-inf", "100", "0", "-0.0001", "1000e-2", "-100.23", "1e3", "1000", "-0.23e4"]
Infinity
NaN
-Infinity
100.0
0.0
-1.0e-4
10.0
-100.23
1000.0
1000.0
-2300.0
it :: ()
> 
>

import Text.Parsec.String (Parser)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import qualified Text.Parsec.Char as PC

import Control.Monad (void, forever)
import Data.Either (isRight, isLeft)


:{
pNum :: Parser Int
pNum = read <$> P.many1 P.digit    
:} 

:{
pOperation :: Char -> (Int -> Int -> Int) ->  Parser Int 
pOperation op fn = do
  numA <- pNum
  P.spaces
  P.char op
  P.spaces
  numB <- pNum
  return $ fn numA numB
:}

:{
pAdd = pOperation '+' (+)
pSub = pOperation '-' (-)
pMul = pOperation '*' (*)
pDiv = pOperation '/' div
pRem = pOperation '%' rem       
:}   

:{
pCalc :: Parser Int
pCalc = P.choice [P.try pAdd
                 ,P.try pSub
                 ,P.try pMul
                 ,P.try pDiv
                 ,P.try pRem
                 ]         
:}


:{
runCalculator :: IO ()
runCalculator =
    forever $ do
      line <- putStr "calc > " >> getLine
      run pCalc line
:}

> run pAdd "100 + 200"
300
it :: ()

> run pAdd "103+200"
303
it :: ()
> run pAdd "103+"
Parser Error
(line 1, column 5):
unexpected end of input
expecting white space or digit
it :: ()
> 

> run pCalc "2010 / 10"
201
it :: ()
>  
> run pCalc "100 % 432"
100
it :: ()
> run pCalc "203 - 126"
77
it :: ()
> run pCalc "203 + 126"
329
it :: ()
> run pCalc "203 * 126"
25578
it :: ()
> run pCalc "203 % 126"
77
it :: ()
> run pCalc "203 % "
Parser Error
(line 1, column 7):
unexpected end of input
expecting space or digit
it :: ()
> 

> runCalculator -- Run Ctrl + C to exit 
calc > 100 * 20
2000
calc > 89 - 100
-11
calc > 2323  ^?
Parser Error
(line 1, column 7):
unexpected "\DEL"
expecting space, "+", "-", "*", "/" or "%"
calc > 232 / 10
23
calc > 35 * 9
315
calc > 35 * 
Parser Error
(line 1, column 6):
unexpected end of input
expecting space or digit
calc > 
Parser Error
(line 1, column 1):
unexpected end of input
expecting digit
calc > ^CInterrupted.
>

:set -XFlexibleContexts

import Text.Parsec.String (Parser)
import Text.Parsec ((<|>))
import qualified Text.Parsec as P
import qualified Text.Parsec.Char as PC

import Control.Monad (void)

import Data.Either (isRight, isLeft)
import Text.Read (readMaybe)

import Test.HUnit     

import Data.List (intercalate)

:{
data Sexp = Sym   String
          | Str   String
          | List [Sexp]
          deriving (Eq, Read, Show)
:}



:{
apply :: Parser a -> String -> Either P.ParseError a
apply p s =  P.parse p "" s
:}

:{
applyOpt :: Parser a -> String -> Maybe a
applyOpt p s = case P.parse p "" s of
               Left _  -> Nothing
               Right a -> Just a
:}                 


:{
run :: Show a => Parser a -> String -> IO ()
run p str =
    case P.parse p "" str of
      Left err  -> do putStrLn "Parser Error"
                      print err
      Right res -> print res
:} 


:{
sexpToStr :: Sexp -> String
sexpToStr (Sym s)   = s
sexpToStr (Str s)   = "\"" ++ s ++ "\""
sexpToStr (List xs) = "( " ++ (intercalate " " $ map sexpToStr xs) ++ " )"
:}

:{ 
pStr :: Parser Sexp 
pStr = do
  P.char '"'
  s <- P.manyTill P.anyChar (P.char '"')
  return $ Str s
:}

:{
pSym :: Parser Sexp 
pSym = Sym <$> P.many1 p
      where
        pSym = P.oneOf "!$%&|*+-/:<=>?@^_~" 
        p = P.try P.letter <|> P.try P.digit <|> P.try pSym
:}   

:{
pList :: Parser Sexp
pList = do
  P.char '('
  P.spaces
  slist <- P.many (P.spaces *> p <* P.spaces)
  P.spaces          
  P.char ')'
  return $ List slist
      where
        p = P.try pStr <|> P.try pSym <|> P.try pList
:}

:{ 
pSexp :: Parser Sexp
pSexp = P.try pSym
    <|> P.try pStr
    <|> P.try pList
:}        

:{
sexpOfStr :: String -> Maybe Sexp    
sexpOfStr = applyOpt pSexp
:}

-- Convert a list of values to s-expression.
--
:{
sexpOfList :: (a -> Sexp) -> [a] -> Sexp
sexpOfList fn xs = List $ map fn xs               
:}   

:{
sexpOfValue :: Show a => a -> Sexp
sexpOfValue v = Sym $ show v
:}  

-- Tries to extract a list of values form a s-expression.
:{
sexpToList :: (Sexp -> Maybe a) -> Sexp -> Maybe [a]
sexpToList fn (Sym _)   = Nothing
sexpToList fn (Str _)   = Nothing
sexpToList fn (List xs) = sequence $ map fn xs                    
:}


-- Try to extract a single value from a s-expression. 
:{
sexpToValue :: Read a => Sexp -> Maybe a
sexpToValue sp =
    case sp of
      Sym s -> readMaybe s
      _     -> Nothing
:}


:{
sexpToInt    = sexpToValue :: Sexp -> Maybe Int
sexpToDouble = sexpToValue :: Sexp -> Maybe Double
:}

> :script /tmp/sexpSerial.hs 
data Sexp = Sym String | Str String | List [Sexp]
apply :: Parser a -> String -> Either P.ParseError a
applyOpt :: Parser a -> String -> Maybe a
run :: Show a => Parser a -> String -> IO ()
sexpToStr :: Sexp -> String
pStr :: Parser Sexp
pSym :: Parser Sexp
pList :: Parser Sexp
pSexp :: Parser Sexp
sexpOfStr :: String -> Maybe Sexp
sexpOfList :: (a -> Sexp) -> [a] -> Sexp
sexpOfValue :: Show a => a -> Sexp
sexpToList :: (Sexp -> Maybe a) -> Sexp -> Maybe [a]
sexpToValue :: Read a => Sexp -> Maybe a
sexpToDouble :: Sexp -> Maybe Double
sexpToInt :: Sexp -> Maybe Int
> 


> sexpToStr $ List [Sym "100", Sym "200", Sym "300"]
"( 100 200 300 )"
it :: String
>

> sexpToStr $ List [Sym "100", List [ Sym "200", Sym "300"], Str "hello world", Sym "x"]
"( 100 ( 200 300 ) \"hello world\" x )"
it :: String
> 


>  
> run pSym "hello"
Sym "hello"
it :: ()
> 
> run pSym "hello world"
Sym "hello"
it :: ()
> run pSym "3434hello world"
Sym "3434hello"
it :: ()
> 

> run pQuotedStr "\"hello world haskell\""
Str "hello world haskell"
it :: ()
> 
> run (P.spaces >> pQuotedStr) "  \"hello world haskell\""
Str "hello world haskell"
it :: ()
> run (P.spaces >> pQuotedStr) "  \"hello\""
Str "hello"
it :: ()
> 

> 
> run pList "( 100 200 300)"
List [Sym "100",Sym "200",Sym "300"]
it :: ()
> 
> run pList "( 100 200 300  )"
List [Sym "100",Sym "200",Sym "300"]
it :: ()
> 
> run pList "( 100 200 300 hello world \"hello\" \"parsec is amazing\" )"
List [Sym "100",Sym "200",Sym "300",Sym "hello",Sym "world",Str "hello",Str "parsec is amazing"]
it :: ()
> 
> run pList "( 100 200 (300 hello world \"hello\") ()  \"parsec is amazing\" )"
List [Sym "100",Sym "200",List [Sym "300",Sym "hello",Sym "world",Str "hello"],List [],Str "parsec is amazing"]
it :: ()
> 
> run pList "(+ 100 200 300  )"
List [Sym "+",Sym "100",Sym "200",Sym "300"]
it :: ()
> 

> 
> run pSexp "1232"
Sym "1232"
it :: ()
> run pSexp "hello"
Sym "hello"
it :: ()
> run pSexp "(hello world)"
List [Sym "hello",Sym "world"]
it :: ()
> run pSexp "(++ hello world)"
List [Sym "++",Sym "hello",Sym "world"]
it :: ()
> 

> let test1 = "( 100 200 300 400 500 )"
test1 :: [Char]
> 

> let test1 = "( 100 200 300 400 500 )"
test1 :: [Char]
> 
> sexpOfStr test1 
Just (List [Sym "100",Sym "200",Sym "300",Sym "400",Sym "500"])
it :: Maybe Sexp
> 

> sexpOfStr test1 >>= sexpToList sexpToInt 
Just [100,200,300,400,500]
it :: Maybe [Int]
> 
> 
> sexpOfStr test1 >>= sexpToList sexpToDouble 
Just [100.0,200.0,300.0,400.0,500.0]
it :: Maybe [Double]
> 

> sexpOfList sexpOfValue [100, 200, 300, 5400]
List [Sym "100",Sym "200",Sym "300",Sym "5400"]
it :: Sexp
> 

> let test2 = sexpToStr $ sexpOfList sexpOfValue [100, 200, 300, 5400]
test2 :: String
> test2
"( 100 200 300 5400 )"
it :: String
> 
> sexpOfStr test2
Just (List [Sym "100",Sym "200",Sym "300",Sym "5400"])
it :: Maybe Sexp
> 
> sexpOfStr test2 >>= sexpToList sexpToInt 
Just [100,200,300,5400]
it :: Maybe [Int]
>