mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-10-03 22:38:04 +03:00
initial commit
This commit is contained in:
commit
9241ebe43c
12
.gitignore
vendored
Normal file
12
.gitignore
vendored
Normal file
@ -0,0 +1,12 @@
|
||||
*.sw[po]
|
||||
*.o
|
||||
*.so
|
||||
cabal.sandbox.config
|
||||
.cabal-sandbox
|
||||
dist/
|
||||
*.hi
|
||||
*.o
|
||||
includes
|
||||
*.html
|
||||
*.agdai
|
||||
*.history
|
19
LICENSE
Normal file
19
LICENSE
Normal file
@ -0,0 +1,19 @@
|
||||
Copyright (c) 2013-2015, Stephen Diehl
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to
|
||||
deal in the Software without restriction, including without limitation the
|
||||
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
sell copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
IN THE SOFTWARE.
|
91
README.md
Normal file
91
README.md
Normal file
@ -0,0 +1,91 @@
|
||||
<p align="center">
|
||||
<a href="http://dev.stephendiehl.com/fun/">
|
||||
<img src="https://github.com/sdiehl/write-you-a-haskell/raw/master/misc/Haskell-Logo.png"/>
|
||||
</a>
|
||||
</p>
|
||||
|
||||
<p align="center">
|
||||
<a href="http://dev.stephendiehl.com/fun/">
|
||||
<img src="https://github.com/sdiehl/write-you-a-haskell/raw/master/misc/cover.png"/>
|
||||
</a>
|
||||
<br/>
|
||||
<em>Building a modern functional compiler from first principles.</em>
|
||||
</p>
|
||||
|
||||
<p align="center">
|
||||
<a href="https://twitter.com/smdiehl">Stephen Diehl</a>
|
||||
</p>
|
||||
|
||||
Releases
|
||||
--------
|
||||
|
||||
**December**
|
||||
|
||||
* [Chapter 1: Introduction](http://dev.stephendiehl.com/fun/introduction.html)
|
||||
* [Chapter 2: Haskell Basics](http://dev.stephendiehl.com/fun/basics.html)
|
||||
* [Chapter 3: Parsing](http://dev.stephendiehl.com/fun/parsers.html)
|
||||
* [Chapter 4: Lambda Calculus](http://dev.stephendiehl.com/fun/lambda_calculus.html)
|
||||
|
||||
**January**
|
||||
|
||||
* [Chapter 5: Type Systems](http://dev.stephendiehl.com/fun/type_systems.html)
|
||||
* [Chapter 6: Evaluation](http://dev.stephendiehl.com/fun/evaluation.html)
|
||||
* [Chapter 7: Hindley-Milner Inference](http://dev.stephendiehl.com/fun/hindley_milner.html)
|
||||
* [Chapter 8: Design of ProtoHaskell](http://dev.stephendiehl.com/fun/path.html)
|
||||
|
||||
**February**
|
||||
|
||||
* Chapter 9: Extended Parser
|
||||
* Chapter 10: Custom Datatypes
|
||||
* Chapter 11: Renamer
|
||||
* Chapter 12: Pattern Matching & Desugaring
|
||||
|
||||
**March**
|
||||
|
||||
* Chapter 13: System-F
|
||||
* Chapter 14: Type Classes
|
||||
* Chapter 15: Core Language
|
||||
|
||||
|
||||
**April**
|
||||
|
||||
* Chapter 16: Kinds
|
||||
* Chapter 17: Haskell Type Checker
|
||||
* Chapter 18: Core Interpreter
|
||||
* Chapter 19: Prelude
|
||||
|
||||
**May**
|
||||
|
||||
* Chapter 20: Design of Lazy Evaluation
|
||||
* Chapter 21: STG
|
||||
|
||||
**June**
|
||||
|
||||
* Chapter 22: Compilation
|
||||
* Chapter 23: Design of the Runtime
|
||||
|
||||
**July**
|
||||
|
||||
* Chapter 24: Imp
|
||||
* Chapter 25: Code Generation ( C )
|
||||
* Chapter 26: Code Generation ( LLVM )
|
||||
|
||||
**August**
|
||||
|
||||
* Chapter 27: Row Polymorphism & Effect Typing
|
||||
* Chapter 28: Future Work
|
||||
|
||||
Contributing
|
||||
------------
|
||||
|
||||
Any and all contributions are always welcome. As always, I rely on the
|
||||
perpetual kindness and goodwill of Haskellers (like you!) to help correct
|
||||
grammar, clarify, and fix errors.
|
||||
|
||||
* [Contributing](http://dev.stephendiehl.com/fun/contributing.html)
|
||||
|
||||
License
|
||||
-------
|
||||
|
||||
Released under the MIT License.
|
||||
Copyright (c) 2013-2015, Stephen Diehl
|
0
chapter1/.gitkeep
Normal file
0
chapter1/.gitkeep
Normal file
0
chapter2/.gitkeep
Normal file
0
chapter2/.gitkeep
Normal file
39
chapter3/calc/Eval.hs
Normal file
39
chapter3/calc/Eval.hs
Normal file
@ -0,0 +1,39 @@
|
||||
module Eval where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Functor
|
||||
|
||||
isNum :: Expr -> Bool
|
||||
isNum Zero = True
|
||||
isNum (Succ t) = isNum t
|
||||
isNum _ = False
|
||||
|
||||
isVal :: Expr -> Bool
|
||||
isVal Tr = True
|
||||
isVal Fl = True
|
||||
isVal t | isNum t = True
|
||||
isVal _ = False
|
||||
|
||||
eval' :: Expr -> Maybe Expr
|
||||
eval' x = case x of
|
||||
IsZero Zero -> Just Tr
|
||||
IsZero (Succ t) | isNum t -> Just Fl
|
||||
IsZero t -> IsZero <$> (eval' t)
|
||||
Succ t -> Succ <$> (eval' t)
|
||||
Pred Zero -> Just Zero
|
||||
Pred (Succ t) | isNum t -> Just t
|
||||
Pred t -> Pred <$> (eval' t)
|
||||
If Tr c _ -> Just c
|
||||
If Fl _ a -> Just a
|
||||
If t c a -> (\t' -> If t' c a) <$> eval' t
|
||||
_ -> Nothing
|
||||
|
||||
nf :: Expr -> Expr
|
||||
nf x = fromMaybe x (nf <$> eval' x)
|
||||
|
||||
eval :: Expr -> Maybe Expr
|
||||
eval t = case isVal (nf t) of
|
||||
True -> Just (nf t)
|
||||
False -> Nothing -- term is "stuck"
|
26
chapter3/calc/Main.hs
Normal file
26
chapter3/calc/Main.hs
Normal file
@ -0,0 +1,26 @@
|
||||
module Main where
|
||||
|
||||
import Eval
|
||||
import Parser
|
||||
import Pretty
|
||||
|
||||
import Control.Monad.Trans
|
||||
import System.Console.Haskeline
|
||||
|
||||
process :: String -> IO ()
|
||||
process line = do
|
||||
let res = parseExpr line
|
||||
case res of
|
||||
Left err -> print err
|
||||
Right ex -> case eval ex of
|
||||
Nothing -> putStrLn "Cannot evaluate"
|
||||
Just result -> putStrLn $ ppexpr result
|
||||
|
||||
main :: IO ()
|
||||
main = runInputT defaultSettings loop
|
||||
where
|
||||
loop = do
|
||||
minput <- getInputLine "Arith> "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Goodbye."
|
||||
Just input -> (liftIO $ process input) >> loop
|
86
chapter3/calc/Parser.hs
Normal file
86
chapter3/calc/Parser.hs
Normal file
@ -0,0 +1,86 @@
|
||||
module Parser (
|
||||
parseExpr
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
import Text.Parsec.Language (emptyDef)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
|
||||
import Data.Functor.Identity
|
||||
|
||||
|
||||
lexer :: Tok.TokenParser ()
|
||||
lexer = Tok.makeTokenParser emptyDef
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
semiSep :: Parser a -> Parser [a]
|
||||
semiSep = Tok.semiSep lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
infixOp :: String -> (a -> a) -> Ex.Operator String () Identity a
|
||||
infixOp s f = Ex.Prefix (reservedOp s >> return f)
|
||||
|
||||
|
||||
-- Infix operators
|
||||
table :: Ex.OperatorTable String () Identity Expr
|
||||
table = [
|
||||
[
|
||||
infixOp "succ" Succ
|
||||
, infixOp "pred" Pred
|
||||
, infixOp "iszero" IsZero
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
-- if/then/else
|
||||
ifthen :: Parser Expr
|
||||
ifthen = do
|
||||
reserved "if"
|
||||
cond <- expr
|
||||
reservedOp "then"
|
||||
tr <- expr
|
||||
reserved "else"
|
||||
fl <- expr
|
||||
return (If cond tr fl)
|
||||
|
||||
-- Constants
|
||||
true, false, zero :: Parser Expr
|
||||
true = reserved "true" >> return Tr
|
||||
false = reserved "false" >> return Fl
|
||||
zero = reservedOp "0" >> return Zero
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = Ex.buildExpressionParser table factor
|
||||
|
||||
factor :: Parser Expr
|
||||
factor =
|
||||
true
|
||||
<|> false
|
||||
<|> zero
|
||||
<|> ifthen
|
||||
<|> parens expr
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
||||
|
||||
toplevel :: Parser [Expr]
|
||||
toplevel = semiSep expr
|
||||
|
||||
parseExpr :: String -> Either ParseError Expr
|
||||
parseExpr s = parse (contents expr) "<stdin>" s
|
31
chapter3/calc/Pretty.hs
Normal file
31
chapter3/calc/Pretty.hs
Normal file
@ -0,0 +1,31 @@
|
||||
module Pretty (
|
||||
ppexpr
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
import Type
|
||||
|
||||
import Text.PrettyPrint (Doc, (<>), (<+>))
|
||||
import qualified Text.PrettyPrint as PP
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = PP.parens
|
||||
parensIf False = id
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr _ Zero = PP.text "0"
|
||||
ppr _ Tr = PP.text "true"
|
||||
ppr _ Fl = PP.text "false"
|
||||
ppr p (Succ a) = (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a)
|
||||
ppr p (Pred a) = (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a)
|
||||
ppr p (IsZero a) = (parensIf (p > 0) $ PP.text "iszero" <+> ppr (p+1) a)
|
||||
ppr p (If a b c) =
|
||||
PP.text "if" <+> ppr p a
|
||||
<+> PP.text "then" <+> ppr p b
|
||||
<+> PP.text "else" <+> ppr p c
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = PP.render . ppr 0
|
40
chapter3/calc/README.md
Normal file
40
chapter3/calc/README.md
Normal file
@ -0,0 +1,40 @@
|
||||
Arith
|
||||
======
|
||||
|
||||
A untyped arithmetic.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
Usage:
|
||||
|
||||
```ocaml
|
||||
Arith> succ 0
|
||||
succ 0
|
||||
|
||||
Arith> succ (succ 0)
|
||||
succ (succ 0)
|
||||
|
||||
Arith> if false then true else false
|
||||
false
|
||||
|
||||
Arith> iszero (pred (succ (succ 0)))
|
||||
false
|
||||
|
||||
Arith> pred (succ 0)
|
||||
0
|
||||
|
||||
Arith> iszero false
|
||||
Cannot evaluate
|
||||
|
||||
Arith> if 0 then true else false
|
||||
Cannot evaluate
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
11
chapter3/calc/Syntax.hs
Normal file
11
chapter3/calc/Syntax.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module Syntax where
|
||||
|
||||
data Expr
|
||||
= Tr
|
||||
| Fl
|
||||
| Zero
|
||||
| IsZero Expr
|
||||
| Succ Expr
|
||||
| Pred Expr
|
||||
| If Expr Expr Expr
|
||||
deriving (Eq, Show)
|
24
chapter3/calc/calc.cabal
Normal file
24
chapter3/calc/calc.cabal
Normal file
@ -0,0 +1,24 @@
|
||||
name: calc
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable calc
|
||||
build-depends:
|
||||
base >= 4.6 && <4.7,
|
||||
mtl >= 2.2 && <3.0,
|
||||
filepath >= 1.3 && <1.4,
|
||||
text >= 1.1 && <1.2,
|
||||
pretty >= 1.1 && <1.2,
|
||||
process >= 1.1 && <1.2,
|
||||
directory >= 1.2 && <1.3,
|
||||
haskeline >= 0.7 && <0.8,
|
||||
containers >= 0.5 && <0.6,
|
||||
parsec >= 3.1 && <3.2
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
177
chapter3/parsec.hs
Normal file
177
chapter3/parsec.hs
Normal file
@ -0,0 +1,177 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
||||
|
||||
module NanoParsec where
|
||||
|
||||
import Data.Char
|
||||
import Control.Monad
|
||||
import Control.Applicative
|
||||
|
||||
newtype Parser a = Parser { parse :: String -> [(a,String)] }
|
||||
|
||||
runParser :: Parser a -> String -> a
|
||||
runParser m s =
|
||||
case parse m s of
|
||||
[(res, [])] -> res
|
||||
[(_, rs)] -> error "Parser did not consume entire stream."
|
||||
[] -> error "Parser error."
|
||||
|
||||
item :: Parser Char
|
||||
item = Parser $ \s ->
|
||||
case s of
|
||||
[] -> []
|
||||
(c:cs) -> [(c,cs)]
|
||||
|
||||
bind :: Parser a -> (a -> Parser b) -> Parser b
|
||||
bind p f = Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s
|
||||
|
||||
unit :: a -> Parser a
|
||||
unit a = Parser (\s -> [(a,s)])
|
||||
|
||||
instance Functor Parser where
|
||||
fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s])
|
||||
|
||||
instance Applicative Parser where
|
||||
pure = return
|
||||
(Parser cs1) <*> (Parser cs2) = Parser (\s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1])
|
||||
|
||||
instance Monad Parser where
|
||||
return = unit
|
||||
(>>=) = bind
|
||||
|
||||
instance MonadPlus Parser where
|
||||
mzero = failure
|
||||
mplus = combine
|
||||
|
||||
instance Alternative Parser where
|
||||
empty = mzero
|
||||
(<|>) = option
|
||||
|
||||
combine :: Parser a -> Parser a -> Parser a
|
||||
combine p q = Parser (\s -> parse p s ++ parse q s)
|
||||
|
||||
failure :: Parser a
|
||||
failure = Parser (\cs -> [])
|
||||
|
||||
option :: Parser a -> Parser a -> Parser a
|
||||
option p q = Parser $ \s ->
|
||||
case parse (mplus p q) s of
|
||||
[] -> []
|
||||
(x:xs) -> [x]
|
||||
|
||||
satisfy :: (Char -> Bool) -> Parser Char
|
||||
satisfy p = item `bind` \c ->
|
||||
if p c
|
||||
then unit c
|
||||
else (Parser (\cs -> []))
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Combinators
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
oneOf :: [Char] -> Parser Char
|
||||
oneOf s = satisfy (flip elem s)
|
||||
|
||||
chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
|
||||
chainl p op a = (p `chainl1` op) <|> return a
|
||||
|
||||
chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
|
||||
p `chainl1` op = do {a <- p; rest a}
|
||||
where rest a = (do f <- op
|
||||
b <- p
|
||||
rest (f a b))
|
||||
<|> return a
|
||||
|
||||
char :: Char -> Parser Char
|
||||
char c = satisfy (c ==)
|
||||
|
||||
natural :: Parser Integer
|
||||
natural = read <$> some (satisfy isDigit)
|
||||
|
||||
string :: String -> Parser String
|
||||
string [] = return []
|
||||
string (c:cs) = do { char c; string cs; return (c:cs)}
|
||||
|
||||
token :: Parser a -> Parser a
|
||||
token p = do { a <- p; spaces ; return a}
|
||||
|
||||
reserved :: String -> Parser String
|
||||
reserved s = token (string s)
|
||||
|
||||
spaces :: Parser String
|
||||
spaces = many $ oneOf " \n\r"
|
||||
|
||||
digit :: Parser Char
|
||||
digit = satisfy isDigit
|
||||
|
||||
number :: Parser Int
|
||||
number = do
|
||||
s <- string "-" <|> return []
|
||||
cs <- some digit
|
||||
return $ read (s ++ cs)
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens m = do
|
||||
reserved "("
|
||||
n <- m
|
||||
reserved ")"
|
||||
return n
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Calulator parser
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- number = [ "-" ] digit { digit }.
|
||||
-- digit = "0" | "1" | ... | "8" | "9".
|
||||
-- expr = term { addop term }.
|
||||
-- term = factor { mulop factor }.
|
||||
-- factor = "(" expr ")" | var | number.
|
||||
-- addop = "+" | "-".
|
||||
-- mulop = "*".
|
||||
|
||||
data Expr
|
||||
= Add Expr Expr
|
||||
| Mul Expr Expr
|
||||
| Sub Expr Expr
|
||||
| Lit Int
|
||||
deriving Show
|
||||
|
||||
eval :: Expr -> Int
|
||||
eval ex = case ex of
|
||||
Add a b -> eval a + eval b
|
||||
Mul a b -> eval a * eval b
|
||||
Sub a b -> eval a - eval b
|
||||
Lit n -> n
|
||||
|
||||
int :: Parser Expr
|
||||
int = do
|
||||
n <- number
|
||||
return (Lit n)
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = term `chainl1` addop
|
||||
|
||||
term :: Parser Expr
|
||||
term = factor `chainl1` mulop
|
||||
|
||||
factor :: Parser Expr
|
||||
factor =
|
||||
int
|
||||
<|> parens expr
|
||||
|
||||
infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
|
||||
infixOp x f = reserved x >> return f
|
||||
|
||||
addop :: Parser (Expr -> Expr -> Expr)
|
||||
addop = (infixOp "+" Add) <|> (infixOp "-" Sub)
|
||||
|
||||
mulop :: Parser (Expr -> Expr -> Expr)
|
||||
mulop = infixOp "*" Mul
|
||||
|
||||
run :: String -> Expr
|
||||
run = runParser expr
|
||||
|
||||
main :: IO ()
|
||||
main = forever $ do
|
||||
putStr "> "
|
||||
a <- getLine
|
||||
print $ eval $ run a
|
0
chapter4/.gitkeep
Normal file
0
chapter4/.gitkeep
Normal file
79
chapter4/untyped/Eval.hs
Normal file
79
chapter4/untyped/Eval.hs
Normal file
@ -0,0 +1,79 @@
|
||||
module Eval (
|
||||
runEval
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
|
||||
|
||||
data Value
|
||||
= VInt Integer
|
||||
| VBool Bool
|
||||
| VClosure String Expr (Eval.Scope)
|
||||
|
||||
instance Show Value where
|
||||
show (VInt x) = show x
|
||||
show (VBool x) = show x
|
||||
show VClosure{} = "<<closure>>"
|
||||
|
||||
data EvalState = EvalState
|
||||
{ depth :: Int
|
||||
} deriving (Show)
|
||||
|
||||
inc :: Eval a -> Eval a
|
||||
inc m = do
|
||||
modify $ \s -> s { depth = (depth s) + 1 }
|
||||
out <- m
|
||||
modify $ \s -> s { depth = (depth s) - 1 }
|
||||
return out
|
||||
|
||||
red :: Expr -> Eval ()
|
||||
red x = do
|
||||
d <- gets depth
|
||||
tell [(d, x)]
|
||||
return ()
|
||||
|
||||
type Step = (Int, Expr)
|
||||
type Eval a = WriterT [Step] (State EvalState) a
|
||||
|
||||
type Scope = Map.Map String Value
|
||||
|
||||
eval :: Eval.Scope -> Expr -> Eval Value
|
||||
eval env expr = case expr of
|
||||
|
||||
Lit (LInt x) -> do
|
||||
return $ VInt (fromIntegral x)
|
||||
|
||||
Lit (LBool x) -> do
|
||||
return $ VBool x
|
||||
|
||||
Var x -> do
|
||||
red expr
|
||||
return $ env Map.! x
|
||||
|
||||
Lam x body -> inc $ do
|
||||
return (VClosure x body env)
|
||||
|
||||
App a b -> inc $ do
|
||||
x <- eval env a
|
||||
red a
|
||||
y <- eval env b
|
||||
red b
|
||||
apply x y
|
||||
|
||||
extend :: Scope -> String -> Value -> Scope
|
||||
extend env v t = Map.insert v t env
|
||||
|
||||
apply :: Value -> Value -> Eval Value
|
||||
apply (VClosure n e clo) ex = do
|
||||
eval (extend clo n ex) e
|
||||
apply _ _ = error "Tried to apply non-closure"
|
||||
|
||||
emptyScope :: Scope
|
||||
emptyScope = Map.empty
|
||||
|
||||
runEval :: Expr -> (Value, [Step])
|
||||
runEval x = evalState (runWriterT (eval emptyScope x)) (EvalState 0)
|
32
chapter4/untyped/Main.hs
Normal file
32
chapter4/untyped/Main.hs
Normal file
@ -0,0 +1,32 @@
|
||||
module Main where
|
||||
|
||||
import Syntax
|
||||
import Parser
|
||||
import Eval
|
||||
import Pretty
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans
|
||||
import System.Console.Haskeline
|
||||
|
||||
showStep :: (Int, Expr) -> IO ()
|
||||
showStep (d, x) = putStrLn ((replicate d ' ') ++ "=> " ++ ppexpr x)
|
||||
|
||||
process :: String -> IO ()
|
||||
process line = do
|
||||
let res = parseExpr line
|
||||
case res of
|
||||
Left err -> print err
|
||||
Right ex -> do
|
||||
let (out, ~steps) = runEval ex
|
||||
mapM_ showStep steps
|
||||
print out
|
||||
|
||||
main :: IO ()
|
||||
main = runInputT defaultSettings loop
|
||||
where
|
||||
loop = do
|
||||
minput <- getInputLine "Untyped> "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Goodbye."
|
||||
Just input -> (liftIO $ process input) >> loop
|
73
chapter4/untyped/Parser.hs
Normal file
73
chapter4/untyped/Parser.hs
Normal file
@ -0,0 +1,73 @@
|
||||
module Parser (parseExpr) where
|
||||
|
||||
import Data.Char
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
import Text.Parsec.Language (haskellStyle)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
|
||||
import Syntax
|
||||
|
||||
lexer :: Tok.TokenParser ()
|
||||
lexer = Tok.makeTokenParser style
|
||||
where ops = ["->","\\","+","*","-","="]
|
||||
names = []
|
||||
style = haskellStyle {Tok.reservedOpNames = ops,
|
||||
Tok.reservedNames = names,
|
||||
Tok.commentLine = "#"}
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
identifier :: Parser String
|
||||
identifier = Tok.identifier lexer
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
||||
|
||||
natural :: Parser Integer
|
||||
natural = Tok.natural lexer
|
||||
|
||||
variable :: Parser Expr
|
||||
variable = do
|
||||
x <- identifier
|
||||
return (Var x)
|
||||
|
||||
number :: Parser Expr
|
||||
number = do
|
||||
n <- natural
|
||||
return (Lit (LInt (fromIntegral n)))
|
||||
|
||||
lambda :: Parser Expr
|
||||
lambda = do
|
||||
reservedOp "\\"
|
||||
args <- many1 identifier
|
||||
reservedOp "."
|
||||
body <- expr
|
||||
return $ foldr Lam body args
|
||||
|
||||
term :: Parser Expr
|
||||
term = parens expr
|
||||
<|> variable
|
||||
<|> number
|
||||
<|> lambda
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = do
|
||||
es <- many1 term
|
||||
return (foldl1 App es)
|
||||
|
||||
parseExpr :: String -> Either ParseError Expr
|
||||
parseExpr input = parse (contents expr) "<stdin>" input
|
49
chapter4/untyped/Pretty.hs
Normal file
49
chapter4/untyped/Pretty.hs
Normal file
@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
module Pretty (
|
||||
ppexpr
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Text.PrettyPrint
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
instance Pretty Name where
|
||||
ppr _ x = text x
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr _ (Var x) = text x
|
||||
ppr _ (Lit (LInt a)) = text (show a)
|
||||
ppr _ (Lit (LBool b)) = text (show b)
|
||||
ppr p e@(App _ _) = parensIf (p>0) (ppr p f <+> sep (map (ppr (p+1)) xs))
|
||||
where (f, xs) = viewApp e
|
||||
ppr p e@(Lam _ _) = parensIf (p>0) $ char '\\' <> hsep vars <+> text "." <+> body
|
||||
where
|
||||
vars = map (ppr 0) (viewVars e)
|
||||
body = ppr (p+1) (viewBody e)
|
||||
|
||||
viewVars :: Expr -> [Name]
|
||||
viewVars (Lam n a) = n : viewVars a
|
||||
viewVars _ = []
|
||||
|
||||
viewBody :: Expr -> Expr
|
||||
viewBody (Lam _ a) = viewBody a
|
||||
viewBody x = x
|
||||
|
||||
viewApp :: Expr -> (Expr, [Expr])
|
||||
viewApp (App e1 e2) = go e1 [e2]
|
||||
where
|
||||
go (App a b) xs = go a (b : xs)
|
||||
go f xs = (f, xs)
|
||||
viewApp _ = error "not application"
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = render . ppr 0
|
15
chapter4/untyped/README.md
Normal file
15
chapter4/untyped/README.md
Normal file
@ -0,0 +1,15 @@
|
||||
Untyped Lambda Calculus
|
||||
=======================
|
||||
|
||||
Untyped lambda calculus.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
2
chapter4/untyped/Setup.hs
Normal file
2
chapter4/untyped/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
15
chapter4/untyped/Syntax.hs
Normal file
15
chapter4/untyped/Syntax.hs
Normal file
@ -0,0 +1,15 @@
|
||||
module Syntax where
|
||||
|
||||
type Name = String
|
||||
|
||||
data Expr
|
||||
= Var Name
|
||||
| Lit Lit
|
||||
| App Expr Expr
|
||||
| Lam Name Expr
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Lit
|
||||
= LInt Int
|
||||
| LBool Bool
|
||||
deriving (Show, Eq, Ord)
|
21
chapter4/untyped/untyped.cabal
Normal file
21
chapter4/untyped/untyped.cabal
Normal file
@ -0,0 +1,21 @@
|
||||
name: untyped
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable untyped
|
||||
build-depends:
|
||||
base >= 4.6 && <4.7
|
||||
, pretty >= 1.1 && <1.2
|
||||
, parsec >= 3.1 && <3.2
|
||||
, containers >= 0.5 && <0.6
|
||||
, haskeline >= 0.7
|
||||
, mtl
|
||||
, transformers
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
0
chapter5/.gitkeep
Normal file
0
chapter5/.gitkeep
Normal file
55
chapter5/calc_typed/Check.hs
Normal file
55
chapter5/calc_typed/Check.hs
Normal file
@ -0,0 +1,55 @@
|
||||
module Check (
|
||||
check
|
||||
) where
|
||||
|
||||
import Type
|
||||
import Syntax
|
||||
import Pretty
|
||||
|
||||
import Control.Monad.Except
|
||||
|
||||
data TypeError
|
||||
= TypeMismatch Type Type
|
||||
|
||||
instance Show TypeError where
|
||||
show (TypeMismatch a b) = "Type Mismatch: " ++ pptype a ++ " is not " ++ pptype b
|
||||
|
||||
type Check a = Except TypeError a
|
||||
|
||||
typeof :: Expr -> Check Type
|
||||
typeof expr = case expr of
|
||||
Tr -> return TBool
|
||||
Fl -> return TBool
|
||||
Zero -> return TNat
|
||||
|
||||
Succ a -> do
|
||||
ta <- typeof a
|
||||
case ta of
|
||||
TNat -> return TNat
|
||||
_ -> throwError $ TypeMismatch ta TNat
|
||||
|
||||
Pred a -> do
|
||||
ta <- typeof a
|
||||
case ta of
|
||||
TNat -> return TNat
|
||||
_ -> throwError $ TypeMismatch ta TNat
|
||||
|
||||
IsZero a -> do
|
||||
ta <- typeof a
|
||||
case ta of
|
||||
TNat -> return TBool
|
||||
_ -> throwError $ TypeMismatch ta TNat
|
||||
|
||||
If a b c -> do
|
||||
ta <- typeof a
|
||||
tb <- typeof b
|
||||
tc <- typeof c
|
||||
if ta /= TBool
|
||||
then throwError $ TypeMismatch ta TBool
|
||||
else
|
||||
if tb /= tc
|
||||
then throwError $ TypeMismatch ta tb
|
||||
else return tc
|
||||
|
||||
check :: Expr -> Either TypeError Type
|
||||
check = runExcept . typeof
|
42
chapter5/calc_typed/Eval.hs
Normal file
42
chapter5/calc_typed/Eval.hs
Normal file
@ -0,0 +1,42 @@
|
||||
module Eval (
|
||||
eval
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Functor
|
||||
|
||||
-- Evaluate a single step.
|
||||
eval1 :: Expr -> Maybe Expr
|
||||
eval1 expr = case expr of
|
||||
IsZero Zero -> Just Tr
|
||||
IsZero (Succ t) | isNum t -> Just Fl
|
||||
IsZero t -> IsZero <$> (eval1 t)
|
||||
Succ t -> Succ <$> (eval1 t)
|
||||
Pred Zero -> Just Zero
|
||||
Pred (Succ t) | isNum t -> Just t
|
||||
Pred t -> Pred <$> (eval1 t)
|
||||
If Tr c _ -> Just c
|
||||
If Fl _ a -> Just a
|
||||
If t c a -> (\t' -> If t' c a) <$> eval1 t
|
||||
_ -> Nothing
|
||||
|
||||
isNum :: Expr -> Bool
|
||||
isNum Zero = True
|
||||
isNum (Succ t) = isNum t
|
||||
isNum _ = False
|
||||
|
||||
isVal :: Expr -> Bool
|
||||
isVal Tr = True
|
||||
isVal Fl = True
|
||||
isVal t | isNum t = True
|
||||
isVal _ = False
|
||||
|
||||
nf :: Expr -> Expr
|
||||
nf t = fromMaybe t (nf <$> eval1 t)
|
||||
|
||||
eval :: Expr -> Maybe Expr
|
||||
eval t = case isVal (nf t) of
|
||||
True -> Just (nf t)
|
||||
False -> Nothing -- term is "stuck"
|
36
chapter5/calc_typed/Main.hs
Normal file
36
chapter5/calc_typed/Main.hs
Normal file
@ -0,0 +1,36 @@
|
||||
module Main where
|
||||
|
||||
import Eval
|
||||
import Type
|
||||
import Check
|
||||
import Parser
|
||||
import Pretty
|
||||
import Syntax
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Control.Monad.Trans
|
||||
import System.Console.Haskeline
|
||||
|
||||
eval' :: Expr -> Expr
|
||||
eval' = fromJust . eval
|
||||
|
||||
process :: String -> IO ()
|
||||
process line = do
|
||||
let res = parseExpr line
|
||||
case res of
|
||||
Left err -> print err
|
||||
Right ex -> do
|
||||
let chk = check ex
|
||||
case chk of
|
||||
Left err -> print err
|
||||
Right ty -> putStrLn $ (ppexpr $ eval' ex) ++ " : " ++ (pptype ty)
|
||||
|
||||
main :: IO ()
|
||||
main = runInputT defaultSettings loop
|
||||
where
|
||||
loop = do
|
||||
minput <- getInputLine "Arith> "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Goodbye."
|
||||
Just input -> (liftIO $ process input) >> loop
|
83
chapter5/calc_typed/Parser.hs
Normal file
83
chapter5/calc_typed/Parser.hs
Normal file
@ -0,0 +1,83 @@
|
||||
module Parser (
|
||||
parseExpr
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
import Text.Parsec.Language (emptyDef)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
|
||||
import Data.Functor.Identity
|
||||
|
||||
lexer :: Tok.TokenParser ()
|
||||
lexer = Tok.makeTokenParser emptyDef
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
semiSep :: Parser a -> Parser [a]
|
||||
semiSep = Tok.semiSep lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
infixOp :: String -> (a -> a) -> Ex.Operator String () Identity a
|
||||
infixOp s f = Ex.Prefix (reservedOp s >> return f)
|
||||
|
||||
table :: Ex.OperatorTable String () Identity Expr
|
||||
table = [
|
||||
[
|
||||
infixOp "succ" Succ
|
||||
, infixOp "pred" Pred
|
||||
, infixOp "iszero" IsZero
|
||||
]
|
||||
]
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = Ex.buildExpressionParser table factor
|
||||
|
||||
ifthen :: Parser Expr
|
||||
ifthen = do
|
||||
reserved "if"
|
||||
cond <- expr
|
||||
reservedOp "then"
|
||||
tr <- expr
|
||||
reserved "else"
|
||||
fl <- expr
|
||||
return (If cond tr fl)
|
||||
|
||||
true, false, zero :: Parser Expr
|
||||
true = reserved "true" >> return Tr
|
||||
false = reserved "false" >> return Fl
|
||||
zero = reservedOp "0" >> return Zero
|
||||
|
||||
factor :: Parser Expr
|
||||
factor =
|
||||
true
|
||||
<|> false
|
||||
<|> zero
|
||||
<|> ifthen
|
||||
<|> parens expr
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
||||
|
||||
toplevel :: Parser [Expr]
|
||||
toplevel = semiSep expr
|
||||
|
||||
parseExpr :: String -> Either ParseError Expr
|
||||
parseExpr s = parse (contents expr) "<stdin>" s
|
||||
|
||||
parseToplevel :: String -> Either ParseError [Expr]
|
||||
parseToplevel s = parse (contents toplevel) "<stdin>" s
|
40
chapter5/calc_typed/Pretty.hs
Normal file
40
chapter5/calc_typed/Pretty.hs
Normal file
@ -0,0 +1,40 @@
|
||||
module Pretty (
|
||||
ppexpr,
|
||||
pptype
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
import Type
|
||||
|
||||
import Text.PrettyPrint (Doc, (<>), (<+>))
|
||||
import qualified Text.PrettyPrint as PP
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = PP.parens
|
||||
parensIf False = id
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr p expr = case expr of
|
||||
Zero -> PP.text "0"
|
||||
Tr -> PP.text "true"
|
||||
Fl -> PP.text "false"
|
||||
Succ a -> (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a)
|
||||
Pred a -> (parensIf (p > 0) $ PP.text "succ" <+> ppr (p+1) a)
|
||||
IsZero a -> (parensIf (p > 0) $ PP.text "iszero" <+> ppr (p+1) a)
|
||||
If a b c ->
|
||||
PP.text "if" <+> ppr p a
|
||||
<+> PP.text "then" <+> ppr p b
|
||||
<+> PP.text "else" <+> ppr p c
|
||||
|
||||
instance Pretty Type where
|
||||
ppr _ TNat = PP.text "Nat"
|
||||
ppr _ TBool = PP.text "Bool"
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = PP.render . ppr 0
|
||||
|
||||
pptype :: Type -> String
|
||||
pptype = PP.render . ppr 0
|
40
chapter5/calc_typed/README.md
Normal file
40
chapter5/calc_typed/README.md
Normal file
@ -0,0 +1,40 @@
|
||||
Arith
|
||||
======
|
||||
|
||||
A typed arithmetic.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
Usage:
|
||||
|
||||
```ocaml
|
||||
Arith> succ 0
|
||||
succ 0 : Nat
|
||||
|
||||
Arith> succ (succ 0)
|
||||
succ (succ 0) : Nat
|
||||
|
||||
Arith> if false then true else false
|
||||
false : Bool
|
||||
|
||||
Arith> iszero (pred (succ (succ 0)))
|
||||
false : Bool
|
||||
|
||||
Arith> pred (succ 0)
|
||||
0 : Nat
|
||||
|
||||
Arith> iszero false
|
||||
Type Mismatch: Bool is not Nat
|
||||
|
||||
Arith> if 0 then true else false
|
||||
Type Mismatch: Nat is not Bool
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
11
chapter5/calc_typed/Syntax.hs
Normal file
11
chapter5/calc_typed/Syntax.hs
Normal file
@ -0,0 +1,11 @@
|
||||
module Syntax where
|
||||
|
||||
data Expr
|
||||
= Tr
|
||||
| Fl
|
||||
| Zero
|
||||
| IsZero Expr
|
||||
| Succ Expr
|
||||
| Pred Expr
|
||||
| If Expr Expr Expr
|
||||
deriving (Eq, Show)
|
6
chapter5/calc_typed/Type.hs
Normal file
6
chapter5/calc_typed/Type.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Type where
|
||||
|
||||
data Type
|
||||
= TBool
|
||||
| TNat
|
||||
deriving (Eq, Show)
|
15
chapter5/calc_typed/arith.cabal
Normal file
15
chapter5/calc_typed/arith.cabal
Normal file
@ -0,0 +1,15 @@
|
||||
name: arith
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable calc
|
||||
other-extensions: GADTs
|
||||
build-depends: base >=4.6 && <4.7, pretty >=1.1 && <1.2, parsec >=3.1 && <3.2
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
58
chapter5/stlc/Check.hs
Normal file
58
chapter5/stlc/Check.hs
Normal file
@ -0,0 +1,58 @@
|
||||
module Check (
|
||||
check,
|
||||
checkTop,
|
||||
TypeError(..)
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
|
||||
type Env = [(Name, Type)]
|
||||
|
||||
extend :: (Name, Type) -> Env -> Env
|
||||
extend xt env = xt : env
|
||||
|
||||
data TypeError
|
||||
= Mismatch Type Type
|
||||
| NotFunction Type
|
||||
| NotInScope Name
|
||||
|
||||
type Check = ExceptT TypeError (Reader Env)
|
||||
|
||||
inEnv :: (Name, Type) -> Check a -> Check a
|
||||
inEnv (x,t) = local (extend (x,t))
|
||||
|
||||
lookupVar :: Name -> Check Type
|
||||
lookupVar x = do
|
||||
env <- ask
|
||||
case lookup x env of
|
||||
Just e -> return e
|
||||
Nothing -> throwError $ NotInScope x
|
||||
|
||||
check :: Expr -> Check Type
|
||||
check expr = case expr of
|
||||
|
||||
Lit LInt{} -> return TInt
|
||||
|
||||
Lit LBool{} -> return TBool
|
||||
|
||||
Lam x t e -> do
|
||||
rhs <- inEnv (x,t) (check e)
|
||||
return (TArr t rhs)
|
||||
|
||||
App e1 e2 -> do
|
||||
t1 <- check e1
|
||||
t2 <- check e2
|
||||
case t1 of
|
||||
(TArr a b) | a == t2 -> return b
|
||||
(TArr a _) -> throwError $ Mismatch t2 a
|
||||
ty -> throwError $ NotFunction ty
|
||||
|
||||
Var x -> lookupVar x
|
||||
|
||||
runCheck :: Env -> Check a -> Either TypeError a
|
||||
runCheck env = flip runReader env . runExceptT
|
||||
|
||||
checkTop :: Env -> Expr -> Either TypeError Type
|
||||
checkTop env x = runCheck env $ (check x)
|
48
chapter5/stlc/Eval.hs
Normal file
48
chapter5/stlc/Eval.hs
Normal file
@ -0,0 +1,48 @@
|
||||
module Eval where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Control.Monad.Identity
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data Value
|
||||
= VInt Integer
|
||||
| VBool Bool
|
||||
| VClosure String Expr (Eval.Scope)
|
||||
|
||||
instance Show Value where
|
||||
show (VInt x) = show x
|
||||
show (VBool x) = show x
|
||||
show VClosure{} = "<<closure>>"
|
||||
|
||||
type Evaluate t = Identity t
|
||||
type Scope = Map.Map String Value
|
||||
|
||||
eval :: Eval.Scope -> Expr -> Identity Value
|
||||
eval env expr = case expr of
|
||||
|
||||
Lit (LInt x) -> return $ VInt (fromIntegral x)
|
||||
|
||||
Lit (LBool x) -> return $ VBool x
|
||||
|
||||
Var x -> return $ env Map.! x
|
||||
|
||||
Lam x _ body -> return (VClosure x body env)
|
||||
|
||||
App a b -> do
|
||||
x <- eval env a
|
||||
y <- eval env b
|
||||
apply x y
|
||||
|
||||
extend :: Scope -> String -> Value -> Scope
|
||||
extend env v t = Map.insert v t env
|
||||
|
||||
apply :: Value -> Value -> Evaluate Value
|
||||
apply (VClosure v t0 e) t1 = eval (extend e v t1) t0
|
||||
apply _ _ = error "Tried to apply closure"
|
||||
|
||||
emptyScope :: Scope
|
||||
emptyScope = Map.empty
|
||||
|
||||
runEval :: Expr -> Value
|
||||
runEval x = runIdentity (eval emptyScope x)
|
36
chapter5/stlc/Lexer.hs
Normal file
36
chapter5/stlc/Lexer.hs
Normal file
@ -0,0 +1,36 @@
|
||||
module Lexer where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
import Text.Parsec.Language (haskellStyle)
|
||||
|
||||
lexer :: Tok.TokenParser ()
|
||||
lexer = Tok.makeTokenParser style
|
||||
where ops = ["->","\\","+","*","-","="]
|
||||
names = ["True", "False"]
|
||||
style = haskellStyle {Tok.reservedOpNames = ops,
|
||||
Tok.reservedNames = names,
|
||||
Tok.commentLine = "#"}
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
identifier :: Parser String
|
||||
identifier = Tok.identifier lexer
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
||||
|
||||
natural :: Parser Integer
|
||||
natural = Tok.natural lexer
|
28
chapter5/stlc/Main.hs
Normal file
28
chapter5/stlc/Main.hs
Normal file
@ -0,0 +1,28 @@
|
||||
import Syntax
|
||||
import Parser
|
||||
import Check
|
||||
import Eval
|
||||
import Pretty
|
||||
|
||||
import Control.Monad.Trans
|
||||
import System.Console.Haskeline
|
||||
|
||||
process :: String -> IO ()
|
||||
process line = do
|
||||
let res = parseExpr line
|
||||
case res of
|
||||
Left err -> print err
|
||||
Right ex -> do
|
||||
let chk = checkTop [] ex
|
||||
case chk of
|
||||
Left tyerr -> print tyerr
|
||||
Right _ -> print $ runEval ex
|
||||
|
||||
main :: IO ()
|
||||
main = runInputT defaultSettings loop
|
||||
where
|
||||
loop = do
|
||||
minput <- getInputLine "Stlc> "
|
||||
case minput of
|
||||
Nothing -> outputStrLn "Goodbye."
|
||||
Just input -> (liftIO $ process input) >> loop
|
76
chapter5/stlc/Parser.hs
Normal file
76
chapter5/stlc/Parser.hs
Normal file
@ -0,0 +1,76 @@
|
||||
module Parser (
|
||||
parseExpr
|
||||
) where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.String (Parser)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
|
||||
import Lexer
|
||||
import Syntax
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Expression
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
variable :: Parser Expr
|
||||
variable = do
|
||||
x <- identifier
|
||||
return (Var x)
|
||||
|
||||
number :: Parser Expr
|
||||
number = do
|
||||
n <- natural
|
||||
return (Lit (LInt (fromIntegral n)))
|
||||
|
||||
lambda :: Parser Expr
|
||||
lambda = do
|
||||
reservedOp "\\"
|
||||
x <- identifier
|
||||
reservedOp ":"
|
||||
t <- type'
|
||||
reservedOp "."
|
||||
e <- expr
|
||||
return (Lam x t e)
|
||||
|
||||
bool :: Parser Expr
|
||||
bool = (reserved "True" >> return (Lit (LBool True)))
|
||||
<|> (reserved "False" >> return (Lit (LBool False)))
|
||||
|
||||
term :: Parser Expr
|
||||
term = parens expr
|
||||
<|> bool
|
||||
<|> number
|
||||
<|> variable
|
||||
<|> lambda
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = do
|
||||
es <- many1 term
|
||||
return (foldl1 App es)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
tyatom :: Parser Type
|
||||
tyatom = tylit <|> (parens type')
|
||||
|
||||
tylit :: Parser Type
|
||||
tylit = (reservedOp "Bool" >> return TBool) <|> (reservedOp "Int" >> return TInt)
|
||||
|
||||
type' :: Parser Type
|
||||
type' = Ex.buildExpressionParser tyops tyatom
|
||||
where
|
||||
infixOp x f = Ex.Infix (reservedOp x >> return f)
|
||||
tyops = [
|
||||
[infixOp "->" TArr Ex.AssocRight]
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Toplevel
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
parseExpr :: String -> Either ParseError Expr
|
||||
parseExpr input = parse (contents expr) "<stdin>" input
|
53
chapter5/stlc/Pretty.hs
Normal file
53
chapter5/stlc/Pretty.hs
Normal file
@ -0,0 +1,53 @@
|
||||
module Pretty (
|
||||
ppexpr,
|
||||
pptype
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
import Check
|
||||
|
||||
import Text.PrettyPrint
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
pp :: p -> Doc
|
||||
pp = ppr 0
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr p ex = case ex of
|
||||
Var x -> text x
|
||||
Lit (LInt a) -> text (show a)
|
||||
Lit (LBool b) -> text (show b)
|
||||
App a b -> (parensIf (p>0) (ppr (p+1) a)) <+> (ppr p b)
|
||||
Lam x t a -> parensIf (p > 0) $
|
||||
char '\\'
|
||||
<+> parens (text x <+> char ':' <+> ppr p t)
|
||||
<+> text "->"
|
||||
<+> ppr (p+1) a
|
||||
|
||||
instance Pretty Type where
|
||||
ppr _ TInt = text "Int"
|
||||
ppr _ TBool = text "Bool"
|
||||
ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b
|
||||
where
|
||||
isArrow TArr{} = True
|
||||
isArrow _ = False
|
||||
|
||||
instance Show TypeError where
|
||||
show (Mismatch a b) =
|
||||
"Expecting " ++ (pptype b) ++ " but got " ++ (pptype a)
|
||||
show (NotFunction a) =
|
||||
"Tried to apply to non-function type: " ++ (pptype a)
|
||||
show (NotInScope a) =
|
||||
"Variable " ++ a ++ " is not in scope"
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = render . ppr 0
|
||||
|
||||
pptype :: Type -> String
|
||||
pptype = render . ppr 0
|
32
chapter5/stlc/README.md
Normal file
32
chapter5/stlc/README.md
Normal file
@ -0,0 +1,32 @@
|
||||
Simply Typed Lambda Calculus
|
||||
============================
|
||||
|
||||
Simply typed lambda calculus.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
Usage:
|
||||
|
||||
```haskell
|
||||
./stlc
|
||||
Stlc> (\x : Int . \y : Int . y) 1 2
|
||||
2
|
||||
|
||||
Stlc> (\x : (Int -> Int). x) (\x : Int . 1) 2
|
||||
1
|
||||
|
||||
Stlc> (\x : Int . x) False
|
||||
Couldn't match expected type 'Int' with actual type: 'Bool'
|
||||
|
||||
Stlc> (\x : Int . (\y : Int . x))
|
||||
<<closure>>
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
2
chapter5/stlc/Setup.hs
Normal file
2
chapter5/stlc/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
21
chapter5/stlc/Syntax.hs
Normal file
21
chapter5/stlc/Syntax.hs
Normal file
@ -0,0 +1,21 @@
|
||||
module Syntax where
|
||||
|
||||
type Name = String
|
||||
|
||||
data Expr
|
||||
= Var Name
|
||||
| Lit Ground
|
||||
| App Expr Expr
|
||||
| Lam Name Type Expr
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Ground
|
||||
= LInt Int
|
||||
| LBool Bool
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Type
|
||||
= TInt
|
||||
| TBool
|
||||
| TArr Type Type
|
||||
deriving (Eq, Read, Show)
|
21
chapter5/stlc/stlc.cabal
Normal file
21
chapter5/stlc/stlc.cabal
Normal file
@ -0,0 +1,21 @@
|
||||
name: stlc
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable stlc
|
||||
build-depends:
|
||||
base >= 4.6 && <4.7
|
||||
, pretty >= 1.1 && <1.2
|
||||
, parsec >= 3.1 && <3.2
|
||||
, containers >= 0.5 && <0.6
|
||||
, haskeline >= 0.7
|
||||
, mtl
|
||||
, transformers
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
31
chapter6/hoas.hs
Normal file
31
chapter6/hoas.hs
Normal file
@ -0,0 +1,31 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
data Expr a where
|
||||
Lift :: a -> Expr a
|
||||
Tup :: Expr a -> Expr b -> Expr (a, b)
|
||||
Lam :: (Expr a -> Expr b) -> Expr (a -> b)
|
||||
App :: Expr (a -> b) -> Expr a -> Expr b
|
||||
Fix :: Expr (a -> a) -> Expr a
|
||||
|
||||
eval :: Expr a -> a
|
||||
eval (Lift v) = v
|
||||
eval (Tup e1 e2) = (eval e1, eval e2)
|
||||
eval (Lam f) = \x -> eval (f (Lift x))
|
||||
eval (App e1 e2) = (eval e1) (eval e2)
|
||||
eval (Fix f) = (eval f) (eval (Fix f))
|
||||
|
||||
fact :: Expr (Integer -> Integer)
|
||||
fact =
|
||||
Fix (
|
||||
Lam (\f ->
|
||||
Lam (\y ->
|
||||
Lift (
|
||||
if eval y == 0
|
||||
then 1
|
||||
else eval y * (eval f) (eval y - 1)))))
|
||||
|
||||
test :: Integer
|
||||
test = eval fact 10
|
||||
|
||||
main :: IO ()
|
||||
main = print test
|
42
chapter6/interp.hs
Normal file
42
chapter6/interp.hs
Normal file
@ -0,0 +1,42 @@
|
||||
-- Traditional call-by-value interpreter.
|
||||
|
||||
data Expr
|
||||
= Var Int
|
||||
| Lam Expr
|
||||
| App Expr Expr
|
||||
| Lit Int
|
||||
| Prim PrimOp Expr Expr
|
||||
deriving Show
|
||||
|
||||
data Value
|
||||
= VInt Int
|
||||
| VClosure Expr Env
|
||||
deriving Show
|
||||
|
||||
data PrimOp = Add | Mul
|
||||
deriving Show
|
||||
|
||||
type Env = [Value]
|
||||
|
||||
eval :: Env -> Expr -> Value
|
||||
eval env term = case term of
|
||||
Var n -> env !! n
|
||||
Lam a -> VClosure a env
|
||||
App a b ->
|
||||
let VClosure c env' = eval env a in
|
||||
let v = eval env b in
|
||||
eval (v : env') c
|
||||
|
||||
Lit n -> VInt n
|
||||
Prim p a b -> (evalPrim p) (eval env a) (eval env b)
|
||||
|
||||
evalPrim :: PrimOp -> Value -> Value -> Value
|
||||
evalPrim Add (VInt a) (VInt b) = VInt (a + b)
|
||||
evalPrim Mul (VInt a) (VInt b) = VInt (a + b)
|
||||
|
||||
emptyEnv :: Env
|
||||
emptyEnv = []
|
||||
|
||||
-- (\x y -> x + y) 10 20
|
||||
test :: Value
|
||||
test = eval emptyEnv $ App (App (Lam (Lam (Prim Add (Var 0) (Var 1)))) (Lit 10)) (Lit 20)
|
104
chapter6/io.hs
Normal file
104
chapter6/io.hs
Normal file
@ -0,0 +1,104 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
import Control.Monad
|
||||
|
||||
type Name = String
|
||||
|
||||
data ExprP a
|
||||
= VarP a
|
||||
| GlobalP Name
|
||||
| AppP (ExprP a) (ExprP a)
|
||||
| LamP (a -> ExprP a)
|
||||
| LitP Char
|
||||
| EffectP a
|
||||
|
||||
data Value
|
||||
= VChar Char
|
||||
| VFun (Value -> Value)
|
||||
| VEffect (IO Value)
|
||||
| VUnit
|
||||
|
||||
instance Show Value where
|
||||
show (VChar x) = show x
|
||||
show (VUnit) = "()"
|
||||
show (VFun _) = "<<function>>"
|
||||
show (VEffect {}) = "<<effect>>"
|
||||
|
||||
newtype Expr = Expr { unExpr :: forall a . ExprP a }
|
||||
|
||||
fromVFun :: Value -> (Value -> Value)
|
||||
fromVFun val = case val of
|
||||
VFun f -> f
|
||||
_ -> error "not a function"
|
||||
|
||||
fromVChar :: Value -> Char
|
||||
fromVChar val = case val of
|
||||
VChar n -> n
|
||||
_ -> error "not a char"
|
||||
|
||||
fromVEff :: Value -> (IO Value)
|
||||
fromVEff val = case val of
|
||||
VEffect f -> f
|
||||
_ -> error "not a effect"
|
||||
|
||||
lam :: (Value -> Value) -> Value
|
||||
lam = VFun
|
||||
|
||||
unary :: (Value -> Value) -> Value
|
||||
unary f = lam $ \a -> f a
|
||||
|
||||
binary :: (Value -> Value -> Value) -> Value
|
||||
binary f = lam $ \a ->
|
||||
lam $ \b -> f a b
|
||||
|
||||
prim :: Name -> Value
|
||||
prim op = case op of
|
||||
"putChar#" -> unary $ \x ->
|
||||
VEffect $ do
|
||||
putChar (fromVChar x)
|
||||
return VUnit
|
||||
|
||||
"getChar#" -> VEffect $ do
|
||||
val <- getChar
|
||||
return (VChar val)
|
||||
|
||||
"bindIO#" -> binary $ \x y -> bindIO x y
|
||||
"returnIO#" -> unary $ \x -> returnIO x
|
||||
"thenIO#" -> binary $ \x y -> thenIO x y
|
||||
|
||||
bindIO :: Value -> Value -> Value
|
||||
bindIO (VEffect f) (VFun g) = VEffect (f >>= fromVEff . g)
|
||||
|
||||
thenIO :: Value -> Value -> Value
|
||||
thenIO (VEffect f) (VEffect g) = VEffect (f >> g)
|
||||
|
||||
returnIO :: Value -> Value
|
||||
returnIO a = VEffect $ return a
|
||||
|
||||
eval :: Expr -> Value
|
||||
eval e = ev (unExpr e) where
|
||||
ev (LamP f) = VFun(ev . f)
|
||||
ev (AppP e1 e2) = fromVFun (ev e1) (ev e2)
|
||||
ev (LitP n) = VChar n
|
||||
ev (EffectP v) = v
|
||||
ev (VarP v) = v
|
||||
ev (GlobalP op) = prim op
|
||||
|
||||
gets, puts, bind, seqn :: ExprP a
|
||||
gets = GlobalP "getChar#"
|
||||
puts = GlobalP "putChar#"
|
||||
bind = GlobalP "bindIO#"
|
||||
seqn = GlobalP "thenIO#"
|
||||
|
||||
run :: Expr -> IO ()
|
||||
run f = void (fromVEff (eval f))
|
||||
|
||||
|
||||
example1 :: IO ()
|
||||
example1 = run $ Expr (AppP (AppP bind gets) puts)
|
||||
|
||||
example2 :: IO ()
|
||||
example2 = run $ Expr $ foldr1 seq (str "Hello Haskell!\n")
|
||||
where
|
||||
seq a b = AppP (AppP seqn a) b
|
||||
str xs = fmap (\c -> AppP puts (LitP c)) xs
|
91
chapter6/lazy.hs
Normal file
91
chapter6/lazy.hs
Normal file
@ -0,0 +1,91 @@
|
||||
import Data.IORef
|
||||
|
||||
data Expr
|
||||
= EVar String
|
||||
| ELam String Expr
|
||||
| EApp Expr Expr
|
||||
| EBool Bool
|
||||
| EInt Integer
|
||||
| EFix Expr
|
||||
deriving (Show)
|
||||
|
||||
data Value
|
||||
= VBool Bool
|
||||
| VInt Integer
|
||||
| VClosure (Thunk -> IO Value)
|
||||
|
||||
instance Show Value where
|
||||
show (VBool b) = show b
|
||||
show (VInt n) = show n
|
||||
show (VClosure _) = "<<closure>>"
|
||||
|
||||
type Env = [(String, IORef Thunk)]
|
||||
|
||||
type Thunk = () -> IO Value
|
||||
|
||||
lookupEnv :: Env -> String -> IO (IORef Thunk)
|
||||
lookupEnv [] y = error $ "Unbound Variable" ++ y
|
||||
lookupEnv ((x, v) : xs) n =
|
||||
if x == n
|
||||
then return v
|
||||
else lookupEnv xs n
|
||||
|
||||
force :: IORef Thunk -> IO Value
|
||||
force ref = do
|
||||
th <- readIORef ref
|
||||
v <- th ()
|
||||
update ref v
|
||||
return v
|
||||
|
||||
mkThunk :: Env -> String -> Expr -> (Thunk -> IO Value)
|
||||
mkThunk env x body = \a -> do
|
||||
a' <- newIORef a
|
||||
eval ((x, a') : env) body
|
||||
|
||||
update :: IORef Thunk -> Value -> IO ()
|
||||
update ref v = do
|
||||
writeIORef ref (\() -> return v)
|
||||
return ()
|
||||
|
||||
eval :: Env -> Expr -> IO Value
|
||||
eval env ex = case ex of
|
||||
EVar n -> do
|
||||
th <- lookupEnv env n
|
||||
v <- force th
|
||||
return v
|
||||
|
||||
ELam x e -> return $ VClosure (mkThunk env x e)
|
||||
|
||||
EApp a b -> do
|
||||
VClosure c <- eval env a
|
||||
c (\() -> eval env b)
|
||||
|
||||
EBool b -> return $ VBool b
|
||||
EInt n -> return $ VInt n
|
||||
EFix e -> eval env (EApp e (EFix e))
|
||||
|
||||
-- Tests
|
||||
-- -----
|
||||
|
||||
-- diverge = fix (\x -> x x)
|
||||
diverge :: Expr
|
||||
diverge = EFix (ELam "x" (EApp (EVar "x") (EVar "x")))
|
||||
|
||||
-- ignore = \x -> 0
|
||||
ignore :: Expr
|
||||
ignore = ELam "x" (EInt 0)
|
||||
|
||||
-- omega = (\x -> x x) (\x -> x x)
|
||||
omega :: Expr
|
||||
omega = EApp (ELam "x" (EApp (EVar "x") (EVar "x")))
|
||||
(ELam "x" (EApp (EVar "x") (EVar "x")))
|
||||
|
||||
-- test1 = (\y -> 42) omega
|
||||
test1 :: IO Value
|
||||
test1 = eval [] $ EApp (ELam "y" (EInt 42)) omega
|
||||
|
||||
-- test2 = (\y -> 0) diverge
|
||||
test2 :: IO Value
|
||||
test2 = eval [] $ EApp ignore diverge
|
||||
|
||||
main = return ()
|
0
chapter6/phoas.hs
Normal file
0
chapter6/phoas.hs
Normal file
75
chapter7/poly/Eval.hs
Normal file
75
chapter7/poly/Eval.hs
Normal file
@ -0,0 +1,75 @@
|
||||
module Eval (
|
||||
runEval,
|
||||
|
||||
TermEnv,
|
||||
emptyTmenv
|
||||
) where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Control.Monad.Identity
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data Value
|
||||
= VInt Integer
|
||||
| VBool Bool
|
||||
| VClosure String Expr TermEnv
|
||||
|
||||
type TermEnv = Map.Map String Value
|
||||
type Interpreter t = Identity t
|
||||
|
||||
emptyTmenv :: TermEnv
|
||||
emptyTmenv = Map.empty
|
||||
|
||||
instance Show Value where
|
||||
show (VInt n) = show n
|
||||
show (VBool n) = show n
|
||||
show VClosure{} = "<<closure>>"
|
||||
|
||||
eval :: TermEnv -> Expr -> Interpreter Value
|
||||
eval env expr = case expr of
|
||||
Lit (LInt k) -> return $ VInt k
|
||||
Lit (LBool k) -> return $ VBool k
|
||||
|
||||
Var x -> do
|
||||
let Just v = Map.lookup x env
|
||||
return v
|
||||
|
||||
Op op a b -> do
|
||||
VInt a' <- eval env a
|
||||
VInt b' <- eval env b
|
||||
return $ (binop op) a' b'
|
||||
|
||||
Lam x body ->
|
||||
return (VClosure x body env)
|
||||
|
||||
App fun arg -> do
|
||||
VClosure x body clo <- eval env fun
|
||||
argv <- eval env arg
|
||||
let nenv = Map.insert x argv clo
|
||||
eval nenv body
|
||||
|
||||
Let x e body -> do
|
||||
e' <- eval env e
|
||||
let nenv = Map.insert x e' env
|
||||
eval nenv body
|
||||
|
||||
If cond tr fl -> do
|
||||
VBool br <- eval env cond
|
||||
if br == True
|
||||
then eval env tr
|
||||
else eval env fl
|
||||
|
||||
Fix e -> do
|
||||
eval env (App e (Fix e))
|
||||
|
||||
binop :: Binop -> Integer -> Integer -> Value
|
||||
binop Add a b = VInt $ a + b
|
||||
binop Mul a b = VInt $ a * b
|
||||
binop Sub a b = VInt $ a - b
|
||||
binop Eql a b = VBool $ a == b
|
||||
|
||||
runEval :: TermEnv -> String -> Expr -> (Value, TermEnv)
|
||||
runEval env nm ex =
|
||||
let res = runIdentity (eval env ex) in
|
||||
(res, Map.insert nm res env)
|
212
chapter7/poly/Infer.hs
Normal file
212
chapter7/poly/Infer.hs
Normal file
@ -0,0 +1,212 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Infer where
|
||||
|
||||
import Prelude hiding (foldr)
|
||||
|
||||
import Type
|
||||
import Syntax
|
||||
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Except
|
||||
|
||||
import Data.Monoid
|
||||
import Data.List (nub)
|
||||
import Data.Foldable (foldr)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
newtype TypeEnv = TypeEnv (Map.Map Var Scheme) deriving Monoid
|
||||
|
||||
data Unique = Unique { count :: Int }
|
||||
type Infer a = ExceptT TypeError (State Unique) a
|
||||
type Subst = Map.Map TVar Type
|
||||
|
||||
data TypeError
|
||||
= UnificationFail Type Type
|
||||
| InfiniteType TVar Type
|
||||
| UnboundVariable String
|
||||
| GenericTypeError
|
||||
|
||||
runInfer :: Infer (Subst, Type) -> Either TypeError Scheme
|
||||
runInfer m = case evalState (runExceptT m) initUnique of
|
||||
Left err -> Left err
|
||||
Right res -> Right $ closeOver res
|
||||
|
||||
closeOver :: (Map.Map TVar Type, Type) -> Scheme
|
||||
closeOver (sub, ty) = normalize sc
|
||||
where sc = generalize emptyTyenv (apply sub ty)
|
||||
|
||||
initUnique :: Unique
|
||||
initUnique = Unique { count = 0 }
|
||||
|
||||
extend :: TypeEnv -> (Var, Scheme) -> TypeEnv
|
||||
extend (TypeEnv env) (x, s) = TypeEnv $ Map.insert x s env
|
||||
|
||||
emptyTyenv :: TypeEnv
|
||||
emptyTyenv = TypeEnv Map.empty
|
||||
|
||||
typeof :: TypeEnv -> Var -> Maybe Type.Scheme
|
||||
typeof (TypeEnv env) name = Map.lookup name env
|
||||
|
||||
class Substitutable a where
|
||||
apply :: Subst -> a -> a
|
||||
ftv :: a -> Set.Set TVar
|
||||
|
||||
instance Substitutable Type where
|
||||
apply _ (TCon a) = TCon a
|
||||
apply s t@(TVar a) = Map.findWithDefault t a s
|
||||
apply s (t1 `TArr` t2) = apply s t1 `TArr` apply s t2
|
||||
|
||||
ftv TCon{} = Set.empty
|
||||
ftv (TVar a) = Set.singleton a
|
||||
ftv (t1 `TArr` t2) = ftv t1 `Set.union` ftv t2
|
||||
|
||||
instance Substitutable Scheme where
|
||||
apply s (Forall as t) = Forall as $ apply s' t
|
||||
where s' = foldr Map.delete s as
|
||||
ftv (Forall as t) = ftv t `Set.difference` Set.fromList as
|
||||
|
||||
instance Substitutable a => Substitutable [a] where
|
||||
apply = fmap . apply
|
||||
ftv = foldr (Set.union . ftv) Set.empty
|
||||
|
||||
instance Substitutable TypeEnv where
|
||||
apply s (TypeEnv env) = TypeEnv $ Map.map (apply s) env
|
||||
ftv (TypeEnv env) = ftv $ Map.elems env
|
||||
|
||||
|
||||
nullSubst :: Subst
|
||||
nullSubst = Map.empty
|
||||
|
||||
compose :: Subst -> Subst -> Subst
|
||||
s1 `compose` s2 = Map.map (apply s1) s2 `Map.union` s1
|
||||
|
||||
unify :: Type -> Type -> Infer Subst
|
||||
unify (l `TArr` r) (l' `TArr` r') = do
|
||||
s1 <- unify l l'
|
||||
s2 <- unify (apply s1 r) (apply s1 r')
|
||||
return (s2 `compose` s1)
|
||||
|
||||
unify (TVar a) t = bind a t
|
||||
unify t (TVar a) = bind a t
|
||||
unify (TCon a) (TCon b) | a == b = return nullSubst
|
||||
unify t1 t2 = throwError $ UnificationFail t1 t2
|
||||
|
||||
bind :: TVar -> Type -> Infer Subst
|
||||
bind a t | t == TVar a = return nullSubst
|
||||
| occursCheck a t = throwError $ InfiniteType a t
|
||||
| otherwise = return $ Map.singleton a t
|
||||
|
||||
occursCheck :: Substitutable a => TVar -> a -> Bool
|
||||
occursCheck a t = a `Set.member` ftv t
|
||||
|
||||
letters :: [String]
|
||||
letters = [1..] >>= flip replicateM ['a'..'z']
|
||||
|
||||
fresh :: Infer Type
|
||||
fresh = do
|
||||
s <- get
|
||||
put s{count = count s + 1}
|
||||
return $ TVar $ TV (letters !! count s)
|
||||
|
||||
instantiate :: Scheme -> Infer Type
|
||||
instantiate (Forall as t) = do
|
||||
as' <- mapM (const fresh) as
|
||||
let s = Map.fromList $ zip as as'
|
||||
return $ apply s t
|
||||
|
||||
generalize :: TypeEnv -> Type -> Scheme
|
||||
generalize env t = Forall as t
|
||||
where as = Set.toList $ ftv t `Set.difference` ftv env
|
||||
|
||||
ops :: Map.Map Binop Type
|
||||
ops = Map.fromList [
|
||||
(Add, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Mul, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Sub, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Eql, (typeInt `TArr` (typeInt `TArr` typeBool)))
|
||||
]
|
||||
|
||||
lookupEnv :: TypeEnv -> Var -> Infer (Subst, Type)
|
||||
lookupEnv (TypeEnv env) x = do
|
||||
case Map.lookup x env of
|
||||
Nothing -> throwError $ UnboundVariable (show x)
|
||||
Just s -> do t <- instantiate s
|
||||
return (nullSubst, t)
|
||||
|
||||
infer :: TypeEnv -> Expr -> Infer (Subst, Type)
|
||||
infer env ex = case ex of
|
||||
|
||||
Var x -> lookupEnv env x
|
||||
|
||||
Lam x e -> do
|
||||
tv <- fresh
|
||||
let env' = env `extend` (x, Forall [] tv)
|
||||
(s1, t1) <- infer env' e
|
||||
return (s1, apply s1 tv `TArr` t1)
|
||||
|
||||
App e1 e2 -> do
|
||||
tv <- fresh
|
||||
(s1, t1) <- infer env e1
|
||||
(s2, t2) <- infer (apply s1 env) e2
|
||||
s3 <- unify (apply s2 t1) (TArr t2 tv)
|
||||
return (s3 `compose` s2 `compose` s1, apply s3 tv)
|
||||
|
||||
Let x e1 e2 -> do
|
||||
(s1, t1) <- infer env e1
|
||||
let env' = apply s1 env
|
||||
t' = generalize env' t1
|
||||
(s2, t2) <- infer (env' `extend` (x, t')) e2
|
||||
return (s1 `compose` s2, t2)
|
||||
|
||||
If cond tr fl -> do
|
||||
(s1, t1) <- infer env cond
|
||||
(s2, t2) <- infer env tr
|
||||
(s3, t3) <- infer env fl
|
||||
s4 <- unify t1 typeBool
|
||||
s5 <- unify t2 t3
|
||||
return (s5 `compose` s4 `compose` s3 `compose` s2 `compose` s1, apply s5 t2)
|
||||
|
||||
Fix e1 -> do
|
||||
(s1, t) <- infer env e1
|
||||
tv <- fresh
|
||||
s2 <- unify (TArr tv tv) t
|
||||
return (s2, apply s1 tv)
|
||||
|
||||
Op op e1 e2 -> do
|
||||
(s1, t1) <- infer env e1
|
||||
(s2, t2) <- infer env e2
|
||||
tv <- fresh
|
||||
s3 <- unify (TArr t1 (TArr t2 tv)) (ops Map.! op)
|
||||
return (s1 `compose` s2 `compose` s3, apply s3 tv)
|
||||
|
||||
Lit (LInt _) -> return (nullSubst, typeInt)
|
||||
Lit (LBool _) -> return (nullSubst, typeBool)
|
||||
|
||||
inferExpr :: TypeEnv -> Expr -> Either TypeError Scheme
|
||||
inferExpr env = runInfer . infer env
|
||||
|
||||
inferTop :: TypeEnv -> [(String, Expr)] -> Either TypeError TypeEnv
|
||||
inferTop env [] = Right env
|
||||
inferTop env ((name, ex):xs) = case (inferExpr env ex) of
|
||||
Left err -> Left err
|
||||
Right ty -> inferTop (extend env (name, ty)) xs
|
||||
|
||||
normalize :: Scheme -> Scheme
|
||||
normalize (Forall ts body) = Forall (fmap snd ord) (normtype body)
|
||||
where
|
||||
ord = zip (nub $ fv [] body) (fmap TV letters)
|
||||
|
||||
fv xs (TVar a) = xs ++ [a]
|
||||
fv xs (TArr a b) = fv xs a ++ fv xs b
|
||||
fv _ (TCon _) = []
|
||||
|
||||
normtype (TArr a b) = TArr (normtype a) (normtype b)
|
||||
normtype (TCon a) = TCon a
|
||||
normtype (TVar a) =
|
||||
case lookup a ord of
|
||||
Just x -> TVar x
|
||||
Nothing -> error "type variable not in signature"
|
19
chapter7/poly/LICENSE
Normal file
19
chapter7/poly/LICENSE
Normal file
@ -0,0 +1,19 @@
|
||||
Copyright (c) 2014-2015, Stephen Diehl
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to
|
||||
deal in the Software without restriction, including without limitation the
|
||||
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
sell copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
IN THE SOFTWARE.
|
73
chapter7/poly/Lexer.hs
Normal file
73
chapter7/poly/Lexer.hs
Normal file
@ -0,0 +1,73 @@
|
||||
module Lexer where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text.Lazy
|
||||
import qualified Data.Text.Lazy as L
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
|
||||
import Data.Functor.Identity
|
||||
|
||||
type Op a = Ex.Operator L.Text () Identity a
|
||||
type Operators a = Ex.OperatorTable L.Text () Identity a
|
||||
|
||||
reservedNames :: [String]
|
||||
reservedNames = [
|
||||
"let",
|
||||
"in",
|
||||
"fix",
|
||||
"rec",
|
||||
"if",
|
||||
"then",
|
||||
"else"
|
||||
]
|
||||
|
||||
reservedOps :: [String]
|
||||
reservedOps = [
|
||||
"->",
|
||||
"\\",
|
||||
"+",
|
||||
"*",
|
||||
"-",
|
||||
"="
|
||||
]
|
||||
|
||||
lexer :: Tok.GenTokenParser L.Text () Identity
|
||||
lexer = Tok.makeTokenParser $ Tok.LanguageDef
|
||||
{ Tok.commentStart = "{-"
|
||||
, Tok.commentEnd = "-}"
|
||||
, Tok.commentLine = "--"
|
||||
, Tok.nestedComments = True
|
||||
, Tok.identStart = letter
|
||||
, Tok.identLetter = alphaNum <|> oneOf "_'"
|
||||
, Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
|
||||
, Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
|
||||
, Tok.reservedNames = reservedNames
|
||||
, Tok.reservedOpNames = reservedOps
|
||||
, Tok.caseSensitive = True
|
||||
}
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
identifier :: Parser String
|
||||
identifier = Tok.identifier lexer
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
semiSep :: Parser a -> Parser [a]
|
||||
semiSep = Tok.semiSep lexer
|
||||
|
||||
semi :: Parser String
|
||||
semi = Tok.semi lexer
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
169
chapter7/poly/Main.hs
Normal file
169
chapter7/poly/Main.hs
Normal file
@ -0,0 +1,169 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
import Syntax
|
||||
import Infer
|
||||
import Parser
|
||||
import Pretty
|
||||
import Eval
|
||||
|
||||
import Data.Monoid
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text.Lazy as L
|
||||
import qualified Data.Text.Lazy.IO as L
|
||||
import Data.List (isPrefixOf, foldl')
|
||||
|
||||
import Control.Monad.State.Strict
|
||||
|
||||
import System.Exit
|
||||
import System.Environment
|
||||
import System.Console.Repline
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data IState = IState
|
||||
{ tyctx :: TypeEnv -- Type environment
|
||||
, tmctx :: TermEnv -- Value environment
|
||||
}
|
||||
|
||||
initState :: IState
|
||||
initState = IState emptyTyenv emptyTmenv
|
||||
|
||||
type Repl a = HaskelineT (StateT IState IO) a
|
||||
|
||||
hoistErr :: Show e => Either e a -> Repl a
|
||||
hoistErr (Right val) = return val
|
||||
hoistErr (Left err) = do
|
||||
liftIO $ print err
|
||||
abort
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Execution
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
evalDef :: TermEnv -> (String, Expr) -> TermEnv
|
||||
evalDef env (nm, ex) = tmctx'
|
||||
where (val, tmctx') = runEval env nm ex
|
||||
|
||||
|
||||
exec :: Bool -> L.Text -> Repl ()
|
||||
exec update source = do
|
||||
-- Get the current interpreter state
|
||||
st <- get
|
||||
|
||||
-- Parser ( returns AST )
|
||||
mod <- hoistErr $ parseModule "<stdin>" source
|
||||
|
||||
-- Type Inference ( returns Typing Environment )
|
||||
tyctx' <- hoistErr $ inferTop (tyctx st) mod
|
||||
|
||||
-- Create the new environment
|
||||
let st' = st { tmctx = foldl' evalDef (tmctx st) mod
|
||||
, tyctx = tyctx' <> (tyctx st)
|
||||
}
|
||||
|
||||
-- Update the interpreter state
|
||||
when update (put st')
|
||||
|
||||
-- If a value is entered, print it.
|
||||
case lookup "it" mod of
|
||||
Nothing -> return ()
|
||||
Just ex -> do
|
||||
let (val, _) = runEval (tmctx st') "it" ex
|
||||
showOutput (show val) st'
|
||||
|
||||
showOutput :: String -> IState -> Repl ()
|
||||
showOutput arg st = do
|
||||
case Infer.typeof (tyctx st) "it" of
|
||||
Just val -> liftIO $ putStrLn $ ppsignature (arg, val)
|
||||
Nothing -> return ()
|
||||
|
||||
cmd :: String -> Repl ()
|
||||
cmd source = exec True (L.pack source)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Commands
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- :browse command
|
||||
browse :: [String] -> Repl ()
|
||||
browse _ = do
|
||||
st <- get
|
||||
liftIO $ mapM_ putStrLn $ ppenv (tyctx st)
|
||||
|
||||
-- :load command
|
||||
load :: [String] -> Repl ()
|
||||
load args = do
|
||||
contents <- liftIO $ L.readFile (unwords args)
|
||||
exec True contents
|
||||
|
||||
-- :type command
|
||||
typeof :: [String] -> Repl ()
|
||||
typeof args = do
|
||||
st <- get
|
||||
let arg = unwords args
|
||||
case Infer.typeof (tyctx st) arg of
|
||||
Just val -> liftIO $ putStrLn $ ppsignature (arg, val)
|
||||
Nothing -> exec False (L.pack arg)
|
||||
|
||||
-- :quit command
|
||||
quit :: a -> Repl ()
|
||||
quit _ = liftIO $ exitSuccess
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Tab completion
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Prefix tab completer
|
||||
defaultMatcher :: MonadIO m => [(String, CompletionFunc m)]
|
||||
defaultMatcher = [
|
||||
(":load" , fileCompleter)
|
||||
]
|
||||
|
||||
-- Default tab completer
|
||||
comp :: (Monad m, MonadState IState m) => WordCompleter m
|
||||
comp n = do
|
||||
let cmds = [":load", ":browse", ":quit", ":type"]
|
||||
TypeEnv ctx <- gets tyctx
|
||||
let defs = Map.keys ctx
|
||||
return $ filter (isPrefixOf n) (cmds ++ defs)
|
||||
|
||||
options :: [(String, [String] -> Repl ())]
|
||||
options = [
|
||||
("load" , load)
|
||||
, ("browse" , browse)
|
||||
, ("quit" , quit)
|
||||
, ("type" , Main.typeof)
|
||||
]
|
||||
|
||||
completer :: CompleterStyle (StateT IState IO)
|
||||
completer = Prefix (wordCompleter comp) defaultMatcher
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Shell
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
shell :: Repl a -> IO ()
|
||||
shell pre
|
||||
= flip evalStateT initState
|
||||
$ evalRepl "Poly> " cmd options completer pre
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Toplevel
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
[] -> shell (return ())
|
||||
[fname] -> shell (load [fname])
|
||||
["test", fname] -> shell (load [fname] >> browse [] >> quit ())
|
||||
_ -> putStrLn "invalid arguments"
|
160
chapter7/poly/Parser.hs
Normal file
160
chapter7/poly/Parser.hs
Normal file
@ -0,0 +1,160 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser (
|
||||
parseExpr,
|
||||
parseModule
|
||||
) where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text.Lazy (Parser)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
|
||||
import qualified Data.Text.Lazy as L
|
||||
|
||||
import Lexer
|
||||
import Syntax
|
||||
|
||||
integer :: Parser Integer
|
||||
integer = Tok.integer lexer
|
||||
|
||||
variable :: Parser Expr
|
||||
variable = do
|
||||
x <- identifier
|
||||
return (Var x)
|
||||
|
||||
number :: Parser Expr
|
||||
number = do
|
||||
n <- integer
|
||||
return (Lit (LInt (fromIntegral n)))
|
||||
|
||||
bool :: Parser Expr
|
||||
bool = (reserved "True" >> return (Lit (LBool True)))
|
||||
<|> (reserved "False" >> return (Lit (LBool False)))
|
||||
|
||||
fix :: Parser Expr
|
||||
fix = do
|
||||
reservedOp "fix"
|
||||
x <- aexp
|
||||
return (Fix x)
|
||||
|
||||
lambda :: Parser Expr
|
||||
lambda = do
|
||||
reservedOp "\\"
|
||||
args <- many identifier
|
||||
reservedOp "->"
|
||||
body <- expr
|
||||
return $ foldr Lam body args
|
||||
|
||||
letin :: Parser Expr
|
||||
letin = do
|
||||
reserved "let"
|
||||
x <- identifier
|
||||
reservedOp "="
|
||||
e1 <- expr
|
||||
reserved "in"
|
||||
e2 <- expr
|
||||
return (Let x e1 e2)
|
||||
|
||||
letrecin :: Parser Expr
|
||||
letrecin = do
|
||||
reserved "let"
|
||||
reserved "rec"
|
||||
x <- identifier
|
||||
reservedOp "="
|
||||
e1 <- expr
|
||||
reserved "in"
|
||||
e2 <- expr
|
||||
return (Let x e1 e2)
|
||||
|
||||
ifthen :: Parser Expr
|
||||
ifthen = do
|
||||
reserved "if"
|
||||
cond <- aexp
|
||||
reservedOp "then"
|
||||
tr <- aexp
|
||||
reserved "else"
|
||||
fl <- aexp
|
||||
return (If cond tr fl)
|
||||
|
||||
aexp :: Parser Expr
|
||||
aexp =
|
||||
parens expr
|
||||
<|> bool
|
||||
<|> number
|
||||
<|> ifthen
|
||||
<|> fix
|
||||
<|> try letrecin
|
||||
<|> letin
|
||||
<|> lambda
|
||||
<|> variable
|
||||
|
||||
term :: Parser Expr
|
||||
term = Ex.buildExpressionParser table aexp
|
||||
|
||||
infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a
|
||||
infixOp x f = Ex.Infix (reservedOp x >> return f)
|
||||
|
||||
table :: Operators Expr
|
||||
table = [
|
||||
[
|
||||
infixOp "*" (Op Mul) Ex.AssocLeft
|
||||
],
|
||||
[
|
||||
infixOp "+" (Op Add) Ex.AssocLeft
|
||||
, infixOp "-" (Op Sub) Ex.AssocLeft
|
||||
],
|
||||
[
|
||||
infixOp "==" (Op Eql) Ex.AssocLeft
|
||||
]
|
||||
]
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = do
|
||||
es <- many1 term
|
||||
return (foldl1 App es)
|
||||
|
||||
type Binding = (String, Expr)
|
||||
|
||||
letdecl :: Parser Binding
|
||||
letdecl = do
|
||||
reserved "let"
|
||||
name <- identifier
|
||||
args <- many identifier
|
||||
reservedOp "="
|
||||
body <- expr
|
||||
return $ (name, foldr Lam body args)
|
||||
|
||||
letrecdecl :: Parser (String, Expr)
|
||||
letrecdecl = do
|
||||
reserved "let"
|
||||
reserved "rec"
|
||||
name <- identifier
|
||||
args <- many identifier
|
||||
reservedOp "="
|
||||
body <- expr
|
||||
return $ (name, Fix $ foldr Lam body (name:args))
|
||||
|
||||
val :: Parser Binding
|
||||
val = do
|
||||
ex <- expr
|
||||
return ("it", ex)
|
||||
|
||||
decl :: Parser Binding
|
||||
decl = try letrecdecl <|> letdecl <|> val
|
||||
|
||||
top :: Parser Binding
|
||||
top = do
|
||||
x <- decl
|
||||
optional semi
|
||||
return x
|
||||
|
||||
modl :: Parser [Binding]
|
||||
modl = many top
|
||||
|
||||
parseExpr :: L.Text -> Either ParseError Expr
|
||||
parseExpr input = parse (contents expr) "<stdin>" input
|
||||
|
||||
parseModule :: FilePath -> L.Text -> Either ParseError [(String, Expr)]
|
||||
parseModule fname input = parse (contents modl) fname input
|
93
chapter7/poly/Pretty.hs
Normal file
93
chapter7/poly/Pretty.hs
Normal file
@ -0,0 +1,93 @@
|
||||
{-# Language TypeSynonymInstances #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
|
||||
module Pretty (
|
||||
ppscheme,
|
||||
pptype,
|
||||
ppexpr,
|
||||
ppsignature,
|
||||
ppenv,
|
||||
ppdecl
|
||||
) where
|
||||
|
||||
import Type
|
||||
import Syntax
|
||||
import Infer
|
||||
|
||||
import Text.PrettyPrint
|
||||
import qualified Data.Map as Map
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
instance Pretty Var where
|
||||
ppr _ x = text x
|
||||
|
||||
instance Pretty TVar where
|
||||
ppr _ (TV x) = text x
|
||||
|
||||
instance Pretty Type where
|
||||
ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b
|
||||
where
|
||||
isArrow TArr{} = True
|
||||
isArrow _ = False
|
||||
ppr p (TVar a) = ppr p a
|
||||
ppr _ (TCon a) = text a
|
||||
|
||||
instance Pretty Scheme where
|
||||
ppr p (Forall [] t) = ppr p t
|
||||
ppr p (Forall ts t) = text "forall" <+> hcat (punctuate space (fmap (ppr p) ts)) <> text "." <+> ppr p t
|
||||
|
||||
instance Pretty Binop where
|
||||
ppr _ Add = text "+"
|
||||
ppr _ Sub = text "-"
|
||||
ppr _ Mul = text "-"
|
||||
ppr _ Eql = text "=="
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr p (Var a) = ppr p a
|
||||
ppr p (App a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b
|
||||
ppr p (Lam a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b
|
||||
ppr p (Let a b c) = text "let" <> ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c
|
||||
ppr p (Lit a) = ppr p a
|
||||
ppr p (Op o a b) = parensIf (p>0) $ ppr p a <+> ppr p o <+> ppr p b
|
||||
ppr p (Fix a) = parensIf (p>0) $ text "fix" <> ppr p a
|
||||
ppr p (If a b c) =
|
||||
text "if" <> ppr p a <+>
|
||||
text "then" <+> ppr p b <+>
|
||||
text "else" <+> ppr p c
|
||||
|
||||
instance Pretty Lit where
|
||||
ppr _ (LInt i) = integer i
|
||||
ppr _ (LBool True) = text "True"
|
||||
ppr _ (LBool False) = text "False"
|
||||
|
||||
instance Show TypeError where
|
||||
show (UnificationFail a b) =
|
||||
concat ["Cannot unify types: \n\t", pptype a, "\nwith \n\t", pptype b]
|
||||
show (InfiniteType (TV a) b) =
|
||||
concat ["Cannot construct the the infinite type: ", a, " = ", pptype b]
|
||||
show (UnboundVariable a) = "Not in scope: " ++ a
|
||||
|
||||
ppscheme :: Scheme -> String
|
||||
ppscheme = render . ppr 0
|
||||
|
||||
pptype :: Type -> String
|
||||
pptype = render . ppr 0
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = render . ppr 0
|
||||
|
||||
ppsignature :: (String, Scheme) -> String
|
||||
ppsignature (a, b) = a ++ " : " ++ ppscheme b
|
||||
|
||||
ppdecl :: (String, Expr) -> String
|
||||
ppdecl (a, b) = "let " ++ a ++ " = " ++ ppexpr b
|
||||
|
||||
ppenv :: TypeEnv -> [String]
|
||||
ppenv (TypeEnv env) = fmap ppsignature $ Map.toList env
|
75
chapter7/poly/README.md
Normal file
75
chapter7/poly/README.md
Normal file
@ -0,0 +1,75 @@
|
||||
PolyML
|
||||
======
|
||||
|
||||
A simple ML dialect with definitions, let polymorphism and a fixpoint operator. Uses syntax directed HM type
|
||||
inference.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
Usage:
|
||||
|
||||
```ocaml
|
||||
Poly> let i x = x;
|
||||
i : forall a. a -> a
|
||||
|
||||
Poly> i 3
|
||||
3
|
||||
|
||||
Poly> :type i
|
||||
i : forall a. a -> a
|
||||
|
||||
Poly> :type let k x y = x;
|
||||
k : forall a b. a -> b -> a
|
||||
|
||||
Poly> :type let s f g x = f x (g x)
|
||||
s : forall a b c. ((a -> b) -> c -> a) -> (a -> b) -> c -> b
|
||||
|
||||
Poly> :type let on g f = \x y -> g (f x) (f y)
|
||||
on : forall a b c. (a -> a -> b) -> (c -> a) -> c -> c -> b
|
||||
|
||||
Poly> :type let let_bound = i (i i) (i 3)
|
||||
let_bound : Int
|
||||
|
||||
Poly> :type let compose f g = \x -> f (g x)
|
||||
compose : forall a b c. (a -> b) -> (c -> a) -> c -> b
|
||||
|
||||
Poly> let rec factorial n =
|
||||
if (n == 0)
|
||||
then 1
|
||||
else (n * (factorial (n-1)));
|
||||
```
|
||||
|
||||
Notes
|
||||
=====
|
||||
|
||||
Top level let declarations are syntatic sugar for nested lambda. For example:
|
||||
|
||||
```ocaml
|
||||
let add x y = x + y;
|
||||
```
|
||||
|
||||
Is semantically equivelant to:
|
||||
|
||||
```ocaml
|
||||
let add = \x -> \y -> x + y;
|
||||
```
|
||||
|
||||
Top level Let-rec declarations are syntatic sugar for use of the ``fix`` operator. For example:
|
||||
|
||||
```ocaml
|
||||
let rec factorial n = if (n == 0) then 1 else (n * (factorial (n-1)));
|
||||
```
|
||||
Is semantically equivelant to:
|
||||
|
||||
```ocaml
|
||||
let factorial = fix (\factorial n -> if (n == 0) then 1 else (n * (factorial (n-1))));
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
26
chapter7/poly/Syntax.hs
Normal file
26
chapter7/poly/Syntax.hs
Normal file
@ -0,0 +1,26 @@
|
||||
module Syntax where
|
||||
|
||||
type Var = String
|
||||
|
||||
data Expr
|
||||
= Var Var
|
||||
| App Expr Expr
|
||||
| Lam Var Expr
|
||||
| Let Var Expr Expr
|
||||
| Lit Lit
|
||||
| If Expr Expr Expr
|
||||
| Fix Expr
|
||||
| Op Binop Expr Expr
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Lit
|
||||
= LInt Integer
|
||||
| LBool Bool
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Binop = Add | Sub | Mul | Eql
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type Decl = (String, Expr)
|
||||
|
||||
data Program = Program [Decl] Expr deriving (Show, Eq)
|
19
chapter7/poly/Type.hs
Normal file
19
chapter7/poly/Type.hs
Normal file
@ -0,0 +1,19 @@
|
||||
module Type where
|
||||
|
||||
newtype TVar = TV String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Type
|
||||
= TVar TVar
|
||||
| TCon String
|
||||
| TArr Type Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Scheme = Forall [TVar] Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
typeInt :: Type
|
||||
typeInt = TCon "Int"
|
||||
|
||||
typeBool :: Type
|
||||
typeBool = TCon "Bool"
|
22
chapter7/poly/poly.cabal
Normal file
22
chapter7/poly/poly.cabal
Normal file
@ -0,0 +1,22 @@
|
||||
name: poly
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable poly
|
||||
build-depends:
|
||||
base >= 4.6 && <4.7
|
||||
, pretty >= 1.1 && <1.2
|
||||
, parsec >= 3.1 && <3.2
|
||||
, text >= 1.2 && <1.3
|
||||
, containers >= 0.5 && <0.6
|
||||
, mtl >= 2.2 && <2.3
|
||||
, transformers >= 0.4.2 && <0.5
|
||||
, repline >= 0.1.2.0
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
111
chapter7/poly/test.ml
Normal file
111
chapter7/poly/test.ml
Normal file
@ -0,0 +1,111 @@
|
||||
-- Booleans
|
||||
let T x y = x;
|
||||
let F x y = y;
|
||||
|
||||
-- SKI combinators
|
||||
let I x = x;
|
||||
let K x y = x;
|
||||
let S f g x = f x (g x);
|
||||
|
||||
let skk = S K K;
|
||||
|
||||
let Mu f = f (fix f);
|
||||
|
||||
-- Other combinators
|
||||
let B x y z = x (y z);
|
||||
let C x y z = x z y;
|
||||
let W x y = x y y;
|
||||
|
||||
-- Integer arithmetic
|
||||
let nsucc x = x + 1;
|
||||
let npred x = x - 1;
|
||||
|
||||
-- Arithmetic
|
||||
let succ n f x = f (n f x);
|
||||
|
||||
let zero f x = x ;
|
||||
let one f x = f x ;
|
||||
let two f x = f (f x) ;
|
||||
let three f x = f (f (f x)) ;
|
||||
let four f x = f (f (f (f x))) ;
|
||||
let five f x = f (f (f (f (f x)))) ;
|
||||
let six f x = f (f (f (f (f (f x))))) ;
|
||||
let seven f x = f (f (f (f (f (f (f x)))))) ;
|
||||
let eight f x = f (f (f (f (f (f (f (f x))))))) ;
|
||||
let nine f x = f (f (f (f (f (f (f (f (f x)))))))) ;
|
||||
let ten f x = f (f (f (f (f (f (f (f (f (f x))))))))) ;
|
||||
|
||||
let iszero n = n (\x -> F) T;
|
||||
let plus m n f x = n f (m f x);
|
||||
let mult m n f = m (n f);
|
||||
let pow m n = n m;
|
||||
let pred n f x = n (\g h -> h (g f)) (\u -> x) I;
|
||||
let ack = \m -> m (\f n -> n f (f one)) succ;
|
||||
let sub m n = (n pred) m;
|
||||
|
||||
-- Conversions
|
||||
|
||||
let unbool n = n True False;
|
||||
let unchurch n = n (\i -> i + 1) 0;
|
||||
let rec church n =
|
||||
if (n == 0)
|
||||
then zero
|
||||
else \f x -> f (church (n-1) f x);
|
||||
|
||||
-- Logic
|
||||
let not p = p F T;
|
||||
let and p q = p q F;
|
||||
let or p q = p T q;
|
||||
let cond p x y = p x y;
|
||||
let xor p q = p (q F T) q;
|
||||
let equ p q = not (xor p q);
|
||||
let nand x y = cond x (not y) T;
|
||||
let nor x y = cond x F (not y);
|
||||
|
||||
-- Tuples
|
||||
let fst p = p T;
|
||||
let snd p = p F;
|
||||
let pair a b f = f a b;
|
||||
|
||||
-- Lists
|
||||
let nil x = x;
|
||||
let cons x y = pair F (pair x y);
|
||||
let null z = z T;
|
||||
let head z = fst (snd z);
|
||||
let tail z = snd (snd z);
|
||||
let indx xs n = head (n tail xs);
|
||||
|
||||
let fact = fix (\fact -> \n -> if (n == 0) then 1 else (n * (fact (n-1))));
|
||||
|
||||
let rec fib n =
|
||||
if (n == 0)
|
||||
then 0
|
||||
else if (n==1)
|
||||
then 1
|
||||
else ((fib (n-1)) + (fib (n-2)));
|
||||
|
||||
-- Functions
|
||||
let const x y = x;
|
||||
let compose f g = \x -> f (g x);
|
||||
let twice f x = f (f x);
|
||||
let on g f = \x y -> g (f x) (f y);
|
||||
let ap f x = f (f x);
|
||||
|
||||
-- Let Polymorphism
|
||||
let poly = I (I I) (I 3);
|
||||
let self = (\x -> x) (\x -> x);
|
||||
let innerlet = \x -> (let y = \z -> z in y);
|
||||
let innerletrec = \x -> (let rec y = \z -> z in y);
|
||||
|
||||
-- Fresh variables
|
||||
let wtf = \a b c d e e' f g h i j k l m n o o' o'' o''' p q r r' s t u u' v w x y z ->
|
||||
q u i c k b r o w n f o' x j u' m p s o'' v e r' t h e' l a z y d o''' g;
|
||||
|
||||
-- if-then-else
|
||||
let notbool x = if x then False else True;
|
||||
let eqzero x = if (x == 0) then True else False;
|
||||
|
||||
let rec until p f x =
|
||||
if (p x)
|
||||
then x
|
||||
else (until p f (f x));
|
69
chapter7/poly_constraints/Env.hs
Normal file
69
chapter7/poly_constraints/Env.hs
Normal file
@ -0,0 +1,69 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Env (
|
||||
Env(..),
|
||||
empty,
|
||||
lookup,
|
||||
remove,
|
||||
extend,
|
||||
extends,
|
||||
merge,
|
||||
mergeEnvs,
|
||||
singleton,
|
||||
keys,
|
||||
fromList,
|
||||
toList,
|
||||
) where
|
||||
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
import Syntax
|
||||
import Type
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Foldable hiding (toList)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Typing Environment
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data Env = TypeEnv { types :: Map.Map Name Scheme }
|
||||
deriving (Eq, Show)
|
||||
|
||||
empty :: Env
|
||||
empty = TypeEnv Map.empty
|
||||
|
||||
extend :: Env -> (Name, Scheme) -> Env
|
||||
extend env (x, s) = env { types = Map.insert x s (types env) }
|
||||
|
||||
remove :: Env -> Name -> Env
|
||||
remove (TypeEnv env) var = TypeEnv (Map.delete var env)
|
||||
|
||||
extends :: Env -> [(Name, Scheme)] -> Env
|
||||
extends env xs = env { types = Map.union (Map.fromList xs) (types env) }
|
||||
|
||||
lookup :: Name -> Env -> Maybe Scheme
|
||||
lookup key (TypeEnv tys) = Map.lookup key tys
|
||||
|
||||
merge :: Env -> Env -> Env
|
||||
merge (TypeEnv a) (TypeEnv b) = TypeEnv (Map.union a b)
|
||||
|
||||
mergeEnvs :: [Env] -> Env
|
||||
mergeEnvs = foldl' merge empty
|
||||
|
||||
singleton :: Name -> Scheme -> Env
|
||||
singleton x y = TypeEnv (Map.singleton x y)
|
||||
|
||||
keys :: Env -> [Name]
|
||||
keys (TypeEnv env) = Map.keys env
|
||||
|
||||
fromList :: [(Name, Scheme)] -> Env
|
||||
fromList xs = TypeEnv (Map.fromList xs)
|
||||
|
||||
toList :: Env -> [(Name, Scheme)]
|
||||
toList (TypeEnv env) = Map.toList env
|
||||
|
||||
instance Monoid Env where
|
||||
mempty = empty
|
||||
mappend = merge
|
70
chapter7/poly_constraints/Eval.hs
Normal file
70
chapter7/poly_constraints/Eval.hs
Normal file
@ -0,0 +1,70 @@
|
||||
module Eval where
|
||||
|
||||
import Syntax
|
||||
|
||||
import Control.Monad.Identity
|
||||
import qualified Data.Map as Map
|
||||
|
||||
data Value
|
||||
= VInt Integer
|
||||
| VBool Bool
|
||||
| VClosure String Expr TermEnv
|
||||
|
||||
type TermEnv = Map.Map String Value
|
||||
type Interpreter t = Identity t
|
||||
|
||||
emptyTmenv :: TermEnv
|
||||
emptyTmenv = Map.empty
|
||||
|
||||
instance Show Value where
|
||||
show (VInt n) = show n
|
||||
show (VBool n) = show n
|
||||
show VClosure{} = "<<closure>>"
|
||||
|
||||
eval :: TermEnv -> Expr -> Interpreter Value
|
||||
eval env expr = case expr of
|
||||
Lit (LInt k) -> return $ VInt k
|
||||
Lit (LBool k) -> return $ VBool k
|
||||
|
||||
Var x -> do
|
||||
let Just v = Map.lookup x env
|
||||
return v
|
||||
|
||||
Op op a b -> do
|
||||
VInt a' <- eval env a
|
||||
VInt b' <- eval env b
|
||||
return $ (binop op) a' b'
|
||||
|
||||
Lam x body ->
|
||||
return (VClosure x body env)
|
||||
|
||||
App fun arg -> do
|
||||
VClosure x body clo <- eval env fun
|
||||
argv <- eval env arg
|
||||
let nenv = Map.insert x argv clo
|
||||
eval nenv body
|
||||
|
||||
Let x e body -> do
|
||||
e' <- eval env e
|
||||
let nenv = Map.insert x e' env
|
||||
eval nenv body
|
||||
|
||||
If cond tr fl -> do
|
||||
VBool br <- eval env cond
|
||||
if br == True
|
||||
then eval env tr
|
||||
else eval env fl
|
||||
|
||||
Fix e -> do
|
||||
eval env (App e (Fix e))
|
||||
|
||||
binop :: Binop -> Integer -> Integer -> Value
|
||||
binop Add a b = VInt $ a + b
|
||||
binop Mul a b = VInt $ a * b
|
||||
binop Sub a b = VInt $ a - b
|
||||
binop Eql a b = VBool $ a == b
|
||||
|
||||
runEval :: TermEnv -> String -> Expr -> (Value, TermEnv)
|
||||
runEval env nm ex =
|
||||
let res = runIdentity (eval env ex) in
|
||||
(res, Map.insert nm res env)
|
293
chapter7/poly_constraints/Infer.hs
Normal file
293
chapter7/poly_constraints/Infer.hs
Normal file
@ -0,0 +1,293 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Infer (
|
||||
Constraint,
|
||||
TypeError(..),
|
||||
Subst(..),
|
||||
inferTop,
|
||||
constraintsExpr
|
||||
) where
|
||||
|
||||
import Env
|
||||
import Type
|
||||
import Syntax
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import Control.Monad.RWS
|
||||
import Control.Monad.Identity
|
||||
|
||||
import Data.List (nub)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Classes
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Inference monad
|
||||
type Infer a = (RWST
|
||||
Env -- Typing environment
|
||||
[Constraint] -- Generated constraints
|
||||
InferState -- Inference state
|
||||
(Except -- Inference errors
|
||||
TypeError)
|
||||
a) -- Result
|
||||
|
||||
-- | Inference state
|
||||
data InferState = InferState { count :: Int }
|
||||
|
||||
-- | Initial inference state
|
||||
initInfer :: InferState
|
||||
initInfer = InferState { count = 0 }
|
||||
|
||||
type Constraint = (Type, Type)
|
||||
|
||||
type Unifier = (Subst, [Constraint])
|
||||
|
||||
-- | Constraint solver monad
|
||||
type Solve a = StateT Unifier (ExceptT TypeError Identity) a
|
||||
|
||||
newtype Subst = Subst (Map.Map TVar Type)
|
||||
deriving (Eq, Ord, Show, Monoid)
|
||||
|
||||
class Substitutable a where
|
||||
apply :: Subst -> a -> a
|
||||
ftv :: a -> Set.Set TVar
|
||||
|
||||
instance Substitutable Type where
|
||||
apply _ (TCon a) = TCon a
|
||||
apply (Subst s) t@(TVar a) = Map.findWithDefault t a s
|
||||
apply s (t1 `TArr` t2) = apply s t1 `TArr` apply s t2
|
||||
|
||||
ftv TCon{} = Set.empty
|
||||
ftv (TVar a) = Set.singleton a
|
||||
ftv (t1 `TArr` t2) = ftv t1 `Set.union` ftv t2
|
||||
|
||||
instance Substitutable Scheme where
|
||||
apply (Subst s) (Forall as t) = Forall as $ apply s' t
|
||||
where s' = Subst $ foldr Map.delete s as
|
||||
ftv (Forall as t) = ftv t `Set.difference` Set.fromList as
|
||||
|
||||
instance Substitutable Constraint where
|
||||
apply s (t1, t2) = (apply s t1, apply s t2)
|
||||
ftv (t1, t2) = ftv t1 `Set.union` ftv t2
|
||||
|
||||
instance Substitutable a => Substitutable [a] where
|
||||
apply = map . apply
|
||||
ftv = foldr (Set.union . ftv) Set.empty
|
||||
|
||||
instance Substitutable Env where
|
||||
apply s (TypeEnv env) = TypeEnv $ Map.map (apply s) env
|
||||
ftv (TypeEnv env) = ftv $ Map.elems env
|
||||
|
||||
data TypeError
|
||||
= UnificationFail Type Type
|
||||
| InfiniteType TVar Type
|
||||
| UnboundVariable String
|
||||
| Ambigious [Constraint]
|
||||
| UnificationMismatch [Type] [Type]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Inference
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Run the inference monad
|
||||
runInfer :: Env -> Infer Type -> Either TypeError (Type, [Constraint])
|
||||
runInfer env m = runExcept $ evalRWST m env initInfer
|
||||
|
||||
-- | Solve for the toplevel type of an expression in a given environment
|
||||
inferExpr :: Env -> Expr -> Either TypeError Scheme
|
||||
inferExpr env ex = case runInfer env (infer ex) of
|
||||
Left err -> Left err
|
||||
Right (ty, cs) -> case runSolve cs of
|
||||
Left err -> Left err
|
||||
Right subst -> Right $ closeOver $ apply subst ty
|
||||
|
||||
-- | Return the internal constraints used in solving for the type of an expression
|
||||
constraintsExpr :: Env -> Expr -> Either TypeError ([Constraint], Subst, Type, Scheme)
|
||||
constraintsExpr env ex = case runInfer env (infer ex) of
|
||||
Left err -> Left err
|
||||
Right (ty, cs) -> case runSolve cs of
|
||||
Left err -> Left err
|
||||
Right subst -> Right $ (cs, subst, ty, sc)
|
||||
where
|
||||
sc = closeOver $ apply subst ty
|
||||
|
||||
-- | Canonicalize and return the polymorphic toplevel type.
|
||||
closeOver :: Type -> Scheme
|
||||
closeOver = normalize . generalize Env.empty
|
||||
|
||||
-- | Unify two types
|
||||
uni :: Type -> Type -> Infer ()
|
||||
uni t1 t2 = tell [(t1, t2)]
|
||||
|
||||
-- | Extend type environment
|
||||
inEnv :: (Name, Scheme) -> Infer a -> Infer a
|
||||
inEnv (x, sc) m = do
|
||||
let scope e = (remove e x) `extend` (x, sc)
|
||||
local scope m
|
||||
|
||||
-- | Lookup type in the environment
|
||||
lookupEnv :: Name -> Infer Type
|
||||
lookupEnv x = do
|
||||
(TypeEnv env) <- ask
|
||||
case Map.lookup x env of
|
||||
Nothing -> throwError $ UnboundVariable x
|
||||
Just s -> do t <- instantiate s
|
||||
return t
|
||||
|
||||
letters :: [String]
|
||||
letters = [1..] >>= flip replicateM ['a'..'z']
|
||||
|
||||
fresh :: Infer Type
|
||||
fresh = do
|
||||
s <- get
|
||||
put s{count = count s + 1}
|
||||
return $ TVar $ TV (letters !! count s)
|
||||
|
||||
instantiate :: Scheme -> Infer Type
|
||||
instantiate (Forall as t) = do
|
||||
as' <- mapM (\_ -> fresh) as
|
||||
let s = Subst $ Map.fromList $ zip as as'
|
||||
return $ apply s t
|
||||
|
||||
generalize :: Env -> Type -> Scheme
|
||||
generalize env t = Forall as t
|
||||
where as = Set.toList $ ftv t `Set.difference` ftv env
|
||||
|
||||
ops :: Map.Map Binop Type
|
||||
ops = Map.fromList [
|
||||
(Add, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Mul, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Sub, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
||||
, (Eql, (typeInt `TArr` (typeInt `TArr` typeBool)))
|
||||
]
|
||||
|
||||
infer :: Expr -> Infer Type
|
||||
infer expr = case expr of
|
||||
Lit (LInt _) -> return $ typeInt
|
||||
Lit (LBool _) -> return $ typeBool
|
||||
|
||||
Var x -> lookupEnv x
|
||||
|
||||
Lam x e -> do
|
||||
tv <- fresh
|
||||
t <- inEnv (x, Forall [] tv) (infer e)
|
||||
return (tv `TArr` t)
|
||||
|
||||
App e1 e2 -> do
|
||||
t1 <- infer e1
|
||||
t2 <- infer e2
|
||||
tv <- fresh
|
||||
uni t1 (t2 `TArr` tv)
|
||||
return tv
|
||||
|
||||
Let x e1 e2 -> do
|
||||
env <- ask
|
||||
t1 <- infer e1
|
||||
let sc = generalize env t1
|
||||
t2 <- inEnv (x, sc) (infer e2)
|
||||
return t2
|
||||
|
||||
Fix e1 -> do
|
||||
t1 <- infer e1
|
||||
tv <- fresh
|
||||
uni (tv `TArr` tv) t1
|
||||
return tv
|
||||
|
||||
Op op e1 e2 -> do
|
||||
t1 <- infer e1
|
||||
t2 <- infer e2
|
||||
tv <- fresh
|
||||
let u1 = t1 `TArr` (t2 `TArr` tv)
|
||||
u2 = ops Map.! op
|
||||
uni u1 u2
|
||||
return tv
|
||||
|
||||
If cond tr fl -> do
|
||||
t1 <- infer cond
|
||||
t2 <- infer tr
|
||||
t3 <- infer fl
|
||||
uni t1 typeBool
|
||||
uni t2 t3
|
||||
return t2
|
||||
|
||||
inferTop :: Env -> [(String, Expr)] -> Either TypeError Env
|
||||
inferTop env [] = Right env
|
||||
inferTop env ((name, ex):xs) = case (inferExpr env ex) of
|
||||
Left err -> Left err
|
||||
Right ty -> inferTop (extend env (name, ty)) xs
|
||||
|
||||
normalize :: Scheme -> Scheme
|
||||
normalize (Forall _ body) = Forall (map snd ord) (normtype body)
|
||||
where
|
||||
ord = zip (nub $ fv [] body) (map TV letters)
|
||||
|
||||
fv xs (TVar a) = xs ++ [a]
|
||||
fv xs (TArr a b) = fv xs a ++ fv xs b
|
||||
fv _ (TCon _) = []
|
||||
|
||||
normtype (TArr a b) = TArr (normtype a) (normtype b)
|
||||
normtype (TCon a) = TCon a
|
||||
normtype (TVar a) =
|
||||
case Prelude.lookup a ord of
|
||||
Just x -> TVar x
|
||||
Nothing -> error "type variable not in signature"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Constraint Solver
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | The empty substitution
|
||||
emptySubst :: Subst
|
||||
emptySubst = mempty
|
||||
|
||||
-- | Compose substitutions
|
||||
compose :: Subst -> Subst -> Subst
|
||||
(Subst s1) `compose` (Subst s2) = Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1
|
||||
|
||||
-- | Run the constraint solver
|
||||
runSolve :: [Constraint] -> Either TypeError Subst
|
||||
runSolve cs = runIdentity $ runExceptT $ (evalStateT solver st)
|
||||
where st = (emptySubst, cs)
|
||||
|
||||
-- | Empty unifier
|
||||
emptyUnifer :: Unifier
|
||||
emptyUnifer = (emptySubst, [])
|
||||
|
||||
unifyMany :: [Type] -> [Type] -> Solve Unifier
|
||||
unifyMany [] [] = return emptyUnifer
|
||||
unifyMany (t1 : ts1) (t2 : ts2) =
|
||||
do (su1,cs1) <- unifies t1 t2
|
||||
(su2,cs2) <- unifyMany (apply su1 ts1) (apply su1 ts2)
|
||||
return (su2 `compose` su1, cs1 ++ cs2)
|
||||
unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2
|
||||
|
||||
unifies :: Type -> Type -> Solve Unifier
|
||||
unifies t1 t2 | t1 == t2 = return emptyUnifer
|
||||
unifies (TVar v) t = v `bind` t
|
||||
unifies t (TVar v) = v `bind` t
|
||||
unifies (TArr t1 t2) (TArr t3 t4) = unifyMany [t1, t2] [t3, t4]
|
||||
unifies t1 t2 = throwError $ UnificationFail t1 t2
|
||||
|
||||
-- Unification solver
|
||||
solver :: Solve Subst
|
||||
solver = do
|
||||
(su, cs) <- get
|
||||
case cs of
|
||||
[] -> return su
|
||||
((t1, t2): cs0) -> do
|
||||
(su1, cs1) <- unifies t1 t2
|
||||
put (su1 `compose` su, cs1 ++ (apply su1 cs0))
|
||||
solver
|
||||
|
||||
bind :: TVar -> Type -> Solve Unifier
|
||||
bind a t | t == TVar a = return (emptySubst, [])
|
||||
| occursCheck a t = throwError $ InfiniteType a t
|
||||
| otherwise = return $ (Subst $ Map.singleton a t, [])
|
||||
|
||||
occursCheck :: Substitutable a => TVar -> a -> Bool
|
||||
occursCheck a t = a `Set.member` ftv t
|
19
chapter7/poly_constraints/LICENSE
Normal file
19
chapter7/poly_constraints/LICENSE
Normal file
@ -0,0 +1,19 @@
|
||||
Copyright (c) 2014-2015, Stephen Diehl
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to
|
||||
deal in the Software without restriction, including without limitation the
|
||||
rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
||||
sell copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in
|
||||
all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
||||
IN THE SOFTWARE.
|
73
chapter7/poly_constraints/Lexer.hs
Normal file
73
chapter7/poly_constraints/Lexer.hs
Normal file
@ -0,0 +1,73 @@
|
||||
module Lexer where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text.Lazy
|
||||
import qualified Data.Text.Lazy as L
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
|
||||
import Data.Functor.Identity
|
||||
|
||||
type Op a = Ex.Operator L.Text () Identity a
|
||||
type Operators a = Ex.OperatorTable L.Text () Identity a
|
||||
|
||||
reservedNames :: [String]
|
||||
reservedNames = [
|
||||
"let",
|
||||
"in",
|
||||
"fix",
|
||||
"rec",
|
||||
"if",
|
||||
"then",
|
||||
"else"
|
||||
]
|
||||
|
||||
reservedOps :: [String]
|
||||
reservedOps = [
|
||||
"->",
|
||||
"\\",
|
||||
"+",
|
||||
"*",
|
||||
"-",
|
||||
"="
|
||||
]
|
||||
|
||||
lexer :: Tok.GenTokenParser L.Text () Identity
|
||||
lexer = Tok.makeTokenParser $ Tok.LanguageDef
|
||||
{ Tok.commentStart = "{-"
|
||||
, Tok.commentEnd = "-}"
|
||||
, Tok.commentLine = "--"
|
||||
, Tok.nestedComments = True
|
||||
, Tok.identStart = letter
|
||||
, Tok.identLetter = alphaNum <|> oneOf "_'"
|
||||
, Tok.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
|
||||
, Tok.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
|
||||
, Tok.reservedNames = reservedNames
|
||||
, Tok.reservedOpNames = reservedOps
|
||||
, Tok.caseSensitive = True
|
||||
}
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = Tok.reserved lexer
|
||||
|
||||
reservedOp :: String -> Parser ()
|
||||
reservedOp = Tok.reservedOp lexer
|
||||
|
||||
identifier :: Parser String
|
||||
identifier = Tok.identifier lexer
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = Tok.parens lexer
|
||||
|
||||
semiSep :: Parser a -> Parser [a]
|
||||
semiSep = Tok.semiSep lexer
|
||||
|
||||
semi :: Parser String
|
||||
semi = Tok.semi lexer
|
||||
|
||||
contents :: Parser a -> Parser a
|
||||
contents p = do
|
||||
Tok.whiteSpace lexer
|
||||
r <- p
|
||||
eof
|
||||
return r
|
167
chapter7/poly_constraints/Main.hs
Normal file
167
chapter7/poly_constraints/Main.hs
Normal file
@ -0,0 +1,167 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
import Syntax
|
||||
import Infer
|
||||
import Parser
|
||||
import Pretty
|
||||
import Eval
|
||||
import qualified Env
|
||||
|
||||
import Data.Monoid
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text.Lazy as L
|
||||
import qualified Data.Text.Lazy.IO as L
|
||||
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.State.Strict
|
||||
|
||||
import Data.List (isPrefixOf, foldl')
|
||||
|
||||
import System.Exit
|
||||
import System.Environment
|
||||
import System.Console.Repline
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data IState = IState
|
||||
{ tyctx :: Env.Env -- Type environment
|
||||
, tmctx :: TermEnv -- Value environment
|
||||
}
|
||||
|
||||
initState :: IState
|
||||
initState = IState Env.empty emptyTmenv
|
||||
|
||||
type Repl a = HaskelineT (StateT IState IO) a
|
||||
hoistErr :: Show e => Either e a -> Repl a
|
||||
hoistErr (Right val) = return val
|
||||
hoistErr (Left err) = do
|
||||
liftIO $ print err
|
||||
abort
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Execution
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
evalDef :: TermEnv -> (String, Expr) -> TermEnv
|
||||
evalDef env (nm, ex) = tmctx'
|
||||
where (val, tmctx') = runEval env nm ex
|
||||
|
||||
exec :: Bool -> L.Text -> Repl ()
|
||||
exec update source = do
|
||||
-- Get the current interpreter state
|
||||
st <- get
|
||||
|
||||
-- Parser ( returns AST )
|
||||
mod <- hoistErr $ parseModule "<stdin>" source
|
||||
|
||||
-- Type Inference ( returns Typing Environment )
|
||||
tyctx' <- hoistErr $ inferTop (tyctx st) mod
|
||||
|
||||
-- Create the new environment
|
||||
let st' = st { tmctx = foldl' evalDef (tmctx st) mod
|
||||
, tyctx = tyctx' <> (tyctx st)
|
||||
}
|
||||
|
||||
-- Update the interpreter state
|
||||
when update (put st')
|
||||
|
||||
-- If a value is entered, print it.
|
||||
case lookup "it" mod of
|
||||
Nothing -> return ()
|
||||
Just ex -> do
|
||||
let (val, _) = runEval (tmctx st') "it" ex
|
||||
showOutput (show val) st'
|
||||
|
||||
showOutput :: String -> IState -> Repl ()
|
||||
showOutput arg st = do
|
||||
case Env.lookup "it" (tyctx st) of
|
||||
Just val -> liftIO $ putStrLn $ ppsignature (arg, val)
|
||||
Nothing -> return ()
|
||||
|
||||
cmd :: String -> Repl ()
|
||||
cmd source = exec True (L.pack source)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Commands
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- :browse command
|
||||
browse :: [String] -> Repl ()
|
||||
browse _ = do
|
||||
st <- get
|
||||
liftIO $ mapM_ putStrLn $ ppenv (tyctx st)
|
||||
|
||||
-- :load command
|
||||
load :: [String] -> Repl ()
|
||||
load args = do
|
||||
contents <- liftIO $ L.readFile (unwords args)
|
||||
exec True contents
|
||||
|
||||
-- :type command
|
||||
typeof :: [String] -> Repl ()
|
||||
typeof args = do
|
||||
st <- get
|
||||
let arg = unwords args
|
||||
case Env.lookup arg (tyctx st) of
|
||||
Just val -> liftIO $ putStrLn $ ppsignature (arg, val)
|
||||
Nothing -> exec False (L.pack arg)
|
||||
|
||||
-- :quit command
|
||||
quit :: a -> Repl ()
|
||||
quit _ = liftIO $ exitSuccess
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Interactive Shell
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Prefix tab completer
|
||||
defaultMatcher :: MonadIO m => [(String, CompletionFunc m)]
|
||||
defaultMatcher = [
|
||||
(":load" , fileCompleter)
|
||||
--, (":type" , values)
|
||||
]
|
||||
|
||||
-- Default tab completer
|
||||
comp :: (Monad m, MonadState IState m) => WordCompleter m
|
||||
comp n = do
|
||||
let cmds = [":load", ":type", ":browse", ":quit"]
|
||||
Env.TypeEnv ctx <- gets tyctx
|
||||
let defs = Map.keys ctx
|
||||
return $ filter (isPrefixOf n) (cmds ++ defs)
|
||||
|
||||
options :: [(String, [String] -> Repl ())]
|
||||
options = [
|
||||
("load" , load)
|
||||
, ("browse" , browse)
|
||||
, ("quit" , quit)
|
||||
, ("type" , Main.typeof)
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Entry Point
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
completer :: CompleterStyle (StateT IState IO)
|
||||
completer = Prefix (wordCompleter comp) defaultMatcher
|
||||
|
||||
shell :: Repl a -> IO ()
|
||||
shell pre = flip evalStateT initState
|
||||
$ evalRepl "Poly> " cmd options completer pre
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Toplevel
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
[] -> shell (return ())
|
||||
[fname] -> shell (load [fname])
|
||||
["test", fname] -> shell (load [fname] >> browse [] >> quit ())
|
||||
_ -> putStrLn "invalid arguments"
|
160
chapter7/poly_constraints/Parser.hs
Normal file
160
chapter7/poly_constraints/Parser.hs
Normal file
@ -0,0 +1,160 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Parser (
|
||||
parseExpr,
|
||||
parseModule
|
||||
) where
|
||||
|
||||
import Text.Parsec
|
||||
import Text.Parsec.Text.Lazy (Parser)
|
||||
|
||||
import qualified Text.Parsec.Expr as Ex
|
||||
import qualified Text.Parsec.Token as Tok
|
||||
|
||||
import qualified Data.Text.Lazy as L
|
||||
|
||||
import Lexer
|
||||
import Syntax
|
||||
|
||||
integer :: Parser Integer
|
||||
integer = Tok.integer lexer
|
||||
|
||||
variable :: Parser Expr
|
||||
variable = do
|
||||
x <- identifier
|
||||
return (Var x)
|
||||
|
||||
number :: Parser Expr
|
||||
number = do
|
||||
n <- integer
|
||||
return (Lit (LInt (fromIntegral n)))
|
||||
|
||||
bool :: Parser Expr
|
||||
bool = (reserved "True" >> return (Lit (LBool True)))
|
||||
<|> (reserved "False" >> return (Lit (LBool False)))
|
||||
|
||||
fix :: Parser Expr
|
||||
fix = do
|
||||
reservedOp "fix"
|
||||
x <- aexp
|
||||
return (Fix x)
|
||||
|
||||
lambda :: Parser Expr
|
||||
lambda = do
|
||||
reservedOp "\\"
|
||||
args <- many identifier
|
||||
reservedOp "->"
|
||||
body <- expr
|
||||
return $ foldr Lam body args
|
||||
|
||||
letin :: Parser Expr
|
||||
letin = do
|
||||
reserved "let"
|
||||
x <- identifier
|
||||
reservedOp "="
|
||||
e1 <- expr
|
||||
reserved "in"
|
||||
e2 <- expr
|
||||
return (Let x e1 e2)
|
||||
|
||||
letrecin :: Parser Expr
|
||||
letrecin = do
|
||||
reserved "let"
|
||||
reserved "rec"
|
||||
x <- identifier
|
||||
reservedOp "="
|
||||
e1 <- expr
|
||||
reserved "in"
|
||||
e2 <- expr
|
||||
return (Let x e1 e2)
|
||||
|
||||
ifthen :: Parser Expr
|
||||
ifthen = do
|
||||
reserved "if"
|
||||
cond <- aexp
|
||||
reservedOp "then"
|
||||
tr <- aexp
|
||||
reserved "else"
|
||||
fl <- aexp
|
||||
return (If cond tr fl)
|
||||
|
||||
aexp :: Parser Expr
|
||||
aexp =
|
||||
parens expr
|
||||
<|> bool
|
||||
<|> number
|
||||
<|> ifthen
|
||||
<|> fix
|
||||
<|> try letrecin
|
||||
<|> letin
|
||||
<|> lambda
|
||||
<|> variable
|
||||
|
||||
term :: Parser Expr
|
||||
term = Ex.buildExpressionParser table aexp
|
||||
|
||||
infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a
|
||||
infixOp x f = Ex.Infix (reservedOp x >> return f)
|
||||
|
||||
table :: Operators Expr
|
||||
table = [
|
||||
[
|
||||
infixOp "*" (Op Mul) Ex.AssocLeft
|
||||
],
|
||||
[
|
||||
infixOp "+" (Op Add) Ex.AssocLeft
|
||||
, infixOp "-" (Op Sub) Ex.AssocLeft
|
||||
],
|
||||
[
|
||||
infixOp "==" (Op Eql) Ex.AssocLeft
|
||||
]
|
||||
]
|
||||
|
||||
expr :: Parser Expr
|
||||
expr = do
|
||||
es <- many1 term
|
||||
return (foldl1 App es)
|
||||
|
||||
type Binding = (String, Expr)
|
||||
|
||||
letdecl :: Parser Binding
|
||||
letdecl = do
|
||||
reserved "let"
|
||||
name <- identifier
|
||||
args <- many identifier
|
||||
reservedOp "="
|
||||
body <- expr
|
||||
return $ (name, foldr Lam body args)
|
||||
|
||||
letrecdecl :: Parser (String, Expr)
|
||||
letrecdecl = do
|
||||
reserved "let"
|
||||
reserved "rec"
|
||||
name <- identifier
|
||||
args <- many identifier
|
||||
reservedOp "="
|
||||
body <- expr
|
||||
return $ (name, Fix $ foldr Lam body (name:args))
|
||||
|
||||
val :: Parser Binding
|
||||
val = do
|
||||
ex <- expr
|
||||
return ("it", ex)
|
||||
|
||||
decl :: Parser Binding
|
||||
decl = try letrecdecl <|> letdecl <|> val
|
||||
|
||||
top :: Parser Binding
|
||||
top = do
|
||||
x <- decl
|
||||
optional semi
|
||||
return x
|
||||
|
||||
modl :: Parser [Binding]
|
||||
modl = many top
|
||||
|
||||
parseExpr :: L.Text -> Either ParseError Expr
|
||||
parseExpr input = parse (contents expr) "<stdin>" input
|
||||
|
||||
parseModule :: FilePath -> L.Text -> Either ParseError [(String, Expr)]
|
||||
parseModule fname input = parse (contents modl) fname input
|
118
chapter7/poly_constraints/Pretty.hs
Normal file
118
chapter7/poly_constraints/Pretty.hs
Normal file
@ -0,0 +1,118 @@
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language TypeSynonymInstances #-}
|
||||
|
||||
module Pretty (
|
||||
ppconstraint,
|
||||
ppconstraints,
|
||||
ppdecl,
|
||||
ppenv,
|
||||
ppexpr,
|
||||
ppscheme,
|
||||
ppsubst,
|
||||
ppsignature,
|
||||
pptype
|
||||
) where
|
||||
|
||||
import Env
|
||||
import Type
|
||||
import Syntax
|
||||
import Infer
|
||||
|
||||
import Text.PrettyPrint
|
||||
import qualified Data.Map as Map
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
instance Pretty Name where
|
||||
ppr _ x = text x
|
||||
|
||||
instance Pretty TVar where
|
||||
ppr _ (TV x) = text x
|
||||
|
||||
instance Pretty Type where
|
||||
ppr p (TArr a b) = (parensIf (isArrow a) (ppr p a)) <+> text "->" <+> ppr p b
|
||||
where
|
||||
isArrow TArr{} = True
|
||||
isArrow _ = False
|
||||
ppr p (TVar a) = ppr p a
|
||||
ppr _ (TCon a) = text a
|
||||
|
||||
instance Pretty Scheme where
|
||||
ppr p (Forall [] t) = ppr p t
|
||||
ppr p (Forall ts t) = text "forall" <+> hcat (punctuate space (map (ppr p) ts)) <> text "." <+> ppr p t
|
||||
|
||||
instance Pretty Binop where
|
||||
ppr _ Add = text "+"
|
||||
ppr _ Sub = text "-"
|
||||
ppr _ Mul = text "*"
|
||||
ppr _ Eql = text "=="
|
||||
|
||||
instance Pretty Expr where
|
||||
ppr p (Var a) = ppr p a
|
||||
ppr p (App a b) = parensIf (p > 0) $ ppr (p+1) a <+> ppr p b
|
||||
ppr p (Lam a b) = text "\\" <> ppr p a <+> text "->" <+> ppr p b
|
||||
ppr p (Let a b c) = text "let" <> ppr p a <+> text "=" <+> ppr p b <+> text "in" <+> ppr p c
|
||||
ppr p (Lit a) = ppr p a
|
||||
ppr p (Op o a b) = parensIf (p>0) $ ppr p a <+> ppr p o <+> ppr p b
|
||||
ppr p (Fix a) = parensIf (p>0) $ text "fix" <> ppr p a
|
||||
ppr p (If a b c) =
|
||||
text "if" <> ppr p a <+>
|
||||
text "then" <+> ppr p b <+>
|
||||
text "else" <+> ppr p c
|
||||
|
||||
instance Pretty Lit where
|
||||
ppr _ (LInt i) = integer i
|
||||
ppr _ (LBool True) = text "True"
|
||||
ppr _ (LBool False) = text "False"
|
||||
|
||||
instance Pretty Constraint where
|
||||
ppr p (a, b) = (ppr p a) <+> text " ~ " <+> (ppr p b)
|
||||
|
||||
instance Pretty [Constraint] where
|
||||
ppr p cs = vcat (punctuate space (map (ppr p) cs))
|
||||
|
||||
instance Pretty Subst where
|
||||
ppr p (Subst s) = vcat (punctuate space (map pprSub $ Map.toList s))
|
||||
where pprSub (a, b) = ppr 0 a <+> text "~" <+> ppr 0 b
|
||||
|
||||
instance Show TypeError where
|
||||
show (UnificationFail a b) =
|
||||
concat ["Cannot unify types: \n\t", pptype a, "\nwith \n\t", pptype b]
|
||||
show (InfiniteType (TV a) b) =
|
||||
concat ["Cannot construct the the infinite type: ", a, " = ", pptype b]
|
||||
show (Ambigious cs) =
|
||||
concat ["Cannot not match expected type: '" ++ pptype a ++ "' with actual type: '" ++ pptype b ++ "'\n" | (a,b) <- cs]
|
||||
show (UnboundVariable a) = "Not in scope: " ++ a
|
||||
|
||||
ppscheme :: Scheme -> String
|
||||
ppscheme = render . ppr 0
|
||||
|
||||
pptype :: Type -> String
|
||||
pptype = render . ppr 0
|
||||
|
||||
ppexpr :: Expr -> String
|
||||
ppexpr = render . ppr 0
|
||||
|
||||
ppsignature :: (String, Scheme) -> String
|
||||
ppsignature (a, b) = a ++ " : " ++ ppscheme b
|
||||
|
||||
ppdecl :: (String, Expr) -> String
|
||||
ppdecl (a, b) = "let " ++ a ++ " = " ++ ppexpr b
|
||||
|
||||
ppenv :: Env -> [String]
|
||||
ppenv (TypeEnv env) = map ppsignature $ Map.toList env
|
||||
|
||||
ppconstraint :: Constraint -> String
|
||||
ppconstraint = render . ppr 0
|
||||
|
||||
ppconstraints :: [Constraint] -> String
|
||||
ppconstraints = render . ppr 0
|
||||
|
||||
ppsubst :: Subst -> String
|
||||
ppsubst = render . ppr 0
|
75
chapter7/poly_constraints/README.md
Normal file
75
chapter7/poly_constraints/README.md
Normal file
@ -0,0 +1,75 @@
|
||||
PolyML
|
||||
======
|
||||
|
||||
A simple ML dialect with definitions, let polymorphism and a fixpoint operator. Uses syntax directed HM type
|
||||
inference.
|
||||
|
||||
To compile and run:
|
||||
|
||||
```shell
|
||||
$ cabal run
|
||||
```
|
||||
|
||||
Usage:
|
||||
|
||||
```ocaml
|
||||
Poly> let i x = x;
|
||||
i : forall a. a -> a
|
||||
|
||||
Poly> i 3
|
||||
3
|
||||
|
||||
Poly> :type i
|
||||
i : forall a. a -> a
|
||||
|
||||
Poly> :type let k x y = x;
|
||||
k : forall a b. a -> b -> a
|
||||
|
||||
Poly> :type let s f g x = f x (g x)
|
||||
s : forall a b c. ((a -> b) -> c -> a) -> (a -> b) -> c -> b
|
||||
|
||||
Poly> :type let on g f = \x y -> g (f x) (f y)
|
||||
on : forall a b c. (a -> a -> b) -> (c -> a) -> c -> c -> b
|
||||
|
||||
Poly> :type let let_bound = i (i i) (i 3)
|
||||
let_bound : Int
|
||||
|
||||
Poly> :type let compose f g = \x -> f (g x)
|
||||
compose : forall a b c. (a -> b) -> (c -> a) -> c -> b
|
||||
|
||||
Poly> let rec factorial n =
|
||||
if (n == 0)
|
||||
then 1
|
||||
else (n * (factorial (n-1)));
|
||||
```
|
||||
|
||||
Notes
|
||||
=====
|
||||
|
||||
Top level let declarations are syntatic sugar for nested lambda. For example:
|
||||
|
||||
```ocaml
|
||||
let add x y = x + y;
|
||||
```
|
||||
|
||||
Is semantically equivelant to:
|
||||
|
||||
```ocaml
|
||||
let add = \x -> \y -> x + y;
|
||||
```
|
||||
|
||||
Top level Let-rec declarations are syntatic sugar for use of the ``fix`` operator. For example:
|
||||
|
||||
```ocaml
|
||||
let rec factorial n = if (n == 0) then 1 else (n * (factorial (n-1)));
|
||||
```
|
||||
Is semantically equivelant to:
|
||||
|
||||
```ocaml
|
||||
let factorial = fix (\factorial n -> if (n == 0) then 1 else (n * (factorial (n-1))));
|
||||
```
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
26
chapter7/poly_constraints/Syntax.hs
Normal file
26
chapter7/poly_constraints/Syntax.hs
Normal file
@ -0,0 +1,26 @@
|
||||
module Syntax where
|
||||
|
||||
type Name = String
|
||||
|
||||
data Expr
|
||||
= Var Name
|
||||
| App Expr Expr
|
||||
| Lam Name Expr
|
||||
| Let Name Expr Expr
|
||||
| Lit Lit
|
||||
| If Expr Expr Expr
|
||||
| Fix Expr
|
||||
| Op Binop Expr Expr
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Lit
|
||||
= LInt Integer
|
||||
| LBool Bool
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Binop = Add | Sub | Mul | Eql
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Program = Program [Decl] Expr deriving Eq
|
||||
|
||||
type Decl = (String, Expr)
|
17
chapter7/poly_constraints/Type.hs
Normal file
17
chapter7/poly_constraints/Type.hs
Normal file
@ -0,0 +1,17 @@
|
||||
module Type where
|
||||
|
||||
newtype TVar = TV String
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Type
|
||||
= TVar TVar
|
||||
| TCon String
|
||||
| TArr Type Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Scheme = Forall [TVar] Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
typeInt, typeBool :: Type
|
||||
typeInt = TCon "Int"
|
||||
typeBool = TCon "Bool"
|
22
chapter7/poly_constraints/poly.cabal
Normal file
22
chapter7/poly_constraints/poly.cabal
Normal file
@ -0,0 +1,22 @@
|
||||
name: poly
|
||||
version: 0.1.0.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Stephen Diehl
|
||||
maintainer: stephen.m.diehl@gmail.com
|
||||
build-type: Simple
|
||||
extra-source-files: README.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable poly
|
||||
build-depends:
|
||||
base >= 4.6 && <4.7
|
||||
, pretty >= 1.1 && <1.2
|
||||
, parsec >= 3.1 && <3.2
|
||||
, text >= 1.2 && <1.3
|
||||
, containers >= 0.5 && <0.6
|
||||
, mtl >= 2.2 && <2.3
|
||||
, transformers >= 0.4.2 && <0.5
|
||||
, repline >= 0.1.2.0
|
||||
default-language: Haskell2010
|
||||
main-is: Main.hs
|
111
chapter7/poly_constraints/test.ml
Normal file
111
chapter7/poly_constraints/test.ml
Normal file
@ -0,0 +1,111 @@
|
||||
-- Booleans
|
||||
let T x y = x;
|
||||
let F x y = y;
|
||||
|
||||
-- SKI combinators
|
||||
let I x = x;
|
||||
let K x y = x;
|
||||
let S f g x = f x (g x);
|
||||
|
||||
let skk = S K K;
|
||||
|
||||
let Mu f = f (fix f);
|
||||
|
||||
-- Other combinators
|
||||
let B x y z = x (y z);
|
||||
let C x y z = x z y;
|
||||
let W x y = x y y;
|
||||
|
||||
-- Integer arithmetic
|
||||
let nsucc x = x + 1;
|
||||
let npred x = x - 1;
|
||||
|
||||
-- Arithmetic
|
||||
let succ n f x = f (n f x);
|
||||
|
||||
let zero f x = x ;
|
||||
let one f x = f x ;
|
||||
let two f x = f (f x) ;
|
||||
let three f x = f (f (f x)) ;
|
||||
let four f x = f (f (f (f x))) ;
|
||||
let five f x = f (f (f (f (f x)))) ;
|
||||
let six f x = f (f (f (f (f (f x))))) ;
|
||||
let seven f x = f (f (f (f (f (f (f x)))))) ;
|
||||
let eight f x = f (f (f (f (f (f (f (f x))))))) ;
|
||||
let nine f x = f (f (f (f (f (f (f (f (f x)))))))) ;
|
||||
let ten f x = f (f (f (f (f (f (f (f (f (f x))))))))) ;
|
||||
|
||||
let iszero n = n (\x -> F) T;
|
||||
let plus m n f x = n f (m f x);
|
||||
let mult m n f = m (n f);
|
||||
let pow m n = n m;
|
||||
let pred n f x = n (\g h -> h (g f)) (\u -> x) I;
|
||||
let ack = \m -> m (\f n -> n f (f one)) succ;
|
||||
let sub m n = (n pred) m;
|
||||
|
||||
-- Conversions
|
||||
|
||||
let unbool n = n True False;
|
||||
let unchurch n = n (\i -> i + 1) 0;
|
||||
let rec church n =
|
||||
if (n == 0)
|
||||
then zero
|
||||
else \f x -> f (church (n-1) f x);
|
||||
|
||||
-- Logic
|
||||
let not p = p F T;
|
||||
let and p q = p q F;
|
||||
let or p q = p T q;
|
||||
let cond p x y = p x y;
|
||||
let xor p q = p (q F T) q;
|
||||
let equ p q = not (xor p q);
|
||||
let nand x y = cond x (not y) T;
|
||||
let nor x y = cond x F (not y);
|
||||
|
||||
-- Tuples
|
||||
let fst p = p T;
|
||||
let snd p = p F;
|
||||
let pair a b f = f a b;
|
||||
|
||||
-- Lists
|
||||
let nil x = x;
|
||||
let cons x y = pair F (pair x y);
|
||||
let null z = z T;
|
||||
let head z = fst (snd z);
|
||||
let tail z = snd (snd z);
|
||||
let indx xs n = head (n tail xs);
|
||||
|
||||
let fact = fix (\fact -> \n -> if (n == 0) then 1 else (n * (fact (n-1))));
|
||||
|
||||
let rec fib n =
|
||||
if (n == 0)
|
||||
then 0
|
||||
else if (n==1)
|
||||
then 1
|
||||
else ((fib (n-1)) + (fib (n-2)));
|
||||
|
||||
-- Functions
|
||||
let const x y = x;
|
||||
let compose f g = \x -> f (g x);
|
||||
let twice f x = f (f x);
|
||||
let on g f = \x y -> g (f x) (f y);
|
||||
let ap f x = f (f x);
|
||||
|
||||
-- Let Polymorphism
|
||||
let poly = I (I I) (I 3);
|
||||
let self = (\x -> x) (\x -> x);
|
||||
let innerlet = \x -> (let y = \z -> z in y);
|
||||
let innerletrec = \x -> (let rec y = \z -> z in y);
|
||||
|
||||
-- Fresh variables
|
||||
let wtf = \a b c d e e' f g h i j k l m n o o' o'' o''' p q r r' s t u u' v w x y z ->
|
||||
q u i c k b r o w n f o' x j u' m p s o'' v e r' t h e' l a z y d o''' g;
|
||||
|
||||
-- if-then-else
|
||||
let notbool x = if x then False else True;
|
||||
let eqzero x = if (x == 0) then True else False;
|
||||
|
||||
let rec until p f x =
|
||||
if (p x)
|
||||
then x
|
||||
else (until p f (f x));
|
12
chapter8/.gitignore
vendored
Normal file
12
chapter8/.gitignore
vendored
Normal file
@ -0,0 +1,12 @@
|
||||
*.sw[po]
|
||||
*.o
|
||||
*.so
|
||||
cabal.sandbox.config
|
||||
.cabal-sandbox
|
||||
dist/
|
||||
*.hi
|
||||
*.o
|
||||
includes
|
||||
*.html
|
||||
*.agdai
|
||||
*.history
|
13
chapter8/protohaskell/Compiler.hs
Normal file
13
chapter8/protohaskell/Compiler.hs
Normal file
@ -0,0 +1,13 @@
|
||||
module Compiler (
|
||||
-- * Code paths
|
||||
modl,
|
||||
expr,
|
||||
|
||||
-- * Module driver
|
||||
modls,
|
||||
) where
|
||||
|
||||
-- Future chapters.
|
||||
modl = undefined
|
||||
expr = undefined
|
||||
modls = undefined
|
77
chapter8/protohaskell/Flags.hs
Normal file
77
chapter8/protohaskell/Flags.hs
Normal file
@ -0,0 +1,77 @@
|
||||
module Flags (
|
||||
-- * Compiler flags
|
||||
Flag(..),
|
||||
Flags,
|
||||
|
||||
-- * Setting/Unsetting
|
||||
isSet,
|
||||
set,
|
||||
unset,
|
||||
|
||||
-- * Command line switches
|
||||
flagOpts,
|
||||
flagFor,
|
||||
) where
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Control.Monad (msum)
|
||||
import Data.List (isPrefixOf)
|
||||
|
||||
-- Flag set.
|
||||
type Flags = S.Set Flag
|
||||
|
||||
data Flag
|
||||
= DumpC
|
||||
| DumpLLVM -- ^ \-ddump-llvm
|
||||
| DumpASM -- ^ \-ddump-asm
|
||||
| DumpParsed -- ^ \-ddump-parsed
|
||||
| DumpDesugar -- ^ \-ddump-desugar
|
||||
| DumpInfer -- ^ \-ddump-infer
|
||||
| DumpCore -- ^ \-ddump-core
|
||||
| DumpTypes -- ^ \-ddump-types
|
||||
| DumpKinds -- ^ \-ddump-types
|
||||
| DumpStg -- ^ \-ddump-stg
|
||||
| DumpImp -- ^ \-ddump-imp
|
||||
| DumpRenamer -- ^ \-ddump-rn
|
||||
| DumpToFile -- ^ \-ddump-to-file
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Query a flag setting.
|
||||
isSet :: Flags -> Flag -> Bool
|
||||
isSet = flip S.member
|
||||
|
||||
-- | Insert a flag into the flag set.
|
||||
set :: Flags -> Flag -> Flags
|
||||
set = flip S.insert
|
||||
|
||||
-- | Remove a flag into the flag set.
|
||||
unset :: Flags -> Flag -> Flags
|
||||
unset = flip S.delete
|
||||
|
||||
flags :: [(String, Flag)]
|
||||
flags = [
|
||||
("ddump-parsed" , DumpParsed)
|
||||
, ("ddump-ds" , DumpDesugar)
|
||||
, ("ddump-core" , DumpCore)
|
||||
, ("ddump-infer" , DumpInfer)
|
||||
, ("ddump-types" , DumpTypes)
|
||||
, ("ddump-kinds" , DumpKinds)
|
||||
, ("ddump-stg" , DumpStg)
|
||||
, ("ddump-imp" , DumpImp)
|
||||
, ("ddump-c" , DumpC)
|
||||
, ("ddump-rn" , DumpRenamer)
|
||||
, ("ddump-to-file" , DumpToFile)
|
||||
]
|
||||
|
||||
matches :: String -> (String, Flag) -> Maybe Flag
|
||||
matches s (flagstr, flag)
|
||||
| ('-' : flagstr) `isPrefixOf` s = Just flag
|
||||
| otherwise = Nothing
|
||||
|
||||
-- | Command line switches for flag options
|
||||
flagOpts :: [String]
|
||||
flagOpts = fmap fst flags
|
||||
|
||||
-- | Lookup the flag from a command line option switch.
|
||||
flagFor :: String -> Maybe Flags.Flag
|
||||
flagFor s = msum $ fmap (matches s) flags
|
443
chapter8/protohaskell/Frontend.hs
Normal file
443
chapter8/protohaskell/Frontend.hs
Normal file
@ -0,0 +1,443 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Frontend (
|
||||
-- * Frontend AST
|
||||
Expr(..),
|
||||
Decl(..),
|
||||
Match(..),
|
||||
BindGroup(..),
|
||||
Pattern(..),
|
||||
ConDecl(..),
|
||||
Module(..),
|
||||
Stmt(..),
|
||||
Literal(..),
|
||||
Fixity(..),
|
||||
FixitySpec(..),
|
||||
Assoc(..),
|
||||
Constr,
|
||||
|
||||
-- * Constructors
|
||||
mkEApp,
|
||||
mkELam,
|
||||
mkPair,
|
||||
mkList,
|
||||
mkIf,
|
||||
|
||||
-- * Deconstructors
|
||||
viewApp,
|
||||
viewLam,
|
||||
viewVars,
|
||||
|
||||
-- * Free variables
|
||||
freeVars,
|
||||
allVars,
|
||||
boundVars,
|
||||
occursIn,
|
||||
fconsDecl,
|
||||
|
||||
-- * Declaration manipulation
|
||||
sdef,
|
||||
sname,
|
||||
sget,
|
||||
slookup,
|
||||
ssingleton,
|
||||
globals,
|
||||
|
||||
-- * Declaration grouping
|
||||
groupToplevel,
|
||||
groupDecls,
|
||||
|
||||
-- * Pattern manipulation
|
||||
pvars,
|
||||
freePvs,
|
||||
) where
|
||||
|
||||
import Prelude hiding (foldr, foldr1, concatMap)
|
||||
|
||||
import Name
|
||||
import Type
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Foldable
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy)
|
||||
import Data.Traversable
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Identity
|
||||
|
||||
import GHC.Word (Word8)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Surface Language
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
type Constr = Name
|
||||
|
||||
data Expr
|
||||
= EApp Expr Expr -- ^ a b
|
||||
| EVar Name -- ^ x
|
||||
| ELam Name Expr -- ^ \\x . y
|
||||
| ELit Literal -- ^ 1, 'a'
|
||||
| ELet Name Expr Expr -- ^ let x = y in x
|
||||
| EIf Expr Expr Expr -- ^ if x then tr else fl
|
||||
| ECase Expr [Match] -- ^ case x of { p -> e; ... }
|
||||
| EAnn Expr Type -- ^ ( x : Int )
|
||||
| EDo [Stmt] -- ^ do { ... }
|
||||
| EFail -- ^ pattern match fail
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Stmt
|
||||
= Generator Pattern Expr -- ^ pat <- exp
|
||||
| Qualifier Expr -- ^ exp
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Pattern
|
||||
= PVar Name -- ^ x
|
||||
| PCon Constr [Pattern] -- ^ C x y
|
||||
| PLit Literal -- ^ 3
|
||||
| PWild -- ^ _
|
||||
deriving (Eq, Show)
|
||||
|
||||
data BindGroup = BindGroup
|
||||
{ _matchName :: Name
|
||||
, _matchPats :: [Match]
|
||||
, _matchType :: Maybe Type
|
||||
, _matchWhere :: [[Decl]]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Match = Match
|
||||
{ _matchPat :: [Pattern]
|
||||
, _matchBody :: Expr
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Literal
|
||||
= LitInt Int -- ^ 1
|
||||
| LitChar Char -- ^ 'a'
|
||||
| LitString [Word8] -- A primitive C-style string, type Addr#
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ConDecl
|
||||
= ConDecl Constr Type -- ^ T :: a -> T a
|
||||
| RecDecl Constr [(Name, Type)] Type -- ^ T :: { label :: a } -> T a
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
data Decl
|
||||
= FunDecl BindGroup -- ^ f x = x + 1
|
||||
| TypeDecl Type -- ^ f :: Int -> Int
|
||||
| DataDecl Constr [Name] [ConDecl] -- ^ data T where { ... }
|
||||
| ClassDecl [Pred] Name [Name] [Decl] -- ^ class (P) => T where { ... }
|
||||
| InstDecl [Pred] Name Type [Decl] -- ^ instance (P) => T where { ... }
|
||||
| FixityDecl FixitySpec -- infixl 1 {..}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FixitySpec = FixitySpec
|
||||
{ fixityFix :: Fixity
|
||||
, fixityName :: String
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data Assoc
|
||||
= L
|
||||
| R
|
||||
| N
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Fixity
|
||||
= Infix Assoc Int
|
||||
| Prefix Int
|
||||
| Postfix Int
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Module = Module Name [Decl] -- ^ module T where { .. }
|
||||
deriving (Eq,Show)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Extraction
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Get the binding groups associated with a definition
|
||||
fgroup :: Decl -> [BindGroup]
|
||||
fgroup (FunDecl xs) = [xs]
|
||||
fgroup _ = []
|
||||
|
||||
-- | Extract pattern variables.
|
||||
pvars :: [Pattern] -> [Name]
|
||||
pvars ps = [a | PVar a <- ps]
|
||||
|
||||
-- | Lookup a toplevel declaration by name.
|
||||
slookup :: String -> Module -> Maybe Decl
|
||||
slookup nm (Module _ decls) =
|
||||
case decls' of
|
||||
[] -> Nothing
|
||||
(x:_) -> Just x
|
||||
where
|
||||
decls' = [d | d@(FunDecl (BindGroup name _ _ _)) <- decls, name == Name nm]
|
||||
|
||||
-- | Extract a function declaration by name.
|
||||
sget :: Name -> [Decl] -> Maybe (Name, Maybe Type, Expr)
|
||||
sget nm decls =
|
||||
case decls' of
|
||||
[] -> Nothing
|
||||
(x:_) -> Just (sdef x)
|
||||
where
|
||||
decls' = [d | d@(FunDecl (BindGroup name _ _ _)) <- decls, name == nm]
|
||||
|
||||
-- Singleton named toplevel declaration.
|
||||
ssingleton :: Name -> Expr -> Decl
|
||||
ssingleton nm ex = FunDecl (BindGroup nm [Match [] ex] Nothing [])
|
||||
|
||||
-- | Extract the desugared bind group.
|
||||
sdef :: Decl -> (Name, Maybe Type, Expr)
|
||||
sdef (FunDecl (BindGroup name [Match [] rhs] tysig _)) = (name, tysig, rhs)
|
||||
sdef _ = error "Bind group is not in desugared form"
|
||||
|
||||
-- | Extract the desugared bind group name.
|
||||
sname :: Decl -> Name
|
||||
sname (FunDecl (BindGroup name [Match _ _] _ _)) = name
|
||||
sname (DataDecl name _ _) = name
|
||||
sname (ClassDecl _ name _ _) = name
|
||||
sname (InstDecl _ name _ _) = name
|
||||
sname _ = error "Bind group is not in desugared form"
|
||||
|
||||
-- | Extract a set of the named constructor used in a type
|
||||
fcons :: Type -> Set.Set Name
|
||||
fcons (TCon (AlgTyCon n)) = Set.singleton n
|
||||
fcons (TCon {}) = Set.empty
|
||||
fcons (TVar {}) = Set.empty
|
||||
fcons (t1 `TArr` t2) = fcons t1 `Set.union` fcons t2
|
||||
fcons (t1 `TApp` t2) = fcons t1 `Set.union` fcons t2
|
||||
|
||||
fconsConDecl :: ConDecl -> Set.Set Name
|
||||
fconsConDecl (ConDecl _ (TForall _ _ ty)) = fcons ty
|
||||
fconsConDecl (RecDecl _ _ (TForall _ _ ty)) = fcons ty
|
||||
|
||||
-- | Extract a set of the named constructor used in a type declaration
|
||||
fconsDecl :: Decl -> Set.Set Name
|
||||
fconsDecl (DataDecl _ _ xs) = Set.unions $ fmap fconsConDecl xs
|
||||
fconsDecl _ = Set.empty
|
||||
|
||||
-- | The global function names
|
||||
globals :: Module -> [Name]
|
||||
globals (Module _ decls) = fmap sname decls
|
||||
where
|
||||
sname :: Decl -> Name
|
||||
sname (FunDecl (BindGroup name _ _ _)) = name
|
||||
sname (DataDecl name _ _) = name
|
||||
sname (ClassDecl _ name _ _) = name
|
||||
sname (InstDecl _ name _ _) = name
|
||||
sname _ = error "Bind group is not in desugared form"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Grouping
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
groupToplevel :: Module -> Module
|
||||
groupToplevel (Module nm decls) = Module nm $ mconcat [clsub, icls, datas, funs]
|
||||
where
|
||||
funs = groupDecls [e | e@FunDecl{} <- decls]
|
||||
datas = [e | e@DataDecl{} <- decls]
|
||||
clsub = [e | e@ClassDecl{} <- decls]
|
||||
icls = [e | e@InstDecl{} <- decls]
|
||||
|
||||
groupBindings :: [BindGroup] -> [BindGroup]
|
||||
groupBindings = fmap joinBindings . groupBy ((==) `on` _matchName)
|
||||
|
||||
joinBindings :: [BindGroup] -> BindGroup
|
||||
joinBindings xs@(x:_) =
|
||||
BindGroup (_matchName x) (concatMap _matchPats xs) (_matchType x) (concatMap _matchWhere xs)
|
||||
joinBindings [] = error "empty binding group"
|
||||
|
||||
-- Build up a nested list of
|
||||
groupDecls :: [Decl] -> [Decl]
|
||||
groupDecls decls = fmap FunDecl $ groupBindings (concatMap fgroup decls)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Traversal
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
descend :: (Expr -> Expr) -> Expr -> Expr
|
||||
descend f ex = runIdentity (descendM (return . f) ex)
|
||||
|
||||
descendM :: (Monad m, Applicative m) => (Expr -> m Expr) -> Expr -> m Expr
|
||||
descendM f e = case e of
|
||||
EApp a b -> EApp <$> descendM f a <*> descendM f b
|
||||
EVar a -> EVar <$> pure a
|
||||
ELam a b -> ELam <$> pure a <*> descendM f b
|
||||
ELit n -> ELit <$> pure n
|
||||
ELet n a b -> ELet <$> pure n <*> descendM f a <*> descendM f b
|
||||
EIf a b c -> EIf <$> descendM f a <*> descendM f b <*> descendM f c
|
||||
ECase a xs -> ECase <$> f a <*> traverse (descendCaseM f) xs
|
||||
EAnn a t -> EAnn <$> descendM f a <*> pure t
|
||||
EFail -> pure EFail
|
||||
|
||||
descendCaseM :: (Monad m, Applicative m) => (Expr -> m Expr) -> Match -> m Match
|
||||
descendCaseM f e = case e of
|
||||
Match ps a -> Match <$> pure ps <*> descendM f a
|
||||
|
||||
compose
|
||||
:: (Expr -> Expr)
|
||||
-> (Expr -> Expr)
|
||||
-> (Expr -> Expr)
|
||||
compose f g = descend (f . g)
|
||||
|
||||
composeM
|
||||
:: (Applicative m, Monad m)
|
||||
=> (Expr -> m Expr)
|
||||
-> (Expr -> m Expr)
|
||||
-> (Expr -> m Expr)
|
||||
composeM f g = descendM (f <=< g)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Variables
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
class AllVars a where
|
||||
allVars :: a -> Set.Set Name
|
||||
|
||||
class FreeVars a where
|
||||
freeVars :: a -> Set.Set Name
|
||||
|
||||
instance AllVars a => AllVars [a] where
|
||||
allVars = Set.unions . fmap allVars
|
||||
|
||||
instance FreeVars a => FreeVars [a] where
|
||||
freeVars = Set.unions . fmap freeVars
|
||||
|
||||
instance AllVars Pattern where
|
||||
allVars pt = case pt of
|
||||
PVar n -> Set.singleton n
|
||||
PCon _ ps -> Set.unions $ fmap allVars ps
|
||||
PLit _ -> Set.empty
|
||||
PWild -> Set.empty
|
||||
|
||||
instance AllVars Match where
|
||||
allVars ex = case ex of
|
||||
Match pats rhs -> allVars rhs
|
||||
|
||||
instance AllVars Expr where
|
||||
allVars ex = case ex of
|
||||
EVar x -> Set.singleton x
|
||||
ELet n v e -> Set.unions [Set.singleton n, allVars v, allVars e]
|
||||
ELam _ e -> allVars e
|
||||
EApp a b -> allVars a `Set.union` allVars b
|
||||
ECase n as -> allVars n `Set.union` Set.unions (fmap allVars as)
|
||||
ELit _ -> Set.empty
|
||||
EIf c x y -> Set.unions [allVars c, allVars x, allVars y]
|
||||
EAnn x _ -> allVars x
|
||||
EFail -> Set.empty
|
||||
|
||||
instance AllVars Decl where
|
||||
allVars (FunDecl bg) = allVars bg
|
||||
allVars (DataDecl {}) = Set.empty
|
||||
allVars (TypeDecl {}) = Set.empty
|
||||
allVars (ClassDecl {}) = Set.empty
|
||||
allVars (InstDecl {}) = Set.empty
|
||||
allVars (FixityDecl {})= Set.empty
|
||||
|
||||
instance AllVars BindGroup where
|
||||
allVars (BindGroup _ pats _ _) = Set.unions (fmap allVars pats)
|
||||
|
||||
instance FreeVars Expr where
|
||||
freeVars ex = case ex of
|
||||
ELam n x -> freeVars x Set.\\ Set.singleton n
|
||||
ELet n v e -> (freeVars e Set.\\ Set.singleton n) `Set.union` (freeVars v)
|
||||
EApp f xs -> freeVars f `Set.union` freeVars xs
|
||||
ECase e m -> freeVars e `Set.union` Set.unions (fmap freeVars m)
|
||||
EDo xs -> Set.unions (fmap freeVars xs)
|
||||
EVar n -> Set.singleton n
|
||||
ELit _ -> Set.empty
|
||||
EIf c x y -> freeVars c `Set.union` freeVars x `Set.union` freeVars y
|
||||
EAnn x _ -> freeVars x
|
||||
EFail -> Set.empty
|
||||
|
||||
instance FreeVars Match where
|
||||
freeVars ex = case ex of
|
||||
Match pats rhs -> freeVars rhs Set.\\ Set.unions (fmap allVars pats)
|
||||
|
||||
instance FreeVars Stmt where
|
||||
freeVars ex = case ex of
|
||||
Generator pat x -> freeVars x Set.\\ (allVars pat)
|
||||
Qualifier x -> freeVars x
|
||||
|
||||
instance FreeVars Decl where
|
||||
freeVars (FunDecl bg) = freeVars bg
|
||||
freeVars (DataDecl {}) = Set.empty
|
||||
freeVars (TypeDecl {}) = Set.empty
|
||||
freeVars (ClassDecl {}) = Set.empty
|
||||
freeVars (InstDecl {}) = Set.empty
|
||||
freeVars (FixityDecl {}) = Set.empty
|
||||
|
||||
instance FreeVars BindGroup where
|
||||
freeVars (BindGroup _ pats _ _) = Set.unions (fmap freeVars pats)
|
||||
|
||||
|
||||
occursIn :: AllVars a => Name -> a -> Bool
|
||||
occursIn name ex = name `Set.member` (allVars ex)
|
||||
|
||||
boundVars :: (FreeVars a, AllVars a) => a -> Set.Set Name
|
||||
boundVars ex = (allVars ex) `Set.difference` (freeVars ex)
|
||||
|
||||
-- free pattern variables
|
||||
freePvs :: Pattern -> [Name]
|
||||
freePvs (PVar a) = [a]
|
||||
freePvs (PCon _ b) = concatMap freePvs b
|
||||
freePvs (PLit _) = []
|
||||
freePvs (PWild) = []
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Constructors
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Constructors for the wired-in syntax
|
||||
|
||||
_paircon, _conscon, _nilcon :: Name
|
||||
_paircon = "Pair"
|
||||
_conscon = "Cons"
|
||||
_nilcon = "Nil"
|
||||
|
||||
mkEApp :: Expr -> [Expr] -> Expr
|
||||
mkEApp = foldl' EApp
|
||||
|
||||
mkELam :: Expr -> [Name] -> Expr
|
||||
mkELam = foldr ELam
|
||||
|
||||
mkPair :: [Expr] -> Expr
|
||||
mkPair = foldr1 pair
|
||||
where
|
||||
pair x y = mkEApp (EVar _paircon) [x,y]
|
||||
|
||||
mkList :: [Expr] -> Expr
|
||||
mkList = foldr cons nil
|
||||
where
|
||||
cons x y = mkEApp (EVar _conscon) [x,y]
|
||||
nil = EVar _nilcon
|
||||
|
||||
mkIf :: Expr -> Expr
|
||||
mkIf (EIf c x y) =
|
||||
ECase c [
|
||||
Match [PCon "True" []] x,
|
||||
Match [PCon "False" []] y
|
||||
]
|
||||
mkIf x = x
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Deconstructors
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
viewVars :: Expr -> [Name]
|
||||
viewVars (ELam n a) = n : viewVars a
|
||||
viewVars _ = []
|
||||
|
||||
viewLam :: Expr -> Expr
|
||||
viewLam (ELam _ a) = viewLam a
|
||||
viewLam x = x
|
||||
|
||||
viewApp :: Expr -> (Expr, [Expr])
|
||||
viewApp = go []
|
||||
where
|
||||
go !xs (EApp a b) = go (b : xs) a
|
||||
go xs f = (f, xs)
|
124
chapter8/protohaskell/Monad.hs
Normal file
124
chapter8/protohaskell/Monad.hs
Normal file
@ -0,0 +1,124 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Monad (
|
||||
-- * Compiler driver
|
||||
CompilerM,
|
||||
runCompilerM,
|
||||
|
||||
-- * Compiler state
|
||||
CompilerState(..),
|
||||
emptyCS,
|
||||
|
||||
-- * Reporting
|
||||
Pos,
|
||||
Msg,
|
||||
|
||||
-- * Utilities
|
||||
inIO,
|
||||
ifSet,
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
import qualified Data.Text.Lazy as L
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Except
|
||||
|
||||
import qualified Flags
|
||||
import qualified Frontend as Syn
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Compiler Monad
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
type CompilerMonad =
|
||||
ExceptT Msg
|
||||
(StateT CompilerState IO)
|
||||
|
||||
-- | Main compiler driver a monad.
|
||||
newtype CompilerM a = Compiler { runCompiler :: CompilerMonad a }
|
||||
deriving
|
||||
( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadFix
|
||||
, MonadPlus
|
||||
, MonadIO
|
||||
, MonadState CompilerState
|
||||
, MonadError Msg
|
||||
)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Compiler State
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data CompilerState = CompilerState
|
||||
{ _fname :: Maybe FilePath -- ^ File path
|
||||
, _imports :: [FilePath] -- ^ Loaded modules
|
||||
, _src :: Maybe L.Text -- ^ File source
|
||||
, _ast :: Maybe Syn.Module -- ^ Frontend AST
|
||||
, _flags :: Flags.Flags -- ^ Compiler flags
|
||||
|
||||
-- Future Chapters
|
||||
-- , _tenv :: Env.Env -- ^ Typing environment
|
||||
-- , _kenv :: Map.Map Name Kind -- ^ Kind environment
|
||||
-- , _cenv :: ClassEnv.ClassEnv -- ^ Class environment
|
||||
-- , _cast :: Maybe Core.Module -- ^ Core AST
|
||||
-- , _cprg :: Maybe String -- ^ Outputted source
|
||||
-- , _venv :: CoreEval.ValEnv Core.Expr -- ^ Core interpreter environment
|
||||
-- , _denv :: DataEnv.DataEnv -- ^ Entity dictionary
|
||||
-- , _clenv :: ClassEnv.ClassHier -- ^ Typeclass hierarchy
|
||||
-- , _stg :: Maybe STG.Module -- ^ STG module
|
||||
-- , _imp :: Maybe Imp.ImpModule -- ^ Imp module
|
||||
} deriving (Eq, Show)
|
||||
|
||||
-- | Initial empty compiler state.
|
||||
emptyCS :: CompilerState
|
||||
emptyCS = CompilerState
|
||||
{ _fname = Nothing
|
||||
, _imports = mempty
|
||||
, _src = Nothing
|
||||
, _ast = Nothing
|
||||
, _flags = mempty
|
||||
|
||||
-- Future Chapters
|
||||
-- , _tenv = mempty
|
||||
-- , _cenv = mempty
|
||||
-- , _kenv = mempty
|
||||
-- , _cast = Nothing
|
||||
-- , _cprg = Nothing
|
||||
-- , _venv = mempty
|
||||
-- , _denv = mempty
|
||||
-- , _clenv = mempty
|
||||
-- , _stg = Nothing
|
||||
-- , _imp = Nothing
|
||||
}
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Position information
|
||||
type Pos = String
|
||||
|
||||
-- | Failure message.
|
||||
type Msg = String
|
||||
|
||||
-- | Run the compiler pipeline.
|
||||
runCompilerM
|
||||
:: CompilerM a
|
||||
-> CompilerState
|
||||
-> IO (Either Msg a, CompilerState)
|
||||
runCompilerM = runStateT . runExceptT . runCompiler
|
||||
|
||||
-- | Lift IO action into the Compiler IO layer.
|
||||
inIO :: IO a -> CompilerM a
|
||||
inIO = Compiler . liftIO
|
||||
|
||||
-- | Conditional execute monadic action if a flag is set.
|
||||
ifSet :: Flags.Flag -> CompilerM a -> CompilerM ()
|
||||
ifSet flag m = do
|
||||
flags <- gets _flags
|
||||
when (Flags.isSet flags flag) (void m)
|
49
chapter8/protohaskell/Name.hs
Normal file
49
chapter8/protohaskell/Name.hs
Normal file
@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Name (
|
||||
-- * Name types
|
||||
Name(..),
|
||||
Named(getName),
|
||||
|
||||
-- * Name conversion/renaming
|
||||
unName,
|
||||
prefix,
|
||||
|
||||
-- * Name supplies
|
||||
letters,
|
||||
genNames,
|
||||
) where
|
||||
|
||||
import Data.String
|
||||
import Data.Monoid
|
||||
import Data.Hashable
|
||||
import Control.Monad
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
data Name
|
||||
= Gen String Integer
|
||||
| Name String
|
||||
deriving (Eq, Ord, Show, Read, Generic)
|
||||
|
||||
instance Hashable Name where
|
||||
|
||||
instance IsString Name where
|
||||
fromString = Name
|
||||
|
||||
prefix :: String -> Name -> Name
|
||||
prefix p (Gen nm i) = Gen (p <> nm) i
|
||||
prefix p (Name nm) = Name (p <> nm)
|
||||
|
||||
unName :: IsString a => Name -> a
|
||||
unName (Name s) = fromString s
|
||||
unName (Gen s n) = fromString (s ++ show n)
|
||||
|
||||
letters :: [String]
|
||||
letters = [1..] >>= flip replicateM ['a'..'z']
|
||||
|
||||
genNames :: [Name]
|
||||
genNames = Prelude.zipWith Gen letters [0..]
|
||||
|
||||
class Named a where
|
||||
getName :: a -> Name
|
311
chapter8/protohaskell/Pretty.hs
Normal file
311
chapter8/protohaskell/Pretty.hs
Normal file
@ -0,0 +1,311 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
module Pretty (
|
||||
-- * Types
|
||||
Pretty(ppr, pp, ppg),
|
||||
banner,
|
||||
|
||||
-- * Frontend
|
||||
ppexpr,
|
||||
ppmodule,
|
||||
ppsdecl,
|
||||
|
||||
-- * Types
|
||||
pptype,
|
||||
ppsignature,
|
||||
ppksignature,
|
||||
ppkind,
|
||||
) where
|
||||
|
||||
import Text.PrettyPrint
|
||||
import Data.List (intersperse)
|
||||
|
||||
import Type
|
||||
import Name
|
||||
import qualified Frontend as S
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Pretty Printer
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
class Pretty p where
|
||||
ppr :: Int -> p -> Doc
|
||||
|
||||
{-# INLINE pp #-}
|
||||
pp :: p -> Doc
|
||||
pp = ppr 0
|
||||
|
||||
{-# INLINE ppg #-}
|
||||
ppg :: p -> String
|
||||
ppg = render . pp
|
||||
|
||||
instance Pretty Name where
|
||||
ppr _ (Name x) = text x
|
||||
ppr _ (Gen nm i) = pp nm <> integer i
|
||||
|
||||
instance Pretty String where
|
||||
ppr _ x = text x
|
||||
|
||||
instance Pretty Int where
|
||||
ppr _ x = int x
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Printer Utils
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
spaced :: Pretty a => Int -> [a] -> Doc
|
||||
spaced p = hsep . fmap (ppr p)
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf True = parens
|
||||
parensIf False = id
|
||||
|
||||
tysig :: Pretty a => Name -> a -> Doc
|
||||
tysig f ty = pp f <+> "::" <+> pp ty
|
||||
|
||||
spaces :: Int -> String
|
||||
spaces n
|
||||
| n <= 0 = ""
|
||||
| otherwise = replicate n ' '
|
||||
|
||||
indent :: Int -> Doc -> Doc
|
||||
indent i d = hang (text (spaces i) <> d) i empty
|
||||
|
||||
block :: Pretty a => [a] -> Doc
|
||||
block xs =
|
||||
char '{'
|
||||
$$ nest 2 (vcat (punctuate semi (fmap pp xs)))
|
||||
$$ char '}'
|
||||
|
||||
commafy :: [Doc] -> Doc
|
||||
commafy = hsep . punctuate comma
|
||||
|
||||
ppmaybe :: Pretty a => Maybe a -> Doc
|
||||
ppmaybe = maybe empty pp
|
||||
|
||||
banner :: Show a => a -> String
|
||||
banner x = render $
|
||||
text (replicate n '=')
|
||||
<+>
|
||||
text msg
|
||||
<+>
|
||||
text (replicate n '=')
|
||||
where
|
||||
msg = show x
|
||||
n = (76 - length msg) `div` 2
|
||||
|
||||
|
||||
instance Pretty S.Expr where
|
||||
ppr p ex = case ex of
|
||||
S.EVar x -> pp x
|
||||
|
||||
S.ELit (S.LitInt x) -> int x
|
||||
S.ELit (S.LitChar x) -> quotes $ char x
|
||||
|
||||
e@(S.EApp {}) ->
|
||||
parensIf (p>0) $ ppr p f <+> args
|
||||
where
|
||||
(f, xs) = S.viewApp e
|
||||
args = sep $ fmap (ppr (p+1)) xs
|
||||
|
||||
e@(S.ELam {}) ->
|
||||
parensIf (p>0) $ char '\\' <> hsep vars <+> "->" <+> body
|
||||
where
|
||||
body = ppr (p+1) (S.viewLam e)
|
||||
vars = fmap pp (S.viewVars e)
|
||||
|
||||
S.ECase x alts ->
|
||||
"case" <+> (ppr p x) <+> "of" <+> char '{'
|
||||
$$ blk (vcat (punctuate semi brs))
|
||||
$$ char '}'
|
||||
where
|
||||
blk a = nest 2 a
|
||||
brs = fmap pp alts
|
||||
|
||||
S.EDo stmts ->
|
||||
"do" <+> char '{'
|
||||
$$ blk (vcat (punctuate semi brs))
|
||||
$$ char '}'
|
||||
where
|
||||
blk a = nest 2 a
|
||||
brs = fmap pp stmts
|
||||
|
||||
S.ELet a b c ->
|
||||
"let"
|
||||
<+> ppr p a
|
||||
<+> "=" <+> ppr p b
|
||||
<+> "in" <+> ppr p c
|
||||
|
||||
S.EIf c t f ->
|
||||
hang (text "if" <+> pp c)
|
||||
2 (vcat [ hang (text "then") 2 (pp t)
|
||||
, hang (text "else") 2 (pp f)
|
||||
])
|
||||
|
||||
S.EAnn x ty -> parens $ pp x <+> ":" <+> pp ty
|
||||
|
||||
S.EFail -> "<<fail>>"
|
||||
|
||||
instance Pretty S.Stmt where
|
||||
ppr _ (S.Generator pat ex) = pp pat <+> "<-" <+> pp ex
|
||||
ppr _ (S.Qualifier ex) = pp ex
|
||||
|
||||
instance Pretty S.Match where
|
||||
ppr p (S.Match lhs rhs) = sep (fmap (ppr p) lhs) <+> "->" <+> (ppr p rhs)
|
||||
|
||||
instance Pretty S.Literal where
|
||||
ppr _ (S.LitInt n) = int n
|
||||
ppr _ (S.LitChar n) = quotes $ char n
|
||||
|
||||
instance Pretty S.Pattern where
|
||||
ppr p e = case e of
|
||||
S.PVar a -> ppr p a
|
||||
S.PLit a -> ppr p a
|
||||
S.PWild -> "_"
|
||||
S.PCon f xs ->
|
||||
let args = fmap (ppr (p+1)) xs in
|
||||
parensIf (length args > 0) $ ppr p f <+> (sep args)
|
||||
|
||||
instance Pretty [S.BindGroup] where
|
||||
ppr _ xs = vcat (fmap pp xs)
|
||||
|
||||
instance Pretty S.BindGroup where
|
||||
ppr p (S.BindGroup f xs ty wh) =
|
||||
(maybe empty (tysig f) ty)
|
||||
$+$
|
||||
vcat (fmap (prefix . ppMatch) xs)
|
||||
$+$
|
||||
ppWheres wh
|
||||
where
|
||||
prefix = (pp f <+>)
|
||||
-- toplevel Matches use (=) instead of (->)
|
||||
ppMatch (S.Match lhs rhs) = sep (fmap (ppr p) lhs) <+> "=" <+> (ppr p rhs)
|
||||
|
||||
ppWheres [] = empty
|
||||
ppWheres [[]] = empty
|
||||
ppWheres ws = nest 2 $ hang "where" 2 (vcat (fmap ppWhere ws))
|
||||
|
||||
ppWhere [] = empty
|
||||
ppWhere ws = vcat (fmap pp ws)
|
||||
|
||||
instance Pretty S.Module where
|
||||
ppr p prg =
|
||||
("module" <+> pp nm <+> "where")
|
||||
$$ vcat (intersperse "" (fmap pp xs))
|
||||
where
|
||||
(S.Module nm xs) = S.groupToplevel prg
|
||||
|
||||
instance Pretty S.Decl where
|
||||
ppr p decl = case decl of
|
||||
S.FunDecl a -> ppr p a
|
||||
S.TypeDecl f -> pp f
|
||||
|
||||
S.DataDecl con_id args cons ->
|
||||
"data" <+> ppr p con_id <+> spaced p args <+>
|
||||
"where" $+$ nest 2 (vcat (fmap pp cons))
|
||||
|
||||
S.ClassDecl preds con_id args defs ->
|
||||
"class" <+> ppcontext preds <+> ppr p con_id <+> spaced p args <+>
|
||||
"where" $+$ nest 2 (vcat (fmap pp defs))
|
||||
|
||||
S.InstDecl preds con_id ty defs ->
|
||||
"instance" <+> ppcontext preds <+> ppr p con_id <+> pp ty <+>
|
||||
"where" $+$ nest 2 (vcat (fmap pp defs))
|
||||
|
||||
instance Pretty S.ConDecl where
|
||||
ppr _ (S.ConDecl datacon ty) = tysig datacon ty
|
||||
ppr _ (S.RecDecl con fds ty) =
|
||||
braces (hcat (punctuate comma (fmap go fds)))
|
||||
<+> "->" <+> pp ty
|
||||
where
|
||||
go (a,b) = pp a <+> ":" <+> pp b
|
||||
|
||||
ppexpr :: S.Expr -> String
|
||||
ppexpr = ppg
|
||||
|
||||
ppsdecl :: S.Decl -> String
|
||||
ppsdecl = ppg
|
||||
|
||||
ppmodule :: S.Module -> String
|
||||
ppmodule = ppg
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
isArrow :: Type -> Bool
|
||||
isArrow TArr{} = True
|
||||
isArrow _ = False
|
||||
|
||||
instance Pretty Type where
|
||||
ppr p ty = case ty of
|
||||
TArr a b -> (parensIf (isArrow a) (ppr p a)) <+> "->" <+> ppr p b
|
||||
|
||||
TVar a -> ppr p a
|
||||
|
||||
TCon a | a == unitTyCon -> "()"
|
||||
|
||||
TCon a -> ppr p a
|
||||
|
||||
TApp a b
|
||||
| a == tyList -> brackets (ppr p b)
|
||||
|
||||
TApp (TApp a b) c
|
||||
| a == tyPair -> parens $ ppr p b <> char ',' <+> ppr p c
|
||||
|
||||
TApp a b
|
||||
| isArrow b -> parensIf (p > 0) $ ppr p a <+> parens (ppr (p+1) b)
|
||||
| otherwise -> parensIf (p > 0) $ ppr p a <+> ppr (p+1) b
|
||||
|
||||
instance Pretty TVar where
|
||||
ppr _ (TV x) = pp x
|
||||
|
||||
instance Pretty TyCon where
|
||||
ppr _ (AlgTyCon a) = pp a
|
||||
ppr _ (PrimTyCon a) = pp a <> char '#'
|
||||
|
||||
instance Pretty Pred where
|
||||
ppr p (IsIn name ty) = pp name <+> ppr p ty
|
||||
|
||||
ppcontext :: [Pred] -> Doc
|
||||
ppcontext [] = empty
|
||||
ppcontext [pred] = pp pred
|
||||
ppcontext ps = parens (hcat (punctuate comma (fmap pp ps)))
|
||||
|
||||
pptype :: Type -> String
|
||||
pptype = ppg
|
||||
|
||||
pptvar :: TVar -> String
|
||||
pptvar = ppg
|
||||
|
||||
ppsignature :: (Name, Type) -> String
|
||||
ppsignature (a, b) = render $ pp a <+> "::" <+> pp (pptype b)
|
||||
|
||||
ppksignature :: (Name, Kind) -> String
|
||||
ppksignature (a, b) = render $ pp a <+> "::" <+> pp (ppkind b)
|
||||
|
||||
pppred :: Pred -> String
|
||||
pppred = ppg
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Kinds
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
isKArrow :: Kind -> Bool
|
||||
isKArrow KArr{} = True
|
||||
isKArrow _ = False
|
||||
|
||||
instance Pretty Kind where
|
||||
ppr p (KArr a b) = (parensIf (isKArrow a) (ppr p a)) <+> text "->" <+> ppr p b
|
||||
|
||||
ppr _ (KStar) = "*"
|
||||
ppr _ (KVar s) = pp s
|
||||
ppr _ (KPrim) = "#"
|
||||
|
||||
ppkind :: Kind -> String
|
||||
ppkind = ppg
|
17
chapter8/protohaskell/README.md
Normal file
17
chapter8/protohaskell/README.md
Normal file
@ -0,0 +1,17 @@
|
||||
ProtoHaskell ( Chapter 8 )
|
||||
==========================
|
||||
|
||||
Frontend syntax for ProtoHaskell for Chapter 8.
|
||||
|
||||
* ``Monad`` - Compiler monad
|
||||
* ``Flags`` - Compiler flags
|
||||
* ``Frontend`` - Frontend syntax
|
||||
* ``Name`` - Syntax names
|
||||
* ``Compiler`` - Initial compiler stub
|
||||
* ``Pretty`` - Pretty printer
|
||||
* ``Type`` - Type syntax
|
||||
|
||||
License
|
||||
=======
|
||||
|
||||
Released under MIT license.
|
219
chapter8/protohaskell/Type.hs
Normal file
219
chapter8/protohaskell/Type.hs
Normal file
@ -0,0 +1,219 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Type (
|
||||
-- * Types
|
||||
Type(..),
|
||||
Kind(..),
|
||||
TVar(..),
|
||||
Pred(..),
|
||||
TyCon(..),
|
||||
|
||||
-- * Alpha equivalence
|
||||
Alpha(aeq),
|
||||
|
||||
-- * Type predicates
|
||||
predicates,
|
||||
predicate,
|
||||
|
||||
-- * Constructors
|
||||
mkTArr,
|
||||
mkTApp,
|
||||
mkTPair,
|
||||
mkTList,
|
||||
|
||||
-- * Deconstructors
|
||||
viewTArr,
|
||||
viewTApp,
|
||||
typeArity,
|
||||
|
||||
-- * Wired-in types
|
||||
tyArrow,
|
||||
tyList,
|
||||
tyPair,
|
||||
tyInt,
|
||||
tyChar,
|
||||
tyBool,
|
||||
tyUnit,
|
||||
tyAddr,
|
||||
|
||||
intTyCon,
|
||||
charTyCon,
|
||||
addrTyCon,
|
||||
listTyCon,
|
||||
pairTyCon,
|
||||
unitTyCon,
|
||||
) where
|
||||
|
||||
import Name
|
||||
import Data.Char
|
||||
import Data.String
|
||||
import Data.List (foldl')
|
||||
|
||||
data Type
|
||||
= TVar TVar
|
||||
| TCon TyCon
|
||||
| TApp Type Type
|
||||
| TArr Type Type
|
||||
| TForall [Pred] [TVar] Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Kind
|
||||
= KStar
|
||||
| KArr Kind Kind
|
||||
| KPrim
|
||||
| KVar Name
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data TyCon
|
||||
= AlgTyCon { tyId :: Name }
|
||||
| PrimTyCon { tyId :: Name }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Pred
|
||||
= IsIn Name Type
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Type Variables
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
data TVar = TV
|
||||
{ tvName :: Name
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
instance IsString TVar where
|
||||
fromString x = TV (fromString x)
|
||||
|
||||
instance IsString TyCon where
|
||||
fromString = AlgTyCon . fromString
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Alpha Equivalence
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
class Alpha a where
|
||||
aeq :: a -> a -> Bool
|
||||
|
||||
instance Alpha TVar where
|
||||
aeq _ _ = True
|
||||
|
||||
instance Alpha Type where
|
||||
aeq (TVar _) (TVar _) = True
|
||||
aeq (TApp a b) (TApp c d) = aeq a c && aeq b d
|
||||
aeq (TArr a b) (TArr c d) = aeq a c && aeq b d
|
||||
aeq (TCon a) (TCon b) = a == b
|
||||
aeq _ _ = False
|
||||
|
||||
instance Alpha Kind where
|
||||
aeq KStar KStar = True
|
||||
aeq KPrim KPrim = True
|
||||
aeq (KArr a b) (KArr c d) = aeq a c && aeq b d
|
||||
aeq _ _ = False
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Transformations
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
predicates :: Type -> [Pred]
|
||||
predicates (TForall pd _ _) = pd
|
||||
|
||||
predicate :: [Pred] -> Type -> Type
|
||||
predicate pd (TForall _ as ty) = TForall pd as ty
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Deconstructors
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
viewTArr :: Type -> [Type]
|
||||
viewTArr (TArr t1 t2) = t1 : viewTArr t2
|
||||
viewTArr t = [t]
|
||||
|
||||
|
||||
viewTApp :: Type -> [Type]
|
||||
viewTApp t = go t []
|
||||
where
|
||||
go (TApp t1 t2) acc = go t1 (t2:acc)
|
||||
go t1 acc = (t1 : acc)
|
||||
|
||||
typeArity :: Type -> Int
|
||||
typeArity ty = length (viewTArr ty)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Constructors
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
mkTArr :: [Type] -> Type
|
||||
mkTArr [] = error "not defined for empty lists"
|
||||
mkTArr [t] = t
|
||||
mkTArr (t:ts) = TArr t (mkTArr ts)
|
||||
|
||||
mkTApp :: TyCon -> [Type] -> Type
|
||||
mkTApp tcon args = foldl' TApp (TCon tcon) args
|
||||
|
||||
mkTPair :: [Type] -> Type
|
||||
mkTPair = foldr1 pair
|
||||
where pair x y = mkTApp (AlgTyCon "Pair") [x,y]
|
||||
|
||||
mkTList :: Type -> Type
|
||||
mkTList tp
|
||||
= TApp (TCon (AlgTyCon "List")) tp
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Wired-in Types
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | @ Int# @
|
||||
tyInt :: Type
|
||||
tyInt = TCon intTyCon
|
||||
|
||||
-- | @ Char# @
|
||||
tyChar :: Type
|
||||
tyChar = TCon charTyCon
|
||||
|
||||
-- | @ Addr# @
|
||||
tyAddr :: Type
|
||||
tyAddr = TCon addrTyCon
|
||||
|
||||
-- | @ Bool @
|
||||
tyBool :: Type
|
||||
tyBool = TCon (AlgTyCon "Bool")
|
||||
|
||||
-- | @ \[\] @
|
||||
tyList :: Type
|
||||
tyList = TCon listTyCon
|
||||
|
||||
-- | @ (,) @
|
||||
tyPair :: Type
|
||||
tyPair = TCon pairTyCon
|
||||
|
||||
-- | @ () @
|
||||
tyUnit :: Type
|
||||
tyUnit = TCon unitTyCon
|
||||
|
||||
|
||||
-- | Int#
|
||||
intTyCon :: TyCon
|
||||
intTyCon = PrimTyCon "Int"
|
||||
|
||||
-- | Char#
|
||||
charTyCon :: TyCon
|
||||
charTyCon = PrimTyCon "Char"
|
||||
|
||||
-- | Addr#
|
||||
addrTyCon :: TyCon
|
||||
addrTyCon = PrimTyCon "Addr"
|
||||
|
||||
-- | List
|
||||
listTyCon :: TyCon
|
||||
listTyCon = AlgTyCon "List"
|
||||
|
||||
-- | Pair
|
||||
pairTyCon :: TyCon
|
||||
pairTyCon = AlgTyCon "Pair"
|
||||
|
||||
unitTyCon :: TyCon
|
||||
unitTyCon = AlgTyCon "Unit"
|
||||
|
||||
-- | (->)
|
||||
tyArrow :: Type
|
||||
tyArrow = TCon (AlgTyCon "->")
|
BIN
misc/Haskell-Logo.png
Normal file
BIN
misc/Haskell-Logo.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 4.2 KiB |
BIN
misc/cover.png
Normal file
BIN
misc/cover.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 6.1 KiB |
Loading…
Reference in New Issue
Block a user