Merge branch 'master' of /home/bjp/public_html/repos/curry-frontend

.gitignore

 dist/
-*/.curry
+.curry/

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/Check/WarnCheck.hs

@@ -28,7 +28,7 @@ import Env.ScopeEnv (ScopeEnv)
 type CheckState = State CState
 
 data CState = CState
-  { messages  :: [WarnMsg]
+  { messages  :: [Message]
   , scope     :: ScopeEnv QualIdent IdInfo
   , values    :: ValueEnv
   , moduleId  :: ModuleIdent
@@ -38,7 +38,7 @@ emptyState :: CState
 emptyState = CState [] ScopeEnv.new emptyTopEnv (mkMIdent [])
 
 -- |Run a 'CheckState' action and return the list of messages
-run ::  CheckState a -> [WarnMsg]
+run ::  CheckState a -> [Message]
 run f = reverse (messages (execState f emptyState))
 
 -- Find potentially incorrect code in a Curry program and generate
@@ -48,7 +48,7 @@ run f = reverse (messages (execState f emptyState))
 --    - idle case alternatives
 --    - overlapping case alternatives
 --    - function rules which are not together
-warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [WarnMsg]
+warnCheck :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] -> [Message]
 warnCheck mid vals imports decls = run $ do
   addImportedValues vals
   addModuleId mid
@@ -596,12 +596,12 @@ modifyScope f state = state{ scope = f (scope state) }
 genWarning :: Position -> String -> CheckState ()
 genWarning pos msg
    = modify (\state -> state{ messages = warnMsg:(messages state) })
- where warnMsg = WarnMsg (Just pos) msg
+ where warnMsg = Message (Just pos) msg
 
 genWarning' :: (Position, String) -> CheckState ()
 genWarning' (pos, msg)
    = modify (\state -> state{ messages = warnMsg:(messages state) })
-    where warnMsg = WarnMsg (Just pos) msg
+    where warnMsg = Message (Just pos) msg
 
 --
 insertVar :: Ident -> CheckState ()

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/Frontend.hs

@@ -66,7 +66,7 @@ genCurrySyntax fn mod1
 
 --
 genFullCurrySyntax ::
-  (Options -> ModuleEnv -> CS.Module -> IO (a, b, c, CS.Module, d, [WarnMsg]))
+  (Options -> ModuleEnv -> CS.Module -> IO (a, b, c, CS.Module, d, [Message]))
   -> [FilePath] -> MsgMonad CS.Module -> IO (MsgMonad CS.Module)
 genFullCurrySyntax check paths m = runMsgIO m $ \mod1 -> do
   errs <- makeInterfaces paths mod1

src/Gen/GenFlatCurry.hs

@@ -47,7 +47,7 @@ trace' _ x = x
 
 -- transforms intermediate language code (IL) to FlatCurry code
 genFlatCurry :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-		-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
+		-> ArityEnv -> IL.Module -> (Prog, [Message])
 genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
    = (prog', messages)
  where (prog, messages)
@@ -57,7 +57,7 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
 
 -- transforms intermediate language code (IL) to FlatCurry interfaces
 genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-         -> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
+         -> ArityEnv -> IL.Module -> (Prog, [Message])
 genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul =
   (patchPreludeFCY intf, messages)
   where (intf, messages)
@@ -120,7 +120,7 @@ data FlatEnv = FlatEnv
   , varIndexE     :: Int
   , varIdsE       :: ScopeEnv Ident VarIndex
   , tvarIndexE    :: Int
-  , messagesE     :: [WarnMsg]
+  , messagesE     :: [Message]
   , genInterfaceE :: Bool
   , localTypes    :: Map.Map QualIdent IL.Type
   , constrTypes   :: Map.Map QualIdent IL.Type
@@ -132,7 +132,7 @@ data IdentExport = NotConstr       -- function, type-constructor
 
 -- Runs a 'FlatState' action and returns the result
 run :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
-    -> Bool -> FlatState a -> (a, [WarnMsg])
+    -> Bool -> FlatState a -> (a, [Message])
 run opts cEnv mEnv tyEnv tcEnv aEnv genIntf f
    = (result, messagesE env)
  where
@@ -1084,7 +1084,7 @@ clearVarIndices = modify (\env -> env { varIndexE = 0,
 genWarning :: String -> FlatState ()
 genWarning msg
    = modify (\env -> env{ messagesE = warnMsg:(messagesE env) })
-    where warnMsg = WarnMsg Nothing msg
+    where warnMsg = Message Nothing msg
 
 --
 genInterface :: FlatState Bool

src/Html/SyntaxColoring.hs

@@ -43,7 +43,7 @@ data Code =  Keyword String
            | CharCode String
            | Symbol String
            | Identifier IdentifierKind QualIdent
-           | CodeWarning [WarnMsg] Code
+           | CodeWarning [Message] Code
            | NotParsed String
              deriving Show
 
@@ -114,10 +114,10 @@ getQualIdent  _ = Nothing
 
 -- DEBUGGING----------- wird bald nicht mehr gebraucht
 
-setMessagePosition :: WarnMsg -> WarnMsg
-setMessagePosition m@(WarnMsg (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
-setMessagePosition (WarnMsg _ m) =
-        let mes@(WarnMsg pos _) =  (WarnMsg (getPositionFromString m) m) in
+setMessagePosition :: Message -> Message
+setMessagePosition m@(Message (Just p) _) = trace'' ("pos:" ++ show p ++ ":" ++ show m) m
+setMessagePosition (Message _ m) =
+        let mes@(Message pos _) =  (Message (getPositionFromString m) m) in
         trace'' ("pos:" ++ show pos ++ ":" ++ show mes) mes
 
 getPositionFromString :: String -> Maybe Position
@@ -144,28 +144,28 @@ flatCode code = code
 
 -- ----------Message---------------------------------------
 
-getMessages :: MsgMonad a -> [WarnMsg]
+getMessages :: MsgMonad a -> [Message]
 getMessages = snd . runMsg --(Result mess _) = mess
 -- getMessages (Failure mess) = mess
 
-lessMessage :: WarnMsg -> WarnMsg -> Bool
-lessMessage (WarnMsg mPos1 _) (WarnMsg mPos2 _) = mPos1 < mPos2
+lessMessage :: Message -> Message -> Bool
+lessMessage (Message mPos1 _) (Message mPos2 _) = mPos1 < mPos2
 
-nubMessages :: [WarnMsg] -> [WarnMsg]
+nubMessages :: [Message] -> [Message]
 nubMessages = nubBy eqMessage
 
-eqMessage :: WarnMsg -> WarnMsg -> Bool
-eqMessage (WarnMsg p1 s1) (WarnMsg p2 s2) = (p1 == p2) && (s1 == s2)
+eqMessage :: Message -> Message -> Bool
+eqMessage (Message p1 s1) (Message p2 s2) = (p1 == p2) && (s1 == s2)
 
-prepareMessages :: [WarnMsg] -> [WarnMsg]
+prepareMessages :: [Message] -> [Message]
 prepareMessages = qsort lessMessage . map setMessagePosition . nubMessages
 
 
-buildMessagesIntoPlainText :: [WarnMsg] -> String -> Program
+buildMessagesIntoPlainText :: [Message] -> String -> Program
 buildMessagesIntoPlainText messages text =
     buildMessagesIntoPlainText' messages (lines text) [] 1
  where
-    buildMessagesIntoPlainText' :: [WarnMsg] -> [String] -> [String] -> Int -> Program
+    buildMessagesIntoPlainText' :: [Message] -> [String] -> [String] -> Int -> Program
     buildMessagesIntoPlainText' _ [] [] _ =
           []
     buildMessagesIntoPlainText' _ [] postStrs ln =
@@ -182,7 +182,7 @@ buildMessagesIntoPlainText messages text =
                   (ln,1,NewLine) :
                   buildMessagesIntoPlainText' post preStrs [] (ln + 1)
       where
-         isLeq (WarnMsg (Just p) _) = line p <= ln
+         isLeq (Message (Just p) _) = line p <= ln
          isLeq _ = True