Types.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Development.Rattle.Types(
    Trace(..), Touch(..), fsaTrace, normalizeTouch,
    TouchSet, tsRead, tsWrite, newTouchSet, addTouchSet,
    Cmd(..), mkCmd,
    RunIndex, runIndex0, nextRunIndex,
    ) where

import Data.Hashable
import Data.List.Extra
import System.Directory
import System.Info.Extra
import Control.Monad
import General.Binary
import Data.Word
import Development.Shake.Command
import Data.Semigroup
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString as BS
import qualified Data.HashSet as Set
import GHC.Generics
import Prelude
import System.Time.Extra
import General.FileName

-- record the hash as the first field
data Cmd = Cmd Int [CmdOption] [String]
    deriving Eq

instance Show Cmd where
    show (Cmd _ a b) = "Cmd " ++ show a ++ " " ++ show b

instance Hashable Cmd where
    hashWithSalt _ = hash
    hash (Cmd x _ _) = x

mkCmd :: [CmdOption] -> [String] -> Cmd
mkCmd a b = Cmd (hash (a,b)) a b

instance BinaryEx Cmd where
    getEx x = mkCmd (getEx a) (getEx b)
        where (a,b) = getExPair x
    putEx (Cmd _ a b) = putExPair (putEx a) (putEx b)

-- The common values for CmdOption are [], [Shell] and a few others - optimise those
instance BinaryEx [CmdOption] where
    getEx x
        | BS.null x = []
        | BS.length x == 1 = case getEx x :: Word8 of
            0 -> [Shell]
            1 -> [EchoStderr False]
            2 -> [Shell,EchoStderr False]
        | otherwise = map read $ getEx x

    putEx [] = mempty
    putEx [Shell] = putEx (0 :: Word8)
    putEx [EchoStderr False] = putEx (1 :: Word8)
    putEx [Shell,EchoStderr False] = putEx (2 :: Word8)
    putEx xs = putEx $ map show xs

deriving instance Generic CmdOption
deriving instance Read CmdOption
instance Hashable CmdOption

data Trace a = Trace
    {tRun :: {-# UNPACK #-} !RunIndex
    ,tStart :: {-# UNPACK #-} !Seconds
    ,tStop :: {-# UNPACK #-} !Seconds
    ,tTouch :: Touch a
    } deriving (Show, Functor, Foldable, Traversable, Eq)

instance BinaryEx a => BinaryEx (Trace a) where
    getEx x = Trace a b c $ getEx d
        where (a,b,c,d) = binarySplit3 x
    putEx (Trace a b c d) = putExStorable a <> putExStorable b <> putExStorable c <> putEx d

data Touch a = Touch
    {tRead :: [a]
    ,tWrite :: [a]
    } deriving (Show, Functor, Foldable, Traversable, Eq)

instance BinaryEx a => BinaryEx (Touch a) where
    getEx x = Touch (map getEx $ getExList a) (map getEx $ getExList b)
        where [a,b] = getExList x
    putEx (Touch a b) = putExList [putExList $ map putEx a, putExList $ map putEx b]

instance Semigroup (Touch a) where
    Touch r1 w1 <> Touch r2 w2 = Touch (r1++r2) (w1++w2)

instance Monoid (Touch a) where
    mempty = Touch [] []
    mappend = (<>)
    mconcat xs = Touch (concatMap tRead xs) (concatMap tWrite xs)

instance Hashable a => Hashable (Trace a) where
    hashWithSalt s (Trace a b c d) = hashWithSalt s (a,b,c,d)

instance Hashable a => Hashable (Touch a) where
    hashWithSalt s (Touch r w) = hashWithSalt s (r,w)

fsaTrace :: [FSATrace BS.ByteString] -> IO (Touch FileName)
-- We want to get normalized traces. On Linux, things come out normalized, and we just want to dedupe them
-- On Windows things come out as C:\windows\system32\KERNELBASE.dll instead of C:\Windows\System32\KernelBase.dll
-- so important to call (expensive) normalizeTouch
fsaTrace fs
    | isWindows =
        -- normalize twice because normalisation is cheap, but canonicalisation might be expensive
        fmap (normalizeTouch . fmap (byteStringToFileName . UTF8.fromString)) $
        canonicalizeTouch $
        fmap UTF8.toString $ normalizeTouch $ mconcatMap f fs
    | otherwise =
        -- We know the file names are already normalized from Shake so avoid a redundant conversion
        pure $ normalizeTouch $ byteStringToFileName <$> mconcatMap f fs
    where
        f (FSAWrite x) = Touch [] [x]
        f (FSARead x) = Touch [x] []
        f (FSADelete x) = Touch [] [x]
        f (FSAMove x y) = Touch [] [x,y]
        f (FSAQuery x) = Touch [x] []
        f (FSATouch x) = Touch [] [x]

normalizeTouch :: (Ord a, Hashable a) => Touch a -> Touch a
-- added 'sort' because HashSet uses the ordering of the hashes, which is confusing
-- and since we are sorting, try and avoid doing too much hash manipulation of the reads
normalizeTouch (Touch a b) = Touch (f $ sort a) (sort $ Set.toList b2)
    where
        b2 = Set.fromList b
        f (x1:x2:xs) | x1 == x2 = f (x1:xs)
        f (x:xs) | x `Set.member` b2 = f xs
                 | otherwise = x : f xs
        f [] = []

canonicalizeTouch :: Touch FilePath -> IO (Touch FilePath)
canonicalizeTouch (Touch a b) = Touch <$> mapM canonicalizePath a <*> mapM canonicalizePath b


-- For sets, Set.fromList is fastest if there are no dupes
-- Otherwise a Set.member/Set.insert is fastest
data TouchSet = TouchSet {tsRead :: Set.HashSet FileName, tsWrite :: Set.HashSet FileName}

newTouchSet :: [Touch FileName] -> TouchSet
newTouchSet [] = TouchSet Set.empty Set.empty
newTouchSet (Touch{..}:xs) = foldl' addTouchSet (TouchSet (Set.fromList tRead) (Set.fromList tWrite)) xs

addTouchSet :: TouchSet -> Touch FileName -> TouchSet
addTouchSet TouchSet{..} Touch{..} = TouchSet (f tsRead tRead) (f tsWrite tWrite)
    where f = foldl' (\mp k -> if Set.member k mp then mp else Set.insert k mp)


-- | Which run we are in, monotonically increasing
newtype RunIndex = RunIndex Int
    deriving (Eq,Ord,Show,Storable,BinaryEx,Hashable)

runIndex0 :: RunIndex
runIndex0 = RunIndex 0

nextRunIndex :: RunIndex -> RunIndex
nextRunIndex (RunIndex i) = RunIndex $ i + 1