Fakultas Ilmu Komputer UI

Commit b3179acc authored by Sean Gillespie's avatar Sean Gillespie
Browse files

Update SystemF Expression

Replace the placeholder `ty` with the datatype `Ty ty`
parent 56c90b9e
{-# 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')
......@@ -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)]
......
......@@ -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" $
......
......@@ -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"))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment