Commit 1b630439 authored by Finn Teegen's avatar Finn Teegen
Browse files

Remove renaming from type syntax check

Fixes #112
parent 1f6ef0f3
......@@ -26,8 +26,7 @@ import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (unless, when)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (nub)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Maybe (isNothing)
import Curry.Base.Ident
import Curry.Base.Position
......@@ -67,7 +66,7 @@ typeSyntaxCheck tcEnv mdl@(Module _ _ _ m _ _ ds) =
dfds = filter isDefaultDecl ds
dfps = map (\(DefaultDecl p _) -> p) dfds
tEnv = foldr (bindType m) (fmap toTypeKind tcEnv) tcds
state = TSCState m tEnv Map.empty 1 []
state = TSCState m tEnv []
-- Type Syntax Check Monad
type TSCM = S.State TSCState
......@@ -76,8 +75,6 @@ type TSCM = S.State TSCState
data TSCState = TSCState
{ moduleIdent :: ModuleIdent
, typeEnv :: TypeEnv
, renameEnv :: RenameEnv
, nextId :: Integer
, errors :: [Message]
}
......@@ -90,28 +87,6 @@ getModuleIdent = S.gets moduleIdent
getTypeEnv :: TSCM TypeEnv
getTypeEnv = S.gets typeEnv
getRenameEnv :: TSCM RenameEnv
getRenameEnv = S.gets renameEnv
modifyRenameEnv :: (RenameEnv -> RenameEnv) -> TSCM ()
modifyRenameEnv f = S.modify $ \s -> s { renameEnv = f $ renameEnv s }
withLocalEnv :: TSCM a -> TSCM a
withLocalEnv act = do
oldEnv <- getRenameEnv
res <- act
modifyRenameEnv $ const oldEnv
return res
resetEnv :: TSCM ()
resetEnv = modifyRenameEnv $ const Map.empty
newId :: TSCM Integer
newId = do
curId <- S.gets nextId
S.modify $ \s -> s { nextId = succ curId }
return curId
report :: Message -> TSCM ()
report err = S.modify (\s -> s { errors = err : errors s })
......@@ -139,170 +114,6 @@ bindType m (ClassDecl _ _ _ cls _ ds) = bindTypeKind m cls (Class qcls ms)
ms = concatMap methods ds
bindType _ _ = id
-- As preparation for the kind check, type variables within type declarations
-- have to be renamed since existentially quantified type variable may shadow
-- a universally quantified variable from the left hand side of a type
-- declaration.
-- TODO: This renaming may be used to support scoped type variables in future.
-- TODO: In the long run, this renaming may be merged with the syntax check
-- renaming and moved into a separate module.
type RenameEnv = Map.Map Ident Ident
class Rename a where
rename :: a -> TSCM a
renameTypeSig :: (Expr a, Rename a) => a -> TSCM a
renameTypeSig x = withLocalEnv $ do
env <- getRenameEnv
bindVars (filter (`notElem` Map.keys env) $ fv x)
rename x
renameReset :: Rename a => a -> TSCM a
renameReset x = withLocalEnv $ resetEnv >> rename x
instance Rename a => Rename [a] where
rename = mapM rename
instance Rename (Decl a) where
rename (InfixDecl p fix pr ops) = return $ InfixDecl p fix pr ops
rename (DataDecl p tc tvs cs clss) = withLocalEnv $ do
bindVars tvs
DataDecl p tc <$> rename tvs <*> rename cs <*> pure clss
rename (ExternalDataDecl p tc tvs) = withLocalEnv $ do
bindVars tvs
ExternalDataDecl p tc <$> rename tvs
rename (NewtypeDecl p tc tvs nc clss) = withLocalEnv $ do
bindVars tvs
NewtypeDecl p tc <$> rename tvs <*> rename nc <*> pure clss
rename (TypeDecl p tc tvs ty) = withLocalEnv $ do
bindVars tvs
TypeDecl p tc <$> rename tvs <*> rename ty
rename (TypeSig p fs qty) =
TypeSig p fs <$> renameTypeSig qty
rename (FunctionDecl p a f eqs) =
FunctionDecl p a f <$> renameReset eqs
rename (PatternDecl p ts rhs) =
PatternDecl p ts <$> renameReset rhs
rename (DefaultDecl p tys) =
DefaultDecl p <$> mapM renameTypeSig tys
rename (ClassDecl p li cx cls tv ds) = withLocalEnv $ do
bindVar tv
ClassDecl p li <$> rename cx <*> pure cls <*> rename tv <*> rename ds
rename (InstanceDecl p li cx cls ty ds) = withLocalEnv $ do
bindVars (fv ty)
flip (InstanceDecl p li) cls <$> rename cx <*> rename ty <*> renameReset ds
rename decl = return decl
instance Rename ConstrDecl where
rename (ConstrDecl p c tys) = withLocalEnv $
ConstrDecl p c <$> rename tys
rename (ConOpDecl p ty1 op ty2) = withLocalEnv $
ConOpDecl p <$> rename ty1 <*> pure op <*> rename ty2
rename (RecordDecl p c fs) = withLocalEnv $
RecordDecl p c <$> rename fs
instance Rename FieldDecl where
rename (FieldDecl p ls ty) = FieldDecl p ls <$> rename ty
instance Rename NewConstrDecl where
rename (NewConstrDecl p c ty) = NewConstrDecl p c <$> rename ty
rename (NewRecordDecl p c (l, ty)) = NewRecordDecl p c . (,) l <$> rename ty
instance Rename Constraint where
rename (Constraint spi cls ty) = Constraint spi cls <$> rename ty
instance Rename QualTypeExpr where
rename (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> rename cx <*> rename ty
instance Rename TypeExpr where
rename (ConstructorType spi tc) = return $ ConstructorType spi tc
rename (ApplyType spi ty1 ty2) = ApplyType spi <$> rename ty1 <*> rename ty2
rename (VariableType spi tv) = VariableType spi <$> rename tv
rename (TupleType spi tys) = TupleType spi <$> rename tys
rename (ListType spi ty) = ListType spi <$> rename ty
rename (ArrowType spi ty1 ty2) = ArrowType spi <$> rename ty1 <*> rename ty2
rename (ParenType spi ty) = ParenType spi <$> rename ty
rename (ForallType spi vs ty) = do
bindVars vs
ForallType spi <$> mapM rename vs <*> rename ty
instance Rename (Equation a) where
rename (Equation p lhs rhs) = Equation p lhs <$> rename rhs
instance Rename (Rhs a) where
rename (SimpleRhs spi li e ds) =
SimpleRhs spi li <$> rename e <*> rename ds
rename (GuardedRhs spi li es ds) =
GuardedRhs spi li <$> rename es <*> rename ds
instance Rename (CondExpr a) where
rename (CondExpr spi c e) = CondExpr spi <$> rename c <*> rename e
instance Rename (Expression a) where
rename (Paren spi e) = Paren spi <$> rename e
rename (Typed spi e qty) = Typed spi <$> rename e
<*> renameTypeSig qty
rename (Record spi a c fs) = Record spi a c <$> rename fs
rename (RecordUpdate spi e fs) = RecordUpdate spi <$> rename e
<*> rename fs
rename (Tuple spi es) = Tuple spi <$> rename es
rename (List spi a es) = List spi a <$> rename es
rename (ListCompr spi e stmts) = ListCompr spi <$> rename e
<*> rename stmts
rename (EnumFrom spi e) = EnumFrom spi <$> rename e
rename (EnumFromThen spi e1 e2) = EnumFromThen spi <$> rename e1
<*> rename e2
rename (EnumFromTo spi e1 e2) = EnumFromTo spi <$> rename e1
<*> rename e2
rename (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> rename e1
<*> rename e2
<*> rename e3
rename (UnaryMinus spi e) = UnaryMinus spi <$> rename e
rename (Apply spi e1 e2) = Apply spi <$> rename e1 <*> rename e2
rename (InfixApply spi e1 op e2) = flip (InfixApply spi) op <$> rename e1
<*> rename e2
rename (LeftSection spi e op) = flip (LeftSection spi) op <$> rename e
rename (RightSection spi op e) = RightSection spi op <$> rename e
rename (Lambda spi ts e) = Lambda spi ts <$> rename e
rename (Let spi li ds e) = Let spi li <$> rename ds <*> rename e
rename (Do spi li stmts e) = Do spi li <$> rename stmts <*> rename e
rename (IfThenElse spi c e1 e2) = IfThenElse spi <$> rename c
<*> rename e1
<*> rename e2
rename (Case spi li ct e alts) = Case spi li ct <$> rename e
<*> rename alts
rename expr = return expr
instance Rename (Statement a) where
rename (StmtExpr spi e) = StmtExpr spi <$> rename e
rename (StmtDecl spi li ds) = StmtDecl spi li <$> rename ds
rename (StmtBind spi t e) = StmtBind spi t <$> rename e
instance Rename (Alt a) where
rename (Alt spi t rhs) = Alt spi t <$> rename rhs
instance Rename a => Rename (Field a) where
rename (Field spi l x) = Field spi l <$> rename x
instance Rename Ident where
rename tv | isAnonId tv = renameIdent tv <$> newId
| otherwise = setSpanInfo (getSpanInfo tv) .
fromMaybe tv <$> lookupVar tv
bindVar :: Ident -> TSCM ()
bindVar tv = do
k <- newId
modifyRenameEnv $ Map.insert tv (renameIdent tv k)
bindVars :: [Ident] -> TSCM ()
bindVars = mapM_ bindVar
lookupVar :: Ident -> TSCM (Maybe Ident)
lookupVar tv = Map.lookup tv <$> getRenameEnv
-- When type declarations are checked, the compiler will allow anonymous
-- type variables on the left hand side of the declaration, but not on
-- the right hand side. Function and pattern declarations must be
......@@ -311,8 +122,7 @@ lookupVar tv = Map.lookup tv <$> getRenameEnv
checkModule :: Module a -> TSCM (Module a)
checkModule (Module spi li ps m es is ds) = do
ds' <- mapM checkDecl ds
ds'' <- rename ds'
return $ Module spi li ps m es is ds''
return $ Module spi li ps m es is ds'
checkDecl :: Decl a -> TSCM (Decl a)
checkDecl (DataDecl p tc tvs cs clss) = do
......
Markdown is supported
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