Skip to content

Instantly share code, notes, and snippets.

@johnbender
Last active December 10, 2015 05:18
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
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/
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)
{
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)
}
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
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
{
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
}
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