attoparsec and operators

Author: sdiehl

008_extended_parser.md

@@ -329,7 +329,7 @@ bit of a riddle about this error came to be.
 
 ```haskell
 Cannot unify types: 
-	Int
+        Int
 with 
         Bool
 in the definition of 'foo'
@@ -462,14 +462,14 @@ them. Before we'd have a little riddle in order to guess which
 
 ```haskell
 Cannot unify types: 
-	Int
-	Introduced at line 27 column 5
+        Int
+        Introduced at line 27 column 5
 
           f 2 3
 
 with 
-	Int -> c
-	Introduced at line 5 column 9
+        Int -> c
+        Introduced at line 5 column 9
 
           let f x y = x y
 ```
@@ -738,6 +738,6 @@ parser is rather sophisicated.
 One of the few papers ever written in Type Error reporting gives some techniques
 for presentation and tracing provenance:
 
-* [Top Quality Type Error Messages](www.staff.science.uu.nl/~swier101/Papers/Theses/TopQuality.pdf)
+* [Top Quality Type Error Messages](http://www.staff.science.uu.nl/~swier101/Papers/Theses/TopQuality.pdf)
 
 \clearpage

Makefile

@@ -7,7 +7,21 @@ FILTER = includes.hs
 TEMPLATE_HTML = template.html
 TEMPLATE_TEX = template.latex
 
-SRC = $(wildcard *.md)
+#SRC = $(wildcard *.md)
+SRC = 000_introduction.md \
+      001_basics.md \
+      002_parsers.md \
+      003_lambda_calculus.md \
+      004_type_systems.md \
+      005_evaluation.md \
+      006_hindley_milner.md \
+      007_path.md \
+      008_extended_parser.md \
+      009_datatypes.md \
+      010_renamer.md \
+      011_pattern_matching.md \
+      #012_systemf.md
+      #026_llvm.md
 OBJ = $(SRC:.md=.html)
 
 all: $(OBJ) top
@@ -23,7 +37,7 @@ all: $(OBJ) top
 
 pdf: $(FILTER)
 	# $(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o WYAH.pdf title.md 0*.md contributing.md
-	$(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o WYAH.pdf title.md 0*.md
+	$(PANDOC) --filter ${FILTER} -f $(IFORMAT) --template $(TEMPLATE_TEX) --latex-engine=xelatex $(FLAGS) -o WYAH.pdf title.md $(SRC)
 
 epub: $(FILTER)
 	$(PANDOC) --filter ${FILTER} -f $(IFORMAT) $(FLAGS) -o WYAH.epub 0*.md

chapter7/poly/Infer.hs

@@ -165,7 +165,7 @@ infer env ex = case ex of
     (s2, t2) <- infer env tr
     (s3, t3) <- infer env fl
     s4 <- unify (apply (compose s2 s3) t1) typeBool
-    s5 <- unify (apply s4 t2) (apply s4 t3)
+    s5 <- unify (apply (compose s1 s4) t2) (apply (compose s1 s4) t3)
     let s6 = s4 `compose` s5
     return (s6, apply s6 t2)
 

chapter9/attoparsec/Main.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+import Control.Applicative
+import Data.Attoparsec.Text
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.List (foldl1')
+
+data Name
+  = Gen Int
+  | Name T.Text
+  deriving (Eq, Show, Ord)
+
+data Expr
+  = Var Name
+  | App Expr Expr
+  | Lam [Name] Expr
+  | Lit Int
+  | Prim PrimOp
+  deriving (Eq, Show)
+
+data PrimOp
+  = Add
+  | Sub
+  | Mul
+  | Div
+  deriving (Eq, Show)
+
+data Defn = Defn Name Expr
+  deriving (Eq, Show)
+
+name :: Parser Name
+name = Name . T.pack <$> many1 letter
+
+num :: Parser Expr
+num = Lit <$> signed decimal
+
+var :: Parser Expr
+var = Var <$> name
+
+lam :: Parser Expr
+lam = do
+  string "\\"
+  vars <- many1 (skipSpace *> name)
+  skipSpace *> string "->"
+  body <- expr
+  return (Lam vars body)
+
+eparen :: Parser Expr
+eparen = char '(' *> expr <* skipSpace <* char ')'
+
+prim :: Parser Expr
+prim = Prim <$> (
+      char '+' *> return Add
+  <|> char '-' *> return Sub
+  <|> char '*' *> return Mul
+  <|> char '/' *> return Div)
+
+expr :: Parser Expr
+expr = foldl1' App <$> many1 (skipSpace *> atom)
+
+atom :: Parser Expr
+atom = try lam
+    <|> eparen
+    <|> prim
+    <|> var
+    <|> num
+
+def :: Parser Defn
+def = do
+  skipSpace
+  nm <- name
+  skipSpace *> char '=' *> skipSpace
+  ex <- expr
+  skipSpace <* char ';'
+  return $ Defn nm ex
+
+file :: T.Text -> Either String [Defn]
+file = parseOnly (many def <* skipSpace)
+
+parseFile :: FilePath -> IO (Either T.Text [Defn])
+parseFile path = do
+  contents <- T.readFile path
+  case file contents of
+    Left a -> return $ Left (T.pack a)
+    Right b -> return $ Right b
+
+main :: IO (Either T.Text [Defn])
+main = parseFile "simple.ml"

chapter9/operators/Parser.hs

@@ -0,0 +1,231 @@
+module Main where
+
+import qualified Text.Parsec.Expr as Ex
+import qualified Text.Parsec.Token as Tok
+
+import Text.Parsec.Language (haskellStyle)
+
+import Data.List
+import Data.Function
+
+import Control.Monad.Identity (Identity)
+
+import Text.Parsec
+import qualified Text.Parsec as P
+
+type Name = String
+
+data Expr
+  = Var Name
+  | Lam Name Expr
+  | App Expr Expr
+  | Let Name Expr Expr
+  | BinOp Name Expr Expr
+  | UnOp Name Expr
+  deriving (Show)
+
+data Assoc
+  = OpLeft
+  | OpRight
+  | OpNone
+  | OpPrefix
+  | OpPostfix
+  deriving Show
+
+data Decl
+  = LetDecl Expr
+  | OpDecl OperatorDef
+  deriving (Show)
+
+type Op x = Ex.Operator String ParseState Identity x
+type Parser a = Parsec String ParseState a
+data ParseState = ParseState [OperatorDef] deriving Show
+
+data OperatorDef = OperatorDef {
+    oassoc :: Assoc
+  , oprec :: Integer
+  , otok :: Name
+  } deriving Show
+
+lexer :: Tok.GenTokenParser String u Identity
+lexer = Tok.makeTokenParser style
+  where ops = ["->","\\","+","*","<","=","[","]","_"]
+        names = ["let","in","infixl", "infixr", "infix", "postfix", "prefix"]
+        style = haskellStyle { Tok.reservedOpNames = ops
+                             , Tok.reservedNames = names
+                             , Tok.identLetter = alphaNum <|> oneOf "#'_"
+                             , Tok.commentLine = "--"
+                             }
+
+reserved   = Tok.reserved lexer
+reservedOp = Tok.reservedOp lexer
+identifier = Tok.identifier lexer
+parens     = Tok.parens lexer
+brackets   = Tok.brackets lexer
+braces     = Tok.braces lexer
+commaSep   = Tok.commaSep lexer
+semi       = Tok.semi lexer
+integer    = Tok.integer lexer
+chr        = Tok.charLiteral lexer
+str        = Tok.stringLiteral lexer
+operator   = Tok.operator lexer
+
+contents :: Parser a -> Parser a
+contents p = do
+  Tok.whiteSpace lexer
+  r <- p
+  eof
+  return r
+
+expr :: Parser Expr
+expr = do
+  es <- many1 term
+  return (foldl1 App es)
+
+lambda :: Parser Expr
+lambda = do
+  reservedOp "\\"
+  args <- identifier
+  reservedOp "->"
+  body <- expr
+  return $ Lam args body
+
+letin :: Parser Expr
+letin = do
+  reserved "let"
+  x <- identifier
+  reservedOp "="
+  e1 <- expr
+  reserved "in"
+  e2 <- expr
+  return (Let x e1 e2)
+
+variable :: Parser Expr
+variable = do
+  x <- identifier
+  return (Var x)
+
+
+addOperator :: OperatorDef -> Parser ()
+addOperator a = P.modifyState $ \(ParseState ops) -> ParseState (a : ops)
+
+mkTable :: ParseState -> [[Op Expr]]
+mkTable (ParseState ops) =
+  map (map toParser) $
+    groupBy ((==) `on` oprec) $
+      reverse $ sortBy (compare `on` oprec) $ ops
+
+toParser :: OperatorDef -> Op Expr
+toParser (OperatorDef ass _ tok) = case ass of
+    OpLeft    -> infixOp tok (BinOp tok) (toAssoc ass)
+    OpRight   -> infixOp tok (BinOp tok) (toAssoc ass)
+    OpNone    -> infixOp tok (BinOp tok) (toAssoc ass)
+    OpPrefix  -> prefixOp tok (UnOp tok)
+    OpPostfix -> postfixOp tok (UnOp tok)
+  where
+    toAssoc OpLeft = Ex.AssocLeft
+    toAssoc OpRight = Ex.AssocRight
+    toAssoc OpNone = Ex.AssocNone
+    toAssoc _ = error "no associativity"
+
+infixOp :: String -> (a -> a -> a) -> Ex.Assoc -> Op a
+infixOp x f = Ex.Infix (reservedOp x >> return f)
+
+prefixOp :: String -> (a -> a) -> Ex.Operator String u Identity a
+prefixOp name f = Ex.Prefix (reservedOp name >> return f)
+
+postfixOp :: String -> (a -> a) -> Ex.Operator String u Identity a
+postfixOp name f = Ex.Postfix (reservedOp name >> return f)
+
+term :: Parser Expr
+term = do
+  tbl <- getState
+  let table = mkTable tbl
+  Ex.buildExpressionParser table aexp
+
+aexp :: Parser Expr
+aexp =  letin
+    <|> lambda
+    <|> variable
+    <|> parens expr
+
+letdecl :: Parser Decl
+letdecl = do
+  e <- expr
+  return $ LetDecl e
+
+
+opleft :: Parser Decl
+opleft = do
+  reserved "infixl"
+  prec <- integer
+  sym <- parens operator
+  let op = (OperatorDef OpLeft prec sym)
+  addOperator op
+  return $ OpDecl op
+
+opright :: Parser Decl
+opright = do
+  reserved "infixr"
+  prec <- integer
+  sym <- parens operator
+  let op = (OperatorDef OpRight prec sym)
+  addOperator op
+  return $ OpDecl op
+
+opnone :: Parser Decl
+opnone = do
+  reserved "infix"
+  prec <- integer
+  sym <- parens operator
+  let op = (OperatorDef OpNone prec sym)
+  addOperator op
+  return $ OpDecl op
+
+opprefix :: Parser Decl
+opprefix = do
+  reserved "prefix"
+  prec <- integer
+  sym <- parens operator
+  let op = OperatorDef OpPrefix prec sym
+  addOperator op
+  return $ OpDecl op
+
+oppostfix :: Parser Decl
+oppostfix = do
+  reserved "postfix"
+  prec <- integer
+  sym <- parens operator
+  let op = OperatorDef OpPostfix prec sym
+  addOperator op
+  return $ OpDecl op
+
+decl :: Parser Decl
+decl =
+    try letdecl
+    <|> opleft
+    <|> opright
+    <|> opnone
+    <|> opprefix
+    <|> oppostfix
+
+top :: Parser Decl
+top = do
+  x <- decl
+  P.optional semi
+  return x
+
+
+modl :: Parser [Decl]
+modl = many top
+
+parseModule :: SourceName -> String -> Either ParseError [Decl]
+parseModule filePath = P.runParser (contents modl) (ParseState []) filePath
+
+main :: IO ()
+main = do
+  input <- readFile "test.in"
+  let res = parseModule "<stdin>" input
+  case res of
+    Left err -> print err
+    Right ast -> mapM_ print ast

chapter9/operators/test.fun

@@ -0,0 +1,11 @@
+infixl 3 ($);
+infixr 4 (#);
+
+infix 4 (.);
+
+prefix 10 (-);
+postfix 10 (!);
+
+let a = y in a $ a $ (-a)!;
+let b = y in a # a # a $ b;
+let c = y in a # a # a # b;