Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- Removed tuples in favour of pairs

To simplify pattern matching compilation
  • Loading branch information...
commit 49656368d1468cee9e1c0fdcf060c5bc21b14f21 1 parent 5faf68c
@Averethel authored
View
6 Syntax/Expr.hs
@@ -34,7 +34,7 @@ module Syntax.Expr where
| Elet Pattern Expr Expr
| Eletrec String [FunClause] Expr
| Eapply Expr [Expr]
- | Etuple [Expr]
+ | Epair Expr Expr
| Econs Expr Expr
| Eif Expr Expr Expr
| Eseq Expr Expr
@@ -75,8 +75,8 @@ module Syntax.Expr where
pprExpr (Efun fcs), iStr " in",
iNewline, pprExpr e ]
pprExpr (Eapply e args) = pprApplication e args
- pprExpr (Etuple es) = iConcat [ iStr "(", iInterleave (iStr ", ") $
- map pprAExpr es, iStr ")" ]
+ pprExpr (Epair e1 e2) = iConcat [ iStr "(", iInterleave (iStr ", ") $
+ map pprAExpr [e1, e2], iStr ")" ]
pprExpr (Econs e1 e2) = pprAExpr e1 `iAppend` iStr " :: "
`iAppend` pprAExpr e2
pprExpr (Eif e1 e2 e3) = iConcat [ iStr "if ( ", pprExpr e1,
View
6 Syntax/Pattern.hs
@@ -7,7 +7,7 @@ module Syntax.Pattern where
Pwildcard
| Pvar String
| Pconst Constant
- | Ptuple [Pattern]
+ | Ppair Pattern Pattern
| Pcons Pattern Pattern
deriving Eq
@@ -29,9 +29,9 @@ module Syntax.Pattern where
iStr v
pprPattern (Pconst c) =
pprConstant c
- pprPattern (Ptuple ps) =
+ pprPattern (Ppair p1 p2) =
iConcat [ iStr "(", iInterleave (iStr ", ") $
- map pprAPattern ps, iStr ")" ]
+ map pprAPattern [p1, p2], iStr ")" ]
pprPattern (Pcons p1 p2) =
pprAPattern p1 `iAppend` iStr " :: " `iAppend` pprAPattern p2
View
11 TypeInference/Expr.hs
@@ -76,14 +76,15 @@ module TypeInference.Expr (typeOfExpr) where
v <- freshVar
s <- unify $ singleConstraint t1 (Tfun ts v) `addConstraints` cns
return (v `applySubst` s `applySubst` s1, s)
- typeOfExpr env cns (Etuple es) = do
- tas <- mapM (typeOfExpr env cns) es
- s <- unify cns
- return (Ttuple (map fst tas) `applySubst` s, s)
+ typeOfExpr env cns (Epair e1 e2) = do
+ (t1, _) <- typeOfExpr env cns e1
+ (t2, _) <- typeOfExpr env cns e2
+ s <- unify cns
+ return (Tpair t1 t2 `applySubst` s, s)
typeOfExpr env cns (Econs e1 e2) = do
(t1, s1) <- typeOfExpr env cns e1
(t2, s2) <- typeOfExpr env cns e2
- s <- unify $ singleConstraint t2 (Tlist t1) `addConstraints` cns
+ s <- unify $ singleConstraint t2 (Tlist t1) `addConstraints` cns
return (t2 `applySubst` s `applySubst` s1 `applySubst` s2, s ++ s1 ++ s2)
typeOfExpr env cns (Eif e1 e2 e3) = do
(t1, _) <- typeOfExpr env cns e1
View
11 TypeInference/Pattern.hs
@@ -28,7 +28,7 @@ module TypeInference.Pattern (typeAndBindingsOfPattern) where
getids Pwildcard = []
getids (Pvar n) = [n]
getids (Pconst _) = []
- getids (Ptuple ps) = concatMap getids ps
+ getids (Ppair p1 p2) = getids p1 ++ getids p2
getids (Pcons p1 p2) = getids p1 ++ getids p2
typeAndBindingsOfPattern :: (MonadError String m, MonadState Counter m) =>
@@ -49,11 +49,10 @@ module TypeInference.Pattern (typeAndBindingsOfPattern) where
typeAndBindingsOfPattern' (Pconst c) = do
t <- typeOfConstant c
return (t, emptyEnv, emptyConstraints)
- typeAndBindingsOfPattern' (Ptuple ps) = do
- tbcs <- mapM typeAndBindingsOfPattern ps
- return (Ttuple $ map (\(a, _, _) -> a) tbcs,
- concatMap (\(_, b, _) -> b) tbcs,
- concatMap (\(_, _, c) -> c) tbcs)
+ typeAndBindingsOfPattern' (Ppair p1 p2) = do
+ (t1, e1, c1) <- typeAndBindingsOfPattern p1
+ (t2, e2, c2) <- typeAndBindingsOfPattern p2
+ return (Tpair t1 t2, e1 ++ e2, c1 ++ c2)
typeAndBindingsOfPattern' (Pcons p1 p2) = do
(t1, b1, c1) <- typeAndBindingsOfPattern p1
(t2, b2, c2) <- typeAndBindingsOfPattern p2
View
7 TypeInference/Unification.hs
@@ -16,9 +16,8 @@ module TypeInference.Unification (unify) where
canUnify _ (Tvar _) = True
canUnify (Tlist t1) (Tlist t2) = canUnify t1 t2
canUnify (Tref t1) (Tref t2) = canUnify t1 t2
- canUnify (Ttuple ts1) (Ttuple ts2) =
- length ts1 == length ts2 &&
- and (zipWith canUnify ts1 ts2)
+ canUnify (Tpair t1 t2) (Tpair t3 t4) =
+ canUnify t1 t3 && canUnify t2 t4
canUnify (Tfun as1 t1) (Tfun as2 t2) =
length as1 == length as2 &&
and (zipWith canUnify as1 as2) &&
@@ -28,7 +27,7 @@ module TypeInference.Unification (unify) where
newConstraints :: Type -> Type -> Constraints
newConstraints (Tlist t1) (Tlist t2) = [(t1, t2)]
newConstraints (Tref t1) (Tref t2) = [(t1, t2)]
- newConstraints (Ttuple ts1) (Ttuple ts2) = zip ts1 ts2
+ newConstraints (Tpair t1 t2) (Tpair t3 t4) = [(t1, t3), (t2, t4)]
newConstraints (Tfun as1 t1) (Tfun as2 t2) = (t1, t2) : zip as1 as2
newConstraints t1 t2 = assert (t1 == t2) []
View
22 Types/Base.hs
@@ -8,7 +8,7 @@ module Types.Base where
| Tvar String
| Tlist Type
| Tref Type
- | Ttuple [Type]
+ | Tpair Type Type
| Tfun [Type] Type
deriving Eq
@@ -24,16 +24,16 @@ module Types.Base where
| otherwise = iStr "(" `iAppend` pprType t `iAppend` iStr ")"
pprType :: Type -> Iseq
- pprType Tint = iStr "int"
- pprType Tbool = iStr "bool"
- pprType Tunit = iStr "unit"
- pprType (Tvar v) = iStr v
- pprType (Tlist t) = pprAType t `iAppend` iStr " list"
- pprType (Tref t) = pprType t `iAppend` iStr " ref"
- pprType (Ttuple ts) = iConcat [ iStr "(", iInterleave (iStr ", ") $
- map pprAType ts, iStr ")" ]
- pprType (Tfun ts t) = iConcat [ iInterleave (iStr " -> ") $ map pprAType ts,
- iStr " -> ", pprType t ]
+ pprType Tint = iStr "int"
+ pprType Tbool = iStr "bool"
+ pprType Tunit = iStr "unit"
+ pprType (Tvar v) = iStr v
+ pprType (Tlist t) = pprAType t `iAppend` iStr " list"
+ pprType (Tref t) = pprType t `iAppend` iStr " ref"
+ pprType (Tpair t1 t2) = iConcat [ iStr "(", iInterleave (iStr ", ") $
+ map pprAType [t1, t2], iStr ")" ]
+ pprType (Tfun ts t) = iConcat [ iInterleave (iStr " -> ") $ map pprAType ts,
+ iStr " -> ", pprType t ]
instance Show Type where
show = show . pprType
View
15 Types/Subst.hs
@@ -23,11 +23,12 @@ module Types.Subst (
applySingleSubst :: (String, Type) -> Type -> Type
applySingleSubst (sb, tb) (Tvar v)
- | sb == v = tb
- | otherwise = Tvar v
- applySingleSubst sb (Tlist tp) = Tlist $ applySingleSubst sb tp
- applySingleSubst sb (Tref tp) = Tref $ applySingleSubst sb tp
- applySingleSubst sb (Ttuple ts) = Ttuple $ map (applySingleSubst sb) ts
- applySingleSubst sb (Tfun as tp) =
+ | sb == v = tb
+ | otherwise = Tvar v
+ applySingleSubst sb (Tlist tp) = Tlist $ applySingleSubst sb tp
+ applySingleSubst sb (Tref tp) = Tref $ applySingleSubst sb tp
+ applySingleSubst sb (Tpair t1 t2) = Tpair (applySingleSubst sb t1) $
+ applySingleSubst sb t2
+ applySingleSubst sb (Tfun as tp) =
Tfun (map (applySingleSubst sb) as) $ applySingleSubst sb tp
- applySingleSubst _ tp = tp
+ applySingleSubst _ tp = tp
Please sign in to comment.
Something went wrong with that request. Please try again.