sdiehl/write-you-a-haskell
1
1
Fork 0
mirror of https://github.com/sdiehl/write-you-a-haskell.git synced 2024-10-03 22:38:04 +03:00
Code Issues Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
Stephen Diehl 2015-01-05 02:54:15 -05:00
commit 9241ebe43c
83 changed files with 5352 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitignore vendored Normal file
View 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
View 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
View 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
View File

0
chapter2/.gitkeep Normal file
View File

39
chapter3/calc/Eval.hs Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

79
chapter4/untyped/Eval.hs Normal file
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

15
chapter4/untyped/Syntax.hs Normal file
View 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
View 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
View File

55
chapter5/calc_typed/Check.hs Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,6 @@
module Type where
data Type
= TBool
| TNat
deriving (Eq, Show)

15
chapter5/calc_typed/arith.cabal Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

21
chapter5/stlc/Syntax.hs Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View File

75
chapter7/poly/Eval.hs Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.2 KiB

BIN
misc/cover.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.1 KiB