-- | 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(..), safeSourcePos, 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
                                                                      , 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          hiding (Def, LMap)

--------------------------------------------------------------------------------
-- | 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 = forall a. PPrint a => Tidy -> a -> Doc
pprintTidy Tidy
k (DiffCheck -> [Var]
checkedVars DiffCheck
dc) forall a. Semigroup a => a -> a -> a
<> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Def -> Def -> Bool
$c/= :: Def -> Def -> Bool
== :: Def -> Def -> Bool
$c== :: Def -> Def -> Bool
Eq, Eq 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
min :: Def -> Def -> Def
$cmin :: Def -> Def -> Def
max :: Def -> Def -> Def
$cmax :: Def -> Def -> Def
>= :: Def -> Def -> Bool
$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
compare :: Def -> Def -> Ordering
$ccompare :: Def -> Def -> Ordering
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 -> String
show (D Int
i Int
j Var
x) = forall a. Outputable a => a -> String
showPpr Var
x forall a. [a] -> [a] -> [a]
++ String
" start: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
" end: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
j

--------------------------------------------------------------------------------
-- | `checkedNames` returns the names of the top-level binders that will be checked
--------------------------------------------------------------------------------
checkedVars              ::  DiffCheck -> [Var]
checkedVars :: DiffCheck -> [Var]
checkedVars              = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Bind a -> [a]
names 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)      = forall a b. (a, b) -> a
fst 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 :: String -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
slice String
target [CoreBind]
cbs TargetSpec
sp = do
  Bool
ex <- String -> IO Bool
doesFileExist String
savedFile
  if Bool
ex
    then IO (Maybe DiffCheck)
doDiffCheck
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    savedFile :: String
savedFile       = Ext -> ShowS
extFileName Ext
Saved String
target
    doDiffCheck :: IO (Maybe DiffCheck)
doDiffCheck     = String
-> String -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved String
target String
savedFile [CoreBind]
cbs TargetSpec
sp

sliceSaved :: FilePath -> FilePath -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved :: String
-> String -> [CoreBind] -> TargetSpec -> IO (Maybe DiffCheck)
sliceSaved String
target String
savedFile [CoreBind]
coreBinds TargetSpec
spec = do
  ([Int]
is, LMap
lm) <- String -> String -> IO ([Int], LMap)
lineDiff String
target String
savedFile
  Output Doc
result   <- String -> IO (Output Doc)
loadResult String
target
  forall (m :: * -> *) a. Monad m => a -> m a
return    forall a b. (a -> b) -> a -> b
$ String -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
sliceSaved' String
target [Int]
is LMap
lm ([CoreBind] -> Output Doc -> TargetSpec -> DiffCheck
DC [CoreBind]
coreBinds Output Doc
result TargetSpec
spec)

sliceSaved' :: FilePath -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
sliceSaved' :: String -> [Int] -> LMap -> DiffCheck -> Maybe DiffCheck
sliceSaved' String
srcF [Int]
is LMap
lm (DC [CoreBind]
coreBinds Output Doc
result TargetSpec
spec)
  | Bool
gDiff     = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [CoreBind] -> Output Doc -> TargetSpec -> DiffCheck
DC [CoreBind]
cbs' Output Doc
res' TargetSpec
sp'
  where
    gDiff :: Bool
gDiff     = String -> [Int] -> TargetSpec -> Bool
globalDiff String
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 forall a. [a] -> [a] -> [a]
++ String -> TargetSpec -> [Def]
specDefs String
srcF TargetSpec
spec
    sigs :: HashSet Var
sigs      = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
M.keys HashMap Var LocSpecType
sigm
    sigm :: HashMap Var LocSpecType
sigm      = String -> [Int] -> TargetSpec -> HashMap Var LocSpecType
sigVars String
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 :: GhcSpecSig
gsSig = GhcSpecSig
gsig { gsAsmSigs :: [(Var, LocSpecType)]
gsAsmSigs = forall k v. HashMap k v -> [(k, v)]
M.toList forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
M.union HashMap Var LocSpecType
sigm HashMap Var LocSpecType
assm } }
  where
    assm :: HashMap Var LocSpecType
assm           = 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 (forall a. Ord a => [a] -> [a]
L.sort [Int]
ls) [Def]
defs
  where
    defs :: [Def]
defs             = 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 forall a. Ord a => a -> a -> Bool
< Def -> Int
start Def
d  = [Int] -> [Def] -> [Var]
go [Int]
is (Def
dforall a. a -> [a] -> [a]
:[Def]
ds)
      | Int
i forall a. Ord a => a -> a -> Bool
> Def -> Int
end Def
d    = [Int] -> [Def] -> [Var]
go (Int
iforall a. a -> [a] -> [a]
:[Int]
is) [Def]
ds
      | Bool
otherwise    = Def -> Var
binder Def
d forall a. a -> [a] -> [a]
: [Int] -> [Def] -> [Var]
go (Int
iforall a. a -> [a] -> [a]
:[Int]
is) [Def]
ds

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

globalDiff :: FilePath -> [Int] -> TargetSpec -> Bool
globalDiff :: String -> [Int] -> TargetSpec -> Bool
globalDiff String
srcF [Int]
ls TargetSpec
gspec = Bool
measDiff Bool -> Bool -> Bool
|| Bool
invsDiff Bool -> Bool -> Bool
|| Bool
dconsDiff
  where
    measDiff :: Bool
measDiff  = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. String -> [Int] -> Located a -> Bool
isDiff String
srcF [Int]
ls) (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSpecData -> [(Symbol, LocSpecType)]
gsMeas GhcSpecData
spec)
    invsDiff :: Bool
invsDiff  = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. String -> [Int] -> Located a -> Bool
isDiff String
srcF [Int]
ls) (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSpecData -> [(Maybe Var, LocSpecType)]
gsInvariants GhcSpecData
spec)
    dconsDiff :: Bool
dconsDiff = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. String -> [Int] -> Located a -> Bool
isDiff String
srcF [Int]
ls) [ 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. String -> [Int] -> Located a -> Bool
isDiff String
srcF [Int]
ls Located a
x = forall a. Located a -> String
file Located a
x forall a. Eq a => a -> a -> Bool
== String
srcF Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Int -> Bool
hits [Int]
ls
  where
    hits :: Int -> Bool
hits Int
i       = forall a. Located a -> Int
line Located a
x forall a. Ord a => a -> a -> Bool
<= Int
i Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
<= 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') 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 (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'      = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
M.delete (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         = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst 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 (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 = forall a b.
(Eq a, Eq b, Hashable a, Hashable b) =>
[(a, b)] -> HashMap a (HashSet b)
mkGraph forall a b. (a -> b) -> a -> b
$ [(Var, Var)]
calls forall a. [a] -> [a] -> [a]
++ [(Var, Var)]
calls'
  where
    calls :: [(Var, Var)]
calls   = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 <- forall {a}. Bind a -> [a]
bindersOf Bind a
b
                      , Var
y <- forall a. CBVisitable a => HashSet Var -> a -> [Var]
freeVars forall a. HashSet a
S.empty Bind a
b
                      , forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Var
y HashSet Var
defVars
              ]
    defVars :: HashSet Var
defVars = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (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  = forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList [Var]
results
  where
    preds :: [HashSet Var -> Bool]
preds          = forall a b. (a -> b) -> [a] -> [b]
map forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member [Var]
vars
    filteredMaps :: [Deps]
filteredMaps   = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
M.filter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HashSet Var -> Bool]
preds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Deps
cg
    results :: [Var]
results        = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
M.toList forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable 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 forall a. HashSet a
S.empty
  where
    next :: HashSet Var -> HashSet Var
next            = forall a. (Eq a, Hashable a) => [HashSet a] -> HashSet a
S.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Var -> HashSet Var
deps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
S.toList
    deps :: Var -> HashSet Var
deps Var
x          = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault forall a. HashSet a
S.empty Var
x Deps
d
    go :: HashSet Var -> HashSet Var -> HashSet Var
go HashSet Var
seen HashSet Var
new
      | forall a. HashSet a -> Bool
S.null HashSet Var
new  = HashSet Var
seen
      | Bool
otherwise   = let seen' :: HashSet Var
seen' = forall a. (Eq a, Hashable 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 forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`S.difference` HashSet Var
seen'
                          new'' :: HashSet Var
new'' = HashSet Var
new'     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 = forall a. (a -> Bool) -> [a] -> [a]
filter CoreBind -> Bool
f [CoreBind]
cbs
  where
    f :: CoreBind -> Bool
f (NonRec Var
x Expr Var
_) = Var
x forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Var
ys
    f (Rec [(Var, Expr Var)]
xes)    = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Var
ys) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes


--------------------------------------------------------------------------------
specDefs :: FilePath -> TargetSpec -> [Def]
--------------------------------------------------------------------------------
specDefs :: String -> TargetSpec -> [Def]
specDefs String
srcF  = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Var, Located a) -> Def
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {a} {a}. (a, Located a) -> Bool
sameFile 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 (forall a. Located a -> Int
line Located a
t) (forall a. Located a -> Int
lineE Located a
t) Var
x
    sameFile :: (a, Located a) -> Bool
sameFile   = (String
srcF forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a -> String
file forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
           forall a. [a] -> [a] -> [a]
++ GhcSpecSig -> [(Var, LocSpecType)]
gsAsmSigs (TargetSpec -> GhcSpecSig
gsSig  TargetSpec
sp)
           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 = String -> Doc
text (forall a. Show a => a -> String
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 =
  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') <- forall a. Maybe a -> [a]
maybeToList 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              = forall t. t -> SrcSpan -> Maybe (Int, Int)
lineSpan Var
x forall a b. (a -> b) -> a -> b
$ Var -> [SrcSpan] -> SrcSpan
catSpans Var
x forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr Var
e
    vSp :: Maybe (Int, Int)
vSp              = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (Var, b) -> Bool
ok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Bind a -> [(a, Expr a)]
varExprs
  where
    ok :: (Var, b) -> Bool
ok       = SrcSpan -> Bool
isGoodSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedThing a => a -> SrcSpan
getSrcSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Var)] -> [(Var, (Int, Int))]
defBounds 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 =
  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
_) = forall t. t -> SrcSpan -> Maybe (Int, Int)
lineSpan Var
x (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' forall a. Num a => a -> a -> a
- Int
1)) 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)
_
  = forall a. Maybe a
Nothing
meetSpans (Just (Int
l,Int
l')) Maybe (Int, Int)
Nothing
  = forall a. a -> Maybe a
Just (Int
l, Int
l')
meetSpans (Just (Int
l,Int
l')) (Just (Int
m, Int
m'))
  = forall a. a -> Maybe a
Just (forall a. Ord a => a -> a -> a
max Int
l Int
m, 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
_) = forall a. a -> Maybe a
Just (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
sp, RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
sp)
lineSpan t
_ SrcSpan
_                  = forall a. Maybe a
Nothing

catSpans :: Var -> [SrcSpan] -> SrcSpan
catSpans :: Var -> [SrcSpan] -> SrcSpan
catSpans Var
b []               = forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String
"DIFFCHECK: catSpans: no spans found for " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
showPpr Var
b
catSpans Var
b [SrcSpan]
xs               = 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, forall a. (Outputable a, NamedThing a) => a -> FastString
varFile Var
b 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 forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
b of
              RealSrcSpan RealSrcSpan
z Maybe BufSpan
_ -> RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
z
              SrcSpan
_               -> forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String
"DIFFCHECK: getFile: no file found for: " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
showPpr a
b


bindSpans :: NamedThing a => Bind a -> [SrcSpan]
bindSpans :: forall a. NamedThing a => Bind a -> [SrcSpan]
bindSpans (NonRec a
x Expr a
e)    = forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x forall a. a -> [a] -> [a]
: forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
bindSpans (Rec    [(a, Expr a)]
xes)    = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> SrcSpan
getSrcSpan [a]
xs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans [Expr a]
es
  where
    ([a]
xs, [Expr a]
es)              = 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         = 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)         = [forall a. NamedThing a => a -> SrcSpan
getSrcSpan Var
x]
exprSpans (Lam a
x Expr a
e)       = forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x forall a. a -> [a] -> [a]
: forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (App Expr a
e Expr a
a)       = forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e forall a. [a] -> [a] -> [a]
++ forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
a
exprSpans (Let Bind a
b Expr a
e)       = forall a. NamedThing a => Bind a -> [SrcSpan]
bindSpans Bind a
b forall a. [a] -> [a] -> [a]
++ forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (Cast Expr a
e CoercionR
_)      = forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e
exprSpans (Case Expr a
e a
x Type
_ [Alt a]
cs) = forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
x forall a. a -> [a] -> [a]
: forall a. NamedThing a => Expr a -> [SrcSpan]
exprSpans Expr a
e forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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)     = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> SrcSpan
getSrcSpan [b]
xs forall a. [a] -> [a] -> [a]
++ 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 :: String -> String -> IO ([Int], LMap)
lineDiff String
new String
old  = [String] -> [String] -> ([Int], LMap)
lineDiff' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getLines String
new forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [String]
getLines String
old
  where
    getLines :: String -> IO [String]
getLines      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile

lineDiff' :: [String] -> [String] -> ([Int], LMap)
lineDiff' :: [String] -> [String] -> ([Int], LMap)
lineDiff' [String]
new [String]
old = ([Int]
changedLines, LMap
lm)
  where
    changedLines :: [Int]
changedLines  = Int -> [Diff Int] -> [Int]
diffLines Int
1 [Diff Int]
diffLineCount
    lm :: LMap
lm            = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int, Int) -> LMap -> LMap
setShift forall v a. Ord v => IntervalMap v a
IM.empty forall a b. (a -> b) -> a -> b
$ [Diff Int] -> [(Int, Int, Int)]
diffShifts [Diff Int]
diffLineCount
    diffLineCount :: [Diff Int]
diffLineCount = forall a b. (a -> b) -> Diff a -> Diff b
diffMap forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> [Diff [a]]
getGroupedDiff [String]
new [String]
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)  = forall a b. a -> PolyDiff a b
First (a -> b
f a
x)
diffMap a -> b
f (Second a
x) = forall a b. b -> PolyDiff a b
Second (a -> b
f a
x)
diffMap a -> b
f (Both a
x a
y) = 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 forall a. Num a => a -> a -> a
+ Int
lnsUnchgd
diffLines Int
curr (First Int
lnsChgd : [Diff Int]
d)    = [Int
curr..(Int
toTakeforall a. Num a => a -> a -> a
-Int
1)] forall a. [a] -> [a] -> [a]
++ Int -> [Diff Int] -> [Int]
diffLines Int
toTake [Diff Int]
d
   where toTake :: Int
toTake = Int
curr 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 = 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 forall a. Num a => a -> a -> a
+ t
n forall a. Num a => a -> a -> a
- t
1, t
new forall a. Num a => a -> a -> a
- t
old) forall a. a -> [a] -> [a]
: t -> t -> [PolyDiff t t] -> [(t, t, t)]
go (t
old forall a. Num a => a -> a -> a
+ t
n)
                                                                   (t
new 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 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 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 :: String -> Output Doc -> IO ()
saveResult String
target Output Doc
res = do
  String -> String -> IO ()
copyFile String
target String
saveF
  String -> ByteString -> IO ()
B.writeFile String
errF forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Output Doc
res
  where
    saveF :: String
saveF = Ext -> ShowS
extFileName Ext
Saved  String
target
    errF :: String
errF  = Ext -> ShowS
extFileName Ext
Cache  String
target

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

--------------------------------------------------------------------------------
adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc
--------------------------------------------------------------------------------
adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc
adjustOutput LMap
lm ChkItv
cm Output Doc
o  = forall a. Monoid a => a
mempty { o_types :: AnnInfo Doc
o_types  = forall a. LMap -> ChkItv -> AnnInfo a -> AnnInfo a
adjustTypes  LMap
lm ChkItv
cm (forall a. Output a -> AnnInfo a
o_types  Output Doc
o) }
                               { o_result :: ErrorResult
o_result = LMap -> ChkItv -> ErrorResult -> ErrorResult
adjustResult LMap
lm ChkItv
cm (forall a. Output a -> ErrorResult
o_result Output Doc
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)          = forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI forall a b. (a -> b) -> a -> b
$ if Bool
True then forall a. Monoid a => a
mempty else 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)  <- 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)  = forall a b. ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult (forall a. Stats -> [a] -> FixResult a
Unsafe Stats
s)  forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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 String)]
es String
z)   = forall a b. ([a] -> FixResult b) -> [a] -> FixResult b
errorsResult (forall a. [(a, Maybe String)] -> String -> FixResult a
`Crash` String
z) forall a b. (a -> b) -> a -> b
$ (, forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a.
PPrint (TError a) =>
LMap -> ChkItv -> TError a -> Maybe (TError a)
adjustError LMap
lm ChkItv
cm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TError Doc, Maybe String)]
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
_ []                 = forall a. Stats -> FixResult a
Safe 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 (forall t. TError t -> SrcSpan
pos TError a
e) of
  Just SrcSpan
sp' -> forall a. a -> Maybe a
Just (TError a
e {pos :: SrcSpan
pos = SrcSpan
sp'})
  Maybe SrcSpan
Nothing  -> 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 SrcSpan
sp' <- LMap -> SrcSpan -> Maybe SrcSpan
adjustSpan LMap
lm SrcSpan
sp
       if forall a. IntervalMap Int a -> SrcSpan -> Bool
isCheckedSpan ChkItv
cm SrcSpan
sp'
         then forall a. Maybe a
Nothing
         else forall a. a -> Maybe a
Just SrcSpan
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
_) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v a. Ord v => v -> IntervalMap v a -> [(Interval v, a)]
`IM.search` IntervalMap Int a
cm) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LMap -> RealSrcSpan -> Maybe RealSrcSpan
adjustReal LMap
lm RealSrcSpan
rsp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
adjustSpan LMap
_  SrcSpan
sp                  = 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                  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Int -> Int -> RealSrcSpan
packRealSrcSpan String
f (Int
l1 forall a. Num a => a -> a -> a
+ Int
δ) Int
c1 (Int
l2 forall a. Num a => a -> a -> a
+ Int
δ) Int
c2
  | Bool
otherwise                     = forall a. Maybe a
Nothing
  where
    (String
f, Int
l1, Int
c1, Int
l2, Int
c2)           = RealSrcSpan -> (String, 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
δ) = forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
IM.insert (forall v. v -> v -> Interval v
IM.Interval Int
l1 Int
l2) Int
δ


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


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

instance ToJSON SourcePos where
  toJSON :: SourcePos -> Value
toJSON SourcePos
p = [Pair] -> Value
object [   Key
"sourceName"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
f
                      , Key
"sourceLine"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pos -> Int
unPos Pos
l
                      , Key
"sourceColumn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Pos -> Int
unPos Pos
c
                      ]
             where
               f :: String
f    = SourcePos -> String
sourceName   SourcePos
p
               l :: Pos
l    = SourcePos -> Pos
sourceLine   SourcePos
p
               c :: Pos
c    = SourcePos -> Pos
sourceColumn SourcePos
p

instance FromJSON SourcePos where
  parseJSON :: Value -> Parser SourcePos
parseJSON (Object Object
v) = String -> Int -> Int -> SourcePos
safeSourcePos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sourceName"
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sourceLine"
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sourceColumn"
  parseJSON Value
_          = forall a. Monoid a => a
mempty

instance FromJSON ErrorResult

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

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

instance ToJSON a => ToJSON (AnnInfo a) where
  toJSON :: AnnInfo a -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
  toEncoding :: AnnInfo a -> Encoding
toEncoding = 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 = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
  toEncoding :: Output Doc -> Encoding
toEncoding = 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 = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions

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

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

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