Base.Expr added (was previously in curry-base)

curry-frontend.cabal

@@ -41,6 +41,7 @@ Executable cymake
   Other-Modules:
       Base.Arity
     , Base.Eval
+    , Base.Expr
     , Base.Import
     , Base.Module
     , Base.OpPrec

src/Base/Expr.hs

+{- |Free and bound variables
+
+    The compiler needs to compute the sets 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
+    definitions as \emph{M.x} always denotes an entity defined at the
+    top-level.
+-}
+module Base.Expr (Expr (..), QualExpr (..), QuantExpr (..)) where
+
+import qualified Data.Set as Set (fromList, notMember)
+
+import Curry.Base.Ident
+import Curry.Syntax
+import qualified IL
+
+class Expr e where
+  fv :: e -> [Ident]
+
+class QualExpr e where
+  qfv :: ModuleIdent -> e -> [Ident]
+
+class QuantExpr e where
+  bv :: e -> [Ident]
+
+instance Expr e => Expr [e] where
+  fv = concatMap fv
+
+instance QualExpr e => QualExpr [e] where
+  qfv m = concatMap (qfv m)
+
+instance QuantExpr e => QuantExpr [e] where
+  bv = concatMap bv
+
+-- The \texttt{Decl} instance of \texttt{QualExpr} returns all free
+-- variables on the right hand side, regardless of whether they are bound
+-- on the left hand side. This is more convenient as declarations are
+-- usually processed in a declaration group where the set of free
+-- variables cannot be computed independently for each declaration. Also
+-- note that the operator in a unary minus expression is not a free
+-- variable. This operator always refers to a global function from the
+-- prelude.
+
+instance QualExpr Decl where
+  qfv m (FunctionDecl _ _ eqs) = qfv m eqs
+  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 (ExternalDecl _ _ _ f _) = [f]
+  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)
+
+instance QuantExpr Lhs where
+  bv = bv . snd . flatLhs
+
+instance QualExpr Lhs where
+  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)
+
+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 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
+
+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 (StmtBind _ _ e) = qfv m e
+
+instance QualExpr Alt where
+  qfv m (Alt _ t rhs) = filterBv t (qfv m rhs)
+
+instance QuantExpr a => QuantExpr (Field a) where
+  bv (Field _ _ t) = bv t
+
+instance QualExpr a => QualExpr (Field a) where
+  qfv m (Field _ _ t) = qfv m t
+
+instance QuantExpr Statement where
+  bv (StmtExpr _ _) = []
+  bv (StmtBind _ t _) = bv t
+  bv (StmtDecl ds) = bv ds
+
+instance QualExpr InfixOp where
+  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
+
+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)
+    = 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
+
+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)
+
+filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
+filterBv e = filter (`Set.notMember` Set.fromList (bv e))
+
+-- Since multiple variable occurrences are allowed in function patterns,
+-- it is necessary to compute the list of bound variables in a different way:
+-- Each variable occuring in the function pattern will be unique in the result
+-- list.
+
+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 (InfixFuncPattern t1 _ t2) = foldl bvfp bvs [t1, t2]
+ bvfp bvs (RecordPattern fs r)
+    = foldl bvfp (maybe bvs (bvfp bvs) r) (map fieldTerm fs)
+    
+-- intermediate language
+
+instance Expr IL.Expression where
+  fv (IL.Variable v) = [v]
+  fv (IL.Apply e1 e2) = fv e1 ++ fv e2
+  fv (IL.Case _ _ e alts) = fv e ++ fv alts
+  fv (IL.Or e1 e2) = fv e1 ++ fv e2
+  fv (IL.Exist v e) = filter (/= v) (fv e)
+  fv (IL.Let (IL.Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
+  fv (IL.Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
+    where (vs,es) = unzip [(v,e') | IL.Binding v e' <- bds]
+  fv _ = []
+
+instance Expr IL.Alt where
+  fv (IL.Alt (IL.ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
+  fv (IL.Alt (IL.VariablePattern v) e) = filter (v /=) (fv e)
+  fv (IL.Alt _ e) = fv e

src/Base/Types.lhs

@@ -19,10 +19,10 @@ order of type variables in the left hand side of a type declaration.
 > import Data.List (nub)
 > import qualified Data.Map as Map (Map, fromList, lookup)
 
-> import Curry.Base.Expr
 > import Curry.Base.Ident
 > import qualified Curry.Syntax as CS
 
+> import Base.Expr
 > import Messages (internalError)
 > import Types
 

src/Check/PrecCheck.lhs

@@ -19,11 +19,11 @@ of the operators involved.
 
 > import Data.List (partition, mapAccumL)
 
-> import Curry.Base.Expr
 > import Curry.Base.Position
 > import Curry.Base.Ident
 > import Curry.Syntax
 
+> import Base.Expr
 > import Base.OpPrec (PEnv, OpPrec (..), PrecInfo (..), defaultP, bindP, qualLookupP)
 > import Messages (errorAt')
 > import Utils (findDouble)

src/Check/SyntaxCheck.lhs

@@ -26,12 +26,12 @@ merged into a single definition.
 > import qualified Data.Map as Map (empty, insert, lookup)
 > import Control.Monad.State as S (State, evalState, get, liftM, modify)
 
-> import Curry.Base.Expr
 > import Curry.Base.Position
 > import Curry.Base.Ident
 > import Curry.Syntax
 
 > import Base.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity)
+> import Base.Expr
 > import Base.Import (ImportEnv, lookupAlias)
 > import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
 > import Base.Value (ValueEnv, ValueInfo (..))

src/Check/TypeCheck.lhs

@@ -30,12 +30,12 @@ type annotation is present.
 > import qualified Data.Set as Set (Set, fromList, member, notMember, unions)
 > import Text.PrettyPrint.HughesPJ
 
-> import Curry.Base.Expr
 > import Curry.Base.Position
 > import Curry.Base.Ident
 > import Curry.Syntax
 > import Curry.Syntax.Pretty
 
+> import Base.Expr
 > import Base.Types (fromQualType, toType, toTypes)
 > import Base.TypeConstructors (TCEnv, TypeInfo (..), bindTypeInfo, qualLookupTC)
 > import Base.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun

src/CurryToIL.lhs

@@ -25,13 +25,13 @@ data structures, we can use only a qualified import for the
 > import qualified Data.Set as Set (delete, fromList, toList)
 > import qualified Data.Map as Map (Map, empty, insert, lookup)
 
-> import Curry.Base.Expr
 > import Curry.Base.Position
 > import Curry.Base.Ident
 > import qualified IL as IL
 > import Curry.Syntax
 
 > import Base.Eval (EvalEnv)
+> import Base.Expr
 > import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
 > import Base.Types (toQualTypes)
 > import Base.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)

src/IL/Type.lhs

@@ -48,33 +48,32 @@ an unlimited range of integer constants in Curry programs.
 
 > import Data.Generics
 
-> import Curry.Base.Expr
 > import Curry.Base.Ident
 > import Curry.Base.Position (SrcRef(..))
 
 > data Module = Module ModuleIdent [ModuleIdent] [Decl] deriving (Eq,Show)
 
 > data Decl
->   = DataDecl QualIdent Int [ConstrDecl [Type]]
->   | NewtypeDecl QualIdent Int (ConstrDecl Type)
+>   = DataDecl     QualIdent Int [ConstrDecl [Type]]
+>   | NewtypeDecl  QualIdent Int (ConstrDecl Type)
 >   | FunctionDecl QualIdent [Ident] Type Expression
 >   | ExternalDecl QualIdent CallConv String Type
->     deriving (Eq,Show)
+>     deriving (Eq, Show)
 
-> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq,Show)
-> data CallConv = Primitive | CCall deriving (Eq,Show)
+> data ConstrDecl a = ConstrDecl QualIdent a deriving (Eq, Show)
+> data CallConv = Primitive | CCall deriving (Eq, Show)
 
 > data Type
 >   = TypeConstructor QualIdent [Type]
->   | TypeVariable Int
->   | TypeArrow Type Type
->     deriving (Eq,Show, Typeable, Data)
+>   | TypeVariable    Int
+>   | TypeArrow       Type Type
+>     deriving (Eq, Show, Typeable, Data)
 
 > data Literal
->   = Char SrcRef Char
->   | Int SrcRef Integer
+>   = Char  SrcRef Char
+>   | Int   SrcRef Integer
 >   | Float SrcRef Double
->     deriving (Eq,Show)
+>     deriving (Eq, Show)
 
 > data ConstrTerm
 >     -- |literal patterns
@@ -108,12 +107,10 @@ an unlimited range of integer constants in Curry programs.
 >   | Letrec [Binding] Expression
 >   deriving (Eq,Show)
 
-> data Eval = Rigid | Flex deriving (Eq,Show)
-> data Alt = Alt ConstrTerm Expression deriving (Eq,Show)
+> data Eval    = Rigid | Flex deriving (Eq,Show)
+> data Alt     = Alt ConstrTerm Expression deriving (Eq,Show)
 > data Binding = Binding Ident Expression deriving (Eq,Show)
 
-\end{verbatim}
-
 > instance SrcRefOf ConstrTerm where
 >   srcRefOf (LiteralPattern l) = srcRefOf l
 >   srcRefOf (ConstructorPattern i _) = srcRefOf i
@@ -124,18 +121,4 @@ an unlimited range of integer constants in Curry programs.
 >   srcRefOf (Int s _)    = s
 >   srcRefOf (Float s _)  = s
 
-> instance Expr Expression where
->   fv (Variable v) = [v]
->   fv (Apply e1 e2) = fv e1 ++ fv e2
->   fv (Case _ _ e alts) = fv e ++ fv alts
->   fv (Or e1 e2) = fv e1 ++ fv e2
->   fv (Exist v e) = filter (/= v) (fv e)
->   fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2)
->   fv (Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e)
->     where (vs,es) = unzip [(v,e') | Binding v e' <- bds]
->   fv _ = []
-
-> instance Expr Alt where
->   fv (Alt (ConstructorPattern _ vs) e) = filter (`notElem` vs) (fv e)
->   fv (Alt (VariablePattern v) e) = filter (v /=) (fv e)
->   fv (Alt _ e) = fv e
+\end{verbatim}
\ No newline at end of file

src/Transform/Desugar.lhs

@@ -66,11 +66,11 @@ all names must be properly qualified before calling this module.}
 > import Data.List
 > import Data.Maybe
 
-> import Curry.Base.Expr
-> import Curry.Base.Position
 > import Curry.Base.Ident
+> import Curry.Base.Position
 > import Curry.Syntax
 
+> import Base.Expr
 > import Base.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
 > import Base.Types (fromType)
 > import Base.Value (ValueEnv, ValueInfo (..), bindFun, bindGlobalInfo

src/Transform/Lift.lhs

@@ -24,11 +24,11 @@ lifted to the top-level.
 > import qualified Data.Map as Map
 > import qualified Data.Set as Set
 
-> import Curry.Base.Expr
 > import Curry.Base.Ident
 > import Curry.Syntax
 
 > import Base.Eval (EvalEnv)
+> import Base.Expr
 > import Base.Value (ValueEnv, ValueInfo (..), lookupValue)
 > import Env.TopEnv
 > import Messages (internalError)

src/Transform/Simplify.lhs

@@ -28,12 +28,12 @@ Currently, the following optimizations are implemented:
 > import Control.Monad.State as S
 > import qualified Data.Map as Map
 
-> import Curry.Base.Expr
 > import Curry.Base.Position
 > import Curry.Base.Ident
 > import Curry.Syntax
 
 > import Base.Eval (EvalEnv)
+> import Base.Expr
 > import Base.Value (ValueEnv, ValueInfo (..), bindFun, qualLookupValue)
 > import Messages (internalError)
 > import SCC