Lexer.x

{
module Lexer (
  Token(..),
  scanTokens
  ) where
}

%wrapper "posn"

$digit = [0-9]
$alpha = [a-zA-Z]
$eol   = [\n]

@symbol = [$alpha $digit \+ \* \/ \_ \~ ! \@ \$ \% \^ \& \= \: \< \> \{ \} \- \| \?]+

tokens :-
  \;.*\n                         ;
  $white+                        ;
  \(                             { \_ _ -> TokenOpenParen }
  \)                             { \_ _ -> TokenCloseParen }
  \-? $digit+ (\. $digit*)?      { \_ s -> TokenNumber (read s) }
  @symbol                        { \_ s -> TokenSymbol s }
  :@symbol?                      { \_ s -> TokenKeyword (tail s) }
  \&@symbol                      { \_ s -> TokenOpt (tail s) }
  \" ([^\\ \"] | \\. | \n)* \"   { \_ s -> TokenString (unquote (tail (init s))) }
  '                              { \_ _ -> TokenQuote }
  `                              { \_ _ -> TokenBackquote }
  \,                             { \_ _ -> TokenUnquote }
  \.                             { \_ _ -> TokenPeriod }
  \?.                            { \_ s -> TokenChar (s !! 1) }
  \[                             { \_ _ -> TokenOpenSquare }
  \]                             { \_ _ -> TokenCloseSquare }
  \#                             { \_ _ -> TokenSharpQuote }

{
data Token
  = TokenOpenParen
  | TokenCloseParen
  | TokenSymbol String -- blah lol
  | TokenKeyword String -- :blah :lol
  | TokenOpt String -- &optional &rest
  | TokenNumber Double
  | TokenString String
  | TokenQuote -- '
  | TokenBackquote -- `
  | TokenUnquote -- ,
  | TokenPeriod -- . (should it be a separate token?)
  | TokenChar Char -- ?_ ?a
  | TokenOpenSquare
  | TokenCloseSquare
  | TokenSharpQuote -- #
  deriving (Eq, Show)

scanTokens = alexScanTokens

unquote "" = ""
unquote ('\\' : '\\' : xs) = '\\' : unquote xs
unquote ('\\' : '"' : xs) = '"' : unquote xs
unquote ('\\' : 'n' : xs) = '\n' : unquote xs
unquote (x:xs) = x : unquote xs
}

Main.hs

module Main where

import qualified Lexer as L
import qualified Parser as P

main :: IO ()
main = do
  putStrLn "Test1:"
  print $ P.parse $ L.scanTokens "(print hello hi)"

  putStrLn "\nTest2:"
  print $ P.parse $ L.scanTokens "(print 5 \"hello, world!\")\n'(hi-5 `print)"

  putStrLn "\nFull-blown file:"
  print . P.parse . L.scanTokens =<< readFile "/home/rasen/.emacs.d/init.el"

Parser.y

{
module Parser where

import qualified Lexer as L
}

%name parse
%tokentype { L.Token }
%error { parseError }

%token
  '('      { L.TokenOpenParen }
  ')'      { L.TokenCloseParen }
  symbol   { L.TokenSymbol $$ }
  keyword  { L.TokenKeyword $$ }
  opt      { L.TokenOpt $$ }
  number   { L.TokenNumber $$ }
  str      { L.TokenString $$ }
  '\''     { L.TokenQuote }
  '`'      { L.TokenBackquote }
  ','      { L.TokenUnquote }
  '.'      { L.TokenPeriod }
  char     { L.TokenChar $$ }
  '['      { L.TokenOpenSquare }
  ']'      { L.TokenCloseSquare }
  '#'      { L.TokenSharpQuote }

%%

File :: { [Node] }
File : ListContent                  { reverse $1 }

ListContent :: { [Node] }
ListContent : ListContent Elem      { $2 : $1 }
            | {- empty -}           { [] }

Elem :: { Node }
Elem : '(' ListContent ')'      { NodeList (reverse $2) }
     | '\'' Elem                { NodeQuoted $2 }
     | symbol                   { NodeSymbol $1 }
     | keyword                  { NodeKeyword $1 }
     | opt                      { NodeOpt $1 }
     | number                   { NodeNumber $1 }
     | str                      { NodeString $1 }
     | '`' Elem                 { NodeBackquoted $2 }
     | ',' Elem                 { NodeUnquoted $2 }
     | '.'                      { NodePeriod }
     | char                     { NodeChar $1 }
     | '[' ListContent ']'      { NodeSquareList (reverse $2) }
     | '#' Elem                 { NodeSharpQuoted $2 }

{
data Node = NodeList         [Node]
          | NodeSquareList   [Node]
          | NodeQuoted       Node
          | NodeSymbol       String
          | NodeKeyword      String
          | NodeOpt          String
          | NodeNumber       Double
          | NodeString       String
          | NodeBackquoted   Node
          | NodeUnquoted     Node
          | NodePeriod
          | NodeChar         Char
          | NodeSharpQuoted  Node
          deriving (Eq, Show)

parseError :: [ L.Token ] -> a
parseError tokens = error $ "Parse error" ++ show tokens
}