Skip to content
GitLab
Commit ea8e1e39 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Refactoring of Base

parent 92227c27
Hide whitespace changes
Inline Side-by-side
src/Base/CurryTypes.lhs
View file @ ea8e1e39
......@@ -13,7 +13,7 @@ order of type variables in the left hand side of a type declaration.
\begin{verbatim}
> module Base.CurryTypes
> ( toQualType, toQualTypes, toType, toTypes, toType', fromQualType, fromType
> ( toQualType, toQualTypes, toType, toTypes, fromQualType, fromType
> ) where
> import Data.List (nub)
......@@ -33,32 +33,36 @@ order of type variables in the left hand side of a type declaration.
> toQualTypes m tvs = map (qualifyType m) . toTypes tvs
> toType :: [Ident] -> CS.TypeExpr -> Type
> toType tvs ty = toType' (Map.fromList (zip (tvs ++ tvs') [0 ..])) ty
> where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs]
> toType tvs ty = toType' (Map.fromList $ zip (tvs ++ newInTy) [0 ..]) ty
> where newInTy = [tv | tv <- nub (fv ty), tv `notElem` tvs]
> toTypes :: [Ident] -> [CS.TypeExpr] -> [Type]
> toTypes tvs tys = map (toType' (Map.fromList (zip (tvs ++ tvs') [0 ..]))) tys
> where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs]
> 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
> toType' tvs (CS.ConstructorType tc tys) =
> TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) =
> maybe (internalError $ "Base.CurryTypes.toType': " ++ show tv) TypeVariable (Map.lookup tv tvs)
> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
> toType' tvs (CS.ConstructorType tc tys)
> = TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) = case Map.lookup tv tvs of
> Just tv' -> TypeVariable tv'
> Nothing -> internalError $ "Base.CurryTypes.toType': " ++ show tv
> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify $ tupleId $ length tys') tys'
> where tys' = map (toType' tvs) tys
> toType' tvs (CS.ListType ty) = TypeConstructor (qualify listId) [toType' tvs ty]
> toType' tvs (CS.ArrowType ty1 ty2) =
> TypeArrow (toType' tvs ty1) (toType' tvs ty2)
> toType' tvs (CS.RecordType fs rty) =
> TypeRecord (concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs)
> (maybe Nothing
> (\ ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv
> _ -> internalError ("Base.CurryTypes.toType' " ++ show ty))
> rty)
> toType' tvs (CS.ListType ty)
> = TypeConstructor (qualify listId) [toType' tvs ty]
> toType' tvs (CS.ArrowType ty1 ty2)
> = TypeArrow (toType' tvs ty1) (toType' tvs ty2)
> toType' tvs (CS.RecordType fs rty)
> = TypeRecord fs' rty'
> where
> fs' = concatMap (\ (ls, ty) -> map (\ l -> (l, toType' tvs ty)) ls) fs
> rty' = case rty of
> Nothing -> Nothing
> Just ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv
> _ -> internalError $ "Base.CurryTypes.toType' " ++ show ty
> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
> fromQualType m = fromType . unqualifyType m
......@@ -66,16 +70,16 @@ order of type variables in the left hand side of a type declaration.
> fromType :: Type -> CS.TypeExpr
> fromType (TypeConstructor tc tys)
> | isTupleId c = CS.TupleType tys'
> | c == listId && length tys == 1 = CS.ListType (head tys')
> | c == unitId && null tys = CS.TupleType []
> | c == listId && length tys == 1 = CS.ListType (head tys')
> | otherwise = CS.ConstructorType tc tys'
> where c = unqualify tc
> tys' = map fromType tys
> 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 (TypeRecord fs rty) = CS.RecordType
> 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)
> (maybe Nothing (Just . fromType . TypeVariable) rty)
> ((fromType . TypeVariable) `fmap` rty)
src/Base/Expr.hs
View file @ ea8e1e39
{- |Free and bound variables
The compiler needs to compute the sets of free and bound variables for
{- |
Module : $Header$
Description : Extraction of free and bound variables
Copyright : (c) Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The compiler needs to compute the lists of free and bound variables for
various different entities. We will devote three type classes to that
purpose. The \texttt{QualExpr} class is expected to take into account
that it is possible to use a qualified name to refer to a function
defined in the current module and therefore \emph{M.x} and $x$, where
$M$ is the current module name, should be considered the same name.
However note that this is correct only after renaming all local
However, note that this is correct only after renaming all local
definitions as \emph{M.x} always denotes an entity defined at the
top-level.
-}
......@@ -18,12 +27,15 @@ import Curry.Base.Ident
import Curry.Syntax
class Expr e where
-- |Free variables in an 'Expr'
fv :: e -> [Ident]
class QualExpr e where
-- |Free qualified variables in an 'Expr'
qfv :: ModuleIdent -> e -> [Ident]
class QuantExpr e where
-- |Bound variables in an 'Expr'
bv :: e -> [Ident]
instance Expr e => Expr [e] where
......@@ -46,72 +58,72 @@ instance QuantExpr e => QuantExpr [e] where
instance QualExpr Decl where
qfv m (FunctionDecl _ _ eqs) = qfv m eqs
qfv m (PatternDecl _ _ rhs) = qfv m rhs
qfv _ _ = []
qfv m (PatternDecl _ _ rhs) = qfv m rhs
qfv _ _ = []
instance QuantExpr Decl where
bv (TypeSig _ vs _) = vs
bv (EvalAnnot _ fs _) = fs
bv (FunctionDecl _ f _) = [f]
bv (TypeSig _ vs _) = vs
bv (EvalAnnot _ fs _) = fs
bv (FunctionDecl _ f _) = [f]
bv (ExternalDecl _ _ _ f _) = [f]
bv (FlatExternalDecl _ fs) = fs
bv (PatternDecl _ t _) = bv t
bv (ExtraVariables _ vs) = vs
bv _ = []
bv (FlatExternalDecl _ fs) = fs
bv (PatternDecl _ t _) = bv t
bv (ExtraVariables _ vs) = vs
bv _ = []
instance QualExpr Equation where
qfv m (Equation _ lhs rhs) = filterBv lhs (qfv m lhs ++ qfv m rhs)
qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs
instance QuantExpr Lhs where
bv = bv . snd . flatLhs
instance QualExpr Lhs where
qfv m lhs = qfv m (snd (flatLhs lhs))
qfv m lhs = qfv m $ snd $ flatLhs lhs
instance QualExpr Rhs where
qfv m (SimpleRhs _ e ds) = filterBv ds (qfv m e ++ qfv m ds)
qfv m (GuardedRhs es ds) = filterBv ds (qfv m es ++ qfv m ds)
qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e ++ qfv m ds
qfv m (GuardedRhs es ds) = filterBv ds $ qfv m es ++ qfv m ds
instance QualExpr CondExpr where
qfv m (CondExpr _ g e) = qfv m g ++ qfv m e
instance QualExpr Expression where
qfv _ (Literal _) = []
qfv m (Variable v) = maybe [] return (localIdent m v)
qfv _ (Constructor _) = []
qfv m (Paren e) = qfv m e
qfv m (Typed e _) = qfv m e
qfv m (Tuple _ es) = qfv m es
qfv m (List _ es) = qfv m es
qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
qfv m (EnumFrom e) = qfv m e
qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2
qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2
qfv _ (Literal _) = []
qfv m (Variable v) = maybe [] return $ localIdent m v
qfv _ (Constructor _) = []
qfv m (Paren e) = qfv m e
qfv m (Typed e _) = qfv m e
qfv m (Tuple _ es) = qfv m es
qfv m (List _ es) = qfv m es
qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs
qfv m (EnumFrom e) = qfv m e
qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2
qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2
qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (UnaryMinus _ e) = qfv m e
qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2
qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2
qfv m (LeftSection e op) = qfv m op ++ qfv m e
qfv m (RightSection op e) = qfv m op ++ qfv m e
qfv m (Lambda _ ts e) = filterBv ts (qfv m e)
qfv m (Let ds e) = filterBv ds (qfv m ds ++ qfv m e)
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (Case _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr fs) = qfv m fs
qfv m (RecordSelection e _) = qfv m e
qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
qfv m (UnaryMinus _ e) = qfv m e
qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2
qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2
qfv m (LeftSection e op) = qfv m op ++ qfv m e
qfv m (RightSection op e) = qfv m op ++ qfv m e
qfv m (Lambda _ ts e) = filterBv ts $ qfv m e
qfv m (Let ds e) = filterBv ds $ qfv m ds ++ qfv m e
qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts
qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
qfv m (Case _ e alts) = qfv m e ++ qfv m alts
qfv m (RecordConstr fs) = qfv m fs
qfv m (RecordSelection e _) = qfv m e
qfv m (RecordUpdate fs e) = qfv m e ++ qfv m fs
qfvStmt :: ModuleIdent -> Statement -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs
instance QualExpr Statement where
qfv m (StmtExpr _ e) = qfv m e
qfv m (StmtDecl ds) = filterBv ds (qfv m ds)
qfv m (StmtExpr _ e) = qfv m e
qfv m (StmtDecl ds) = filterBv ds $ qfv m ds
qfv m (StmtBind _ _ e) = qfv m e
instance QualExpr Alt where
qfv m (Alt _ t rhs) = filterBv t (qfv m rhs)
qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs
instance QuantExpr a => QuantExpr (Field a) where
bv (Field _ _ t) = bv t
......@@ -120,55 +132,55 @@ instance QualExpr a => QualExpr (Field a) where
qfv m (Field _ _ t) = qfv m t
instance QuantExpr Statement where
bv (StmtExpr _ _) = []
bv (StmtExpr _ _) = []
bv (StmtBind _ t _) = bv t
bv (StmtDecl ds) = bv ds
bv (StmtDecl ds) = bv ds
instance QualExpr InfixOp where
qfv m (InfixOp op) = qfv m (Variable op)
qfv m (InfixOp op) = qfv m $ Variable op
qfv _ (InfixConstr _) = []
instance QuantExpr ConstrTerm where
bv (LiteralPattern _) = []
bv (NegativePattern _ _) = []
bv (VariablePattern v) = [v]
bv (ConstructorPattern _ ts) = bv ts
bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2
bv (ParenPattern t) = bv t
bv (TuplePattern _ ts) = bv ts
bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t
bv (LazyPattern _ t) = bv t
bv (FunctionPattern f ts) = bvFuncPatt (FunctionPattern f ts)
bv (InfixFuncPattern t1 op t2) = bvFuncPatt (InfixFuncPattern t1 op t2)
bv (RecordPattern fs r) = maybe [] bv r ++ bv fs
bv (LiteralPattern _) = []
bv (NegativePattern _ _) = []
bv (VariablePattern v) = [v]
bv (ConstructorPattern _ ts) = bv ts
bv (InfixPattern t1 _ t2) = bv t1 ++ bv t2
bv (ParenPattern t) = bv t
bv (TuplePattern _ ts) = bv ts
bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t
bv (LazyPattern _ t) = bv t
bv (FunctionPattern f ts) = bvFuncPatt $ FunctionPattern f ts
bv (InfixFuncPattern t1 op t2) = bvFuncPatt $ InfixFuncPattern t1 op t2
bv (RecordPattern fs r) = maybe [] bv r ++ bv fs
instance QualExpr ConstrTerm where
qfv _ (LiteralPattern _) = []
qfv _ (NegativePattern _ _) = []
qfv _ (VariablePattern _) = []
qfv m (ConstructorPattern _ ts) = qfv m ts
qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2]
qfv m (ParenPattern t) = qfv m t
qfv m (TuplePattern _ ts) = qfv m ts
qfv m (ListPattern _ ts) = qfv m ts
qfv m (AsPattern _ ts) = qfv m ts
qfv m (LazyPattern _ t) = qfv m t
qfv m (FunctionPattern f ts)
qfv _ (LiteralPattern _) = []
qfv _ (NegativePattern _ _) = []
qfv _ (VariablePattern _) = []
qfv m (ConstructorPattern _ ts) = qfv m ts
qfv m (InfixPattern t1 _ t2) = qfv m [t1, t2]
qfv m (ParenPattern t) = qfv m t
qfv m (TuplePattern _ ts) = qfv m ts
qfv m (ListPattern _ ts) = qfv m ts
qfv m (AsPattern _ ts) = qfv m ts
qfv m (LazyPattern _ t) = qfv m t
qfv m (FunctionPattern f ts)
= maybe [] return (localIdent m f) ++ qfv m ts
qfv m (InfixFuncPattern t1 op t2)
= maybe [] return (localIdent m op) ++ qfv m [t1, t2]
qfv m (RecordPattern fs r) = maybe [] (qfv m) r ++ qfv m fs
qfv m (RecordPattern fs r) = maybe [] (qfv m) r ++ qfv m fs
instance Expr TypeExpr where
fv (ConstructorType _ tys) = fv tys
fv (VariableType tv)
| tv == anonId = []
| otherwise = [tv]
fv (TupleType tys) = fv tys
fv (ListType ty) = fv ty
fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2
fv (RecordType fs rty) = maybe [] fv rty ++ fv (map snd fs)
fv (VariableType tv)
| tv == anonId = []
| otherwise = [tv]
fv (TupleType tys) = fv tys
fv (ListType ty) = fv ty
fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2
fv (RecordType fs rty) = maybe [] fv rty ++ fv (map snd fs)
filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
filterBv e = filter (`Set.notMember` Set.fromList (bv e))
......@@ -181,21 +193,21 @@ filterBv e = filter (`Set.notMember` Set.fromList (bv e))
bvFuncPatt :: ConstrTerm -> [Ident]
bvFuncPatt = bvfp []
where
bvfp bvs (LiteralPattern _) = bvs
bvfp bvs (NegativePattern _ _) = bvs
bvfp bvs (VariablePattern v)
| v `elem` bvs = bvs
| otherwise = v : bvs
bvfp bvs (ConstructorPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (InfixPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (ParenPattern t) = bvfp bvs t
bvfp bvs (TuplePattern _ ts) = foldl bvfp bvs ts
bvfp bvs (ListPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (AsPattern v t)
| v `elem` bvs = bvfp bvs t
| otherwise = bvfp (v : bvs) t
bvfp bvs (LazyPattern _ t) = bvfp bvs t
bvfp bvs (FunctionPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (LiteralPattern _) = bvs
bvfp bvs (NegativePattern _ _) = bvs
bvfp bvs (VariablePattern v)
| v `elem` bvs = bvs
| otherwise = v : bvs
bvfp bvs (ConstructorPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (InfixPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (ParenPattern t) = bvfp bvs t
bvfp bvs (TuplePattern _ ts) = foldl bvfp bvs ts
bvfp bvs (ListPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (AsPattern v t)
| v `elem` bvs = bvfp bvs t
| otherwise = bvfp (v : bvs) t
bvfp bvs (LazyPattern _ t) = bvfp bvs t
bvfp bvs (FunctionPattern _ ts) = foldl bvfp bvs ts
bvfp bvs (InfixFuncPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
bvfp bvs (RecordPattern fs r)
bvfp bvs (RecordPattern fs r)
= foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)
src/Base/Messages.hs
View file @ ea8e1e39
module Base.Messages
( info, status
, putErrLn, putErrsLn, abortWith
, internalError, errorAt, errorAt'
, internalError, errorAt, errorAt', errorMessages
, Message, toMessage, posErr, qposErr
) where
import Control.Monad (unless)
import System.IO (hPutStrLn, stderr)
import System.Exit (ExitCode (..), exitWith)
import Curry.Base.Ident (Ident, QualIdent, positionOfIdent, positionOfQualIdent)
import Curry.Base.MessageMonad (Message, toMessage)
import Curry.Base.Position (Position)
import CompilerOpts (Options (optVerbosity), Verbosity (..))
......@@ -32,12 +35,21 @@ abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
-- |Raise an internal error
internalError :: String -> a
internalError msg = error $ "internal error: " ++ msg
internalError msg = error $ "Internal error: " ++ msg
-- |Raise an error for a given position
errorAt :: Position -> String -> a
errorAt p msg = error ("\n" ++ show p ++ ": " ++ msg)
errorAt p msg = error ('\n' : (show $ toMessage p msg))
-- |Raise an error for a given position, uncurried
errorAt' :: (Position, String) -> a
errorAt' = uncurry errorAt
errorMessages :: [Message] -> a
errorMessages = error . unlines . map show
posErr :: Ident -> String -> Message
posErr i errMsg = toMessage (positionOfIdent i) errMsg
qposErr :: QualIdent -> String -> Message
qposErr i errMsg = toMessage (positionOfQualIdent i) errMsg
src/Base/Subst.lhs
View file @ ea8e1e39
......@@ -24,14 +24,14 @@ marked with a boolean flag (see below).
> idSubst :: Ord a => Subst a b
> idSubst = Subst False Map.empty
> substToList :: Ord v => Subst v e -> [(v,e)]
> substToList :: Ord v => Subst v e -> [(v, e)]
> substToList (Subst _ sigma) = Map.toList sigma
> bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e
> bindSubst v e (Subst comp sigma) = Subst comp (Map.insert v e sigma)
> bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
> unbindSubst :: Ord v => v -> Subst v e -> Subst v e
> unbindSubst v (Subst comp sigma) = Subst comp (Map.delete v sigma)
> unbindSubst v (Subst comp sigma) = Subst comp $ Map.delete v sigma
\end{verbatim}
For any substitution we have the following definitions:
......@@ -83,7 +83,7 @@ substVar :: Subst v e => Subst v e -> v -> e
substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma)
where subst' = if comp then subst (Subst comp sigma) else id
> compose :: (Show v,Ord v,Show e) => Subst v e -> Subst v e -> Subst v e
> compose :: (Ord v, Show v ,Show e) => Subst v e -> Subst v e -> Subst v e
> compose sigma sigma' =
> composed (foldr (uncurry bindSubst) sigma' (substToList sigma))
> where composed (Subst _ sigma'') = Subst True sigma''
......
src/Base/TopEnv.lhs
View file @ ea8e1e39
......@@ -33,16 +33,16 @@ with an imported entity identify the modules from which the entity was
imported.
\begin{verbatim}
> module Env.TopEnv
> ( TopEnv (..), Entity (..), emptyTopEnv, predefTopEnv, qualImportTopEnv
> , importTopEnv, bindTopEnv, qualBindTopEnv, rebindTopEnv, qualRebindTopEnv
> , unbindTopEnv, lookupTopEnv, qualLookupTopEnv
> , allImports, moduleImports,localBindings
> module Base.TopEnv
> ( TopEnv (..), Entity (..), emptyTopEnv, predefTopEnv, importTopEnv
> , qualImportTopEnv, bindTopEnv, qualBindTopEnv, rebindTopEnv
> , qualRebindTopEnv, unbindTopEnv, lookupTopEnv, qualLookupTopEnv
> , allImports, moduleImports, localBindings
> ) where
> import Control.Arrow (second)
> import qualified Data.Map as Map
> import Data.Maybe
> import qualified Data.Map as Map (Map, empty, insert, lookup, toList)
> import Data.Maybe (fromMaybe)
> import Curry.Base.Ident
> import Base.Messages (internalError)
......@@ -62,45 +62,42 @@ imported.
> instance Functor TopEnv where
> fmap f (TopEnv env) = TopEnv (fmap (map (second f)) env)
> entities :: QualIdent -> Map.Map QualIdent [(Source,a)] -> [(Source, a)]
> entities x env = fromMaybe [] (Map.lookup x env)
> entities :: QualIdent -> Map.Map QualIdent [(Source, a)] -> [(Source, a)]
> entities x env = fromMaybe [] $ Map.lookup x env
> emptyTopEnv :: TopEnv a
> emptyTopEnv = TopEnv Map.empty
> predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
> predefTopEnv x y (TopEnv env) =
> case Map.lookup x env of
> Just _ -> internalError "TopEnv.predefTopEnv"
> Nothing -> TopEnv (Map.insert x [(Import [],y)] env)
> predefTopEnv x y (TopEnv env) = case Map.lookup x env of
> Just _ -> internalError "TopEnv.predefTopEnv"
> Nothing -> TopEnv $ Map.insert x [(Import [], y)] env
> 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)
> 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)
> 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 m x [] = [(Import [m],x)]
> mergeImport m x ((Local,x') : xs) = (Local,x') : mergeImport m x xs
> mergeImport m x ((Import ms,x') : xs) =
> case merge x x' of
> Just x'' -> (Import (m:ms),x'') : xs
> Nothing -> (Import ms,x') : mergeImport m x xs
> 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
> Just x'' -> (Import (m : ms), x'') : xs
> Nothing -> imp : mergeImport m x xs
> bindTopEnv :: String -> Ident -> a -> TopEnv a -> TopEnv a
> bindTopEnv fun x y env = qualBindTopEnv fun (qualify x) y env
> qualBindTopEnv :: String -> QualIdent -> a -> TopEnv a -> TopEnv a
> qualBindTopEnv fun x y (TopEnv env) =
> TopEnv (Map.insert x (bindLocal y (entities x env)) env)
> TopEnv $ Map.insert x (bindLocal y (entities x env)) env
> where bindLocal y' ys
> | null [y'' | (Local,y'') <- ys] = (Local,y') : ys
> | null [ y'' | (Local, y'') <- ys ] = (Local, y') : ys
> | otherwise = internalError $ "\"qualBindTopEnv " ++ show x
> ++ "\" failed in function \"" ++ fun ++ "\""
......@@ -109,18 +106,18 @@ 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 ((Import ms,y') : ys) = (Import ms,y') : rebindLocal ys
> 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
> unbindTopEnv :: Ident -> TopEnv a -> TopEnv a
> unbindTopEnv x (TopEnv env) =
> TopEnv (Map.insert x' (unbindLocal (entities x' env)) env)
> TopEnv $ Map.insert x' (unbindLocal (entities x' env)) env
> where x' = qualify x
> unbindLocal [] = internalError "TopEnv.unbindTopEnv"
> unbindLocal ((Local,_) : ys) = ys
> unbindLocal ((Import ms,y) : ys) = (Import ms,y) : unbindLocal ys
> unbindLocal ((Local, _) : ys) = ys
> unbindLocal (imported : ys) = imported : unbindLocal ys
> lookupTopEnv :: Ident -> TopEnv a -> [a]
> lookupTopEnv = qualLookupTopEnv . qualify
......@@ -128,20 +125,20 @@ imported.
> qualLookupTopEnv :: QualIdent -> TopEnv a -> [a]
> qualLookupTopEnv x (TopEnv env) = map snd (entities x env)
> allImports :: TopEnv a -> [(QualIdent,a)]
> allImports :: TopEnv a -> [(QualIdent, a)]
> allImports (TopEnv env) =
> [(x,y) | (x,ys) <- Map.toList env, (Import _,y) <- ys]
> [ (x, y) | (x, ys) <- Map.toList env, (Import _, y) <- ys ]
> unqualBindings :: TopEnv a -> [(Ident,(Source,a))]
> unqualBindings :: TopEnv a -> [(Ident, (Source, a))]
> unqualBindings (TopEnv env) =
> [(x',y) | (x,ys) <- takeWhile (not . isQualified . fst) (Map.toList env),
> let x' = unqualify x, y <- ys]
> [(x', y) | (x, ys) <- takeWhile (not . isQualified . fst) (Map.toList env)
> , let x' = unqualify x, y <- ys]
> moduleImports :: ModuleIdent -> TopEnv a -> [(Ident,a)]