secret
Last active

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/

  • Download Gist
Evaluation.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
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)
Main.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14
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
Makefile
Makefile
1 2 3 4 5 6 7 8 9 10 11 12 13
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
Typeing.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
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)
lexer.x
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
{
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)
}
parser.y
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
{
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
}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.