Commit cc84f0ac authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

cosmetics

parent 01e12774
......@@ -37,7 +37,8 @@ order of type variables in the left hand side of a type declaration.
> where newInTy = [tv | tv <- nub (fv ty), tv `notElem` tvs]
> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]
> toTypes tvs tys = map (toType' (Map.fromList $ zip (tvs ++ newInTys) [0 ..])) tys
> toTypes tvs tys = map
> (toType' (Map.fromList $ zip (tvs ++ newInTys) [0 ..])) tys
> where newInTys = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
> toType' :: Map.Map Ident Int -> CS.TypeExpr -> Type
......@@ -78,8 +79,10 @@ order of type variables in the left hand side of a type declaration.
> fromType (TypeVariable tv) = CS.VariableType
> (if tv >= 0 then identSupply !! tv else mkIdent ('_' : show (-tv)))
> fromType (TypeConstrained tys _) = fromType (head tys)
> fromType (TypeArrow ty1 ty2) = CS.ArrowType (fromType ty1) (fromType ty2)
> fromType (TypeSkolem k) = CS.VariableType $ mkIdent $ "_?" ++ show k
> fromType (TypeArrow ty1 ty2) =
> CS.ArrowType (fromType ty1) (fromType ty2)
> fromType (TypeSkolem k) =
> CS.VariableType $ mkIdent $ "_?" ++ show k
> fromType (TypeRecord fs rty) = CS.RecordType
> (map (\ (l, ty) -> ([l], fromType ty)) fs)
> ((fromType . TypeVariable) `fmap` rty)
......@@ -73,17 +73,20 @@ imported.
> Just _ -> internalError "TopEnv.predefTopEnv"
> Nothing -> TopEnv $ Map.insert x [(Import [], y)] env
> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
> -> TopEnv a
> importTopEnv m x y (TopEnv env) =
> TopEnv $ Map.insert x' (mergeImport m y (entities x' env)) env
> where x' = qualify x
> qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
> qualImportTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a
> -> TopEnv a
> qualImportTopEnv m x y (TopEnv env) =
> TopEnv $ Map.insert x' (mergeImport m y (entities x' env)) env
> where x' = qualifyWith m x
> mergeImport :: Entity a => ModuleIdent -> a -> [(Source, a)] -> [(Source, a)]
> mergeImport :: Entity a => ModuleIdent -> a -> [(Source, a)]
> -> [(Source, a)]
> mergeImport m x [] = [(Import [m], x)]
> mergeImport m x (loc@(Local , _) : xs) = loc : mergeImport m x xs
> mergeImport m x (imp@(Import ms, x') : xs) = case merge x x' of
......@@ -107,9 +110,10 @@ imported.
> qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
> qualRebindTopEnv x y (TopEnv env) =
> TopEnv $ Map.insert x (rebindLocal (entities x env)) env
> where rebindLocal [] = internalError "TopEnv.qualRebindTopEnv"
> rebindLocal ((Local, _) : ys) = (Local, y) : ys
> rebindLocal (imported : ys) = imported : rebindLocal ys
> where
> rebindLocal [] = internalError "TopEnv.qualRebindTopEnv"
> rebindLocal ((Local, _) : ys) = (Local, y) : ys
> rebindLocal (imported : ys) = imported : rebindLocal ys
> unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
> unbindTopEnv x (TopEnv env) =
......
......@@ -366,8 +366,8 @@ checker.
> unifyTypes (TypeVariable a1)
> (TypeVariable a2)
> (foldr (unifyTypedLabels fs1) theta fs2)
> unifyTypes ty1 ty2 _ =
> internalError ("Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
> unifyTypes ty1 ty2 _ = internalError $
> "Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")"
> unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
> unifyTypedLabels fs1 (l,ty) theta =
......
......@@ -70,7 +70,8 @@ precCheck env (Module m es is ds)
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck :: CompilerEnv -> Module -> (CompilerEnv, Module)
typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
typeCheck env mdl@(Module _ _ _ ds) =
(env { tyConsEnv = tcEnv', valueEnv = tyEnv' }, mdl)
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) ds
......
......@@ -1024,7 +1024,7 @@ Error messages.
> errIllegalLabel :: Ident -> QualIdent -> Message
> errIllegalLabel l r = posErr l $
> "Label `" ++ name l ++ "` is not defined in record `"
> ++ name (unqualify r) ++ "`"
> ++ name (unqualify r) ++ "`"
> errIllegalRecordId :: Ident -> Message
> errIllegalRecordId r = posErr r $ "Record identifier `" ++ name r
......
......@@ -94,14 +94,16 @@ importInterface m q is i env = env
, valueEnv = importEntities m q vs id mTyEnv $ valueEnv env
, arityEnv = importEntities m q as id mAEnv $ arityEnv env
}
where mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTC i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
mAEnv = intfEnv bindA i -- all arities
expandedSpec = maybe [] (expandSpecs m mTCEnv mTyEnv) is -- all imported type constructors / values
ts = isVisible is (Set.fromList $ foldr addType [] expandedSpec)
vs = isVisible is (Set.fromList $ foldr addValue [] expandedSpec)
as = isVisible is (Set.fromList $ foldr addArity [] expandedSpec)
where
mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTC i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
mAEnv = intfEnv bindA i -- all arities
-- all imported type constructors / values
expandedSpec = maybe [] (expandSpecs m mTCEnv mTyEnv) is
ts = isVisible is (Set.fromList $ foldr addType [] expandedSpec)
vs = isVisible is (Set.fromList $ foldr addValue [] expandedSpec)
as = isVisible is (Set.fromList $ foldr addArity [] expandedSpec)
isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool
isVisible (Just (Importing _ _)) xs = (`Set.member` xs)
......@@ -278,14 +280,19 @@ expandSpecs m tcEnv tyEnv (Hiding _ is) =
concatMap (expandHiding m tcEnv tyEnv) is
expandImport :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import -> [Import]
expandImport m tcEnv tyEnv (Import x) = expandThing m tcEnv tyEnv x
expandImport m tcEnv _ (ImportTypeWith tc cs) = [expandTypeWith m tcEnv tc cs]
expandImport m tcEnv _ (ImportTypeAll tc) = [expandTypeAll m tcEnv tc ]
expandImport m tcEnv tyEnv (Import x) =
expandThing m tcEnv tyEnv x
expandImport m tcEnv _ (ImportTypeWith tc cs) =
[expandTypeWith m tcEnv tc cs]
expandImport m tcEnv _ (ImportTypeAll tc) =
[expandTypeAll m tcEnv tc ]
expandHiding :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Import -> [Import]
expandHiding m tcEnv tyEnv (Import x) = expandHide m tcEnv tyEnv x
expandHiding m tcEnv _ (ImportTypeWith tc cs) = [expandTypeWith m tcEnv tc cs]
expandHiding m tcEnv _ (ImportTypeAll tc) = [expandTypeAll m tcEnv tc ]
expandHiding m tcEnv _ (ImportTypeWith tc cs) =
[expandTypeWith m tcEnv tc cs]
expandHiding m tcEnv _ (ImportTypeAll tc) =
[expandTypeAll m tcEnv tc ]
-- try to expand as type constructor
expandThing :: ModuleIdent -> ExpTCEnv -> ExpValueEnv -> Ident -> [Import]
......@@ -294,7 +301,8 @@ expandThing m tcEnv tyEnv tc = case Map.lookup tc tcEnv of
Nothing -> expandThing' m tyEnv tc Nothing
-- try to expand as function / data constructor
expandThing' :: ModuleIdent -> ExpValueEnv -> Ident -> Maybe [Import] -> [Import]
expandThing' :: ModuleIdent -> ExpValueEnv -> Ident -> Maybe [Import]
-> [Import]
expandThing' m tyEnv f tcImport = case Map.lookup f tyEnv of
Just v
| isConstr v -> fromMaybe (errorAt' $ importDataConstr m f) tcImport
......@@ -312,15 +320,16 @@ expandHide m tcEnv tyEnv tc = case Map.lookup tc tcEnv of
Nothing -> expandHide' m tyEnv tc Nothing
-- try to hide as function / data constructor
expandHide' :: ModuleIdent -> ExpValueEnv -> Ident -> Maybe [Import] -> [Import]
expandHide' :: ModuleIdent -> ExpValueEnv -> Ident -> Maybe [Import]
-> [Import]
expandHide' m tyEnv f tcImport = case Map.lookup f tyEnv of
Just _ -> Import f : fromMaybe [] tcImport
Nothing -> fromMaybe (errorAt' $ undefinedEntity m f) tcImport
expandTypeWith :: ModuleIdent -> ExpTCEnv -> Ident -> [Ident] -> Import
expandTypeWith m tcEnv tc cs = case Map.lookup tc tcEnv of
Just (DataType _ _ cs') ->
ImportTypeWith tc (map (checkConstr [c | Just (DataConstr c _ _) <- cs']) cs)
Just (DataType _ _ cs') -> ImportTypeWith tc
(map (checkConstr [c | Just (DataConstr c _ _) <- cs']) cs)
Just (RenamingType _ _ (DataConstr c _ _)) ->
ImportTypeWith tc (map (checkConstr [c]) cs)
Just _ -> errorAt' $ nonDataType tc
......@@ -369,11 +378,12 @@ importUnifyData cEnv = cEnv { tyConsEnv = importUnifyData' $ tyConsEnv cEnv }
importUnifyData' :: TCEnv -> TCEnv
importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
where setInfo tcs t = fromJust $ Map.lookup (origName t) tcs
allTyCons = foldr (mergeData . snd) Map.empty $ allImports tcEnv
mergeData t tcs =
Map.insert tc (maybe t (fromJust . merge t) $ Map.lookup tc tcs) tcs
where tc = origName t
where
setInfo tcs t = fromJust $ Map.lookup (origName t) tcs
allTyCons = foldr (mergeData . snd) Map.empty $ allImports tcEnv
mergeData t tcs =
Map.insert tc (maybe t (fromJust . merge t) $ Map.lookup tc tcs) tcs
where tc = origName t
-- ---------------------------------------------------------------------------
......@@ -416,11 +426,11 @@ importInterfaceIntf i@(Interface m _ _) env = env
, valueEnv = importEntities m True (const True) id mTyEnv $ valueEnv env
, arityEnv = importEntities m True (const True) id mAEnv $ arityEnv env
}
where mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTCHidden i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
mAEnv = intfEnv bindA i -- all arities
where
mPEnv = intfEnv bindPrec i -- all operator precedences
mTCEnv = intfEnv bindTCHidden i -- all type constructors
mTyEnv = intfEnv bindTy i -- all values
mAEnv = intfEnv bindA i -- all arities
-- Error messages:
......
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