-- | This module contains the code for Incremental checking, which finds the
--   part of a target file (the subset of the @[CoreBind]@ that have been
--   modified since it was last checked, as determined by a diff against
--   a saved version of the file.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections     #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Language.Haskell.Liquid.UX.DiffCheck (

   -- * Changed binders + Unchanged Errors
     DiffCheck (..)

   -- * Use previously saved info to generate DiffCheck target
   , slice

   -- * Use target binders to generate DiffCheck target
   , thin -- , ThinDeps (..)

   -- * Save current information for next time
   , saveResult

   -- * Names of top-level binders that are rechecked
   , checkedVars

   -- * CoreBinds defining given set of Var
   , filterBinds
   , coreDeps
   , dependsOn
   , Def(..)
   , coreDefs
   )
   where


import           Prelude                                hiding (error)
import           Data.Aeson
import qualified Data.Text                              as T
import           Data.Algorithm.Diff
import           Data.Maybe                             (maybeToList, listToMaybe, mapMaybe, fromMaybe)
import qualified Data.IntervalMap.FingerTree            as IM
import qualified Data.HashSet                           as S
import qualified Data.HashMap.Strict                    as M
import qualified Data.List                              as L
import           System.Directory                       (copyFile, doesFileExist)
import           Language.Fixpoint.Types                (atLoc, FixResult (..), SourcePos(..), unPos)
-- import qualified Language.Fixpoint.Misc                 as Misc
import           Language.Fixpoint.Utils.Files
import           Language.Fixpoint.Solver.Stats ()
import           Language.Haskell.Liquid.Misc           (mkGraph)
import           Language.Haskell.Liquid.GHC.Misc
import           Liquid.GHC.API        as Ghc hiding
  (Located, line, sourceName, text, panic, showPpr)
import           Text.PrettyPrint.HughesPJ              (text, render, Doc)
import qualified Data.ByteString                        as B
import qualified Data.ByteString.Lazy                   as LB

import           Language.Haskell.Liquid.Types.Errors
import           Language.Haskell.Liquid.Types.RType
import           Language.Haskell.Liquid.Types.Specs
import           Language.Haskell.Liquid.Types.Types hiding (Def, LMap)
import           Language.Haskell.Liquid.Types.Visitors

--------------------------------------------------------------------------------
-- | Data Types ----------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Main type of value returned for diff-check.
data DiffCheck = DC
  { DiffCheck -> [CoreBind]
newBinds  :: [CoreBind]
  , DiffCheck -> Output Doc
oldOutput :: !(Output Doc)
  , DiffCheck -> TargetSpec
newSpec   :: !TargetSpec
  }

instance PPrint DiffCheck where
  pprintTidy :: Tidy -> DiffCheck -> Doc
pprintTidy Tidy
k DiffCheck
dc = Tidy -> [Var] -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k (DiffCheck -> [Var]
checkedVars DiffCheck
dc) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Tidy -> Output Doc -> Doc
forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k (DiffCheck -> Output Doc
oldOutput DiffCheck
dc)


-- | Variable definitions
data Def  = D
  { Def -> Int
start  :: Int -- ^ line at which binder definition starts
  , Def -> Int
end    :: Int -- ^ line at which binder definition ends
  , Def -> Var
binder :: Var -- ^ name of binder
  }
  deriving (Def -> Def -> Bool
(Def -> Def -> Bool) -> (Def -> Def -> Bool) -> Eq Def
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Def -> Def -> Bool
== :: Def -> Def -> Bool
$c/= :: Def -> Def -> Bool
/= :: Def -> Def -> Bool
Eq, Eq Def
Eq Def =>
(Def -> Def -> Ordering)
-> (Def -> Def -> Bool)
-> (Def -> Def -> Bool)
-> (Def -> Def -> Bool)
-> (Def -> Def -> Bool)
-> (Def -> Def -> Def)
-> (Def -> Def -> Def)
-> Ord Def
Def -> Def -> Bool
Def -> Def -> Ordering
Def -> Def -> Def
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Def -> Def -> Ordering
compare :: Def -> Def -> Ordering
$c< :: Def -> Def -> Bool
< :: Def -> Def -> Bool
$c<= :: Def -> Def -> Bool
<= :: Def -> Def -> Bool
$c> :: Def -> Def -> Bool
> :: Def -> Def -> Bool
$c>= :: Def -> Def -> Bool
>= :: Def -> Def -> Bool
$cmax :: Def -> Def -> Def
max :: Def -> Def -> Def
$cmin :: Def -> Def -> Def
min :: Def -> Def -> Def
Ord)

-- | Variable dependencies "call-graph"
type Deps = M.HashMap Var (S.HashSet Var)

-- | Map from saved-line-num ---> current-line-num
type LMap   = IM.IntervalMap Int Int

-- | Intervals of line numbers that have been re-checked
type ChkItv = IM.IntervalMap Int ()

instance Show Def where
  show :: Def -> [Char]
show (D Int
i Int
j Var
x) = Var -> [Char]
forall a. Outputable a => a -> [Char]
showPpr Var
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" start: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" end: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
j

--------------------------------------------------------------------------------
-- | `checkedNames` returns the names of the top-level binders that will be checked
--------------------------------------------------------------------------------
checkedVars              ::  DiffCheck -> [Var]
checkedVars :: DiffCheck -> [Var]
checkedVars              = (CoreBind -> [Var]) -> [CoreBind] -> [Var]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [Var]
forall {a}. Bind a -> [a]
names ([CoreBind] -> [Var])
-> (DiffCheck -> [CoreBind]) -> DiffCheck -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffCheck -> [CoreBind]
newBinds
   where
     names :: Bind a -> [a]
names (NonRec a
v Expr a
_ ) = [a
v]
     names (Rec [(a, Expr a)]
xs)      = (a, Expr a) -> a
forall a b. (a, b) -> a
fst ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Expr a)]
xs

--------------------------------------------------------------------------------
-- | `slice` returns a subset of the @[CoreBind]@ of the input `target`
--    file which correspond to top-level binders whose code has changed
--    and their transitive dependencies.
--------------------------------------------------------------------------------
slice :: FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
--------------------------------------------------------------------------------
slice :: [Char] -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
slice [Char]
target [CoreBind]
cbs TargetSpec
sp = do
  ex <- [Char] -> IO Bool
doesFileExist [Char]
savedFile
  if ex
    then doDiffCheck
    else return Nothing
  where
    savedFile :: [Char]
savedFile       = Ext -> ShowS
extFileName Ext
Saved [Char]
target
    doDiffCheck :: IO (Maybe DiffCheck)
doDiffCheck     = [Char]
-> [Char] -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved [Char]
target [Char]
savedFile [CoreBind]
cbs TargetSpec
sp

sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved :: [Char]
-> [Char] -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved [Char]
target [Char]
savedFile [CoreBind]
coreBinds TargetSpec
spec = do
  (is, lm) <- [Char] -> [Char] -> IO ([Int], LMap)
lineDiff [Char]
target [Char]
savedFile
  result   <- loadResult target
  return    $ sliceSaved' target is lm (DC coreBinds result spec)

sliceSaved' :: FilePath -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
sliceSaved' :: [Char] -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
sliceSaved' [Char]
srcF [Int]
is LMap
lm (DC [CoreBind]
coreBinds Output Doc
result TargetSpec
spec)
  | Bool
gDiff     = Maybe DiffCheck
forall a. Maybe a
Nothing
  | Bool
otherwise = DiffCheck -> Maybe DiffCheck
forall a. a -> Maybe a
Just (DiffCheck -> Maybe DiffCheck) -> DiffCheck -> Maybe DiffCheck
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> Output Doc -> TargetSpec -> DiffCheck
DC [CoreBind]
cbs' Output Doc
res' TargetSpec
sp'
  where
    gDiff :: Bool
gDiff     = [Char] -> [Int] -> TargetSpec -> Bool
globalDiff [Char]
srcF [Int]
is TargetSpec
spec
    sp' :: TargetSpec
sp'       = HashMap Var LocSpecType -> TargetSpec -> TargetSpec
assumeSpec HashMap Var LocSpecType
sigm TargetSpec
spec
    res' :: Output Doc
res'      = LMap -> ChkItv -> Output Doc -> Output Doc
adjustOutput LMap
lm ChkItv
cm Output Doc
result
    cm :: ChkItv
cm        = [Def] -> ChkItv
checkedItv ([CoreBind] -> [Def]
coreDefs [CoreBind]
cbs')
    cbs' :: [CoreBind]
cbs'      = HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]
thinWith HashSet Var
sigs [CoreBind]
coreBinds ([Int] -> [Def] -> [Var]
diffVars [Int]
is [Def]
defs)
    defs :: [Def]
defs      = [CoreBind] -> [Def]
coreDefs [CoreBind]
coreBinds [Def] -> [Def] -> [Def]
forall a. [a] -> [a] -> [a]
++ [Char] -> TargetSpec -> [Def]
specDefs [Char]
srcF TargetSpec
spec
    sigs :: HashSet Var
sigs      = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Var] -> HashSet Var) -> [Var] -> HashSet Var
forall a b. (a -> b) -> a -> b
$ HashMap Var LocSpecType -> [Var]
forall k v. HashMap k v -> [k]
M.keys HashMap Var LocSpecType
sigm
    sigm :: HashMap Var LocSpecType
sigm      = [Char] -> [Int] -> TargetSpec -> HashMap Var LocSpecType
sigVars [Char]
srcF [Int]
is TargetSpec
spec

-- | Add the specified signatures for vars-with-preserved-sigs,
--   whose bodies have been pruned from [CoreBind] into the "assumes"

assumeSpec :: M.HashMap Var LocSpecType -> TargetSpec -> TargetSpec
assumeSpec :: HashMap Var LocSpecType -> TargetSpec -> TargetSpec
assumeSpec HashMap Var LocSpecType
sigm TargetSpec
sp = TargetSpec
sp { gsSig = gsig { gsAsmSigs = M.toList $ M.union sigm assm } }
  where
    assm :: HashMap Var LocSpecType
assm           = [(Var, LocSpecType)] -> HashMap Var LocSpecType
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList (GhcSpecSig -> [(Var, LocSpecType)]
gsAsmSigs GhcSpecSig
gsig)
    gsig :: GhcSpecSig
gsig           = TargetSpec -> GhcSpecSig
gsSig TargetSpec
sp

diffVars :: [Int] -> [Def] -> [Var]
diffVars :: [Int] -> [Def] -> [Var]
diffVars [Int]
ls [Def]
defs'    = -- tracePpr ("INCCHECK: diffVars lines = " ++ show ls ++ " defs= " ++ show defs) $
                         [Int] -> [Def] -> [Var]
go ([Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort [Int]
ls) [Def]
defs
  where
    defs :: [Def]
defs             = [Def] -> [Def]
forall a. Ord a => [a] -> [a]
L.sort [Def]
defs'
    go :: [Int] -> [Def] -> [Var]
go [Int]
_      []     = []
    go []     [Def]
_      = []
    go (Int
i:[Int]
is) (Def
d:[Def]
ds)
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Def -> Int
start Def
d  = [Int] -> [Def] -> [Var]
go [Int]
is (Def
dDef -> [Def] -> [Def]
forall a. a -> [a] -> [a]
:[Def]
ds)
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Def -> Int
end Def
d    = [Int] -> [Def] -> [Var]
go (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) [Def]
ds
      | Bool
otherwise    = Def -> Var
binder Def
d Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Int] -> [Def] -> [Var]
go (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is) [Def]
ds

sigVars :: FilePath -> [Int] -> TargetSpec -> M.HashMap Var LocSpecType
sigVars :: [Char] -> [Int] -> TargetSpec -> HashMap Var LocSpecType
sigVars [Char]
srcF [Int]
ls TargetSpec
sp = [(Var, LocSpecType)] -> HashMap Var LocSpecType
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Var, LocSpecType)] -> HashMap Var LocSpecType)
-> [(Var, LocSpecType)] -> HashMap Var LocSpecType
forall a b. (a -> b) -> a -> b
$ ((Var, LocSpecType) -> Bool)
-> [(Var, LocSpecType)] -> [(Var, LocSpecType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (LocSpecType -> Bool
forall {a}. Located a -> Bool
ok (LocSpecType -> Bool)
-> ((Var, LocSpecType) -> LocSpecType)
-> (Var, LocSpecType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, LocSpecType) -> LocSpecType
forall a b. (a, b) -> b
snd) ([(Var, LocSpecType)] -> [(Var, LocSpecType)])
-> [(Var, LocSpecType)] -> [(Var, LocSpecType)]
forall a b. (a -> b) -> a -> b
$ TargetSpec -> [(Var, LocSpecType)]
specSigs TargetSpec
sp
  where
    ok :: Located a -> Bool
ok             = Bool -> Bool
not (Bool -> Bool) -> (Located a -> Bool) -> Located a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Int] -> Located a -> Bool
forall a. [Char] -> [Int] -> Located a -> Bool
isDiff [Char]
srcF [Int]
ls

globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool
globalDiff :: [Char] -> [Int] -> TargetSpec -> Bool
globalDiff [Char]
srcF [Int]
ls TargetSpec
gspec = Bool
measDiff Bool -> Bool -> Bool
|| Bool
invsDiff Bool -> Bool -> Bool
|| Bool
dconsDiff
  where
    measDiff :: Bool
measDiff  = (LocSpecType -> Bool) -> [LocSpecType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Int] -> LocSpecType -> Bool
forall a. [Char] -> [Int] -> Located a -> Bool
isDiff [Char]
srcF [Int]
ls) ((Symbol, LocSpecType) -> LocSpecType
forall a b. (a, b) -> b
snd ((Symbol, LocSpecType) -> LocSpecType)
-> [(Symbol, LocSpecType)] -> [LocSpecType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSpecData -> [(Symbol, LocSpecType)]
gsMeas GhcSpecData
spec)
    invsDiff :: Bool
invsDiff  = (LocSpecType -> Bool) -> [LocSpecType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Int] -> LocSpecType -> Bool
forall a. [Char] -> [Int] -> Located a -> Bool
isDiff [Char]
srcF [Int]
ls) ((Maybe Var, LocSpecType) -> LocSpecType
forall a b. (a, b) -> b
snd ((Maybe Var, LocSpecType) -> LocSpecType)
-> [(Maybe Var, LocSpecType)] -> [LocSpecType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSpecData -> [(Maybe Var, LocSpecType)]
gsInvariants GhcSpecData
spec)
    dconsDiff :: Bool
dconsDiff = (Located () -> Bool) -> [Located ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Int] -> Located () -> Bool
forall a. [Char] -> [Int] -> Located a -> Bool
isDiff [Char]
srcF [Int]
ls) [ Located DataCon -> () -> Located ()
forall l b. Loc l => l -> b -> Located b
atLoc Located DataCon
ldc () | Located DataCon
ldc <- GhcSpecNames -> [Located DataCon]
gsDconsP (TargetSpec -> GhcSpecNames
gsName TargetSpec
gspec) ]
    spec :: GhcSpecData
spec      = TargetSpec -> GhcSpecData
gsData TargetSpec
gspec

isDiff :: FilePath -> [Int] -> Located a -> Bool
isDiff :: forall a. [Char] -> [Int] -> Located a -> Bool
isDiff [Char]
srcF [Int]
ls Located a
x = Located a -> [Char]
forall a. Located a -> [Char]
file Located a
x [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
srcF Bool -> Bool -> Bool
&& (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Int -> Bool
hits [Int]
ls
  where
    hits :: Int -> Bool
hits Int
i       = Located a -> Int
forall a. Located a -> Int
line Located a
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Located a -> Int
forall a. Located a -> Int
lineE Located a
x

--------------------------------------------------------------------------------
-- | @thin cbs sp vs@ returns a subset of the @cbs :: [CoreBind]@ which
--   correspond to the definitions of @vs@ and the functions transitively
--   called therein for which there are *no* type signatures. Callees with
--   type signatures are assumed to satisfy those signatures.
--------------------------------------------------------------------------------

{- data ThinDeps = Trans [Var] -- ^ Check all transitive dependencies
              | None   Var  -- ^ Check only the given binders
 -}

--------------------------------------------------------------------------------
thin :: [CoreBind] -> TargetSpec -> [Var] -> DiffCheck
--------------------------------------------------------------------------------
-- thin cbs sp (Trans vs) = DC (thinWith S.empty cbs vs ) mempty sp
thin :: [CoreBind] -> TargetSpec -> [Var] -> DiffCheck
thin [CoreBind]
cbs TargetSpec
sp [Var]
vs = [CoreBind] -> Output Doc -> TargetSpec -> DiffCheck
DC ([CoreBind] -> HashSet Var -> [CoreBind]
filterBinds      [CoreBind]
cbs HashSet Var
vs') Output Doc
forall a. Monoid a => a
mempty TargetSpec
sp'
  where
    vs' :: HashSet Var
vs'        = Deps -> HashSet Var -> HashSet Var -> HashSet Var
txClosure ([CoreBind] -> Deps
coreDeps [CoreBind]
cbs) HashSet Var
xs ([Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Var]
vs)
    sp' :: TargetSpec
sp'        = HashMap Var LocSpecType -> TargetSpec -> TargetSpec
assumeSpec HashMap Var LocSpecType
sigs' TargetSpec
sp
    sigs' :: HashMap Var LocSpecType
sigs'      = (Var -> HashMap Var LocSpecType -> HashMap Var LocSpecType)
-> HashMap Var LocSpecType -> [Var] -> HashMap Var LocSpecType
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Var -> HashMap Var LocSpecType -> HashMap Var LocSpecType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete ([(Var, LocSpecType)] -> HashMap Var LocSpecType
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Var, LocSpecType)]
xts) [Var]
vs
    xts :: [(Var, LocSpecType)]
xts        = TargetSpec -> [(Var, LocSpecType)]
specSigs TargetSpec
sp
    xs :: HashSet Var
xs         = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Var] -> HashSet Var) -> [Var] -> HashSet Var
forall a b. (a -> b) -> a -> b
$ (Var, LocSpecType) -> Var
forall a b. (a, b) -> a
fst ((Var, LocSpecType) -> Var) -> [(Var, LocSpecType)] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, LocSpecType)]
xts

thinWith :: S.HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]
thinWith :: HashSet Var -> [CoreBind] -> [Var] -> [CoreBind]
thinWith HashSet Var
sigs [CoreBind]
cbs [Var]
xs = [CoreBind] -> HashSet Var -> [CoreBind]
filterBinds [CoreBind]
cbs HashSet Var
calls
  where
    calls :: HashSet Var
calls    = Deps -> HashSet Var -> HashSet Var -> HashSet Var
txClosure Deps
cbDeps HashSet Var
sigs ([Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Var]
xs)
    cbDeps :: Deps
cbDeps   = [CoreBind] -> Deps
coreDeps [CoreBind]
cbs

coreDeps    :: [CoreBind] -> Deps
coreDeps :: [CoreBind] -> Deps
coreDeps [CoreBind]
bs = [(Var, Var)] -> Deps
forall a b.
(Eq a, Eq b, Hashable a, Hashable b) =>
[(a, b)] -> HashMap a (HashSet b)
mkGraph ([(Var, Var)] -> Deps) -> [(Var, Var)] -> Deps
forall a b. (a -> b) -> a -> b
$ [(Var, Var)]
calls [(Var, Var)] -> [(Var, Var)] -> [(Var, Var)]
forall a. [a] -> [a] -> [a]
++ [(Var, Var)]
calls'
  where
    calls :: [(Var, Var)]
calls   = (CoreBind -> [(Var, Var)]) -> [CoreBind] -> [(Var, Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [(Var, Var)]
forall {a}. CBVisitable (Bind a) => Bind a -> [(a, Var)]
deps [CoreBind]
bs
    calls' :: [(Var, Var)]
calls'  = [(Var
y, Var
x) | (Var
x, Var
y) <- [(Var, Var)]
calls]
    deps :: Bind a -> [(a, Var)]
deps Bind a
b  = [(a
x, Var
y) | a
x <- Bind a -> [a]
forall {a}. Bind a -> [a]
bindersOf Bind a
b
                      , Var
y <- HashSet Var -> Bind a -> [Var]
forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars HashSet Var
forall a. HashSet a
S.empty Bind a
b
                      , Var -> HashSet Var -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Var
y HashSet Var
defVars
              ]
    defVars :: HashSet Var
defVars = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([CoreBind] -> [Var]
forall a. CBVisitable a => a -> [Var]
letVars [CoreBind]
bs)

-- | Given a call graph, and a list of vars, `dependsOn`
--   checks all functions to see if they call any of the
--   functions in the vars list.
--   If any do, then they must also be rechecked.

dependsOn :: Deps -> [Var] -> S.HashSet Var
dependsOn :: Deps -> [Var] -> HashSet Var
dependsOn Deps
cg [Var]
vars  = [Var] -> HashSet Var
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Var]
results
  where
    preds :: [HashSet Var -> Bool]
preds          = (Var -> HashSet Var -> Bool) -> [Var] -> [HashSet Var -> Bool]
forall a b. (a -> b) -> [a] -> [b]
map Var -> HashSet Var -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member [Var]
vars
    filteredMaps :: [Deps]
filteredMaps   = (HashSet Var -> Bool) -> Deps -> Deps
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
M.filter ((HashSet Var -> Bool) -> Deps -> Deps)
-> [HashSet Var -> Bool] -> [Deps -> Deps]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HashSet Var -> Bool]
preds [Deps -> Deps] -> [Deps] -> [Deps]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Deps -> [Deps]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Deps
cg
    results :: [Var]
results        = ((Var, HashSet Var) -> Var) -> [(Var, HashSet Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, HashSet Var) -> Var
forall a b. (a, b) -> a
fst ([(Var, HashSet Var)] -> [Var]) -> [(Var, HashSet Var)] -> [Var]
forall a b. (a -> b) -> a -> b
$ Deps -> [(Var, HashSet Var)]
forall k v. HashMap k v -> [(k, v)]
M.toList (Deps -> [(Var, HashSet Var)]) -> Deps -> [(Var, HashSet Var)]
forall a b. (a -> b) -> a -> b
$ [Deps] -> Deps
forall k v. Eq k => [HashMap k v] -> HashMap k v
M.unions [Deps]
filteredMaps

txClosure :: Deps -> S.HashSet Var -> S.HashSet Var -> S.HashSet Var
txClosure :: Deps -> HashSet Var -> HashSet Var -> HashSet Var
txClosure Deps
d HashSet Var
sigs    = HashSet Var -> HashSet Var -> HashSet Var
go HashSet Var
forall a. HashSet a
S.empty
  where
    next :: HashSet Var -> HashSet Var
next            = [HashSet Var] -> HashSet Var
forall a. Eq a => [HashSet a] -> HashSet a
S.unions ([HashSet Var] -> HashSet Var)
-> (HashSet Var -> [HashSet Var]) -> HashSet Var -> HashSet Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var -> HashSet Var) -> [Var] -> [HashSet Var]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> HashSet Var
deps ([Var] -> [HashSet Var])
-> (HashSet Var -> [Var]) -> HashSet Var -> [HashSet Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet Var -> [Var]
forall a. HashSet a -> [a]
S.toList
    deps :: Var -> HashSet Var
deps Var
x          = HashSet Var -> Var -> Deps -> HashSet Var
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault HashSet Var
forall a. HashSet a
S.empty Var
x Deps
d
    go :: HashSet Var -> HashSet Var -> HashSet Var
go HashSet Var
seen HashSet Var
new
      | HashSet Var -> Bool
forall a. HashSet a -> Bool
S.null HashSet Var
new  = HashSet Var
seen
      | Bool
otherwise   = let seen' :: HashSet Var
seen' = HashSet Var -> HashSet Var -> HashSet Var
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
S.union HashSet Var
seen HashSet Var
new
                          new' :: HashSet Var
new'  = HashSet Var -> HashSet Var
next HashSet Var
new HashSet Var -> HashSet Var -> HashSet Var
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet Var
seen'
                          new'' :: HashSet Var
new'' = HashSet Var
new'     HashSet Var -> HashSet Var -> HashSet Var
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet Var
sigs
                      in HashSet Var -> HashSet Var -> HashSet Var
go HashSet Var
seen' HashSet Var
new''



--------------------------------------------------------------------------------
filterBinds        :: [CoreBind] -> S.HashSet Var -> [CoreBind]
--------------------------------------------------------------------------------
filterBinds :: [CoreBind] -> HashSet Var -> [CoreBind]
filterBinds [CoreBind]
cbs HashSet Var
ys = (CoreBind -> Bool) -> [CoreBind] -> [CoreBind]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBind -> Bool
f [CoreBind]
cbs
  where
    f :: CoreBind -> Bool
f (NonRec Var
x Expr Var
_) = Var
x Var -> HashSet Var -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Var
ys
    f (Rec [(Var, Expr Var)]
xes)    = (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Var -> HashSet Var -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Var
ys) ([Var] -> Bool) -> [Var] -> Bool
forall a b. (a -> b) -> a -> b
$ (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst ((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes


--------------------------------------------------------------------------------
specDefs :: FilePath -> TargetSpec -> [Def]
--------------------------------------------------------------------------------
specDefs :: [Char] -> TargetSpec -> [Def]
specDefs [Char]
srcF  = ((Var, LocSpecType) -> Def) -> [(Var, LocSpecType)] -> [Def]
forall a b. (a -> b) -> [a] -> [b]
map (Var, LocSpecType) -> Def
forall {a}. (Var, Located a) -> Def
def ([(Var, LocSpecType)] -> [Def])
-> (TargetSpec -> [(Var, LocSpecType)]) -> TargetSpec -> [Def]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Var, LocSpecType) -> Bool)
-> [(Var, LocSpecType)] -> [(Var, LocSpecType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var, LocSpecType) -> Bool
forall {a} {a}. (a, Located a) -> Bool
sameFile ([(Var, LocSpecType)] -> [(Var, LocSpecType)])
-> (TargetSpec -> [(Var, LocSpecType)])
-> TargetSpec
-> [(Var, LocSpecType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSpec -> [(Var, LocSpecType)]
specSigs
  where
    def :: (Var, Located a) -> Def
def (Var
x, Located a
t) = Int -> Int -> Var -> Def
D (Located a -> Int
forall a. Located a -> Int
line Located a
t) (Located a -> Int
forall a. Located a -> Int
lineE Located a
t) Var
x
    sameFile :: (a, Located a) -> Bool
sameFile   = ([Char]
srcF [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==) ([Char] -> Bool)
-> ((a, Located a) -> [Char]) -> (a, Located a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> [Char]
forall a. Located a -> [Char]
file (Located a -> [Char])
-> ((a, Located a) -> Located a) -> (a, Located a) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Located a) -> Located a
forall a b. (a, b) -> b
snd

specSigs :: TargetSpec -> [(Var, LocSpecType)]
specSigs :: TargetSpec -> [(Var, LocSpecType)]
specSigs TargetSpec
sp = GhcSpecSig -> [(Var, LocSpecType)]
gsTySigs  (TargetSpec -> GhcSpecSig
gsSig  TargetSpec
sp)
           [(Var, LocSpecType)]
-> [(Var, LocSpecType)] -> [(Var, LocSpecType)]
forall a. [a] -> [a] -> [a]
++ GhcSpecSig -> [(Var, LocSpecType)]
gsAsmSigs (TargetSpec -> GhcSpecSig
gsSig  TargetSpec
sp)
           [(Var, LocSpecType)]
-> [(Var, LocSpecType)] -> [(Var, LocSpecType)]
forall a. [a] -> [a] -> [a]
++ GhcSpecData -> [(Var, LocSpecType)]
gsCtors   (TargetSpec -> GhcSpecData
gsData TargetSpec
sp)

instance PPrint Def where
  pprintTidy :: Tidy -> Def -> Doc
pprintTidy Tidy
_ Def
d = [Char] -> Doc
text (Def -> [Char]
forall a. Show a => a -> [Char]
show Def
d)


--------------------------------------------------------------------------------
coreDefs     :: [CoreBind] -> [Def]
--------------------------------------------------------------------------------
coreDefs :: [CoreBind] -> [Def]
coreDefs [CoreBind]
cbs = HashMap Var (Int, Int) -> [(Var, Expr Var)] -> [Def]
coreExprDefs HashMap Var (Int, Int)
xm [(Var, Expr Var)]
xes
  where
    xes :: [(Var, Expr Var)]
xes      = [CoreBind] -> [(Var, Expr Var)]
coreVarExprs [CoreBind]
cbs
    xm :: HashMap Var (Int, Int)
xm       = [(Var, Expr Var)] -> HashMap Var (Int, Int)
varBounds [(Var, Expr Var)]
xes

coreExprDefs :: M.HashMap Var (Int, Int) -> [(Var, CoreExpr)]-> [Def]
coreExprDefs :: HashMap Var (Int, Int) -> [(Var, Expr Var)] -> [Def]
coreExprDefs HashMap Var (Int, Int)
xm [(Var, Expr Var)]
xes =
  [Def] -> [Def]
forall a. Ord a => [a] -> [a]
L.sort
    [ Int -> Int -> Var -> Def
D Int
l Int
l' Var
x
      | (Var
x, Expr Var
e) <- [(Var, Expr Var)]
xes
      , (Int
l, Int
l') <- Maybe (Int, Int) -> [(Int, Int)]
forall a. Maybe a -> [a]
maybeToList (Maybe (Int, Int) -> [(Int, Int)])
-> Maybe (Int, Int) -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ HashMap Var (Int, Int) -> (Var, Expr Var) -> Maybe (Int, Int)
coreExprDef HashMap Var (Int, Int)
xm (Var
x, Expr Var
e)
    ]

coreExprDef :: M.HashMap Var (Int, Int) -> (Var, CoreExpr) -> Maybe (Int, Int)
coreExprDef :: HashMap Var (Int, Int) -> (Var, Expr Var) -> Maybe (Int, Int)
coreExprDef HashMap Var (Int, Int)
m (Var
x, Expr Var
e) = Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)
meetSpans Maybe (Int, Int)
eSp Maybe (Int, Int)
vSp
  where
    eSp :: Maybe (Int, Int)
eSp              = Var -> SrcSpan -> Maybe (Int, Int)
forall t. t -> SrcSpan -> Maybe (Int, Int)
lineSpan Var
x (SrcSpan -> Maybe (Int, Int)) -> SrcSpan -> Maybe (Int, Int)
forall a b. (a -> b) -> a -> b
$ Var -> [SrcSpan] -> SrcSpan
catSpans Var
x ([SrcSpan] -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Expr Var -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr Var
e
    vSp :: Maybe (Int, Int)
vSp              = Var -> HashMap Var (Int, Int) -> Maybe (Int, Int)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Var
x HashMap Var (Int, Int)
m
    -- vSp   = lineSpan x (getSrcSpan x)

coreVarExprs :: [CoreBind] -> [(Var, CoreExpr)]
coreVarExprs :: [CoreBind] -> [(Var, Expr Var)]
coreVarExprs = ((Var, Expr Var) -> Bool) -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var, Expr Var) -> Bool
forall {b}. (Var, b) -> Bool
ok ([(Var, Expr Var)] -> [(Var, Expr Var)])
-> ([CoreBind] -> [(Var, Expr Var)])
-> [CoreBind]
-> [(Var, Expr Var)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBind -> [(Var, Expr Var)]) -> [CoreBind] -> [(Var, Expr Var)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CoreBind -> [(Var, Expr Var)]
forall a. Bind a -> [(a, Expr a)]
varExprs
  where
    ok :: (Var, b) -> Bool
ok       = SrcSpan -> Bool
isGoodSrcSpan (SrcSpan -> Bool) -> ((Var, b) -> SrcSpan) -> (Var, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (Var -> SrcSpan) -> ((Var, b) -> Var) -> (Var, b) -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, b) -> Var
forall a b. (a, b) -> a
fst

varExprs :: Bind a -> [(a, Expr a)]
varExprs :: forall a. Bind a -> [(a, Expr a)]
varExprs (NonRec a
x Expr a
e) = [(a
x, Expr a
e)]
varExprs (Rec [(a, Expr a)]
xes)    = [(a, Expr a)]
xes

-- | varBounds computes upper and lower bounds on where each top-level binder's
--   definition can be by using ONLY the lines where the binder is defined.
varBounds :: [(Var, CoreExpr)] -> M.HashMap Var (Int, Int)
varBounds :: [(Var, Expr Var)] -> HashMap Var (Int, Int)
varBounds = [(Var, (Int, Int))] -> HashMap Var (Int, Int)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Var, (Int, Int))] -> HashMap Var (Int, Int))
-> ([(Var, Expr Var)] -> [(Var, (Int, Int))])
-> [(Var, Expr Var)]
-> HashMap Var (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Var)] -> [(Var, (Int, Int))]
defBounds ([(Int, Var)] -> [(Var, (Int, Int))])
-> ([(Var, Expr Var)] -> [(Int, Var)])
-> [(Var, Expr Var)]
-> [(Var, (Int, Int))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Var, Expr Var)] -> [(Int, Var)]
varDefs

varDefs :: [(Var, CoreExpr)] -> [(Int, Var)]
varDefs :: [(Var, Expr Var)] -> [(Int, Var)]
varDefs [(Var, Expr Var)]
xes =
  [(Int, Var)] -> [(Int, Var)]
forall a. Ord a => [a] -> [a]
L.sort [ (Int
l, Var
x) | (Var
x,Expr Var
_) <- [(Var, Expr Var)]
xes, let Just (Int
l, Int
_) = Var -> SrcSpan -> Maybe (Int, Int)
forall t. t -> SrcSpan -> Maybe (Int, Int)
lineSpan Var
x (Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Var
x) ]

defBounds :: [(Int, Var)] -> [(Var, (Int, Int) )]
defBounds :: [(Int, Var)] -> [(Var, (Int, Int))]
defBounds ((Int
l, Var
x) : lxs :: [(Int, Var)]
lxs@((Int
l', Var
_) : [(Int, Var)]
_ )) = (Var
x, (Int
l, Int
l' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Var, (Int, Int)) -> [(Var, (Int, Int))] -> [(Var, (Int, Int))]
forall a. a -> [a] -> [a]
: [(Int, Var)] -> [(Var, (Int, Int))]
defBounds [(Int, Var)]
lxs
defBounds [(Int, Var)]
_                             = []

{-
--------------------------------------------------------------------------------
coreDefs     :: [CoreBind] -> [Def]
--------------------------------------------------------------------------------
coreDefs cbs = tracepp "coreDefs" $
               L.sort [D l l' x | b <- cbs
                                , x <- bindersOf b
                                , isGoodSrcSpan (getSrcSpan x)
                                , (l, l') <- coreDef b]

coreDef :: CoreBind -> [(Int, Int)]
coreDef b
  | True  = tracepp ("coreDef: " ++ showpp (vs, vSp)) $ maybeToList vSp
  | False = tracepp ("coreDef: " ++ showpp (b, eSp, vSp)) $ meetSpans b eSp vSp
  where
    eSp   = lineSpan b $ catSpans b $ bindSpans b
    vSp   = lineSpan b $ catSpans b $ getSrcSpan <$> vs
    vs    = bindersOf b

meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)
meetSpans Nothing       _
  = Nothing
meetSpans (Just (l,l')) Nothing
  = Just (l, l')
meetSpans (Just (l,l')) (Just (m,_))
  = Just (max l m, l')
-}
--------------------------------------------------------------------------------
-- | `meetSpans` cuts off the start-line to be no less than the line at which
--   the binder is defined. Without this, i.e. if we ONLY use the ticks and
--   spans appearing inside the definition of the binder (i.e. just `eSp`)
--   then the generated span can be WAY before the actual definition binder,
--   possibly due to GHC INLINE pragmas or dictionaries OR ...
--   for an example: see the "INCCHECK: Def" generated by
--      liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs
--   where `spanEnd` is a single line function around 1092 but where
--   the generated span starts mysteriously at 222 where Data.List is imported.

meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)
meetSpans :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)
meetSpans Maybe (Int, Int)
Nothing       Maybe (Int, Int)
_
  = Maybe (Int, Int)
forall a. Maybe a
Nothing
meetSpans (Just (Int
l,Int
l')) Maybe (Int, Int)
Nothing
  = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
l, Int
l')
meetSpans (Just (Int
l,Int
l')) (Just (Int
m, Int
m'))
  = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
l Int
m, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
l' Int
m')

-- spanLower :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)
-- spanLower Nothing        _        = Nothing
-- spanLower sp             Nothing  = sp
-- spanLower (Just (l, l')) (Just m) = Just (max l m, l')

-- spanUpper :: Maybe (Int, Int) -> Maybe Int -> Maybe (Int, Int)
-- spanUpper Nothing        _        = Nothing
-- spanUpper sp             Nothing  = sp
-- spanUpper (Just (l, l')) (Just m) = Just (l, min l' m)



lineSpan :: t -> SrcSpan -> Maybe (Int, Int)
lineSpan :: forall t. t -> SrcSpan -> Maybe (Int, Int)
lineSpan t
_ (RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_) = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
sp, RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
sp)
lineSpan t
_ SrcSpan
_                  = Maybe (Int, Int)
forall a. Maybe a
Nothing

catSpans :: Var -> [SrcSpan] -> SrcSpan
catSpans :: Var -> [SrcSpan] -> SrcSpan
catSpans Var
b []               = Maybe SrcSpan -> [Char] -> SrcSpan
forall a. HasCallStack => Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing ([Char] -> SrcSpan) -> [Char] -> SrcSpan
forall a b. (a -> b) -> a -> b
$ [Char]
"DIFFCHECK: catSpans: no spans found for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Var -> [Char]
forall a. Outputable a => a -> [Char]
showPpr Var
b
catSpans Var
b [SrcSpan]
xs               = (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
noSrcSpan [SrcSpan
x | x :: SrcSpan
x@(RealSrcSpan RealSrcSpan
z Maybe BufSpan
_) <- [SrcSpan]
xs, Var -> FastString
forall a. (Outputable a, NamedThing a) => a -> FastString
varFile Var
b FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
z]

-- bindFile
--   :: (Outputable r, NamedThing r) =>
--      Bind r -> FastString
-- bindFile (NonRec x _) = varFile x
-- bindFile (Rec xes)    = varFile $ fst $ head xes

varFile :: (Outputable a, NamedThing a) => a -> FastString
varFile :: forall a. (Outputable a, NamedThing a) => a -> FastString
varFile a
b = case a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
b of
              RealSrcSpan RealSrcSpan
z Maybe BufSpan
_ -> RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
z
              SrcSpan
_               -> Maybe SrcSpan -> [Char] -> FastString
forall a. HasCallStack => Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing ([Char] -> FastString) -> [Char] -> FastString
forall a b. (a -> b) -> a -> b
$ [Char]
"DIFFCHECK: getFile: no file found for: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Outputable a => a -> [Char]
showPpr a
b


bindSpans :: NamedThing a => Bind a -> [SrcSpan]
bindSpans :: forall a. NamedThing a => Bind a -> [SrcSpan]
bindSpans (NonRec a
x Expr a
e)    = a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
bindSpans (Rec    [(a, Expr a)]
xes)    = (a -> SrcSpan) -> [a] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan [a]
xs [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (Expr a -> [SrcSpan]) -> [Expr a] -> [SrcSpan]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans [Expr a]
es
  where
    ([a]
xs, [Expr a]
es)              = [(a, Expr a)] -> ([a], [Expr a])
forall a b. [(a, b)] -> ([a], [b])
unzip [(a, Expr a)]
xes

exprSpans :: NamedThing a => Expr a -> [SrcSpan]
exprSpans :: forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans (Tick CoreTickish
t Expr a
e)
  | SrcSpan -> Bool
isJunkSpan SrcSpan
sp         = Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
  | Bool
otherwise             = [SrcSpan
sp]
  where
    sp :: SrcSpan
sp                    = CoreTickish -> SrcSpan
tickSrcSpan CoreTickish
t

exprSpans (Var Var
x)         = [Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Var
x]
exprSpans (Lam a
x Expr a
e)       = a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (App Expr a
e Expr a
a)       = Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
a
exprSpans (Let Bind a
b Expr a
e)       = Bind a -> [SrcSpan]
forall a. NamedThing a => Bind a -> [SrcSpan]
bindSpans Bind a
b [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (Cast Expr a
e CoercionR
_)      = Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (Case Expr a
e a
x Type
_ [Alt a]
cs) = a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x SrcSpan -> [SrcSpan] -> [SrcSpan]
forall a. a -> [a] -> [a]
: Expr a -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (Alt a -> [SrcSpan]) -> [Alt a] -> [SrcSpan]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Alt a -> [SrcSpan]
forall b. NamedThing b => Alt b -> [SrcSpan]
altSpans [Alt a]
cs
exprSpans Expr a
_               = []

altSpans :: (NamedThing b) => Alt b -> [SrcSpan]
altSpans :: forall b. NamedThing b => Alt b -> [SrcSpan]
altSpans (Alt AltCon
_ [b]
xs Expr b
e)     = (b -> SrcSpan) -> [b] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map b -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan [b]
xs [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ Expr b -> [SrcSpan]
forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr b
e

isJunkSpan :: SrcSpan -> Bool
isJunkSpan :: SrcSpan -> Bool
isJunkSpan RealSrcSpan{} = Bool
False
isJunkSpan SrcSpan
_             = Bool
True

--------------------------------------------------------------------------------
-- | Diff Interface ------------------------------------------------------------
--------------------------------------------------------------------------------
-- | `lineDiff new old` compares the contents of `src` with `dst`
--   and returns the lines of `src` that are different.
--------------------------------------------------------------------------------
lineDiff :: FilePath -> FilePath -> IO ([Int], LMap)
--------------------------------------------------------------------------------
lineDiff :: [Char] -> [Char] -> IO ([Int], LMap)
lineDiff [Char]
new [Char]
old  = [[Char]] -> [[Char]] -> ([Int], LMap)
lineDiff' ([[Char]] -> [[Char]] -> ([Int], LMap))
-> IO [[Char]] -> IO ([[Char]] -> ([Int], LMap))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getLines [Char]
new IO ([[Char]] -> ([Int], LMap)) -> IO [[Char]] -> IO ([Int], LMap)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [[Char]]
getLines [Char]
old
  where
    getLines :: [Char] -> IO [[Char]]
getLines      = ([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [[Char]]
lines (IO [Char] -> IO [[Char]])
-> ([Char] -> IO [Char]) -> [Char] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [Char]
readFile

lineDiff' :: [String] -> [String] -> ([Int], LMap)
lineDiff' :: [[Char]] -> [[Char]] -> ([Int], LMap)
lineDiff' [[Char]]
new [[Char]]
old = ([Int]
changedLines, LMap
lm)
  where
    changedLines :: [Int]
changedLines  = Int -> [Diff Int] -> [Int]
diffLines Int
1 [Diff Int]
diffLineCount
    lm :: LMap
lm            = ((Int, Int, Int) -> LMap -> LMap)
-> LMap -> [(Int, Int, Int)] -> LMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int, Int) -> LMap -> LMap
setShift LMap
forall v a. Ord v => IntervalMap v a
IM.empty ([(Int, Int, Int)] -> LMap) -> [(Int, Int, Int)] -> LMap
forall a b. (a -> b) -> a -> b
$ [Diff Int] -> [(Int, Int, Int)]
diffShifts [Diff Int]
diffLineCount
    diffLineCount :: [Diff Int]
diffLineCount = ([[Char]] -> Int) -> Diff [[Char]] -> Diff Int
forall a b. (a -> b) -> Diff a -> Diff b
diffMap [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Diff [[Char]] -> Diff Int) -> [Diff [[Char]]] -> [Diff Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> [[Char]] -> [Diff [[Char]]]
forall a. Eq a => [a] -> [a] -> [Diff [a]]
getGroupedDiff [[Char]]
new [[Char]]
old

diffMap :: (a -> b) -> Diff a -> Diff b
diffMap :: forall a b. (a -> b) -> Diff a -> Diff b
diffMap a -> b
f (First a
x)  = b -> PolyDiff b b
forall a b. a -> PolyDiff a b
First (a -> b
f a
x)
diffMap a -> b
f (Second a
x) = b -> PolyDiff b b
forall a b. b -> PolyDiff a b
Second (a -> b
f a
x)
diffMap a -> b
f (Both a
x a
y) = b -> b -> PolyDiff b b
forall a b. a -> b -> PolyDiff a b
Both (a -> b
f a
x) (a -> b
f a
y)

-- | Identifies lines that have changed
diffLines :: Int        -- ^ Starting line
          -> [Diff Int] -- ^ List of lengths of diffs
          -> [Int]      -- ^ List of changed line numbers
diffLines :: Int -> [Diff Int] -> [Int]
diffLines Int
_ []                        = []
diffLines Int
curr (Both Int
lnsUnchgd Int
_ : [Diff Int]
d) = Int -> [Diff Int] -> [Int]
diffLines Int
toSkip [Diff Int]
d
   where toSkip :: Int
toSkip = Int
curr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lnsUnchgd
diffLines Int
curr (First Int
lnsChgd : [Diff Int]
d)    = [Int
curr..(Int
toTakeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Diff Int] -> [Int]
diffLines Int
toTake [Diff Int]
d
   where toTake :: Int
toTake = Int
curr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lnsChgd
diffLines Int
curr (Diff Int
_ : [Diff Int]
d)                = Int -> [Diff Int] -> [Int]
diffLines Int
curr [Diff Int]
d

diffShifts :: [Diff Int] -> [(Int, Int, Int)]
diffShifts :: [Diff Int] -> [(Int, Int, Int)]
diffShifts = Int -> Int -> [Diff Int] -> [(Int, Int, Int)]
forall {t}. Num t => t -> t -> [PolyDiff t t] -> [(t, t, t)]
go Int
1 Int
1
  where
    go :: t -> t -> [PolyDiff t t] -> [(t, t, t)]
go t
old t
new (Both t
n t
_ : [PolyDiff t t]
d) = (t
old, t
old t -> t -> t
forall a. Num a => a -> a -> a
+ t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1, t
new t -> t -> t
forall a. Num a => a -> a -> a
- t
old) (t, t, t) -> [(t, t, t)] -> [(t, t, t)]
forall a. a -> [a] -> [a]
: t -> t -> [PolyDiff t t] -> [(t, t, t)]
go (t
old t -> t -> t
forall a. Num a => a -> a -> a
+ t
n)
                                                                   (t
new t -> t -> t
forall a. Num a => a -> a -> a
+ t
n)
                                                                   [PolyDiff t t]
d
    go t
old t
new (Second t
n : [PolyDiff t t]
d) = t -> t -> [PolyDiff t t] -> [(t, t, t)]
go (t
old t -> t -> t
forall a. Num a => a -> a -> a
+ t
n) t
new [PolyDiff t t]
d
    go t
old t
new (First t
n  : [PolyDiff t t]
d) = t -> t -> [PolyDiff t t] -> [(t, t, t)]
go t
old (t
new t -> t -> t
forall a. Num a => a -> a -> a
+ t
n) [PolyDiff t t]
d
    go t
_   t
_   []             = []


-- | @save@ creates an .saved version of the @target@ file, which will be
--    used to find what has changed the /next time/ @target@ is checked.
--------------------------------------------------------------------------------
saveResult :: FilePath -> Output Doc -> IO ()
--------------------------------------------------------------------------------
saveResult :: [Char] -> Output Doc -> IO ()
saveResult [Char]
target Output Doc
res = do
  [Char] -> [Char] -> IO ()
copyFile [Char]
target [Char]
saveF
  [Char] -> ByteString -> IO ()
B.writeFile [Char]
errF (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LB.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Output Doc -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode Output Doc
res
  where
    saveF :: [Char]
saveF = Ext -> ShowS
extFileName Ext
Saved  [Char]
target
    errF :: [Char]
errF  = Ext -> ShowS
extFileName Ext
Cache  [Char]
target

--------------------------------------------------------------------------------
loadResult   :: FilePath -> IO (Output Doc)
--------------------------------------------------------------------------------
loadResult :: [Char] -> IO (Output Doc)
loadResult [Char]
f = do
  ex <- [Char] -> IO Bool
doesFileExist [Char]
jsonF
  if ex
    then convert <$> B.readFile jsonF
    else return mempty
  where
    convert :: ByteString -> Output Doc
convert  = Output Doc -> Maybe (Output Doc) -> Output Doc
forall a. a -> Maybe a -> a
fromMaybe Output Doc
forall a. Monoid a => a
mempty (Maybe (Output Doc) -> Output Doc)
-> (ByteString -> Maybe (Output Doc)) -> ByteString -> Output Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> Maybe (Output Doc)
forall a. FromJSON a => LazyByteString -> Maybe a
decode (LazyByteString -> Maybe (Output Doc))
-> (ByteString -> LazyByteString)
-> ByteString
-> Maybe (Output Doc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LazyByteString
LB.fromStrict
    jsonF :: [Char]
jsonF    = Ext -> ShowS
extFileName Ext
Cache [Char]
f

--------------------------------------------------------------------------------
adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc
--------------------------------------------------------------------------------
adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc
adjustOutput LMap
lm ChkItv
cm Output Doc
o  = Output Doc
forall a. Monoid a => a
mempty { o_types  = adjustTypes  lm cm (o_types  o) }
                               { o_result = adjustResult lm cm (o_result o) }

adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a
adjustTypes :: forall a. LMap -> ChkItv -> AnnInfo a -> AnnInfo a
adjustTypes LMap
lm ChkItv
cm (AI HashMap SrcSpan [(Maybe Text, a)]
m)          = HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI (HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a)
-> HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
forall a b. (a -> b) -> a -> b
$ if Bool
True then HashMap SrcSpan [(Maybe Text, a)]
forall a. Monoid a => a
mempty else [(SrcSpan, [(Maybe Text, a)])] -> HashMap SrcSpan [(Maybe Text, a)]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList -- FIXME PLEASE
                                    [(SrcSpan
sp', [(Maybe Text, a)]
v) | (SrcSpan
sp, [(Maybe Text, a)]
v)  <- HashMap SrcSpan [(Maybe Text, a)] -> [(SrcSpan, [(Maybe Text, a)])]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap SrcSpan [(Maybe Text, a)]
m
                                              , Just SrcSpan
sp' <- [LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
adjustSrcSpan LMap
lm ChkItv
cm SrcSpan
sp]]

adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult
adjustResult :: LMap -> ChkItv -> ErrorResult -> ErrorResult
adjustResult LMap
lm ChkItv
cm (Unsafe Stats
s [TError Doc]
es)  = ([TError Doc] -> ErrorResult) -> [TError Doc] -> ErrorResult
forall a b. ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult (Stats -> [TError Doc] -> ErrorResult
forall a. Stats -> [a] -> FixResult a
Unsafe Stats
s)  ([TError Doc] -> ErrorResult) -> [TError Doc] -> ErrorResult
forall a b. (a -> b) -> a -> b
$ (TError Doc -> Maybe (TError Doc)) -> [TError Doc] -> [TError Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LMap -> ChkItv -> TError Doc -> Maybe (TError Doc)
forall a.
PPrint (TError a) =>
LMap -> ChkItv -> TError a -> Maybe (TError a)
adjustError  LMap
lm ChkItv
cm) [TError Doc]
es
adjustResult LMap
lm ChkItv
cm (Crash [(TError Doc, Maybe [Char])]
es [Char]
z)   = ([(TError Doc, Maybe [Char])] -> ErrorResult)
-> [(TError Doc, Maybe [Char])] -> ErrorResult
forall a b. ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult ([(TError Doc, Maybe [Char])] -> [Char] -> ErrorResult
forall a. [(a, Maybe [Char])] -> [Char] -> FixResult a
`Crash` [Char]
z) ([(TError Doc, Maybe [Char])] -> ErrorResult)
-> [(TError Doc, Maybe [Char])] -> ErrorResult
forall a b. (a -> b) -> a -> b
$ (, Maybe [Char]
forall a. Maybe a
Nothing) (TError Doc -> (TError Doc, Maybe [Char]))
-> [TError Doc] -> [(TError Doc, Maybe [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>((TError Doc, Maybe [Char]) -> Maybe (TError Doc))
-> [(TError Doc, Maybe [Char])] -> [TError Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LMap -> ChkItv -> TError Doc -> Maybe (TError Doc)
forall a.
PPrint (TError a) =>
LMap -> ChkItv -> TError a -> Maybe (TError a)
adjustError LMap
lm ChkItv
cm (TError Doc -> Maybe (TError Doc))
-> ((TError Doc, Maybe [Char]) -> TError Doc)
-> (TError Doc, Maybe [Char])
-> Maybe (TError Doc)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TError Doc, Maybe [Char]) -> TError Doc
forall a b. (a, b) -> a
fst) [(TError Doc, Maybe [Char])]
es
adjustResult LMap
_  ChkItv
_  ErrorResult
r              = ErrorResult
r

errorsResult :: ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult :: forall a b. ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult [a] -> FixResult b
_ []                 = Stats -> FixResult b
forall a. Stats -> FixResult a
Safe Stats
forall a. Monoid a => a
mempty
errorsResult [a] -> FixResult b
f [a]
es                 = [a] -> FixResult b
f [a]
es

adjustError :: (PPrint (TError a)) => LMap -> ChkItv -> TError a -> Maybe (TError a)
adjustError :: forall a.
PPrint (TError a) =>
LMap -> ChkItv -> TError a -> Maybe (TError a)
adjustError LMap
lm ChkItv
cm TError a
e = case LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
adjustSrcSpan LMap
lm ChkItv
cm (TError a -> SrcSpan
forall t. TError t -> SrcSpan
pos TError a
e) of
  Just SrcSpan
sp' -> TError a -> Maybe (TError a)
forall a. a -> Maybe a
Just (TError a
e {pos = sp'})
  Maybe SrcSpan
Nothing  -> Maybe (TError a)
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
--------------------------------------------------------------------------------
adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan
adjustSrcSpan LMap
lm ChkItv
cm SrcSpan
sp
  = do sp' <- LMap -> SrcSpan -> Maybe SrcSpan
adjustSpan LMap
lm SrcSpan
sp
       if isCheckedSpan cm sp'
         then Nothing
         else Just sp'

isCheckedSpan :: IM.IntervalMap Int a -> SrcSpan -> Bool
isCheckedSpan :: forall a. IntervalMap Int a -> SrcSpan -> Bool
isCheckedSpan IntervalMap Int a
cm (RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_) = IntervalMap Int a -> RealSrcSpan -> Bool
forall a. IntervalMap Int a -> RealSrcSpan -> Bool
isCheckedRealSpan IntervalMap Int a
cm RealSrcSpan
sp
isCheckedSpan IntervalMap Int a
_  SrcSpan
_                  = Bool
False

isCheckedRealSpan :: IM.IntervalMap Int a -> RealSrcSpan -> Bool
isCheckedRealSpan :: forall a. IntervalMap Int a -> RealSrcSpan -> Bool
isCheckedRealSpan IntervalMap Int a
cm              = Bool -> Bool
not (Bool -> Bool) -> (RealSrcSpan -> Bool) -> RealSrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Interval Int, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Interval Int, a)] -> Bool)
-> (RealSrcSpan -> [(Interval Int, a)]) -> RealSrcSpan -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntervalMap Int a -> [(Interval Int, a)]
forall v a. Ord v => v -> IntervalMap v a -> [(Interval v, a)]
`IM.search` IntervalMap Int a
cm) (Int -> [(Interval Int, a)])
-> (RealSrcSpan -> Int) -> RealSrcSpan -> [(Interval Int, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> Int
srcSpanStartLine

adjustSpan :: LMap -> SrcSpan -> Maybe SrcSpan
adjustSpan :: LMap -> SrcSpan -> Maybe SrcSpan
adjustSpan LMap
lm (RealSrcSpan RealSrcSpan
rsp Maybe BufSpan
_) = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan)
-> Maybe RealSrcSpan -> Maybe (Maybe BufSpan -> SrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LMap -> RealSrcSpan -> Maybe RealSrcSpan
adjustReal LMap
lm RealSrcSpan
rsp Maybe (Maybe BufSpan -> SrcSpan)
-> Maybe (Maybe BufSpan) -> Maybe SrcSpan
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe BufSpan -> Maybe (Maybe BufSpan)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BufSpan
forall a. Maybe a
strictNothing
adjustSpan LMap
_  SrcSpan
sp                  = SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just SrcSpan
sp

adjustReal :: LMap -> RealSrcSpan -> Maybe RealSrcSpan
adjustReal :: LMap -> RealSrcSpan -> Maybe RealSrcSpan
adjustReal LMap
lm RealSrcSpan
rsp
  | Just Int
δ <- Maybe Int
sh                  = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just (RealSrcSpan -> Maybe RealSrcSpan)
-> RealSrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Int -> Int -> Int -> RealSrcSpan
packRealSrcSpan [Char]
f (Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
δ) Int
c1 (Int
l2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
δ) Int
c2
  | Bool
otherwise                     = Maybe RealSrcSpan
forall a. Maybe a
Nothing
  where
    ([Char]
f, Int
l1, Int
c1, Int
l2, Int
c2)           = RealSrcSpan -> ([Char], Int, Int, Int, Int)
unpackRealSrcSpan RealSrcSpan
rsp
    sh :: Maybe Int
sh                            = Int -> LMap -> Maybe Int
getShift Int
l1 LMap
lm


-- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@
-- in the diff and returns @Nothing@ otherwise.
getShift     :: Int -> LMap -> Maybe Int
getShift :: Int -> LMap -> Maybe Int
getShift Int
old = ((Interval Int, Int) -> Int)
-> Maybe (Interval Int, Int) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Interval Int, Int) -> Int
forall a b. (a, b) -> b
snd (Maybe (Interval Int, Int) -> Maybe Int)
-> (LMap -> Maybe (Interval Int, Int)) -> LMap -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Interval Int, Int)] -> Maybe (Interval Int, Int)
forall a. [a] -> Maybe a
listToMaybe ([(Interval Int, Int)] -> Maybe (Interval Int, Int))
-> (LMap -> [(Interval Int, Int)])
-> LMap
-> Maybe (Interval Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LMap -> [(Interval Int, Int)]
forall v a. Ord v => v -> IntervalMap v a -> [(Interval v, a)]
IM.search Int
old

-- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately
setShift             :: (Int, Int, Int) -> LMap -> LMap
setShift :: (Int, Int, Int) -> LMap -> LMap
setShift (Int
l1, Int
l2, Int
δ) = Interval Int -> Int -> LMap -> LMap
forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
IM.insert (Int -> Int -> Interval Int
forall v. v -> v -> Interval v
IM.Interval Int
l1 Int
l2) Int
δ


checkedItv :: [Def] -> ChkItv
checkedItv :: [Def] -> ChkItv
checkedItv [Def]
chDefs = (Interval Int -> ChkItv -> ChkItv)
-> ChkItv -> [Interval Int] -> ChkItv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Interval Int -> () -> ChkItv -> ChkItv
forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
`IM.insert` ()) ChkItv
forall v a. Ord v => IntervalMap v a
IM.empty [Interval Int]
is
  where
    is :: [Interval Int]
is            = [Int -> Int -> Interval Int
forall v. v -> v -> Interval v
IM.Interval Int
l1 Int
l2 | D Int
l1 Int
l2 Var
_ <- [Def]
chDefs]


--------------------------------------------------------------------------------
-- | Aeson instances -----------------------------------------------------------
--------------------------------------------------------------------------------

instance FromJSON ErrorResult

instance ToJSON Doc where
  toJSON :: Doc -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Doc -> Text) -> Doc -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> Text) -> (Doc -> [Char]) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Char]
render

instance FromJSON Doc where
  parseJSON :: Value -> Parser Doc
parseJSON (String Text
s) = Doc -> Parser Doc
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> Parser Doc) -> Doc -> Parser Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
s
  parseJSON Value
_          = Parser Doc
forall a. Monoid a => a
mempty

instance ToJSON a => ToJSON (AnnInfo a) where
  toJSON :: AnnInfo a -> Value
toJSON = Options -> AnnInfo a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
  toEncoding :: AnnInfo a -> Encoding
toEncoding = Options -> AnnInfo a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions
instance FromJSON a => FromJSON (AnnInfo a)

instance ToJSON (Output Doc) where
  toJSON :: Output Doc -> Value
toJSON = Options -> Output Doc -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
  toEncoding :: Output Doc -> Encoding
toEncoding = Options -> Output Doc -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions
instance FromJSON (Output Doc) where
  parseJSON :: Value -> Parser (Output Doc)
parseJSON = Options -> Value -> Parser (Output Doc)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions

file :: Located a -> FilePath
file :: forall a. Located a -> [Char]
file = SourcePos -> [Char]
sourceName (SourcePos -> [Char])
-> (Located a -> SourcePos) -> Located a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> SourcePos
forall a. Located a -> SourcePos
loc

line :: Located a -> Int
line :: forall a. Located a -> Int
line  = Pos -> Int
unPos (Pos -> Int) -> (Located a -> Pos) -> Located a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine (SourcePos -> Pos) -> (Located a -> SourcePos) -> Located a -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> SourcePos
forall a. Located a -> SourcePos
loc

lineE :: Located a -> Int
lineE :: forall a. Located a -> Int
lineE = Pos -> Int
unPos (Pos -> Int) -> (Located a -> Pos) -> Located a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
sourceLine (SourcePos -> Pos) -> (Located a -> SourcePos) -> Located a -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> SourcePos
forall a. Located a -> SourcePos
locE