From b3179acc78f0414e9f46496113523d2cc0b96582 Mon Sep 17 00:00:00 2001
From: Sean Gillespie <sean@mistersg.net>
Date: Fri, 30 Dec 2016 17:09:19 -0500
Subject: [PATCH] Update SystemF Expression
Replace the placeholder `ty` with the datatype `Ty ty`
---
src/Language/SystemF/Expression.hs | 22 ++++++++++------------
src/Language/SystemF/Parser.hs | 2 +-
test/Language/SystemF/ExpressionSpec.hs | 14 +++++++-------
test/Language/SystemF/ParserSpec.hs | 4 ++--
4 files changed, 20 insertions(+), 22 deletions(-)
diff --git a/src/Language/SystemF/Expression.hs b/src/Language/SystemF/Expression.hs
index d18b9f5..28880c4 100644
--- a/src/Language/SystemF/Expression.hs
+++ b/src/Language/SystemF/Expression.hs
@@ -1,23 +1,21 @@
{-# LANGUAGE FlexibleInstances #-}
module Language.SystemF.Expression where
-import Data.Monoid
-
import Language.Lambda.Util.PrettyPrint
data SystemFExpr name ty
= Var name -- Variable
| App (SystemFExpr name ty) (SystemFExpr name ty) -- Application
- | Abs name ty (SystemFExpr name ty) -- Abstraction
- | TyAbs ty (SystemFExpr name ty) -- Type Abstraction
+ | Abs name (Ty ty) (SystemFExpr name ty) -- Abstraction
+ | TyAbs (Ty ty) (SystemFExpr name ty) -- Type Abstraction
-- \X. body
- | TyApp (SystemFExpr name ty) ty -- Type Application
+ | TyApp (SystemFExpr name ty) (Ty ty) -- Type Application
-- x [X]
deriving (Eq, Show)
data Ty name
- = TyVar name -- Type variable (T)
+ = TyVar name -- Type variable (T)
| TyArrow (Ty name) (Ty name) -- Type arrow (T -> U)
deriving (Eq, Show)
@@ -36,7 +34,7 @@ prettyPrint' = prettyPrint
-- Pretty print a system f expression
pprExpr :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
- -> SystemFExpr n t
+ -> SystemFExpr n t
-> PDoc String
pprExpr pdoc (Var n) = prettyPrint n `add` pdoc
pprExpr pdoc (App e1 e2) = pprApp pdoc e1 e2
@@ -64,7 +62,7 @@ pprApp pdoc e1 e2
pprTApp :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> SystemFExpr n t
- -> t
+ -> Ty t
-> PDoc String
pprTApp pdoc expr ty = expr' `mappend` addSpace (between ty' "[" "]" empty)
where expr' = pprExpr pdoc expr
@@ -74,7 +72,7 @@ pprTApp pdoc expr ty = expr' `mappend` addSpace (between ty' "[" "]" empty)
pprAbs :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
-> n
- -> t
+ -> Ty t
-> SystemFExpr n t
-> PDoc String
pprAbs pdoc name ty body = between vars' lambda' ". " (pprExpr pdoc body')
@@ -106,7 +104,7 @@ pprTyArrow' pdoc a b = between arrow (prettyPrint a) (prettyPrint b) pdoc
-- Pretty print a type abstraction
pprTAbs :: (PrettyPrint n, PrettyPrint t)
=> PDoc String
- -> t
+ -> Ty t
-> SystemFExpr n t
-> PDoc String
pprTAbs pdoc ty body = between vars' lambda' ". " (pprExpr pdoc body')
@@ -114,12 +112,12 @@ pprTAbs pdoc ty body = between vars' lambda' ". " (pprExpr pdoc body')
vars' = intercalate (map prettyPrint vars) " " empty
lambda' = [upperLambda, space]
-uncurryAbs :: n -> t -> SystemFExpr n t -> ([(n, t)], SystemFExpr n t)
+uncurryAbs :: n -> Ty t -> SystemFExpr n t -> ([(n, Ty t)], SystemFExpr n t)
uncurryAbs name ty = uncurry' [(name, ty)]
where uncurry' ns (Abs n' t' body') = uncurry' ((n', t'):ns) body'
uncurry' ns body' = (reverse ns, body')
-uncurryTAbs :: t -> SystemFExpr n t -> ([t], SystemFExpr n t)
+uncurryTAbs :: Ty t -> SystemFExpr n t -> ([Ty t], SystemFExpr n t)
uncurryTAbs ty = uncurry' [ty]
where uncurry' ts (TyAbs t' body') = uncurry' (t':ts) body'
uncurry' ts body' = (reverse ts, body')
diff --git a/src/Language/SystemF/Parser.hs b/src/Language/SystemF/Parser.hs
index 493b2c6..c417e46 100644
--- a/src/Language/SystemF/Parser.hs
+++ b/src/Language/SystemF/Parser.hs
@@ -25,7 +25,7 @@ var = Var <$> identifier
abs :: Parser (SystemFExpr String String)
abs = curry <$> idents <*> expr
- where idents = symbol '\\' *> many1 ((,) <$> identifier <*> (symbol ':' *> identifier)) <* symbol '.'
+ where idents = symbol '\\' *> many1 ((,) <$> identifier <*> (symbol ':' *> (TyVar <$> identifier))) <* symbol '.'
curry = flip . foldr . uncurry $ Abs
abs' :: Parser [(String, String)]
diff --git a/test/Language/SystemF/ExpressionSpec.hs b/test/Language/SystemF/ExpressionSpec.hs
index 03365d2..9757e36 100644
--- a/test/Language/SystemF/ExpressionSpec.hs
+++ b/test/Language/SystemF/ExpressionSpec.hs
@@ -15,20 +15,20 @@ spec = describe "prettyPrint" $ do
prettyPrint' (App (Var "a") (Var "b")) `shouldBe` "a b"
it "prints simple abstractions" $
- prettyPrint (Abs "x" "T" (Var "x")) `shouldBe` "λ x:T. x"
+ prettyPrint (Abs "x" (TyVar "T") (Var "x")) `shouldBe` "λ x:T. x"
it "prints simple type abstractions" $
- prettyPrint (TyAbs "X" (Var "x")) `shouldBe` "Λ X. x"
+ prettyPrint (TyAbs (TyVar "X") (Var "x")) `shouldBe` "Λ X. x"
it "prints simple type applications" $
- prettyPrint (TyApp (Var "t") "T") `shouldBe` "t [T]"
+ prettyPrint' (TyApp (Var "t") (TyVar "T")) `shouldBe` "t [T]"
it "prints nested abstractions" $
- prettyPrint (Abs "f" "F" (Abs "x" "X" (Var "x")))
+ prettyPrint (Abs "f" (TyVar "F") (Abs "x" (TyVar "X") (Var "x")))
`shouldBe` "λ f:F x:X. x"
it "prints nested type abstractions" $
- prettyPrint (TyAbs "A" (TyAbs "B" (Var "x")))
+ prettyPrint (TyAbs (TyVar "A") (TyAbs (TyVar "B") (Var "x")))
`shouldBe` "Λ A B. x"
it "prints nested applications" $
@@ -39,10 +39,10 @@ spec = describe "prettyPrint" $ do
prettyPrint' (App (Var "w") (App (Var "x") (Var "y")))
`shouldBe` "w (x y)"
- prettyPrint (App (Abs "t" "T" (Var "t")) (Var "x"))
+ prettyPrint (App (Abs "t" (TyVar "T") (Var "t")) (Var "x"))
`shouldBe` "(λ t:T. t) x"
- prettyPrint (App (Abs "f" "F" (Var "f")) (Abs "g" "G" (Var "g")))
+ prettyPrint (App (Abs "f" (TyVar "F") (Var "f")) (Abs "g" (TyVar "G") (Var "g")))
`shouldBe` "(λ f:F. f) (λ g:G. g)"
it "prints simple types" $
diff --git a/test/Language/SystemF/ParserSpec.hs b/test/Language/SystemF/ParserSpec.hs
index 95ca469..2c09517 100644
--- a/test/Language/SystemF/ParserSpec.hs
+++ b/test/Language/SystemF/ParserSpec.hs
@@ -16,11 +16,11 @@ spec = describe "parseExpr" $ do
parseExpr "(x)" `shouldBe` Right (Var "x")
it "parses simple abstractions" $
- parseExpr "\\x:T. x" `shouldBe` Right (Abs "x" "T" (Var "x"))
+ parseExpr "\\x:T. x" `shouldBe` Right (Abs "x" (TyVar "T") (Var "x"))
it "parses nested abstractions" $
parseExpr "\\a:A b:B. b"
- `shouldBe` Right (Abs "a" "A" (Abs "b" "B" (Var "b")))
+ `shouldBe` Right (Abs "a" (TyVar "A") (Abs "b" (TyVar "B") (Var "b")))
it "parses simple applications" $
parseExpr "f x" `shouldBe` Right (App (Var "f") (Var "x"))
--
GitLab