Template file for monadic Alex lexer. Inclues better error message, basic token type and lexer

alex-monad-template.x

{
module AlexMonadicTemplate (main) where
}
 
%wrapper "monad"
 
tokens :-
  <0> . { mkL LDummy }
  <0> $white ;
{
 
data Lexeme = L AlexPosn LexemeClass String
 
data LexemeClass
  = LEOF
  | LDummy
  deriving (Eq, Show)
 
mkL :: LexemeClass -> AlexInput -> Int -> Alex Lexeme
mkL c (p,_,_,str) len = return (L p c (take len str))
 
lexError s = do
  (p,c,_,input) <- alexGetInput
  alexError (showPosn p ++ ": " ++ s ++ 
     (if (not (null input))
        then " before " ++ "'" ++ takeWhile (not . flip elem "\r\n") input ++ "'"
        else " at end of file"))
 
showL (L _ cls str) = show cls ++ "'" ++ str ++ "'"
 
alexEOF = return (L undefined LEOF "")
 
showPosn (AlexPn _ line col) = show line ++ ':': show col
 
alexMonadScan' = do
  inp <- alexGetInput
  sc <- alexGetStartCode
  case alexScan inp sc of
    AlexEOF -> alexEOF
    AlexError inp' -> lexError "Lex error"
    AlexSkip  inp' len -> do
        alexSetInput inp'
        alexMonadScan'
    AlexToken inp' len action -> do
        alexSetInput inp'
        action (ignorePendingBytes inp) len
 
lexTokens s = runAlex s $ loop []
  where 
    isEof x = case x of { L _ LEOF _ -> True; _ -> False }
    loop acc = do
      tok <- alexMonadScan'
      if isEof tok
        then return (reverse acc)
        else loop (tok:acc)
 
main = do
  s <- getContents
  let result = lexTokens s
  case result of 
    Right x -> mapM_ (putStrLn . showL) x
    Left err -> putStrLn err
 
}

alex-simple.x

{
module Main where
}

%wrapper "basic"

:-
$white ;
.  { id }

{
main = fmap alexScanTokens getContents >>= (mapM_ putStr)
}