Zentraluebung zu Parsen von Herr Jost

parse_jost.hs

import Prelude hiding (lex)
import Data.Char
import Data.Maybe
import Data.Semigroup

{-  Vorlesung "Programmierung und Modellierung"
    LMU München, Sommersemester 2019
    Steffen Jost

   Code zu Folien 7.23ff
   live gecoded von Dr Steffen Jost, Lehrstuhl TCS, LMU München 
   in der 3. Zentralübung zur Programmierung und Modellierung
   19. Juni 2019
   
   Erklärungen/Gedankengänge: siehe Videoaufzeichung!
-}


-- Code von Folie 7.29:
data Expr = Const Integer
          | Plus  Expr Expr
          | Times Expr Expr
  deriving (Eq)
-- Beispiel:
a2 = Times (Plus (Const 5) (Const 3)) (Const 2)
-- (5+3) * 2

eval :: Expr -> Integer
eval (Const     n)  = n
eval (Plus  l r)    = eval l + eval r
eval (Times l r)    = eval l * eval r



-- Ein paar nützliche Instanzen für die Übung:
instance Show Expr where
  show (Const i)     = show i
  show (Plus  e1 e2) = "("++ show e1 ++ "+" ++ show e2 ++")"
  show (Times e1 e2) = "("++ show e1 ++ "*" ++ show e2 ++")"

instance Read Expr where
  readsPrec _ s = let (e,t) = parseExpr $ lex s in [(e,concatMap show t)]


-- Code Folie 7.30:--
data Token
  = CONST Integer | LPAREN | RPAREN | PLUS | TIMES
  deriving Show 
{-
instance Show Token where
  show (CONST i) = show i
  show LPAREN  = "("
  show RPAREN  = ")"
  show PLUS    = "+"
  show TIMES   = "*"
  -}
s1str = " 3 * (8+3)+  5  *4"
s1 = [CONST 3, TIMES, LPAREN, CONST 8, PLUS, CONST 3, RPAREN, PLUS, CONST 5, TIMES, CONST 4]


-- Lexikalische Analyse
lex :: String -> [Token]
lex "" = []
lex (' ':s) = lex s
lex ('(':s) = LPAREN : lex s
lex (')':s) = RPAREN : lex s
lex ('[':s) = LPAREN : lex s
lex (']':s) = RPAREN : lex s
lex ('+':s) = PLUS   : lex s
lex ('*':s) = TIMES  : lex s
lex s = case lexInt s of
          Just (i, rest) -> CONST i : lex rest 
          Nothing -> error $ "Unbekanntes Zeichen: " <> s
  

lexInt :: String -> Maybe (Integer, String)
lexInt (' ':s) = lexInt s
lexInt ('-':s) = negFst <$> lexPos s
  where negFst (i,r) = (negate i,r)
lexInt      s = lexPos s


lexPos :: String -> Maybe (Integer, String)
lexPos (c:s) | isSpace c = lexPos s
lexPos    s  | null num  = Nothing
             | otherwise = Just (read num, rest)
  where
    (num,rest) = span (`elem` ['0'..'9']) s


-- Alternative Variante von lexInt:
lexInt1 :: String -> Maybe (Integer, String)
lexInt1 = listToMaybe . reads

-- Natürlich könnte man das auch komplett zu Fuss implementieren:
-- lexInt2 ('0':s) = ...
-- lexInt2 ('1':s) = ...
--  ...



-- Syntaxanalyse, Folie 7.31ff.
parseExpr   :: [Token] -> (Expr,[Token])
parseProd   :: [Token] -> (Expr,[Token])
parseFactor :: [Token] -> (Expr,[Token])

parseExpr l = case parseProd l of 
                (prod, PLUS:rest1) -> 
                  let (expr,rest2) = parseExpr rest1
                  in (Plus prod expr, rest2)
                -- (prod, rest) -> (prod, rest) 
                -- erg@(prod, rest) -> erg
                erg -> erg 

parseProd l | (TIMES:rest2) <- rest1 = let (prod,rest3) = parseFactor rest2 
                                       in  (Times factor prod, rest3) 
            | otherwise = (factor,rest1)
  where 
    (factor,rest1) = parseFactor l 

parseFactor ((CONST i):rest) = (Const i, rest)
parseFactor (LPAREN:rest) = case parseExpr rest of
                              (expr, RPAREN:rest2) -> (expr, rest2)
                              _ -> error "Klammer zu machen, es zieht!"
parseFactor _ = error "Syntaxfehler! Konstante oder Klammer auf erwartet!"                             
  

test :: Expr -- query GHCI for "test" to test your solution
test = read "1 * (2 + 3 * 4) + 5 * 6 + 7 + 8 * 9"


parse :: String -> Expr 
parse str = case parseExpr (lex str) of 
              (expr, []) -> expr 
              (_,bad) -> error $ "Unnötiger Ballast am Ende: " ++ show bad

{- 
  > lex "(1 +2  *   3 + 4  )"
  [LPAREN,CONST 1,PLUS,CONST 2,TIMES,CONST 3,PLUS,CONST 4,RPAREN]
        
  > parse "(1 +2  *   3 + 4  )"
    
 
            +
           / \
          1   +
             / \ 
            *   4
           / \ 
          2   3
          
  > eval $ parse "(1 +2  *   3 + 4  )"
  11
-}