{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Main where import Char import System -- parser produced by Happy Version 1.18.4 data HappyAbsSyn = HappyTerminal (Token) | HappyErrorToken Int | HappyAbsSyn4 (Exp) {- to allow type-synonyms as our monads (likely - with explicitly-specified bind and return) - in Haskell98, it seems that with - /type M a = .../, then /(HappyReduction M)/ - is not allowed. But Happy is a - code-generator that can just substitute it. type HappyReduction m = Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] -> HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn -} action_0, action_1, action_2, action_3, action_4, action_5, action_6, action_7, action_8, action_9, action_10, action_11, action_12, action_13, action_14, action_15, action_16, action_17, action_18, action_19, action_20, action_21, action_22, action_23, action_24, action_25 :: () => Int -> ({-HappyReduction (HappyIdentity) = -} Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn) -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn)] -> HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn) happyReduce_1, happyReduce_2, happyReduce_3, happyReduce_4, happyReduce_5, happyReduce_6, happyReduce_7, happyReduce_8, happyReduce_9, happyReduce_10, happyReduce_11, happyReduce_12 :: () => ({-HappyReduction (HappyIdentity) = -} Int -> (Token) -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn) -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn)] -> HappyStk HappyAbsSyn -> [(Token)] -> (HappyIdentity) HappyAbsSyn) action_0 (9) = happyShift action_6 action_0 (10) = happyShift action_7 action_0 (15) = happyShift action_8 action_0 (18) = happyShift action_9 action_0 (4) = happyGoto action_10 action_0 (5) = happyGoto action_2 action_0 (6) = happyGoto action_3 action_0 (7) = happyGoto action_4 action_0 (8) = happyGoto action_5 action_0 _ = happyFail action_1 (9) = happyShift action_6 action_1 (10) = happyShift action_7 action_1 (15) = happyShift action_8 action_1 (18) = happyShift action_9 action_1 (5) = happyGoto action_2 action_1 (6) = happyGoto action_3 action_1 (7) = happyGoto action_4 action_1 (8) = happyGoto action_5 action_1 _ = happyFail action_2 _ = happyReduce_1 action_3 (11) = happyShift action_15 action_3 (12) = happyShift action_16 action_3 _ = happyReduce_2 action_4 (13) = happyShift action_13 action_4 (14) = happyShift action_14 action_4 _ = happyReduce_3 action_5 _ = happyReduce_6 action_6 _ = happyReduce_9 action_7 _ = happyReduce_10 action_8 (9) = happyShift action_6 action_8 (10) = happyShift action_7 action_8 (15) = happyShift action_8 action_8 (18) = happyShift action_9 action_8 (5) = happyGoto action_12 action_8 (6) = happyGoto action_3 action_8 (7) = happyGoto action_4 action_8 (8) = happyGoto action_5 action_8 _ = happyFail action_9 (10) = happyShift action_11 action_9 _ = happyFail action_10 (20) = happyAccept action_10 _ = happyFail action_11 (17) = happyShift action_22 action_11 _ = happyFail action_12 (16) = happyShift action_21 action_12 _ = happyFail action_13 (9) = happyShift action_6 action_13 (10) = happyShift action_7 action_13 (15) = happyShift action_8 action_13 (18) = happyShift action_9 action_13 (8) = happyGoto action_20 action_13 _ = happyFail action_14 (9) = happyShift action_6 action_14 (10) = happyShift action_7 action_14 (15) = happyShift action_8 action_14 (18) = happyShift action_9 action_14 (8) = happyGoto action_19 action_14 _ = happyFail action_15 (9) = happyShift action_6 action_15 (10) = happyShift action_7 action_15 (15) = happyShift action_8 action_15 (18) = happyShift action_9 action_15 (7) = happyGoto action_18 action_15 (8) = happyGoto action_5 action_15 _ = happyFail action_16 (9) = happyShift action_6 action_16 (10) = happyShift action_7 action_16 (15) = happyShift action_8 action_16 (18) = happyShift action_9 action_16 (7) = happyGoto action_17 action_16 (8) = happyGoto action_5 action_16 _ = happyFail action_17 (13) = happyShift action_13 action_17 (14) = happyShift action_14 action_17 _ = happyReduce_5 action_18 (13) = happyShift action_13 action_18 (14) = happyShift action_14 action_18 _ = happyReduce_4 action_19 _ = happyReduce_8 action_20 _ = happyReduce_7 action_21 _ = happyReduce_11 action_22 (9) = happyShift action_6 action_22 (10) = happyShift action_7 action_22 (15) = happyShift action_8 action_22 (18) = happyShift action_9 action_22 (5) = happyGoto action_23 action_22 (6) = happyGoto action_3 action_22 (7) = happyGoto action_4 action_22 (8) = happyGoto action_5 action_22 _ = happyFail action_23 (19) = happyShift action_24 action_23 _ = happyFail action_24 (9) = happyShift action_6 action_24 (10) = happyShift action_7 action_24 (15) = happyShift action_8 action_24 (18) = happyShift action_9 action_24 (5) = happyGoto action_25 action_24 (6) = happyGoto action_3 action_24 (7) = happyGoto action_4 action_24 (8) = happyGoto action_5 action_24 _ = happyFail action_25 _ = happyReduce_12 happyReduce_1 = happySpecReduce_1 4 happyReduction_1 happyReduction_1 (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (happy_var_1 ) happyReduction_1 _ = notHappyAtAll happyReduce_2 = happySpecReduce_1 5 happyReduction_2 happyReduction_2 (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (happy_var_1 ) happyReduction_2 _ = notHappyAtAll happyReduce_3 = happySpecReduce_1 6 happyReduction_3 happyReduction_3 (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (happy_var_1 ) happyReduction_3 _ = notHappyAtAll happyReduce_4 = happySpecReduce_3 6 happyReduction_4 happyReduction_4 (HappyAbsSyn4 happy_var_3) _ (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (BinOpApp Plus happy_var_1 happy_var_3 ) happyReduction_4 _ _ _ = notHappyAtAll happyReduce_5 = happySpecReduce_3 6 happyReduction_5 happyReduction_5 (HappyAbsSyn4 happy_var_3) _ (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (BinOpApp Minus happy_var_1 happy_var_3 ) happyReduction_5 _ _ _ = notHappyAtAll happyReduce_6 = happySpecReduce_1 7 happyReduction_6 happyReduction_6 (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (happy_var_1 ) happyReduction_6 _ = notHappyAtAll happyReduce_7 = happySpecReduce_3 7 happyReduction_7 happyReduction_7 (HappyAbsSyn4 happy_var_3) _ (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (BinOpApp Times happy_var_1 happy_var_3 ) happyReduction_7 _ _ _ = notHappyAtAll happyReduce_8 = happySpecReduce_3 7 happyReduction_8 happyReduction_8 (HappyAbsSyn4 happy_var_3) _ (HappyAbsSyn4 happy_var_1) = HappyAbsSyn4 (BinOpApp Divide happy_var_1 happy_var_3 ) happyReduction_8 _ _ _ = notHappyAtAll happyReduce_9 = happySpecReduce_1 8 happyReduction_9 happyReduction_9 (HappyTerminal (T_Int happy_var_1)) = HappyAbsSyn4 (LitInt happy_var_1 ) happyReduction_9 _ = notHappyAtAll happyReduce_10 = happySpecReduce_1 8 happyReduction_10 happyReduction_10 (HappyTerminal (T_Id happy_var_1)) = HappyAbsSyn4 (Var happy_var_1 ) happyReduction_10 _ = notHappyAtAll happyReduce_11 = happySpecReduce_3 8 happyReduction_11 happyReduction_11 _ (HappyAbsSyn4 happy_var_2) _ = HappyAbsSyn4 (happy_var_2 ) happyReduction_11 _ _ _ = notHappyAtAll happyReduce_12 = happyReduce 6 8 happyReduction_12 happyReduction_12 ((HappyAbsSyn4 happy_var_6) `HappyStk` _ `HappyStk` (HappyAbsSyn4 happy_var_4) `HappyStk` _ `HappyStk` (HappyTerminal (T_Id happy_var_2)) `HappyStk` _ `HappyStk` happyRest) = HappyAbsSyn4 (Let happy_var_2 happy_var_4 happy_var_6 ) `HappyStk` happyRest happyNewToken action sts stk [] = action 20 20 notHappyAtAll (HappyState action) sts stk [] happyNewToken action sts stk (tk:tks) = let cont i = action i i tk (HappyState action) sts stk tks in case tk of { T_Int happy_dollar_dollar -> cont 9; T_Id happy_dollar_dollar -> cont 10; T_Plus -> cont 11; T_Minus -> cont 12; T_Times -> cont 13; T_Divide -> cont 14; T_LeftPar -> cont 15; T_RightPar -> cont 16; T_Equal -> cont 17; T_Let -> cont 18; T_In -> cont 19; _ -> happyError' (tk:tks) } happyError_ tk tks = happyError' (tk:tks) newtype HappyIdentity a = HappyIdentity a happyIdentity = HappyIdentity happyRunIdentity (HappyIdentity a) = a instance Monad HappyIdentity where return = HappyIdentity (HappyIdentity p) >>= q = q p happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b happyThen = (>>=) happyReturn :: () => a -> HappyIdentity a happyReturn = (return) happyThen1 m k tks = (>>=) m (\a -> k a tks) happyReturn1 :: () => a -> b -> HappyIdentity a happyReturn1 = \a tks -> (return) a happyError' :: () => [(Token)] -> HappyIdentity a happyError' = HappyIdentity . happyError parser tks = happyRunIdentity happySomeParser where happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll }) happySeq = happyDontSeq -- Haskell code for defining token type, AST, scanner, top-level -- functions. More or less verbatim from the original TXL example -- (lecture 2). type Id = String ---------------------------------------------------------------- -- Token type ---------------------------------------------------------------- data Token = T_Int Int | T_Id Id | T_Plus | T_Minus | T_Times | T_Divide | T_LeftPar | T_RightPar | T_Equal | T_Let | T_In deriving Show ---------------------------------------------------------------- -- Abstract Syntax Tree ---------------------------------------------------------------- data BinOp = Plus | Minus | Times | Divide deriving Show data Exp = LitInt Int | Var Id | BinOpApp BinOp Exp Exp | Let Id Exp Exp deriving Show ---------------------------------------------------------------- -- Scanner ---------------------------------------------------------------- scanner :: [Char] -> [Token] -- End of input scanner [] = [] -- Drop white space and comments scanner (' ' : cs) = scanner cs scanner ('\n' : cs) = scanner cs scanner ('!' : cs) = scanner (dropWhile (/='\n') cs) -- Scan single character tokens scanner ('+' : cs) = T_Plus : scanner cs scanner ('-' : cs) = T_Minus : scanner cs scanner ('*' : cs) = T_Times : scanner cs scanner ('/' : cs) = T_Divide : scanner cs scanner ('(' : cs) = T_LeftPar : scanner cs scanner (')' : cs) = T_RightPar : scanner cs scanner ('=' : cs) = T_Equal : scanner cs -- Scan literal integers, identifiers, and keywords scanner (c : cs) | isDigit c = T_Int (read (c : takeWhile isDigit cs)) : scanner (dropWhile isDigit cs) | isAlpha c = mkIdOrKwd (c : takeWhile isAlphaNum cs) : scanner (dropWhile isAlphaNum cs) | otherwise = error "Illegal character!" where mkIdOrKwd "let" = T_Let mkIdOrKwd "in" = T_In mkIdOrKwd cs = T_Id cs ---------------------------------------------------------------- -- Pretty printing of expressions ---------------------------------------------------------------- ppExp :: Exp -> String ppExp e = ppExpAux 0 e "" ppExpAux :: Int -> Exp -> ShowS ppExpAux n (LitInt x) = indent n . showString (show x) . nl ppExpAux n (Var i) = indent n . showString i . nl ppExpAux n (BinOpApp op e1 e2) = indent n . showString "BinOpApp" . nl . ppExpAux (n+1) e1 . indent (n+1) . showString (show op) . nl . ppExpAux (n+1) e2 ppExpAux n (Let i e1 e2) = indent n . showString "Let" . nl . indent (n+1) . showString i . nl . ppExpAux (n+1) e1 . ppExpAux (n+1) e2 ---------------------------------------------------------------- -- Utilities ---------------------------------------------------------------- indent n = showString (take (2 * n) (repeat ' ')) nl = showChar '\n' spc = showChar ' ' happyError :: [Token] -> a happyError _ = error "Parse error" ---------------------------------------------------------------- -- Main ---------------------------------------------------------------- -- Usage: -- happytxl file.txl Parse "file.txl" and write result -- to standard output. -- happytxl Read input from standard input and write -- result to standard output. -- (Could be confusing!) main = do args <- getArgs input <- if null args then getContents else readFile (head args) putStr ((ppExp . parser . scanner) input) {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} {-# LINE 1 "" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp {-# LINE 28 "templates/GenericTemplate.hs" #-} {-# LINE 49 "templates/GenericTemplate.hs" #-} {-# LINE 59 "templates/GenericTemplate.hs" #-} {-# LINE 68 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) ----------------------------------------------------------------------------- -- starting the parse happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll ----------------------------------------------------------------------------- -- Accepting the parse -- If the current token is (1), it means we've just accepted a partial -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action {-# LINE 155 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- HappyState data type (not arrays) newtype HappyState b c = HappyState (Int -> -- token number Int -> -- token number (yes, again) b -> -- token semantic value HappyState b c -> -- current state [HappyState b c] -> -- state stack c) ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = let i = (case x of { HappyErrorToken (i) -> i }) in -- trace "shifting the error token" $ new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) happyShift new_state i tk st sts stk = happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) -- happyReduce is specialised for the common cases. happySpecReduce_0 i fn (1) tk st sts stk = happyFail (1) tk st sts stk happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) happySpecReduce_1 i fn (1) tk st sts stk = happyFail (1) tk st sts stk happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') = let r = fn v1 in happySeq r (action nt j tk st sts (r `HappyStk` stk')) happySpecReduce_2 i fn (1) tk st sts stk = happyFail (1) tk st sts stk happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') = let r = fn v1 v2 in happySeq r (action nt j tk st sts (r `HappyStk` stk')) happySpecReduce_3 i fn (1) tk st sts stk = happyFail (1) tk st sts stk happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') = let r = fn v1 v2 v3 in happySeq r (action nt j tk st sts (r `HappyStk` stk')) happyReduce k i fn (1) tk st sts stk = happyFail (1) tk st sts stk happyReduce k nt fn j tk st sts stk = case happyDrop (k - ((1) :: Int)) sts of sts1@(((st1@(HappyState (action))):(_))) -> let r = fn stk in -- it doesn't hurt to always seq here... happyDoSeq r (action nt j tk st1 sts1 r) happyMonadReduce k nt fn (1) tk st sts stk = happyFail (1) tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn (1) tk st sts stk = happyFail (1) tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts)) drop_stk = happyDropStk k stk new_state = action happyDrop (0) l = l happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t happyDropStk (0) l = l happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction {-# LINE 253 "templates/GenericTemplate.hs" #-} happyGoto action j tk st = action j j tk (HappyState action) ----------------------------------------------------------------------------- -- Error recovery ((1) is the error token) -- parse error if we are in recovery and we fail again happyFail (1) tk old_st _ stk = -- trace "failing" $ happyError_ tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it for now --SDM -- discard a state happyFail (1) tk old_st (((HappyState (action))):(sts)) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail i tk (HappyState (action)) sts stk = -- trace "entering error recovery" $ action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk) -- Internal happy errors: notHappyAtAll = error "Internal Happy error\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `seq` b happyDontSeq a b = b ----------------------------------------------------------------------------- -- Don't inline any functions from the template. GHC has a nasty habit -- of deciding to inline happyGoto everywhere, which increases the size of -- the generated parser quite a bit. {-# LINE 317 "templates/GenericTemplate.hs" #-} {-# NOINLINE happyShift #-} {-# NOINLINE happySpecReduce_0 #-} {-# NOINLINE happySpecReduce_1 #-} {-# NOINLINE happySpecReduce_2 #-} {-# NOINLINE happySpecReduce_3 #-} {-# NOINLINE happyReduce #-} {-# NOINLINE happyMonadReduce #-} {-# NOINLINE happyGoto #-} {-# NOINLINE happyFail #-} -- end of Happy Template.