-- TP-1 --- Implantation d'une sorte de Lisp -*- coding: utf-8 -*- -- -- Ce fichier défini les fonctionalités suivantes: -- - Analyseur lexical -- - Analyseur syntaxique -- - Évaluateur (la partie que vous devez compléter) -- - Pretty printer --------------------------------------------------------------------------- -- Importations de librairies et définitions de fonctions auxiliaires -- --------------------------------------------------------------------------- import Text.ParserCombinators.Parsec -- Libraire d'analyse syntaxique (et lexicale). import Data.Char -- Conversion de Chars de/vers Int et autres import Numeric -- Pour la fonction showInt import IO -- Pour stdout, hPutStr import Maybe -- Pour isJust and fromJust --------------------------------------------------------------------------- -- La représentation interne des expressions de notre language -- --------------------------------------------------------------------------- data Sexp = Snil -- La liste vide | Scons Sexp Sexp -- Une paire | Ssym String -- Un symbole | Snum Int -- Un entier -- Génère automatiquement un pretty-printer et une fonction de -- comparaison structurelle. deriving (Show, Eq) -- Exemples: -- (+ 2 3) == (((() . +) . 2) . 3) -- ==> Scons (Scons (Scons Snil (Ssym "+")) -- (Snum 2)) -- (Snum 3) -- -- (/ (* (- 68 32) 5) 9) -- == (((() . /) . (((() . *) . (((() . -) . 68) . 32)) . 5)) . 9) -- ==> -- Scons (Scons (Scons Snil (Ssym "/")) -- (Scons (Scons (Scons Snil (Ssym "*")) -- (Scons (Scons (Scons Snil (Ssym "-")) -- (Snum 68)) -- (Snum 32))) -- (Snum 5))) -- (Snum 9) --------------------------------------------------------------------------- -- Analyseur lexical -- --------------------------------------------------------------------------- -- Les commentaires commencent par un point-virgule et se termine -- à la fin de la ligne. pComment = do { char ';'; many (satisfy (\c -> not (c == '\n'))); char '\n'; return () } -- N'importe quelle combinaison d'espaces et de commentaires est considérée -- comme du blanc. pSpaces = many (do { space ; return () } <|> pComment) -- Un numbre entier est composé de chiffres. integer :: Parser Int integer = do c <- digit integer' (digitToInt c) where integer' n = do c <- digit integer' (10 * n + (digitToInt c)) <|> return n -- Les symboles sont constitués de caractères alphanumériques et de symboles -- de ponctuations. pSymchar = alphaNum <|> satisfy (\c -> c `elem` "!@$%^&*_+-=:|/?<>") pSymbol= do { s <- many1 (pSymchar); return (case parse integer "" s of Right n -> Snum n _ -> Ssym s) } --------------------------------------------------------------------------- -- Analyseur syntaxique -- --------------------------------------------------------------------------- -- La notation "'E" est équivalente à "(quote E)" pQuote = do { char '\''; pSpaces; e <- pSexp; return (Scons (Ssym "quote") (Scons e Snil)) } -- Une liste (Tsil) est de la forme ( [e .] {e} ) pTsil :: Parser Sexp pTsil = do char '(' pSpaces (do { char ')'; return Snil } <|> do head <- (do e <- pSexp pSpaces (do char '.' pSpaces return e <|> return (Scons Snil e))) pLiat head) where pLiat :: Sexp -> Parser Sexp pLiat head = do char ')' return head <|> do e <- pSexp pSpaces pLiat (Scons head e) -- Accepte n'importe quel caractère: utilisé en cas d'erreur. pAny = do { c <- anyChar ; return (Just c) } <|> return Nothing -- Une Sexp peut-être une liste, un symbol ou un entier. pSexpTop = do { pTsil <|> pQuote <|> pSymbol <|> do { x <- pAny; case x of Nothing -> pzero Just c -> error ("Unexpected char '" ++ [c] ++ "'") } } -- On distingue l'analyse syntaxique d'une Sexp principale de celle d'une -- sous-Sexp: si l'analyse d'une sous-Sexp échoue à EOF, c'est une erreur de -- syntaxe alors que si l'analyse de la Sexp principale échoue cela peut être -- tout à fait normal. pSexp = pSexpTop <|> error "Unexpected end of stream" -- Une séquence de Sexps. pSexps = do pSpaces many (do e <- pSexpTop pSpaces return e) -- Déclare que notre analyseur syntaxique peut-être utilisé pour la fonction -- générique "read". instance Read Sexp where readsPrec p s = case parse pSexp "" s of Left _ -> [] Right e -> [(e,"")] --------------------------------------------------------------------------- -- Pretty Printer -- --------------------------------------------------------------------------- showSexp' Snil = showString "()" showSexp' (Snum n) = showsPrec 0 n showSexp' (Ssym s) = showString s showSexp' (Scons e1 e2) = showHead (Scons e1 e2) . showString ")" where showHead (Scons Snil e2) = showString "(" . showSexp' e2 showHead (Scons e1 e2) = showHead e1 . showString " " . showSexp' e2 showHead e = showString "(" . showSexp' e . showString " ." -- On peut utiliser notre pretty-printer pour la fonction générique "show" -- (utilisée par la boucle interactive de Hugs). Mais avant de faire cela, -- il faut enlever le "deriving Show" dans la déclaration de Sexp. {- instance Show Sexp where showsPrec p = showSexp' -} -- Pour lire et imprimer des Sexp plus facilement dans la boucle interactive -- de Hugs: readSexp :: String -> Sexp readSexp = read showSexp :: Sexp -> String showSexp e = showSexp' e "" --------------------------------------------------------------------------- -- Représentation intermédiaire -- --------------------------------------------------------------------------- type Var = String data Lexp = Lnum Int -- Référence à une variable. | Lvar Var -- Expression fonctionnelle prenant une liste d'arguments. | Llambda [Var] Lexp -- Appel de fonction, avec une liste d'arguments. | Lapp Var [Lexp] -- Expression conditionelle. | Lif Lexp Lexp Lexp -- Déclaration simple d'une variable non-récursive. | Llet Var Lexp Lexp -- Déclaration d'une liste de variables qui peuvent être -- mutuellement récursives. | Lfix [(Var,Lexp)] Lexp deriving (Show, Eq) -- Première passe simple qui analyse un Sexp et construit une Lexp équivalente. compile :: Sexp -> Lexp compile (Snum n) = Lnum n compile (Ssym "cons") = -- Exemple simpliste: on présume ici que "cons" n'a pas été redéfini -- entre temps, mais rien ne le garanti. Llambda ["x"] (Llambda ["xs"] (Lapp "cons" [Lvar "x", Lvar "xs"])) compile (Ssym s) = Lvar s compile (Scons (Scons (Scons Snil (Ssym "lambda")) (Scons Snil (Ssym arg))) body) = Llambda [arg] (compile body) compile (Scons (Scons (Scons Snil (Ssym "lambda")) args) body) = error ("unimplemented lambda args: " ++ show args) compile (Scons (Scons (Scons Snil (Ssym "let")) (Scons Snil (Scons (Scons Snil (Ssym var)) e1))) e2) = Llet var (compile e1) (compile e2) compile (Scons (Scons (Scons Snil (Ssym "let")) decls) e2) = error ("unimplemented let decls: " ++ show decls) compile (Scons (Scons Snil (Ssym s)) arg) = Lapp s [compile arg] compile (sexp@(Scons _ _)) = error ("unknown expression: " ++ show sexp) -- Simplifie le code, pour qu'il soit plus compact et/ou plus rapide. opt :: (Var -> Maybe Lexp) -> Lexp -> Lexp opt env (Lnum n) = Lnum n opt env (e @ (Lvar x)) = case env x of Just (e' @ (Lnum n)) -> e' _ -> e opt env e = e optimize :: Lexp -> Lexp optimize = opt (\_ -> Nothing) --------------------------------------------------------------------------- -- Évaluateur -- --------------------------------------------------------------------------- -- Type des valeurs renvoyées par l'évaluateur. data Value = Vnum Int | Vbool Bool | Vnil | Vcons Value Value | Vfun ([Value] -> Value) instance Show Value where showsPrec p (Vnum n) = showsPrec p n showsPrec p Vnil = showString "[]" showsPrec p (Vcons v1 v2) = let showTail Vnil = showChar ']' showTail (Vcons v1 v2) = showChar ' ' . showsPrec p v1 . showTail v2 showTail v = showString " . " . showsPrec p v . showChar ']' in showChar '[' . showsPrec p v1 . showTail v2 showsPrec p _ = showString "" type Env = Var -> Value -- L'environnement initial qui contient les fonctions prédéfinies. env0 :: Env env0 "nil" = Vnil env0 "cons" = Vfun (\ [x,y] -> Vcons x y) env0 "car" = Vfun (\ [Vcons x y] -> x) env0 "cdr" = Vfun (\ [Vcons x y] -> y) env0 "ifnil"= Vfun (\ [x] -> case x of Vnil -> Vbool True Vcons _ _ -> Vbool False _ -> error "Not a list") env0 "+" = Vfun (\ [Vnum x, Vnum y] -> Vnum (x + y)) env0 "*" = Vfun (\ [Vnum x, Vnum y] -> Vnum (x * y)) env0 "/" = Vfun (\ [Vnum x, Vnum y] -> Vnum (x `div` y)) env0 "-" = Vfun (\ [Vnum x, Vnum y] -> Vnum (x - y)) env0 x = error ("Uknown variable: " ++ show x) elookup :: Env -> Var -> Value elookup env = env einsert :: Env -> Var -> Value -> Env einsert env var val = \x -> if (x == var) then val else elookup env x -- La fonction d'évaluation principale. eval :: Env -> Lexp -> Value eval env (Lnum n) = Vnum n eval env (Lvar x) = elookup env x eval env (Llambda formals e) = Vfun (\actuals -> eval (foldr (\ (x,v) e -> einsert e x v) env (zip formals actuals)) e) eval env (Lapp f actuals) = case elookup env f of Vfun f -> f (map (eval env) actuals) _ -> error "Not a function" eval env (Lif e1 e2 e3) = case eval env e1 of Vbool True -> eval env e2 Vbool False -> eval env e3 x -> error ("Not a boolean: " ++ show x) eval env (Llet x e1 e2) = eval (einsert env x (eval env e1)) e2 eval env (Lfix decls e) = let newenv = (foldr (\ (x,e) env -> einsert env x (eval newenv e)) env decls) in eval newenv e --------------------------------------------------------------------------- -- Toplevel -- --------------------------------------------------------------------------- -- Lit un fichier contenant plusieurs Sexps, les évalues l'une après -- l'autre, et renvoie la liste des valeurs obtenues. main :: FilePath -> IO () main filename = do s <- readFile filename (hPutStr stdout . show) (let sexps s = case parse pSexps filename s of Left _ -> [Ssym "#"] Right es -> es in map (eval env0 . optimize . compile) (sexps s)) test :: String -> Value test = eval env0 . optimize . compile . read