Skip to content

Commit cd7282d

Browse files
wenkokkewenkokke
committed
feat(scripts): add lint-diskio-complexities
1 parent 0a461ed commit cd7282d

File tree

1 file changed

+182
-0
lines changed

1 file changed

+182
-0
lines changed

‎scripts/lint-diskio-complexities.hs‎

Lines changed: 182 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,182 @@
1+
#!/usr/bin/env cabal
2+
{- cabal:
3+
build-depends:
4+
, base >=4.16 && <5
5+
, bytestring ^>=0.11
6+
, cassava ^>=0.5
7+
, containers ^>=0.6 || ^>=0.7 || ^>=0.8
8+
, process ^>=1.6
9+
, text ^>=2.1
10+
, vector ^>=0.12 || ^>=0.13
11+
-}
12+
{-# LANGUAGE InstanceSigs #-}
13+
{-# LANGUAGE OverloadedRecordDot #-}
14+
{-# LANGUAGE OverloadedStrings #-}
15+
{-# LANGUAGE RecordWildCards #-}
16+
{-# LANGUAGE TupleSections #-}
17+
{-# LANGUAGE TypeApplications #-}
18+
19+
import Control.Applicative (Alternative (..))
20+
import qualified Data.ByteString.Lazy as BSL
21+
import Data.Csv
22+
import Data.List (zip4)
23+
import Data.Map (Map)
24+
import qualified Data.Map as M
25+
import Data.Maybe (fromMaybe, isNothing)
26+
import Data.Set (Set)
27+
import qualified Data.Set as S
28+
import Data.Text (Text)
29+
import qualified Data.Text as T
30+
import qualified Data.Text.Encoding as TE
31+
import qualified Data.Text.IO as TIO
32+
import Data.Traversable (for)
33+
import Data.Vector (Vector)
34+
import qualified Data.Vector as V
35+
import System.Process (readProcess)
36+
37+
type Function = Text
38+
type MergePolicy = Text
39+
type MergeSchedule = Text
40+
type WorstCaseDiskIOComplexity = Text
41+
type Condition = Text
42+
43+
data DiskIOComplexity = DiskIOComplexity
44+
{ function :: Function
45+
, mergePolicy :: Maybe MergePolicy
46+
, mergeSchedule :: Maybe MergeSchedule
47+
, worstCaseDiskIOComplexity :: WorstCaseDiskIOComplexity
48+
, condition :: Maybe Condition
49+
}
50+
deriving (Eq, Show)
51+
52+
looseEq :: DiskIOComplexity -> DiskIOComplexity -> Bool
53+
dioc1 `looseEq` dioc2 =
54+
and
55+
[ dioc1.function == dioc2.function
56+
, dioc1.mergePolicy == dioc2.mergePolicy
57+
, dioc1.mergeSchedule == dioc2.mergeSchedule
58+
, dioc1.worstCaseDiskIOComplexity == dioc2.worstCaseDiskIOComplexity
59+
, isNothing dioc1.condition || dioc1.condition == dioc2.condition
60+
]
61+
62+
main :: IO ()
63+
main = do
64+
-- Get the disk I/O complexities from the package description
65+
mapForPackageDescription <-
66+
buildDiskIOComplexityMap . decodeDiskIOComplexities
67+
<$> readProcess "./scripts/lint-diskio-complexities/dump-from-package-description.hs" [] ""
68+
69+
-- Get the disk I/O complexities from Database.LSMTree
70+
mapForFullApi <-
71+
buildDiskIOComplexityMap . decodeDiskIOComplexities
72+
<$> readProcess "./scripts/lint-diskio-complexities/dump-from-source.sh" ["./src/Database/LSMTree.hs"] ""
73+
74+
-- Get the disk I/O complexities from Database.LSMTree.Simple
75+
mapForSimpleApi <-
76+
buildDiskIOComplexityMap . decodeDiskIOComplexities
77+
<$> readProcess "./scripts/lint-diskio-complexities/dump-from-source.sh" ["./src/Database/LSMTree/Simple.hs"] ""
78+
79+
-- Comparing Database.LSMTree.Simple to Database.LSMTree
80+
putStrLn "Comparing Database.LSMTree.Simple to Database.LSMTree:"
81+
diskIOComplexityComparisonSimpleToFull <-
82+
for (concat . M.elems $ mapForSimpleApi) $ \diskIOComplexity@DiskIOComplexity{..} -> do
83+
case M.lookup function mapForFullApi of
84+
Nothing ->
85+
pure [("Database.LSMTree.Simple", diskIOComplexity)]
86+
Just fullDiskIOComplexities
87+
| diskIOComplexity `elem` fullDiskIOComplexities -> pure []
88+
| otherwise -> pure (("Database.LSMTree.Simple", diskIOComplexity) : (("Database.LSMTree",) <$> fullDiskIOComplexities))
89+
TIO.putStrLn . prettyDiskIOComplexityTable . concat $ diskIOComplexityComparisonSimpleToFull
90+
91+
-- Comparing lsm-tree.cabal to Database.LSMTree
92+
putStrLn "Comparing lsm-tree.cabal to Database.LSMTree:"
93+
diskIOComplexityComparisonPackageDescriptionToFull <-
94+
for (concat . M.elems $ mapForPackageDescription) $ \diskIOComplexity@DiskIOComplexity{..} -> do
95+
case M.lookup function mapForFullApi of
96+
Nothing ->
97+
pure [("lsm-tree.cabal", diskIOComplexity)]
98+
Just fullDiskIOComplexities
99+
| any (looseEq diskIOComplexity) fullDiskIOComplexities -> pure []
100+
| otherwise -> pure (("lsm-tree.cabal", diskIOComplexity) : (("Database.LSMTree",) <$> fullDiskIOComplexities))
101+
TIO.putStrLn . prettyDiskIOComplexityTable . concat $ diskIOComplexityComparisonPackageDescriptionToFull
102+
103+
--------------------------------------------------------------------------------
104+
-- Helper functions
105+
--------------------------------------------------------------------------------
106+
107+
-- | Typeset a tagged list of 'DiskIOComplexity' records as an aligned table.
108+
prettyDiskIOComplexityTable :: [(Text, DiskIOComplexity)] -> Text
109+
prettyDiskIOComplexityTable diskIOComplexities = do
110+
let tags = fst <$> diskIOComplexities
111+
let maxTagLen = maximum (T.length <$> tags)
112+
let functions = ((.function) . snd) <$> diskIOComplexities
113+
let maxFunctionLen = maximum (T.length <$> functions)
114+
let conditions = (prettyCondition . snd) <$> diskIOComplexities
115+
let maxConditionLen = maximum (T.length <$> conditions)
116+
let worstCaseDiskIOComplexities = ((.worstCaseDiskIOComplexity) . snd) <$> diskIOComplexities
117+
let maxWorstCaseDiskIOComplexityLen = maximum (T.length <$> worstCaseDiskIOComplexities)
118+
T.unlines
119+
[ T.unwords
120+
[ tag `padUpTo` maxTagLen
121+
, function `padUpTo` maxFunctionLen
122+
, condition `padUpTo` maxConditionLen
123+
, worstCaseDiskIOComplexity `padUpTo` maxWorstCaseDiskIOComplexityLen
124+
]
125+
| (tag, function, condition, worstCaseDiskIOComplexity) <-
126+
zip4 tags functions conditions worstCaseDiskIOComplexities
127+
]
128+
where
129+
padUpTo :: Text -> Int -> Text
130+
padUpTo txt len = txt <> T.replicate (len - T.length txt) " "
131+
132+
prettyCondition :: DiskIOComplexity -> Text
133+
prettyCondition DiskIOComplexity{..} =
134+
fromMaybe "*" (unionMaybeWith slash mergePolicy (unionMaybeWith slash mergeSchedule condition))
135+
where
136+
slash :: Text -> Text -> Text
137+
x `slash` y = x <> "/" <> y
138+
139+
unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
140+
unionMaybeWith op (Just x) (Just y) = Just (x `op` y)
141+
unionMaybeWith _op (Just x) Nothing = Just x
142+
unionMaybeWith _op Nothing (Just y) = Just y
143+
unionMaybeWith _op Nothing Nothing = Nothing
144+
145+
-- | Structure vector of 'DiskIOComplexity' records into lookup table by function name.
146+
buildDiskIOComplexityMap :: Vector DiskIOComplexity -> Map Function [DiskIOComplexity]
147+
buildDiskIOComplexityMap = M.unionsWith (<>) . fmap toSingletonMap . V.toList
148+
where
149+
toSingletonMap :: DiskIOComplexity -> Map Function [DiskIOComplexity]
150+
toSingletonMap diskIOComplexity = M.singleton diskIOComplexity.function [diskIOComplexity]
151+
152+
-- | Parse CSV file into vector of 'DiskIOComplexity' records.
153+
decodeDiskIOComplexities :: String -> Vector DiskIOComplexity
154+
decodeDiskIOComplexities =
155+
either error snd . decodeByName . BSL.fromStrict . TE.encodeUtf8 . T.pack
156+
157+
-- | CSV file header for 'DiskIOComplexity' records.
158+
diskIOComplexityHeader :: Header
159+
diskIOComplexityHeader =
160+
header ["Function", "Merge policy", "Merge schedule", "Worst-case disk I/O complexity", "Condition"]
161+
162+
normaliseWorstCaseDiskIOComplexity :: WorstCaseDiskIOComplexity -> WorstCaseDiskIOComplexity
163+
normaliseWorstCaseDiskIOComplexity =
164+
T.replace "+ " "+" . T.replace " +" "+" . T.replace " \\" "\\" . T.replace " " " " . T.replace "\\:" ""
165+
166+
-- | Parse CSV row into 'DiskIOComplexity' record.
167+
instance FromNamedRecord DiskIOComplexity where
168+
parseNamedRecord :: NamedRecord -> Parser DiskIOComplexity
169+
parseNamedRecord m = do
170+
function <- m .: "Function"
171+
mergePolicy <- orNotApplicable (m .: "Merge policy")
172+
mergeSchedule <- orNotApplicable (m .: "Merge schedule")
173+
worstCaseDiskIOComplexity <- normaliseWorstCaseDiskIOComplexity <$> (m .: "Worst-case disk I/O complexity")
174+
condition <- orNotApplicable (m .: "Condition")
175+
pure DiskIOComplexity{..}
176+
where
177+
orNotApplicable :: Parser Text -> Parser (Maybe Text)
178+
orNotApplicable pText = (emptyTextToNothing <$> pText) <|> pure Nothing
179+
where
180+
emptyTextToNothing :: Text -> Maybe Text
181+
emptyTextToNothing txt =
182+
if T.null txt then Nothing else Just txt

0 commit comments

Comments
 (0)