Monadic Parser and Lexer using Alex and Happy

Lexer.x

{
module Lexer where
}

%wrapper "monadUserState"

$digit     = 0-9      -- digits
$alpha     = [a-zA-Z] -- alphabetic characters

-- Each token has a function on the RHS that is a function (String ->
-- Token). We wrap this function in the Alex monad with `pushToken`, which has
-- a result AlexAction ().

tokens :-
  $white+  ;
  $alpha+  { pushToken $ TString        }
  $digit+  { pushToken $ TNumber . read }
  '@'      { pushToken $ \_ -> TAt      }

{

------------
-- Tokens --
------------

data Token
 = TNumber Integer
 | TString String
 | TAt
 deriving (Show, Eq)

-----------
-- Types --
-----------

type AlexUserState = [Token]
type ParseError    = String

--------------------
-- Parser Helpers --
--------------------

alexEOF :: Alex ()
alexEOF = return ()

ignore input len = alexMonadScan

-----------------
-- Lexer State --
-----------------

alexInitUserState :: AlexUserState
alexInitUserState = []

modifyUserState :: (AlexUserState -> AlexUserState) -> Alex ()
modifyUserState f = Alex $ \s -> let current = alex_ust s
                                     new     = f current
                                 in
                                   Right (s { alex_ust = new },())

getUserState ::  Alex AlexUserState
getUserState = Alex $ \s -> Right (s,alex_ust s)

pushToken :: (String -> Token) -> AlexAction ()
pushToken tokenizer =
  \(posn,prevChar,pending,s) len -> modifyUserState (push $ take len s) >> alexMonadScan
    where
       push :: String -> AlexUserState -> AlexUserState
       push s ts = ts ++ [(tokenizer s)]

runAlexScan :: String -> Either ParseError AlexUserState
runAlexScan s = runAlex s $ alexMonadScan >> getUserState

--main = getContents >>= print . runAlexScan

}

Parser.y

{

module Parser where
import Lexer
import Syntax
import Text.Printf


}

%name calc
%tokentype { Token      }
%error     { parseError }
%monad{ Either String }{ >>= }{ return }

%token
  '@'    { TAt        }
  number { TNumber $$ }
  var    { TString $$ }

%%

AST
  : '@'    { At       }
  | number { Numbr $1 }
  | var    { Name $1  }

{

parseError ts = fail "Parse error"

parse :: String -> Either ParseError AST
parse input = runAlexScan input >>= calc

}

Syntax.hs

module Syntax where

data AST
 = Numbr Integer
 | Name  String
 | At
 deriving (Show, Eq)