Added checks for functional patterns, checking whether the function is global...

Added checks for functional patterns, checking whether the function is global and doesn't depend on itself, see #554.

curry-frontend.cabal

@@ -43,6 +43,7 @@ Library
     , directory
     , filepath
     , mtl
+    , multimap
     , process
     , syb
     , transformers
@@ -120,6 +121,7 @@ Executable cymake
     , directory
     , filepath
     , mtl
+    , multimap
     , process
     , syb
     , transformers

src/Checks/SyntaxCheck.hs

@@ -31,8 +31,10 @@ import           Control.Applicative        ((<$>), (<*>))
 import Control.Monad                      (unless, when)
 import qualified Control.Monad.State as S (State, runState, gets, modify)
 import Data.List                          (insertBy, intersect, nub, partition)
-import Data.Maybe                         (isJust, isNothing)
-import qualified Data.Set as Set          (empty, insert, member)
+import qualified Data.Map as Map          (fromList, lookup)
+import Data.Maybe                         (isJust, isNothing, fromMaybe)
+import qualified Data.Set as Set          (empty, insert, member, toList)
+import qualified Data.SetMap as SMap      (SetMap, (!), empty, insert, keys)
 
 import Curry.Base.Ident
 import Curry.Base.Position
@@ -43,6 +45,7 @@ import Curry.Syntax.Pretty (ppPattern)
 import Base.Expr
 import Base.Messages (Message, posMessage, internalError)
 import Base.NestEnv
+import Base.SCC      (scc)
 import Base.Utils    ((++!), findDouble, findMultiples)
 
 import Env.Value           (ValueEnv, ValueInfo (..))
@@ -91,12 +94,13 @@ data SCState = SCState
   , renameEnv   :: RenameEnv        -- ^ Information store
   , scopeId     :: Integer          -- ^ Identifier for the current scope
   , nextId      :: Integer          -- ^ Next fresh identifier
+  , funcDeps    :: FuncDeps         -- ^ Stores data about functions dependencies
   , errors      :: [Message]        -- ^ Syntactic errors in the module
   }
 
 -- |Initial syntax check state
 initState :: [KnownExtension] -> ModuleIdent -> RenameEnv -> SCState
-initState exts m rEnv = SCState exts m rEnv globalScopeId 1 []
+initState exts m rEnv = SCState exts m rEnv globalScopeId 1 noFuncDeps []
 
 -- |Identifier for global (top-level) declarations
 globalScopeId :: Integer
@@ -162,6 +166,10 @@ withLocalEnv act = do
 inNestedScope :: SCM a -> SCM a
 inNestedScope act = withLocalEnv (incNesting >> act)
 
+-- |Modify the `FuncDeps'
+modifyFuncDeps :: (FuncDeps -> FuncDeps) -> SCM ()
+modifyFuncDeps f = S.modify $ \ s -> s { funcDeps = f $ funcDeps s }
+
 -- |Report a syntax error
 report :: Message -> SCM ()
 report msg = S.modify $ \ s -> s { errors = msg : errors s }
@@ -170,6 +178,67 @@ report msg = S.modify $ \ s -> s { errors = msg : errors s }
 ok :: SCM ()
 ok = return ()
 
+-- FuncDeps contains information to deal with dependencies between functions.
+-- This is used for checking whether functional patterns are cyclic.
+-- curGlobalFunc contains the identifier of the global function that is
+-- currently being checked, if any.
+-- data X = X
+-- f = let g = lookup 42 in g [1,2,3]
+-- While `X' is being checked `curGlobalFunc' should be `Nothing', while `lookup'
+-- is being checked is should be `f's identifier.
+-- globalDeps collects all dependencies (other functions) of global functions
+-- funcPats collects all functional patterns and and the global function they're
+-- used in
+data FuncDeps = FuncDeps
+  { curGlobalFunc :: Maybe QualIdent
+  , globalDeps    :: GlobalDeps
+  , funcPats      :: [(QualIdent, QualIdent)]
+  }
+type GlobalDeps = SMap.SetMap QualIdent QualIdent
+
+-- |Initial state for FuncDeps
+noFuncDeps :: FuncDeps
+noFuncDeps = FuncDeps Nothing SMap.empty []
+
+-- |Perform an action inside a function, settìng `curGlobalFunc' to that function
+inFunc :: Ident -> SCM a -> SCM a
+inFunc i scm = do
+  m        <- getModuleIdent
+  let f = qualifyWith m i
+  global <- isNothing <$> S.gets (curGlobalFunc . funcDeps)
+  when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Just f }
+  ret      <- scm
+  when global $ modifyFuncDeps $ \ fd -> fd { curGlobalFunc = Nothing }
+  return ret
+
+-- |Add a dependency to `curGlobalFunction'
+addGlobalDep :: QualIdent -> SCM ()
+addGlobalDep dep = do
+  maybeF <- S.gets (curGlobalFunc . funcDeps)
+  when (isNothing maybeF) $
+    internalError "SyntaxCheck.addGlobalDep: no global function set"
+  let Just f = maybeF
+  modifyFuncDeps $ \ fd -> fd { globalDeps = SMap.insert f dep (globalDeps fd) }
+
+-- |Add a functional pattern to `curGlobalFunction'
+addFuncPat :: QualIdent -> SCM ()
+addFuncPat fp = do
+  maybeF <- S.gets (curGlobalFunc . funcDeps)
+  when (isNothing maybeF) $
+    internalError "SyntaxCheck.addFuncPat: no global function set"
+  let Just f = maybeF
+  modifyFuncDeps $ \ fd ->
+                       fd { funcPats = (fp, f) : funcPats fd }
+
+-- |Return dependencies of global functions
+getGlobalDeps :: SCM GlobalDeps
+getGlobalDeps = globalDeps <$> S.gets funcDeps
+
+-- |Return used functional patterns
+getFuncPats :: SCM [(QualIdent, QualIdent)]
+getFuncPats = funcPats <$> S.gets funcDeps
+
+
 -- A nested environment is used for recording information about the data
 -- constructors and variables in the module. For every data constructor
 -- its arity is saved. This is used for checking that all constructor
@@ -332,6 +401,7 @@ checkModule (Module ps m es is ds) = do
   mapM_ checkPragma ps
   mapM_ bindTypeDecl tds
   ds' <- (tds ++) <$> checkTopDecls vds
+  checkFuncPatDeps
   exts <- getExtensions
   return (Module ps m es is ds', exts)
   where (tds, vds) = partition isTypeDecl ds
@@ -344,6 +414,22 @@ checkExtension :: Extension -> SCM ()
 checkExtension (KnownExtension   _ e) = enableExtension e
 checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e
 
+-- |Checks whether a function in a functional pattern contains cycles
+-- |(depends on its own global function)
+checkFuncPatDeps :: SCM ()
+checkFuncPatDeps = do
+    fps  <- getFuncPats
+    deps <- getGlobalDeps
+    let depLists    = scc (:[]) (Set.toList . (SMap.!) deps) (SMap.keys deps)
+        levelList   = concat $ zipWith (\l n -> zip l (repeat n)) depLists [1..]
+        levels      = Map.fromList levelList
+        funcLevel f = fromMaybe 0 $ Map.lookup f levels :: Integer
+    mapM_ (checkFuncPatDep funcLevel) fps
+
+checkFuncPatDep :: Ord a => (QualIdent -> a) -> (QualIdent, QualIdent) -> SCM ()
+checkFuncPatDep funcLevel (fp, f) = unless (funcLevel fp < funcLevel f) $
+  report $ errFuncPatCyclic fp f
+
 checkTopDecls :: [Decl] -> SCM [Decl]
 checkTopDecls ds = do
   m <- getModuleIdent
@@ -374,8 +460,8 @@ checkDeclLhs (InfixDecl   p fix' pr ops) =
   InfixDecl p fix' <$> checkPrecedence p pr <*> mapM renameVar ops
 checkDeclLhs (TypeSig           p vs ty) =
   (\vs' -> TypeSig p vs' ty) <$> mapM (checkVar "type signature") vs
-checkDeclLhs (FunctionDecl      p _ eqs) =
-  checkEquationsLhs p eqs
+checkDeclLhs (FunctionDecl      p f eqs) =
+  inFunc f $ checkEquationsLhs p eqs
 checkDeclLhs (ForeignDecl  p cc ie f ty) =
   (\f' -> ForeignDecl p cc ie f' ty) <$> checkVar "foreign declaration" f
 checkDeclLhs (    ExternalDecl     p fs) =
@@ -500,7 +586,7 @@ checkDeclRhs _   (DataDecl p tc tvs cs) =
 checkDeclRhs bvs (TypeSig      p vs ty) =
   (\vs' -> TypeSig p vs' ty) <$> mapM (checkLocalVar bvs) vs
 checkDeclRhs _   (FunctionDecl p f eqs) =
-  FunctionDecl p f <$> mapM checkEquation eqs
+  FunctionDecl p f <$> inFunc f (mapM checkEquation eqs)
 checkDeclRhs _   (PatternDecl  p t rhs) =
   PatternDecl p t <$> checkRhs rhs
 checkDeclRhs _   d                      = return d
@@ -632,6 +718,7 @@ checkConstructorPattern p c ts = do
     | otherwise = do
       let n = arity r
       checkFuncPatsExtension p
+      checkFuncPatCall r c
       ts' <- mapM (checkPattern p) ts
       mapM_ (checkFPTerm p) ts'
       return $ if n' > n
@@ -647,10 +734,10 @@ checkInfixPattern p t1 op t2 = do
   env <- getRenameEnv
   case qualLookupVar op env of
     [Constr _ n] -> infixPattern op n
-    [_]          -> funcPattern  op
+    [r]          -> funcPattern r op
     rs           -> case qualLookupVar (qualQualify m op) env of
       [Constr _ n] -> infixPattern (qualQualify m op) n
-      [_]          -> funcPattern  (qualQualify m op)
+      [r]          -> funcPattern r (qualQualify m op)
       rs'          -> do if (null rs && null rs')
                             then report $ errUndefinedData op
                             else report $ errAmbiguousData rs op
@@ -660,8 +747,9 @@ checkInfixPattern p t1 op t2 = do
   infixPattern qop n = do
     when (n /= 2) $ report $ errWrongArity op n 2
     flip InfixPattern qop <$> checkPattern p t1 <*> checkPattern p t2
-  funcPattern qop = do
+  funcPattern r qop = do
     checkFuncPatsExtension p
+    checkFuncPatCall r qop
     ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2]
     mapM_ (checkFPTerm p) ts'
     return $ InfixFuncPattern t1' qop t2'
@@ -685,6 +773,13 @@ checkRecordPattern p c fs = do
     checkFieldLabels "pattern" p mcon fs'
     return $ RecordPattern c fs'
 
+checkFuncPatCall :: RenameInfo -> QualIdent -> SCM ()
+checkFuncPatCall r f = case r of
+  GlobalVar dep _ -> do
+    addGlobalDep dep
+    addFuncPat (dep @> f)
+  _           -> report $ errFuncPatNotGlobal f
+
 -- Note: process decls first
 checkRhs :: Rhs -> SCM Rhs
 checkRhs (SimpleRhs p e ds) = inNestedScope $
@@ -750,7 +845,7 @@ checkVariable v
       []              -> do report $ errUndefinedVariable v
                             return $ Variable v
       [Constr    _ _]   -> return $ Constructor v
-      [GlobalVar _ _]   -> return $ Variable v
+      [GlobalVar f _]   -> addGlobalDep f >> return (Variable v)
       [LocalVar v' _]   -> return $ Variable $ qualify v'
       [RecordLabel _ _] -> return $ Variable v
       rs -> do
@@ -759,7 +854,7 @@ checkVariable v
           []              -> do report $ errAmbiguousIdent rs v
                                 return $ Variable v
           [Constr    _ _]   -> return $ Constructor v
-          [GlobalVar _ _]   -> return $ Variable v
+          [GlobalVar f _]   -> addGlobalDep f >> return (Variable v)
           [LocalVar v' _]   -> return $ Variable $ qualify v'
           [RecordLabel _ _] -> return $ Variable v
           rs'               -> do report $ errAmbiguousIdent rs' v
@@ -832,14 +927,14 @@ checkOp op = do
   case qualLookupVar v env of
     []              -> report (errUndefinedVariable v) >> return op
     [Constr _ _]    -> return $ InfixConstr v
-    [GlobalVar _ _] -> return $ InfixOp v
+    [GlobalVar f _] -> addGlobalDep f >> return (InfixOp v)
     [LocalVar v' _] -> return $ InfixOp $ qualify v'
     rs              -> do
       m <- getModuleIdent
       case qualLookupVar (qualQualify m v) env of
         []              -> report (errAmbiguousIdent rs v) >> return op
         [Constr _ _]    -> return $ InfixConstr v
-        [GlobalVar _ _] -> return $ InfixOp v
+        [GlobalVar f _] -> addGlobalDep f >> return (InfixOp v)
         [LocalVar v' _] -> return $ InfixOp $ qualify v'
         rs'             -> report (errAmbiguousIdent rs' v) >> return op
   where v = opName op
@@ -1070,6 +1165,15 @@ errUnsupportedFuncPattern s p pat = posMessage p $
   text "Functional patterns are not supported inside a" <+> text s <> dot
   $+$ ppPattern 0 pat
 
+errFuncPatNotGlobal :: QualIdent -> Message
+errFuncPatNotGlobal f = posMessage f $ hsep $ map text
+  ["Function", escQualName f, "in functional pattern is not global"]
+
+errFuncPatCyclic :: QualIdent -> QualIdent -> Message
+errFuncPatCyclic fp f = posMessage fp $ hsep $ map text
+  [ "Function", escName $ unqualify fp, "used in functional pattern depends on"
+  , escName $ unqualify f, " causing a cyclic dependency"]
+
 errPrecedenceOutOfRange :: Position -> Integer -> Message
 errPrecedenceOutOfRange p i = posMessage p $ hsep $ map text
   ["Precedence out of range:", show i]

src/CurryDeps.hs

@@ -171,7 +171,7 @@ errCyclicImport []  = internalError "CurryDeps.errCyclicImport: empty list"
 errCyclicImport [m] = message $ sep $ map text
   [ "Recursive import for module", moduleName m ]
 errCyclicImport ms  = message $ sep $
-  text "Cylic import dependency between modules" : punctuate comma inits
+  text "Cyclic import dependency between modules" : punctuate comma inits
   ++ [text "and", lastm]
   where
   (inits, lastm)     = splitLast $ map (text . moduleName) ms

src/Interfaces.hs

@@ -135,7 +135,7 @@ errCyclicImport _ []  = internalError "Interfaces.errCyclicImport: empty list"
 errCyclicImport p [m] = posMessage p $
   text "Recursive import for module" <+> text (moduleName m)
 errCyclicImport p ms  = posMessage p $
-  text "Cylic import dependency between modules"
+  text "Cyclic import dependency between modules"
   <+> hsep (punctuate comma (map text inits)) <+> text "and" <+> text lastm
   where
   (inits, lastm)         = splitLast $ map moduleName ms

test/TestFrontend.hs

@@ -133,6 +133,7 @@ passInfos = map mkPassTest
   , "ExplicitLayout"
   , "FCase"
   , "FP_Lifting"
+  , "FP_NonCyclic"
   , "FP_NonLinearity"
   , "FunctionalPatterns"
   , "HaskellRecords"
@@ -186,6 +187,7 @@ failInfos = map (uncurry mkFailTest)
   , ("ExportCheck/UndefinedElement", ["`foo' is not a constructor or label of type `Bool'"])
   , ("ExportCheck/UndefinedName", ["Undefined name `foo' in export list"])
   , ("ExportCheck/UndefinedType", ["Undefined type `Foo' in export list"])
+  , ("FP_Cyclic", ["Function `g' used in functional pattern depends on `f'  causing a cyclic dependency"])
   , ("FP_Restrictions",
       [ "Functional patterns are not supported inside a case expression"
       , "Functional patterns are not supported inside a case expression"
@@ -193,6 +195,7 @@ failInfos = map (uncurry mkFailTest)
       , "Functional patterns are not supported inside a do sequence"
       ]
     )
+  , ("FP_NonGlobal", ["Function `f1' in functional pattern is not global"])
   , ("ImportError",
       [ "Module Prelude does not export foo"
       , "Module Prelude does not export bar"

test/fail/FP_Cyclic.curry

+{-# Language FunctionalPatterns #-}
+
+f  = let f3 (g _) = 0
+      in 42
+g x = let f1 = f in x

test/fail/FP_NonGlobal.curry

+{-# Language FunctionalPatterns #-}
+
+f = let f1 x      = x
+        f2 (f1 _) = 42
+     in f2
+

test/pass/FP_Lifting.curry

@@ -3,7 +3,9 @@
 f x = g x &> x
  where
   g (h y) = success
-  h y = x
+-- causes an error since h is not global
+--h y = x
+h y = error "undefined"
 
 main = f z
  where z free

test/pass/FP_NonCyclic.curry

+{-# Language FunctionalPatterns #-}
+last (_++[x]) = x
+
+f1 = 42
+f2 e            = [e]
+f  = let f3 (FP_NonCyclic.f1) = 0
+         f4 (f2 _)       = 23
+      in f1