SpanStack.hs

{-# LANGUAGE BangPatterns #-}

module Language.Haskell.Liquid.GHC.SpanStack
   ( -- * Stack of positions
     Span (..)
   , SpanStack

     -- * Creating Stacks
   , empty, push

     -- * Using Stacks
   , srcSpan

     -- * Creating general spans
   , showSpan
   ) where

import           Prelude                   hiding (error)
import           Data.Maybe                       (listToMaybe, fromMaybe)
import           Language.Haskell.Liquid.GHC.Misc (tickSrcSpan, showPpr)
import qualified Liquid.GHC.API  as Ghc
import           Liquid.GHC.API  ( SrcSpan
                                                  , fsLit
                                                  , getSrcSpan
                                                  , isGoodSrcSpan
                                                  , mkGeneralSrcSpan
                                                  )

-- | Opaque type for a stack of spans
newtype SpanStack = SpanStack { unStack :: [(Span, SrcSpan)] }

--------------------------------------------------------------------------------
empty :: SpanStack
--------------------------------------------------------------------------------
empty = SpanStack []

--------------------------------------------------------------------------------
push :: Span -> SpanStack -> SpanStack
--------------------------------------------------------------------------------
push !s stk -- @(SpanStack stk)
  | Just sp <- spanSrcSpan s = SpanStack ((s, sp) : unStack stk)
  | otherwise                = stk

-- | A single span
data Span
  = Var  !Ghc.Var         -- ^ binder for whom we are generating constraint
  | Tick !Ghc.CoreTickish -- ^ nearest known Source Span
  | Span SrcSpan

instance Show Span where
  show (Var x)   = show x
  show (Tick tt) = showPpr tt
  show (Span s)  = show s 

--------------------------------------------------------------------------------
srcSpan :: SpanStack -> SrcSpan
--------------------------------------------------------------------------------
srcSpan s  = fromMaybe noSpan (mbSrcSpan s)
  where
    noSpan = showSpan "Yikes! No source information"

mbSrcSpan :: SpanStack -> Maybe SrcSpan
mbSrcSpan = fmap snd . listToMaybe  . unStack

spanSrcSpan :: Span -> Maybe SrcSpan
spanSrcSpan      = maybeSpan Nothing . go
  where
    go (Var x)   = getSrcSpan x
    go (Tick tt) = tickSrcSpan tt
    go (Span s)  = s 

maybeSpan :: Maybe SrcSpan -> SrcSpan -> Maybe SrcSpan
maybeSpan d sp
  | isGoodSrcSpan sp = Just sp
  | otherwise        = d

--------------------------------------------------------------------------------
showSpan :: (Show a) => a -> SrcSpan
--------------------------------------------------------------------------------
showSpan = mkGeneralSrcSpan . fsLit . show