Merge pull request #1752 from github/infinite-loops

Add a hole value type and terminate conditions if given a hole

semantic.cabal

@@ -15,6 +15,7 @@ library
   hs-source-dirs:      src
   exposed-modules:
                      -- Analyses & term annotations
+                       Analysis.Abstract.BadAddresses
                        Analysis.Abstract.BadVariables
                        Analysis.Abstract.BadValues
                        Analysis.Abstract.BadModuleResolutions

src/Analysis/Abstract/BadAddresses.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+module Analysis.Abstract.BadAddresses where
+
+import Control.Abstract.Analysis
+import Analysis.Abstract.Evaluating
+import Prologue
+
+newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
+
+deriving instance MonadControl term (m effects)                    => MonadControl term (BadAddresses m effects)
+deriving instance MonadEnvironment location value (m effects)      => MonadEnvironment location value (BadAddresses m effects)
+deriving instance MonadHeap location value (m effects)             => MonadHeap location value (BadAddresses m effects)
+deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadAddresses m effects)
+deriving instance MonadEvaluator location term value (m effects)   => MonadEvaluator location term value (BadAddresses m effects)
+
+instance ( Effectful m
+         , Member (Resumable (AddressError location value)) effects
+         , Member (State (EvaluatingState location term value)) effects
+         , MonadAnalysis location term value (m effects)
+         , MonadValue location value (BadAddresses m effects)
+         , Show location
+         )
+      => MonadAnalysis location term value (BadAddresses m effects) where
+  type Effects location term value (BadAddresses m effects) = Effects location term value (m effects)
+
+  analyzeTerm eval term = resumeException @(AddressError location value) (liftAnalyze analyzeTerm eval term) (
+        \yield error -> do
+          traceM ("AddressError:" <> show error)
+          case error of
+            (UninitializedAddress _) -> hole >>= yield)
+
+  analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/BadModuleResolutions.hs

@@ -26,8 +26,10 @@ instance ( Effectful m
   type Effects location term value (BadModuleResolutions m effects) = State [Name] ': Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException @(ResolutionError value) (liftAnalyze analyzeTerm eval term) (
-        \yield error -> case error of
-          (RubyError nameToResolve) -> yield nameToResolve
-          (TypeScriptError nameToResolve) -> yield nameToResolve)
+        \yield error -> do
+          traceM ("ResolutionError:" <> show error)
+          case error of
+            (RubyError nameToResolve) -> yield nameToResolve
+            (TypeScriptError nameToResolve) -> yield nameToResolve)
 
   analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/BadValues.hs

@@ -28,20 +28,22 @@ instance ( Effectful m
   type Effects location term value (BadValues m effects) = State [Name] ': Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException @(ValueError location value) (liftAnalyze analyzeTerm eval term) (
-        \yield error -> case error of
-          ScopedEnvironmentError{} -> do
-            env <- getEnv
-            yield (Env.push env)
-          CallError val              -> yield val
-          StringError val            -> yield (pack $ show val)
-          BoolError{}                -> yield True
-          NumericError{}             -> unit >>= yield
-          Numeric2Error{}            -> unit >>= yield
-          ComparisonError{}          -> unit >>= yield
-          NamespaceError{}           -> getEnv >>= yield
-          BitwiseError{}             -> unit >>= yield
-          Bitwise2Error{}            -> unit >>= yield
-          KeyValueError{}            -> unit >>= \x -> yield (x, x)
+        \yield error -> do
+          traceM ("ValueError" <> show error)
+          case error of
+            ScopedEnvironmentError{} -> do
+              env <- getEnv
+              yield (Env.push env)
+            CallError val              -> yield val
+            StringError val            -> yield (pack $ show val)
+            BoolError{}                -> yield True
+            NumericError{}             -> hole >>= yield
+            Numeric2Error{}            -> hole >>= yield
+            ComparisonError{}          -> hole >>= yield
+            NamespaceError{}           -> getEnv >>= yield
+            BitwiseError{}             -> hole >>= yield
+            Bitwise2Error{}            -> hole >>= yield
+            KeyValueError{}            -> hole >>= \x -> yield (x, x)
           )
 
   analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/BadVariables.hs

@@ -27,13 +27,15 @@ instance ( Effectful m
   type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects)
 
   analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
-        \yield err -> case err of
-          DefaultExportError{}     -> yield ()
-          ExportError{}            -> yield ()
-          IntegerFormatError{}     -> yield 0
-          FloatFormatError{}       -> yield 0
-          RationalFormatError{}    -> yield 0
-          FreeVariableError name   -> raise (modify' (name :)) >> unit >>= yield
-          FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names))
+        \yield err -> do
+          traceM ("EvalError" <> show err)
+          case err of
+            DefaultExportError{}     -> yield ()
+            ExportError{}            -> yield ()
+            IntegerFormatError{}     -> yield 0
+            FloatFormatError{}       -> yield 0
+            RationalFormatError{}    -> yield 0
+            FreeVariableError name   -> raise (modify' (name :)) >> hole >>= yield
+            FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names))
 
   analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/Evaluating.hs

@@ -37,6 +37,7 @@ type EvaluatingEffects location term value
      , Resumable (LoadError term value)
      , Resumable (ValueError location value)
      , Resumable (Unspecialized value)
+     , Resumable (AddressError location value)
      , Fail                                         -- Failure with an error message
      , Fresh                                        -- For allocating new addresses and/or type variables.
      , Reader (SomeOrigin term)                     -- The current term’s origin.

src/Analysis/Abstract/ImportGraph.hs

@@ -71,11 +71,13 @@ instance ( Effectful m
          , Member Syntax.Identifier syntax
          , MonadAnalysis (Located location term) term value (m effects)
          , term ~ Term (Union syntax) ann
+         , Show ann
          )
       => MonadAnalysis (Located location term) term value (ImportGraphing m effects) where
   type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects)
 
-  analyzeTerm eval term@(In _ syntax) = do
+  analyzeTerm eval term@(In ann syntax) = do
+    traceShowM ann
     case prj syntax of
       Just (Syntax.Identifier name) -> do
         moduleInclusion (Variable (unName name))

src/Analysis/Abstract/Quiet.hs

@@ -31,6 +31,7 @@ instance ( Effectful m
       => MonadAnalysis location term value (Quietly m effects) where
   type Effects location term value (Quietly m effects) = Effects location term value (m effects)
 
-  analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
+  analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) ->
+          traceM ("Unspecialized:" <> show err) >> hole >>= yield)
 
   analyzeModule = liftAnalyze analyzeModule

src/Control/Abstract/Addressable.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, UndecidableInstances, GADTs #-}
 module Control.Abstract.Addressable where
 
 import Control.Abstract.Evaluator
@@ -65,8 +65,8 @@ instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where
   allocLoc = pure . Monovariant
 
 -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
-deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value
-deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr)
+deref :: (MonadThrow (AddressError location value) m, MonadAddressable location m, MonadHeap location value m) => Address location value -> m value
+deref addr = lookupHeap addr >>= maybe (throwAddressError $ UninitializedAddress addr) (derefCell addr)
 
 alloc :: MonadAddressable location m => Name -> m (Address location value)
 alloc = fmap Address . allocLoc
@@ -74,3 +74,18 @@ alloc = fmap Address . allocLoc
 -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
 uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a
 uninitializedAddress addr = fail $ "uninitialized address: " <> show addr
+
+data AddressError location value resume where
+  UninitializedAddress :: Address location value -> AddressError location value value
+
+deriving instance Eq location => Eq (AddressError location value resume)
+deriving instance Show location => Show (AddressError location value resume)
+instance Show location => Show1 (AddressError location value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq location => Eq1 (AddressError location value) where
+  liftEq _ (UninitializedAddress a) (UninitializedAddress b)     = a == b
+
+
+throwAddressError :: (MonadThrow (AddressError location value) m) => AddressError location value resume -> m resume
+throwAddressError = throwException
+

src/Control/Abstract/Value.hs

@@ -39,6 +39,9 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location
   --   TODO: This might be the same as the empty tuple for some value types
   unit :: m value
 
+  -- | Construct an abstract hole.
+  hole :: m value
+
   -- | Construct an abstract integral value.
   integer :: Prelude.Integer -> m value
 
@@ -109,6 +112,8 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location
   -- | Construct the nil/null datatype.
   null :: m value
 
+  isHole :: value -> m Bool
+
   -- | Build a class value from a name and environment.
   klass :: Name                       -- ^ The new class's identifier
         -> [value]                    -- ^ A list of superclasses

src/Data/Abstract/Evaluatable.hs

@@ -53,6 +53,7 @@ type MonadEvaluatable location term value m =
   , MonadThrow (LoadError term value) m
   , MonadThrow (EvalError value) m
   , MonadThrow (ResolutionError value) m
+  , MonadThrow (AddressError location value) m
   , MonadValue location value m
   , Recursive term
   , Reducer value (Cell location value)
@@ -215,6 +216,7 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva
           modifyLoadStack (loadStackPush mPath)
           v <- trace ("load (evaluating): " <> show mPath) $ evaluateModule x
           modifyLoadStack loadStackPop
+          traceM ("load done:" <> show mPath)
           env <- filterEnv <$> getExports <*> getEnv
           modifyModuleTable (ModuleTable.insert name (env, v))
           pure (env, v)

src/Data/Abstract/Type.hs

@@ -27,6 +27,7 @@ data Type
   | Hash [(Type, Type)] -- ^ Heterogenous key-value maps.
   | Object              -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass.
   | Null                -- ^ The null type. Unlike 'Unit', this unifies with any other type.
+  | Hole                -- ^ The hole type.
   deriving (Eq, Ord, Show)
 
 -- TODO: À la carte representation of types.
@@ -70,6 +71,7 @@ instance ( Alternative m
     ret <- localEnv (mappend env) body
     pure (Product tvars :-> ret)
 
+  hole       = pure Hole
   unit       = pure Unit
   integer _  = pure Int
   boolean _  = pure Bool
@@ -93,6 +95,8 @@ instance ( Alternative m
   asPair _   = fail "Must evaluate to Value to use asPair"
   asBool _ = fail "Must evaluate to Value to use asBool"
 
+  isHole ty = pure (ty == Hole)
+
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
   liftNumeric _ Float = pure Float

src/Data/Abstract/Value.hs

@@ -28,6 +28,7 @@ type ValueConstructors location
     , Symbol
     , Tuple
     , Unit
+    , Hole
     ]
 
 -- | Open union of primitive values that terms can be evaluated to.
@@ -67,6 +68,13 @@ instance Eq1 Unit where liftEq = genericLiftEq
 instance Ord1 Unit where liftCompare = genericLiftCompare
 instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
 
+data Hole value = Hole
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Hole where liftEq = genericLiftEq
+instance Ord1 Hole where liftCompare = genericLiftCompare
+instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec
+
 -- | Boolean values.
 newtype Boolean value = Boolean Prelude.Bool
   deriving (Eq, Generic1, Ord, Show)
@@ -191,6 +199,7 @@ instance Ord location => ValueRoots location (Value location) where
 
 -- | Construct a 'Value' wrapping the value arguments (if any).
 instance forall location term m. (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where
+  hole     = pure . injValue $ Hole
   unit     = pure . injValue $ Unit
   integer  = pure . injValue . Integer . Number.Integer
   boolean  = pure . injValue . Boolean
@@ -235,13 +244,19 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
     | otherwise                     = throwException @(ValueError location (Value location)) $ StringError v
 
   ifthenelse cond if' else' = do
-    bool <- asBool cond
-    if bool then if' else else'
+    isHole <- isHole cond
+    if isHole then
+      hole
+    else do
+      bool <- asBool cond
+      if bool then if' else else'
 
   asBool val
     | Just (Boolean b) <- prjValue val = pure b
     | otherwise = throwException @(ValueError location (Value location)) $ BoolError val
 
+  isHole val = pure (prjValue val == Just Hole)
+
 
   liftNumeric f arg
     | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i

src/Language/TypeScript/Assignment.hs

@@ -234,8 +234,8 @@ assignmentExpression :: Assignment
 assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression)
 
 augmentedAssignmentExpression :: Assignment
-augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) expression [
-  assign Expression.Plus <$ symbol AnonPlusEqual
+augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [
+    assign Expression.Plus <$ symbol AnonPlusEqual
   , assign Expression.Minus <$ symbol AnonMinusEqual
   , assign Expression.Times <$ symbol AnonStarEqual
   , assign Expression.DividedBy <$ symbol AnonSlashEqual
@@ -244,6 +244,7 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
   , assign Expression.BAnd <$ symbol AnonAmpersandEqual
   , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual
   , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual
+  , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual
   , assign Expression.BOr <$ symbol AnonPipeEqual ])
   where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term
         assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r)))

src/Semantic/Task.hs

@@ -47,6 +47,7 @@ module Semantic.Task
 , Telemetry
 ) where
 
+import           Analysis.Abstract.BadAddresses
 import           Analysis.Abstract.BadModuleResolutions
 import           Analysis.Abstract.BadValues
 import           Analysis.Abstract.BadVariables
@@ -139,7 +140,7 @@ render renderer = send . Render renderer
 
 type ImportGraphAnalysis term effects value =
   Abstract.ImportGraphing
-    (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))
+    (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))))
     effects
     value
 
@@ -167,7 +168,7 @@ graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelu
     asAnalysisForTypeOfPackage = const
 
     extractGraph result = case result of
-      (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _)))))), _) -> pure $! graph
+      (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph
       _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))
 
     withPrelude Nothing a = a
@@ -229,11 +230,13 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.tree_sitter_ast_parse" languageTag $
       IO.rethrowing (parseToAST language blob)
   AssignmentParser parser assignment -> do
+    traceM ("Parsing" <> blobPath)
     ast <- runParser blob parser `catchError` \ (SomeException err) -> do
       writeStat (Stat.increment "parse.parse_failures" languageTag)
       writeLog Error "failed parsing" (("task", "parse") : blobFields)
       throwError (toException err)
     options <- ask
+    traceM ("Assigning" <> blobPath)
     time "parse.assign" languageTag $
       case Assignment.assign blobSource assignment ast of
         Left err -> do

test/Analysis/Python/Spec.hs

@@ -37,11 +37,11 @@ spec = parallel $ do
 
     it "subclasses" $ do
       v <- fst <$> evaluate "subclass.py"
-      v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))
+      v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))))
 
     it "handles multiple inheritance left-to-right" $ do
       v <- fst <$> evaluate "multiple_inheritance.py"
-      v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))
+      v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\"")))))))))
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n

test/Analysis/Ruby/Spec.hs

@@ -27,12 +27,12 @@ spec = parallel $ do
 
     it "evaluates load with wrapper" $ do
       res <- evaluate "load-wrap.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo"))))))))
       environment (snd res) `shouldBe` [ ("Object", addr 0) ]
 
     it "evaluates subclass" $ do
       res <- evaluate "subclass.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<bar>\"")))))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<bar>\""))))))))
       environment (snd res) `shouldBe` [ ("Bar", addr 6)
                                        , ("Foo", addr 3)
                                        , ("Object", addr 0) ]
@@ -44,13 +44,13 @@ spec = parallel $ do
 
     it "evaluates modules" $ do
       res <- evaluate "modules.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<hello>\"")))))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<hello>\""))))))))
       environment (snd res) `shouldBe` [ ("Object", addr 0)
                                        , ("Bar", addr 3) ]
 
     it "has prelude" $ do
       res <- fst <$> evaluate "preluded.rb"
-      res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<foo>\"")))))))
+      res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<foo>\""))))))))
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n

test/Analysis/TypeScript/Spec.hs

@@ -30,7 +30,7 @@ spec = parallel $ do
 
     it "fails exporting symbols not defined in the module" $ do
       v <- fst <$> evaluate "bad-export.ts"
-      v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip")))))))
+      v `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip"))))))))
 
   where
     fixtures = "test/fixtures/typescript/analysis/"