-
-
Save johnbender/8d7db37e8a6dc99e1ea3 to your computer and use it in GitHub Desktop.
Lexer and parser using Alex and Happy along with a simple evaluator and derivation constructor for the CoffeeScript subset described in http://johnbender.us/2012/11/27/math-envy-and-coffeescripts-foibles/
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Evaluation (derive, fullEval, eval) where | |
import Data.Maybe | |
import Parser | |
data InfRule = Inv | |
| App | |
| ArgEval | |
| AppEval deriving Show | |
data RuleMatch = None | |
| RuleMatch InfRule (Maybe Expr) Expr deriving Show | |
data Derivation = Empty | |
| Derivation InfRule Derivation Derivation Expr deriving Show | |
-- build a derivation from an expression | |
derive :: Expr -> Derivation | |
derive t = | |
case (matchRule t) of | |
None -> Empty | |
(RuleMatch rule Nothing t1) -> Derivation rule Empty (derive t1) (eval t) | |
(RuleMatch rule (Just t1) _) -> Derivation rule (derive t1) (derive $ eval t) (eval t) | |
-- reduce an expression to a value term | |
eval :: Expr -> Expr | |
eval t = | |
case (matchRule t) of | |
None -> t | |
(RuleMatch _ Nothing t1) -> t1 | |
(RuleMatch ArgEval (Just t1) t2) -> Apply t2 (eval t1) | |
(RuleMatch AppEval (Just t1) t2) -> Apply (eval t1) t2 | |
-- reduce an expression to a value term | |
fullEval :: Expr -> Expr | |
fullEval t = | |
case (matchRule t) of | |
None -> t | |
_ -> fullEval $ eval t | |
-- match a rule and provide the relevant sub terms for action | |
matchRule :: Expr -> RuleMatch | |
matchRule (BooleanExpr _) = None | |
matchRule (Lambda _) = None | |
-- e-inv | |
matchRule (Invoke (Lambda t)) = RuleMatch Inv Nothing t | |
-- e-app | |
matchRule (Apply (Lambda t) (BooleanExpr _)) = RuleMatch App Nothing t | |
matchRule (Apply (Lambda t) (Lambda _)) = RuleMatch App Nothing t | |
-- e-arg-eval | |
matchRule (Apply t i@(Invoke _)) = RuleMatch ArgEval (Just i) t | |
matchRule (Apply t a@(Apply _ _)) = RuleMatch ArgEval (Just a) t | |
-- e-app-eval | |
matchRule (Apply i@(Invoke _) t) = RuleMatch AppEval (Just i) t | |
matchRule (Apply a@(Apply _ _) t) = RuleMatch AppEval (Just a) t | |
matchRule t = error $ "No inference rule applies for: " ++ (show t) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
module Lexer (Token(..), alexScanTokens) where | |
import Data.Char (toUpper) | |
} | |
%wrapper "basic" | |
tokens :- | |
$white { \s -> Whitespace } | |
true|false { \(x:xs) -> Boolean (read $ (toUpper x) : xs) } | |
"()" { \s -> Unit } | |
"->" { \s -> Arrow } | |
"(" { \s -> LeftParen } | |
")" { \s -> RightParen } | |
{ | |
-- The token type: | |
data Token = | |
Whitespace | | |
Boolean Bool | | |
Unit | | |
Arrow | | |
LeftParen | | |
RightParen | | |
Err | |
deriving (Eq,Show) | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Main where | |
import Control.Monad (liftM) | |
import Evaluation as Eval | |
import Typeing as Type | |
import Parser | |
main = do | |
ast <- (liftM parseCS) $ getContents | |
print ast | |
print $ Type.fixType ast | |
print $ Type.derive ast | |
print $ Eval.fullEval ast | |
print $ Eval.derive ast |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
all: lexer parser executable | |
lexer: | |
alex lexer.x -o Lexer.hs | |
parser: | |
happy parser.y -o Parser.hs | |
executable: | |
ghc Main.hs -o cs | |
clean: | |
rm -rf *.o Parser.hs Lexer.hs *.hi cs |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
module Parser where | |
import Lexer | |
} | |
%name parse | |
%tokentype { Token } | |
%error { parseError } | |
%token | |
white { Whitespace } | |
bool { Boolean $$ } | |
'()' { Unit } | |
'->' { Arrow } | |
'(' { LeftParen } | |
')' { RightParen } | |
%% | |
Expr : Value { $1 } | |
| Lambda '()' { Invoke $1 } | |
| Expr white Expr { Apply $1 $3 } | |
Lambda : '()' white '->' white Expr { Lambda $5 } | |
| '->' white Expr { Lambda $3 } | |
| '(' Lambda ')' { $2 } | |
Value : bool { BooleanExpr $1 } | |
| Lambda { $1 } | |
{ | |
data Expr = | |
BooleanExpr Bool | | |
Apply Expr Expr | | |
Invoke Expr | | |
Lambda Expr | |
deriving Show | |
parseError :: [Token] -> a | |
parseError tokens = error $ "Parse error : " ++ (show tokens) | |
parseCS :: String -> Expr | |
parseCS = parse . alexScanTokens | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Typeing (derive, fixType) where | |
import Data.Maybe | |
import Parser | |
import Evaluation (eval) | |
data Type = Bool | |
| Arrow Type deriving Show | |
data TypeRule = TrueType | |
| FalseType | |
| LambdaType | |
| Inv | |
| App deriving Show | |
data RuleMatch = None | |
| RuleMatch TypeRule Expr deriving Show | |
data Derivation = Empty | |
| Derivation TypeRule Derivation Type deriving Show | |
derive :: Expr -> Derivation | |
derive t = | |
case (matchRule t) of | |
(RuleMatch TrueType _) -> Derivation TrueType Empty $ fixType t | |
(RuleMatch FalseType _ ) -> Derivation FalseType Empty $ fixType t | |
(RuleMatch rule t1) -> Derivation rule (derive t1) $ fixType t | |
fixType :: Expr -> Type | |
fixType t = | |
case (matchRule t) of | |
(RuleMatch TrueType _) -> Bool | |
(RuleMatch FalseType _) -> Bool | |
(RuleMatch LambdaType t1) -> Arrow $ fixType t1 | |
(RuleMatch Inv t1) -> fixType t1 | |
(RuleMatch App _) -> fixType $ eval t | |
-- match a rule and provide the relevant sub terms for action | |
matchRule :: Expr -> RuleMatch | |
matchRule b@(BooleanExpr True) = RuleMatch TrueType b | |
matchRule b@(BooleanExpr False) = RuleMatch FalseType b | |
matchRule (Lambda t) = RuleMatch LambdaType t | |
matchRule (Invoke (Lambda t)) = RuleMatch Inv t | |
matchRule (Apply t@(Lambda _) _) = RuleMatch App t | |
matchRule (Apply t@(Invoke _) _) = RuleMatch App t | |
matchRule (Apply t@(Apply _ _) _) = RuleMatch App t | |
matchRule t = error $ "No type inference rule applies for: " ++ (show t) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment