content: {-# LANGUAGE OverloadedLists #-}
  
  -- | STG error transitions, in order to provide useful information to the user.
  module Stg.Machine.Evaluate.ErrorTransitions (
      updatableClosureWithArgs,
      returnWithEmptyReturnStack,
      functionArgumentNotInScope,
      constructorArgumentNotInScope,
      primopArgumentNotInScope,
      algReturnToPrimAlts,
      primReturnToAlgAlts,
      enterBlackhole,
      updateClosureWithPrimitive,
      nonAlgPrimScrutinee,
      divisionByZero,
      badConArity,
  ) where
  
  
  
  import           Data.Stack                  (Stack (..))
  import           Stg.Language
  import           Stg.Machine.Env
  import           Stg.Machine.Evaluate.Common
  import qualified Stg.Machine.Heap            as H
  import           Stg.Machine.Types
  import           Stg.Util
  
  
  
  -- | Page 39, 2nd paragraph: "[...] closures with non-empty argument lists are
  -- never updatable [...]"
  updatableClosureWithArgs :: StgState -> Maybe StgState
  updatableClosureWithArgs s@StgState
      { stgCode = Enter addr
      , stgHeap = heap }
      | Just (HClosure (Closure (LambdaForm _ Update (_:_) _) _))
          <- H.lookup addr heap
  
    = Just (s { stgInfo = Info (StateError UpdatableClosureWithArgs) [] })
  
  updatableClosureWithArgs _ = Nothing
  
  
  
  -- | Page 39, 4th paragraph: "It is not possible for the ReturnInt state to see an
  -- empty return stack, because that would imply that a closure should be updated
  -- with a primitive value; but no closure has a primitive type."
  returnWithEmptyReturnStack :: StgState -> Maybe StgState
  returnWithEmptyReturnStack s@StgState
      { stgCode  = ReturnInt{}
      , stgStack = Empty }
  
    = Just (s { stgInfo = Info (StateError ReturnIntWithEmptyReturnStack)
                               [Detail_ReturnIntCannotUpdate] })
  
  returnWithEmptyReturnStack _ = Nothing
  
  
  
  -- | A function was applied to an argument that was neither globally defined
  -- nor in the local environment
  functionArgumentNotInScope :: StgState -> Maybe StgState
  functionArgumentNotInScope s@StgState
      { stgCode    = Eval (AppF f xs) locals
      , stgGlobals = globals }
      | Failure notInScope <- vals locals globals (AtomVar f : xs)
  
    = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
  
  functionArgumentNotInScope _ = Nothing
  
  
  
  -- | A constructor was applied to an argument that was neither globally defined
  -- nor in the local environment
  constructorArgumentNotInScope :: StgState -> Maybe StgState
  constructorArgumentNotInScope s@StgState
      { stgCode    = Eval (AppC _con xs) locals
      , stgGlobals = globals }
      | Failure notInScope <- vals locals globals xs
  
    = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
  
  constructorArgumentNotInScope _ = Nothing
  
  
  
  -- | A primitive operation was applied to an argument that was neither globally
  -- defined nor in the local environment
  primopArgumentNotInScope :: StgState -> Maybe StgState
  primopArgumentNotInScope s@StgState
      { stgCode = Eval (AppP _op x y) locals }
      | Failure notInScope <- traverse (localVal locals) ([x,y] :: [Atom])
  
    = Just (s { stgInfo = Info (StateError (VariablesNotInScope notInScope)) [] })
  
  primopArgumentNotInScope _ = Nothing
  
  
  
  -- | Algebraic constructor return, but primitive alternative on return frame
  algReturnToPrimAlts :: StgState -> Maybe StgState
  algReturnToPrimAlts s@StgState
      { stgCode  = ReturnCon{}
      , stgStack = ReturnFrame (Alts PrimitiveAlts{} _) _ :< _ }
  
    = Just (s { stgInfo = Info (StateError AlgReturnToPrimAlts) [] })
  
  algReturnToPrimAlts _ = Nothing
  
  
  
  -- | Primitive return, but algebraic alternative on return frame
  primReturnToAlgAlts :: StgState -> Maybe StgState
  primReturnToAlgAlts s@StgState
      { stgCode  = ReturnInt _
      , stgStack = ReturnFrame (Alts AlgebraicAlts{} _) _ :< _ }
  
    = Just (s { stgInfo = Info (StateError PrimReturnToAlgAlts) [] })
  
  primReturnToAlgAlts _ = Nothing
  
  
  
  -- | A black hole was entered, and the infinite recursion detection triggered
  -- as a result
  enterBlackhole :: StgState -> Maybe StgState
  enterBlackhole s@StgState
      { stgCode  = Enter addr
      , stgHeap  = heap }
      | Just (Blackhole bhTick) <- H.lookup addr heap
  
    = Just (s
          { stgInfo = Info (StateError EnterBlackhole)
                         [Detail_EnterBlackHole addr bhTick] })
  
  enterBlackhole _ = Nothing
  
  
  
  -- | Closures are always lifted, not primitive
  updateClosureWithPrimitive :: StgState -> Maybe StgState
  updateClosureWithPrimitive s@StgState
      { stgCode  = ReturnInt _
      , stgStack = UpdateFrame _ :< _}
  
    = Just (s
          { stgInfo  = Info (StateError UpdateClosureWithPrimitive)
                          [Detail_UpdateClosureWithPrimitive] })
  
  updateClosureWithPrimitive _ = Nothing
  
  
  
  -- | Non-algebraic scrutinee
  --
  -- For more information on this, see 'Stg.Prelude.seq'.
  nonAlgPrimScrutinee :: StgState -> Maybe StgState
  nonAlgPrimScrutinee s@StgState
      { stgCode  = Enter _
      , stgStack = ReturnFrame{} :< _}
  
    = Just (s { stgInfo  = Info (StateError NonAlgPrimScrutinee) [] })
  
  nonAlgPrimScrutinee _ = Nothing
  
  
  
  -- | A primitive division had zero as denominator
  divisionByZero :: StgState -> Maybe StgState
  divisionByZero s@StgState
      { stgCode = Eval (AppP op x y) locals }
      | Success (PrimInt xVal) <- localVal locals x
      , Success (PrimInt yVal) <- localVal locals y
      , Failure Div0 <- applyPrimOp op xVal yVal
  
    = Just (s { stgInfo  = Info (StateError DivisionByZero) [] })
  
  divisionByZero _ = Nothing
  
  
  
  -- | Bad constructor arity: different number of arguments in code segment and in
  -- return frame
  badConArity :: StgState -> Maybe StgState
  badConArity s@StgState
      { stgCode  = ReturnCon con ws
      , stgStack = ReturnFrame alts _ :< _ }
      | Success (AltMatches (AlgebraicAlt _con vars _)) <- lookupAlgebraicAlt alts con
      , length ws /= length vars
  
    = Just (s { stgInfo  = Info (StateError (BadConArity (length ws) (length vars)))
                                            [Detail_BadConArity] })
  
  badConArity _ = Nothing
  