Anonymous III

--
-- lisp0.hs
--
-- Compilation:
--
--   ghc -XTemplateHaskell --make -O lisp0.hs lisp1.hs lisp2.hs lisp3.hs -o test
--
module HSLispDecl where

data LispV =    LispCons  LispV LispV
           |    LispInt Integer
           |    LispString String
           |    LispSymbol String
           |    LispFun ([LispV] -> IO LispV)
           |    LispNIL
           |    LispT
           |    LispF

data LispAst =  LAapply LispAst [LispAst]
             |  LAconst LispV
             |  LAvar   String
             |  LAglobfun String
             |  LAfun   [String] LispAst
             |  LAblock [LispAst]
             |  LAif    LispAst LispAst LispAst
             |  LAlet   String LispAst LispAst deriving (Show)

data LispTop =  LAdefun String [String] LispAst
             |  LAexpr   LispAst deriving (Show)

--
-- Translating core Lisp lists into a Lisp AST
--

expr2AST :: LispV -> LispAst

expr2AST (LispCons (LispSymbol "lambda")
                       (LispCons args body)) = compLambda args body
expr2AST (LispCons (LispSymbol "if")
                   (LispCons cnd
                    (LispCons iftr LispNIL))) = compIf2 cnd iftr
expr2AST (LispCons (LispSymbol "if")
                   (LispCons cnd
                    (LispCons iftr
                     (LispCons iffl LispNIL)))) = compIf3 cnd iftr iffl
expr2AST (LispCons (LispSymbol "quote")
                   (LispCons v LispNIL)) = LAconst v
expr2AST (LispCons (LispSymbol "begin") body) = compBody body
expr2AST (LispCons (LispSymbol "let")
                   (LispCons letdefs letbody)) = compLet letdefs letbody
expr2AST (LispCons fn args) = compApp fn args
expr2AST (LispSymbol s) = LAvar s
expr2AST other = LAconst other

expr2TOP (LispCons (LispSymbol "defun")
                   (LispCons (LispSymbol nm)
                             (LispCons args
                                       body))) = compDefun nm args body
expr2TOP other = LAexpr (expr2AST other)

compDefun nm args body = LAdefun nm (map lispGetArg (lisp2list args))
                                 (compBody body)

compLambda args body = LAfun (map lispGetArg (lisp2list args)) (compBody body)
compIf2 cnd iftr = compIf3 cnd iftr LispNIL
compIf3 cnd iftr iffl = LAif (expr2AST cnd) (expr2AST iftr) (expr2AST iffl)
compBody (LispCons v LispNIL) = expr2AST v
compBody LispNIL = expr2AST LispNIL
compBody other = LAblock (map expr2AST (lisp2list other))
compApp fn args = LAapply (expr2AST fn) (map expr2AST (lisp2list args))
compLet (LispCons (LispCons (LispSymbol nm) (LispCons v LispNIL))
                  rest) body = LAlet nm (expr2AST v) (compLet rest body)
compLet LispNIL body = compBody body

lisp2list (LispCons a rest) = a : (lisp2list rest)
lisp2list LispNIL = []

lispGetArg (LispSymbol s) = s

--
-- A couple of utility functions
--


lispList :: [LispV] -> LispV
lispList (hd : tl) = LispCons hd (lispList tl)
lispList [] = LispNIL

lispDottedList :: [LispV] -> LispV -> LispV
lispDottedList (hd : tl) x = LispCons hd (lispDottedList tl x)
lispDottedList [] x = x


instance Show LispV where
    show (LispCons a b) = "(" ++ (show a) ++ " . " ++ (show b)
    show (LispInt i) = show i
    show (LispString s) = "\"" ++ s ++ "\""
    show (LispSymbol s) = s
    show (LispFun f) = "<FUN>"
    show LispNIL = "()"
    show LispT = "#t"
    show LispF = "#f"

-- lisp1.hs
module HSLisp (compile_expr, lispApp, compile_top, sanitiseAST, sanitiseTOP) where
import Language.Haskell.TH
import HSLispDecl

lispApp (LispFun f) args = f args

compile_top :: LispTop -> DecQ
compile_top (LAdefun nm args body) =
    funD (mkName ("lisp_" ++ nm))
         [(clause [(listP (map (\n -> varP (mkName n)) args))]
                      (normalB (compile_expr body)) [])]

compile_expr :: LispAst -> ExpQ

compile_expr (LAapply (LAglobfun fn) args) =
    do nms <- mapM (\n -> newName "a") args
       ca  <- mapM compile_expr args
       bo  <- appE (varE (mkName fn)) (listE (map varE nms))
       return (gendefs (zip nms ca) bo)

compile_expr (LAapply fn args) =
    do nms <- mapM (\n -> newName "a") (fn : args)
       ca  <- mapM compile_expr (fn : args)
       bo  <- appE (appE (varE (mkName "lispApp")) (varE (head nms))) (listE (map varE (tail nms)))
       return (gendefs (zip nms ca) bo)

compile_expr (LAvar s) = makeret (varE (mkName s))
compile_expr (LAglobfun s) = makefun (varE (mkName s))

compile_expr (LAfun args body) =
    makefun (lamE [(listP (map (\n -> varP (mkName n)) args))] (compile_expr body))
compile_expr (LAconst c) = compile_const c
compile_expr (LAlet nm v body) =
    doE [(bindS (varP (mkName nm)) (compile_expr v)),
         (noBindS (compile_expr body))]
compile_expr (LAif e1 e2 e3) =
    do
      nm1 <- newName "i"
      e1' <- compile_expr e1
      e2' <- compile_expr e2
      e3' <- compile_expr e3
      return (gendefs [(nm1,e1')]
               (CaseE (VarE nm1)
                      [(Match lisp_T (NormalB e2') []),
                       (Match lisp_F (NormalB e3') [])]))
compile_expr (LAblock exprs) =
    do ca <- mapM compile_expr exprs
       return (DoE (map (\e -> (NoBindS e)) ca))

makefun v =  makeret (appE (conE (mkName "LispFun")) v)
makectr n v = makeret (appE (conE (mkName n)) (litE v))

compile_const (LispInt i) = makectr "LispInt" (integerL i)
compile_const (LispString s) = makectr "LispString" (stringL s)
compile_const (LispSymbol s) = makectr "LispSymbol" (stringL s)
compile_const (LispNIL) = makeret (conE (mkName "LispNIL"))
compile_const (LispT) = makeret (conE (mkName "LispT"))
compile_const (LispF) = makeret (conE (mkName "LispF"))
compile_const (LispCons a b) = makeret (appE (appE (conE (mkName "LispCons"))
                                              (compile_const a))
                                        (compile_const b))


gendefs l bo = DoE ((map (\(a,b) -> (BindS (VarP a) b)) l) ++ [NoBindS bo])


lisp_T = ConP (mkName "LispT") []
lisp_F = ConP (mkName "LispF") []

makeret v = appE (varE (mkName "return")) v

--
-- All the non-local names are considered global functions.
-- There's no way to share the context between top-level definitions
-- in Template Haskell.
--

sanitiseAST env (LAapply a ars) = LAapply (sanitiseAST env a) (map (sanitiseAST env) ars)
sanitiseAST env (LAconst c) = LAconst c
sanitiseAST env (LAvar v) = if v `elem` env then (LAvar v) else (LAglobfun ("lisp_"++v))
sanitiseAST env (LAglobfun v) = LAglobfun v
sanitiseAST env (LAfun args b) = LAfun args (sanitiseAST (args ++ env) b)
sanitiseAST env (LAblock b) = LAblock (map (sanitiseAST env) b)
sanitiseAST env (LAif a b c) = LAif (sanitiseAST env a) (sanitiseAST env b) (sanitiseAST env c)
sanitiseAST env (LAlet nm v b) = LAlet nm (sanitiseAST env v) (sanitiseAST (nm:env) b)


sanitiseTOP (LAdefun nm args body) = LAdefun nm args (sanitiseAST args body)
sanitiseTOP (LAexpr e) = LAexpr (sanitiseAST [] e)-- lisp2.hs
module HSLispParse (parseExpr, thlisp, thlisptop, tplisp)
where
import Text.ParserCombinators.Parsec hiding (spaces)
import HSLispDecl
import HSLisp
import Language.Haskell.TH


symbol :: Parser Char
symbol = oneOf "_$#"

spaces :: Parser ()
spaces = skipMany1 space

parseString :: Parser LispV
parseString = do char '"'
                 x <- many (noneOf "\"")
                 char '"'
                 return $ LispString x

parseSymb :: Parser LispV
parseSymb = do first <- letter <|> symbol
               rest <- many (letter <|> digit <|> symbol)
               let symb = [first] ++ rest
               return $ case symb of
                          "#t" -> LispT
                          "#f" -> LispF
                          otherwise -> LispSymbol symb

parseNumber :: Parser LispV
parseNumber = fmap (LispInt . read) $ many1 digit

parseList :: Parser LispV
parseList = fmap lispList $ sepBy parseExpr spaces

parseDottedList :: Parser LispV
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ lispDottedList head tail

parseQuoted q1 q2 = do
    char q1
    x <- parseExpr
    return $ lispList [LispSymbol q2, x]

parseExpr :: Parser LispV
parseExpr = parseSymb
        <|> parseString
        <|> parseNumber
        <|> (parseQuoted '\'' "quote")
        <|> (parseQuoted '`' "quasiquote")
        <|> (parseQuoted ',' "unquote")
        <|> do char '('
               x <- (try parseList) <|> parseDottedList
               char ')'
               return x


thlisp :: String -> ExpQ
thlisp input =
    case (parse parseExpr "lisp" input) of
        Left err -> compile_expr (LAconst (LispNIL))
        Right val -> compile_expr (sanitiseAST [] (expr2AST val))

thlisptop :: String -> Q [Dec]
thlisptop input =
    do
      r <-
          case (parse parseExpr "lisp" input) of
            Left err -> compile_top (LAexpr (LAconst (LispNIL)))
            Right val -> compile_top (sanitiseTOP (expr2TOP val))
      return [r]

tplisp input =
    case (parse parseExpr "lisp" input) of
      Left err -> compile_expr (LAconst (LispNIL))
      Right val -> compile_expr (sanitiseAST [] (expr2AST val))


-- lisp3.hs
module Main where
import Language.Haskell.TH
import HSLispDecl
import HSLisp
import HSLispParse

-- Functions to be used by Lisp programs
lisp_print [a] = do print a
                    return LispNIL

lisp_plus [(LispInt a),(LispInt b)] = return (LispInt (a+b))
lisp_mul [(LispInt a),(LispInt b)] = return (LispInt (a*b))
lisp_minus [(LispInt a),(LispInt b)] = return (LispInt (a-b))

lisp_car [(LispCons a b)] = return a
lisp_cdr [(LispCons a b)] = return b
lisp_cons [a,b] = return (LispCons a b)
lisp_nullp [LispNIL] = return LispT
lisp_nullp [other] = return LispF
lisp_not [LispT] = return LispF
lisp_not [LispF] = return LispT
lisp_eq [(LispInt a),(LispInt b)] = return (if (a==b) then LispT else LispF)
lisp_eq [a,b] = return LispF

-- Toplevel Lisp definition
$(thlisptop "(defun fact (x) (if (eq x 1) 1 (mul x (fact (minus x 1)))))")

-- Expression-level Lisp code
main =
    do
      $(thlisp "(begin (print \"Hello, \") (print \" ... world!\"))")
      $(thlisp "(let ((a 2) (b 2)) (print (plus a b)))")
      $(thlisp "((lambda (a b) (print a) (print b) (print (plus a b))) 2 20)")
      $(thlisp "(print (fact 10))")
      $(thlisp "(let ((a 2) (b 3)) (print (if (eq a b) (mul a b) (plus a b))))")

      -- Inspecting the generated code:
      i <- runQ (tplisp "((lambda (a b) (print a) (print b) (print (plus a b))) 2 20)")
      putStrLn (pprint i)