-- | 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. module Language.Haskell.Liquid.DiffCheck (slice, save, thin) where import Control.Applicative ((<$>)) import Data.Algorithm.Diff import CoreSyn import Name import SrcLoc -- import Outputable import Var import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Function (on) import System.Directory (copyFile, doesFileExist) import Language.Fixpoint.Files import Language.Haskell.Liquid.GhcInterface import Language.Haskell.Liquid.GhcMisc import Text.Parsec.Pos (sourceLine) import Control.Monad(forM) ------------------------------------------------------------------------- -- Data Types ----------------------------------------------------------- ------------------------------------------------------------------------- data Def = D { start :: Int , end :: Int , binder :: Var } deriving (Eq, Ord) instance Show Def where show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j -- | `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] -> IO [CoreBind] ------------------------------------------------------------------------- slice target cbs = do let saved = extFileName Saved target ex <- doesFileExist saved if ex then do is <- {- tracePpr "INCCHECK: changed lines" <$> -} lineDiff target saved let dfs = coreDefs cbs forM dfs $ putStrLn . ("INCCHECK: Def " ++) . show let xs = diffVars is dfs return $ thin cbs xs else return cbs -- | `thin` returns a subset of the @[CoreBind]@ given which correspond -- to those binders that depend on any of the @Var@s provided. ------------------------------------------------------------------------- thin :: [CoreBind] -> [Var] -> [CoreBind] ------------------------------------------------------------------------- thin cbs xs = filterBinds cbs ys where ys = dependentVars (coreDeps cbs) $ S.fromList xs ------------------------------------------------------------------------- filterBinds :: [CoreBind] -> S.HashSet Var -> [CoreBind] ------------------------------------------------------------------------- filterBinds cbs ys = filter f cbs where f (NonRec x _) = x `S.member` ys f (Rec xes) = any (`S.member` ys) $ fst <$> xes ------------------------------------------------------------------------- coreDefs :: [CoreBind] -> [Def] ------------------------------------------------------------------------- coreDefs cbs = L.sort [D l l' x | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b] coreDef b = meetSpans b eSp vSp where eSp = lineSpan b $ catSpans b $ bindSpans b vSp = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b -- | `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 b Nothing _ = error $ "INCCHECK: cannot find span for top-level binders: " ++ showPpr (bindersOf b) ++ "\nRun without --diffcheck option\n" meetSpans b (Just (l,l')) Nothing = (l, l') meetSpans b (Just (l,l')) (Just (m,_)) = (max l m, l') -- coreDef b = lineSpan $ catSpans b $ map getSrcSpan -- $ tracePpr ("INCCHECK: letvars " ++ showPpr (bindersOf b)) -- $ letVars b lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp) lineSpan b _ = Nothing -- error $ "INCCHECK: lineSpan unexpected dummy span in lineSpan" ++ showPpr (bindersOf b) catSpans b [] = error $ "INCCHECK: catSpans: no spans found for " ++ showPpr b catSpans b xs = foldr1 combineSrcSpans xs bindSpans (NonRec x e) = getSrcSpan x : exprSpans e bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es where (xs, es) = unzip xes exprSpans (Tick t _) = [tickSrcSpan t] exprSpans (Var x) = [getSrcSpan x] exprSpans (Lam x e) = getSrcSpan x : exprSpans e exprSpans (App e a) = exprSpans e ++ exprSpans a exprSpans (Let b e) = bindSpans b ++ exprSpans e exprSpans (Cast e _) = exprSpans e exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs exprSpans e = [] altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e -- coreDefs cbs = mkDefs lxs -- where -- lxs = coreDefs' cbs -- -- lxs = L.sortBy (compare `on` fst) [(line x, x) | x <- xs ] -- -- xs = concatMap bindersOf cbs -- -- line = sourceLine . getSourcePos -- -- mkDefs [] = [] -- mkDefs ((l,x):lxs) = case lxs of -- [] -> [D l Nothing x] -- (l',_):_ -> (D l (Just l') x) : mkDefs lxs -- -- coreDefs' cbs = L.sort [(l, x) | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b] ------------------------------------------------------------------------- coreDeps :: [CoreBind] -> Deps ------------------------------------------------------------------------- coreDeps = M.fromList . concatMap bindDep bindDep b = [(x, ys) | x <- bindersOf b] where ys = S.fromList $ freeVars S.empty b type Deps = M.HashMap Var (S.HashSet Var) ------------------------------------------------------------------------- dependentVars :: Deps -> S.HashSet Var -> S.HashSet Var ------------------------------------------------------------------------- dependentVars d xs = {- tracePpr "INCCHECK: tx changed vars" $ -} go S.empty $ {- tracePpr "INCCHECK: seed changed vars" -} xs where pre = S.unions . fmap deps . S.toList deps x = M.lookupDefault S.empty x d go seen new | S.null new = seen | otherwise = let seen' = S.union seen new new' = pre new `S.difference` seen' in go seen' new' ------------------------------------------------------------------------- diffVars :: [Int] -> [Def] -> [Var] ------------------------------------------------------------------------- diffVars lines defs = -- tracePpr ("INCCHECK: diffVars lines = " ++ show lines ++ " defs= " ++ show defs) $ go (L.sort lines) (L.sort defs) where go _ [] = [] go [] _ = [] go (i:is) (d:ds) | i < start d = go is (d:ds) | i > end d = go (i:is) ds | otherwise = binder d : go (i:is) ds ------------------------------------------------------------------------- -- Diff Interface ------------------------------------------------------- ------------------------------------------------------------------------- -- | `save` creates an .saved version of the `target` file, which will be -- used to find what has changed the /next time/ `target` is checked. ------------------------------------------------------------------------- save :: FilePath -> IO () ------------------------------------------------------------------------- save target = copyFile target $ extFileName Saved target -- | `lineDiff src dst` compares the contents of `src` with `dst` -- and returns the lines of `src` that are different. ------------------------------------------------------------------------- lineDiff :: FilePath -> FilePath -> IO [Int] ------------------------------------------------------------------------- lineDiff src dst = do s1 <- getLines src s2 <- getLines dst let ns = diffLines 1 $ getGroupedDiff s1 s2 putStrLn $ "INCCHECK: diff lines = " ++ show ns return ns diffLines _ [] = [] diffLines n (Both ls _ : d) = diffLines n' d where n' = n + length ls diffLines n (First ls : d) = [n .. (n' - 1)] ++ diffLines n' d where n' = n + length ls diffLines n (Second _ : d) = diffLines n d getLines = fmap lines . readFile