diff --git a/app/hcount.hs b/app/hcount.hs --- a/app/hcount.hs +++ b/app/hcount.hs @@ -1,840 +1,320 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-top-binds #-} - -import qualified Data.Attoparsec.Text as A -import qualified Data.Char as Char -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import HieTypes -import NumHask.Prelude -import Options.Applicative as OA -import Stan.Ghc.Compat -import Stan.Hie - -main :: IO () -main = do - hccfg <- execParser (info (hc <**> helper) (fullDesc <> progDesc "Count haskell names using hie files")) - report hccfg - --- | report to stdout --- >>> report defaultHCountConfig -report :: HCountConfig -> IO () -report cfg = do - fs <- mapM readHieFiles (unpack <$> hcHiefiles cfg) - putStrLn $ ("Number of repos: " :: Text) <> show (length fs) - putStrLn $ ("Number of files: " :: Text) <> show (length $ mconcat fs) - let ns = getNames fs - putStrLn $ ("Total names: " :: Text) <> show (sum . fmap snd $ ns) - putStrLn $ ("Unique names: " :: Text) <> show (length ns) - - when (hcAll cfg) $ do - putStrLn ("top names" :: Text) - putStrLn ("total names: " <> show (sum $ snd <$> ns) :: Text) - putStrLn ("" :: Text) - mapM_ putStrLn (fmap formatResults $ take (hcTopn cfg) $ first locname <$> ns) - - when (hcOperators cfg) $ do - putStrLn ("top operators" :: Text) - let op' = filter (oph (hcExcluded cfg) . fst) ns - putStrLn ("total operators: " <> show (sum $ snd <$> op') :: Text) - putStrLn ("" :: Text) - mapM_ putStrLn (fmap formatResults $ take (hcTopn cfg) $ first locname <$> op') - - when (hcFunctions cfg) $ do - putStrLn ("top lower case functions" :: Text) - let lower' = filter (lowerh (hcExcluded cfg) . fst) ns - putStrLn ("total functions: " <> show (sum $ snd <$> lower') :: Text) - putStrLn ("" :: Text) - mapM_ putStrLn (fmap formatResults $ take (hcTopn cfg) $ first locname <$> lower') - - when (hcConstructors cfg) $ do - putStrLn ("top upper case constructors" :: Text) - let upper' = filter (upperh (hcExcluded cfg) . fst) ns - putStrLn ("total constructors: " <> show (sum $ snd <$> upper') :: Text) - putStrLn ("" :: Text) - mapM_ putStrLn (fmap formatResults $ take (hcTopn cfg) $ first locname <$> upper') - - when (hcLocals cfg) $ do - putStrLn ("top local names" :: Text) - let local' = filter (localh . fst) ns - putStrLn ("total local names: " <> show (sum $ snd <$> local') :: Text) - putStrLn ("" :: Text) - mapM_ putStrLn (fmap formatResults $ take (hcTopn cfg) $ first locname <$> local') - -getNames :: [[HieFile]] -> [((Loc, Text), Int)] -getNames = sortOn (Down . snd) . Map.toList . Main.count . names . fmap fst . mconcat . fmap astFlat . asts . mconcat - --- | Get the trees from each hie file, throwing away file details -asts :: [HieFile] -> [HieAST TypeIndex] -asts fs = mconcat $ Map.elems . getAsts . hie_asts <$> fs - --- | Throw away the tree structure and retain node information. --- --- deconstruction of: --- sum = P.foldr (+) zero --- --- P.foldr --- NodeInfo {nodeAnnotations = fromList [("HsVar","HsExpr"),("HsWrap","HsExpr")], nodeType = [7,24], nodeIdentifiers = fromList [(Right NameMeta {nameMetaPackage = "base", nameMetaModuleName = ModuleName {unModuleName = "Data.Foldable"}, nameMetaName = "foldr"},IdentifierDetails {identType = Just 24, identInfo = fromList [Use]})]} --- --- (+) --- --- NodeInfo {nodeAnnotations = fromList [("HsVar","HsExpr"),("HsWrap","HsExpr")], nodeType = [5,30], nodeIdentifiers = fromList [(Right NameMeta {nameMetaPackage = "numhask-0.7.0.1-7TAYiN9QGfDA9z2ZI270ii", nameMetaModuleName = ModuleName {unModuleName = "NumHask.Algebra.Additive"}, nameMetaName = "+"},IdentifierDetails {identType = Just 30, identInfo = fromList [Use]})]} --- --- zero --- --- NodeInfo {nodeAnnotations = fromList [("HsVar","HsExpr"),("HsWrap","HsExpr")], nodeType = [1,32], nodeIdentifiers = fromList [(Right NameMeta {nameMetaPackage = "numhask-0.7.0.1-7TAYiN9QGfDA9z2ZI270ii", nameMetaModuleName = ModuleName {unModuleName = "NumHask.Algebra.Additive"}, nameMetaName = "zero"},IdentifierDetails {identType = Just 32, identInfo = fromList [Use]})]} --- --- LogField $ negate x --- --- NodeInfo {nodeAnnotations = fromList [("HsConLikeOut","HsExpr"),("HsVar","HsExpr"),("HsWrap","HsExpr")], nodeType = [1246,1084], nodeIdentifiers = fromList [(Right NameMeta {nameMetaPackage = "numhask-0.7.0.1-7TAYiN9QGfDA9z2ZI270ii", nameMetaModuleName = ModuleName {unModuleName = "NumHask.Data.LogField"}, nameMetaName = "LogField"},IdentifierDetails {identType = Nothing, identInfo = fromList [Use]})]} --- --- NodeInfo {nodeAnnotations = fromList [("HsVar","HsExpr"),("HsWrap","HsExpr")], nodeType = [1247,1256], nodeIdentifiers = fromList [(Right NameMeta {nameMetaPackage = "base", nameMetaModuleName = ModuleName {unModuleName = "GHC.Base"}, nameMetaName = "$"},IdentifierDetails {identType = Just 1256, identInfo = fromList [Use]})]} --- --- NodeInfo {nodeAnnotations = fromList [("HsVar","HsExpr")], nodeType = [1220], nodeIdentifiers = fromList [(Right $_in$x,IdentifierDetails {identType = Just 1220, identInfo = fromList [Use]})]} --- --- lf = fs !! 4 --- lf207s = filter (\x -> 207 == (srcLocLine . realSrcSpanStart . snd $ x)) $ (mconcat $ astFlat <$> asts [lf]) -astFlat :: HieAST a -> [(NodeInfo a, Span)] -astFlat h = [(nodeInfo h, nodeSpan h)] <> mconcat (fmap astFlat (nodeChildren h)) - -data Loc = Local | Main | Base | Unknown | Package Text deriving (Show, Eq, Ord) - --- | extract simplified names of variables from the NodeInfo -names :: [NodeInfo a] -> [(Loc, Text)] -names nodes = - [ simplifyLocName $ pack $ nameStableString x - | (Right x) <- - mconcat $ - Map.keys . nodeIdentifiers - <$> filter (Set.member ("HsVar", "HsExpr") . nodeAnnotations) nodes - ] - --- | count occurrences -count :: (Ord a) => [a] -> Map.Map a Int -count = Map.fromListWith (+) . fmap (,1) - --- | simplified location name -simplifyLocName :: Text -> (Loc, Text) -simplifyLocName t = either (const (Unknown, t)) id $ A.parseOnly lp t - where - lp = pLocal' <|> pLocal <|> pBase' <|> pBase <|> pPackage' <|> pPackage <|> pMain - -pLocal :: A.Parser (Loc, Text) -pLocal = do - _ <- A.string "$_in$" - n <- A.takeText - pure (Local, n) - -pLocal' :: A.Parser (Loc, Text) -pLocal' = do - _ <- A.string "$_in$" - _ <- A.string "$d" <|> A.string "$cp1" <|> A.string "$cp2" <|> A.string "$cp3" <|> A.string "$cp4" <|> A.string "$c" <|> A.string "$C:" - n <- A.takeText - pure (Local, n) - -pBase' :: A.Parser (Loc, Text) -pBase' = do - _ <- A.string "$base$" - _ <- A.skipWhile (/= '$') - _ <- A.char '$' - _ <- A.string "C:" - n <- A.takeText - pure (Base, n) - -pBase :: A.Parser (Loc, Text) -pBase = do - _ <- A.string "$base$" - _ <- A.skipWhile (/= '$') - _ <- A.char '$' - n <- A.takeText - pure (Base, n) - --- "numhask-space-0.7.0.0-LPYAlOQ382DJicX4NZ3Jtj" --- -pPackageName :: A.Parser Text -pPackageName = do - ps <- A.sepBy1 (A.takeWhile (`notElem` ['-', '$'])) (A.char '-') - case reverse ps of - (_ : _ : ps') -> pure $ Text.intercalate "-" (reverse ps') - ps' -> pure $ Text.intercalate "-" (reverse ps') - -pPackage' :: A.Parser (Loc, Text) -pPackage' = do - _ <- A.char '$' - p <- pPackageName - _ <- A.char '$' - _ <- A.skipWhile (/= '$') - _ <- A.char '$' - _ <- A.string "C:" - n <- A.takeText - pure (Package p, n) - -pPackage :: A.Parser (Loc, Text) -pPackage = do - _ <- A.char '$' - p <- pPackageName - _ <- A.char '$' - _ <- A.skipWhile (/= '$') - _ <- A.char '$' - n <- A.takeText - pure (Package p, n) - -pMain :: A.Parser (Loc, Text) -pMain = do - _ <- A.string "$main$" - _ <- A.skipWhile (/= '$') - _ <- A.char '$' - n <- A.takeText - pure (Main, n) - -lowerh :: [Text] -> (Loc, Text) -> Bool -lowerh _ (Local, _) = False -lowerh _ (Main, _) = False -lowerh _ (Base, n) = Char.isLower (Text.head n) -lowerh ex (Package p, n) = Char.isLower (Text.head n) && notElem p ex -lowerh _ (Unknown, _) = False - -upperh :: [Text] -> (Loc, Text) -> Bool -upperh _ (Local, _) = False -upperh _ (Main, _) = False -upperh _ (Base, n) = Char.isUpper (Text.head n) -upperh ex (Package p, n) = Char.isUpper (Text.head n) && notElem p ex -upperh _ (Unknown, _) = False - -oph :: [Text] -> (Loc, Text) -> Bool -oph _ (Local, _) = False -oph _ (Main, _) = False -oph _ (Base, n) = not $ Char.isLetter (Text.head n) -oph ex (Package p, n) = not (Char.isLetter (Text.head n)) && notElem p ex -oph _ (Unknown, _) = False - -locname :: (Loc, Text) -> (Text, Text) -locname (Local, n) = ("local", n) -locname (Main, n) = ("main", n) -locname (Base, n) = ("base", n) -locname (Package p, n) = (p, n) -locname (Unknown, n) = ("unknown", n) - -localh :: (Loc, Text) -> Bool -localh (Local, _) = True -localh (Main, _) = True -localh (Base, _) = False -localh (Package _, _) = False -localh (Unknown, _) = True - -data HCountConfig = HCountConfig {hcHiefiles :: [Text], hcExcluded :: [Text], hcTopn :: Int, hcAll :: Bool, hcOperators :: Bool, hcFunctions :: Bool, hcConstructors :: Bool, hcLocals :: Bool} deriving (Show) - -defaultHCountConfig :: HCountConfig -defaultHCountConfig = HCountConfig [".hie"] [] 10 True True True True True - -hc :: Parser HCountConfig -hc = - HCountConfig - <$> fmap - (\x -> bool x [".hie"] (null x)) - ( many $ - OA.option - str - ( metavar "DIR" - <> long "hie-directory" - <> short 'd' - <> help "location of hie directory (default \".hie\")" - ) - ) - <*> many - ( OA.option - str - ( metavar "TEXT" - <> long "excluded-lib" - <> short 'e' - <> help "Libraries to exclude from analysis" - ) - ) - <*> OA.option - auto - ( long "topn" - <> short 't' - <> help "How many names to print" - <> showDefault - <> value 10 - <> metavar "INT" - ) - <*> flag - True - False - ( long "no-all-names" - <> short 'a' - <> help "no report on all names" - <> showDefault - ) - <*> flag - True - False - ( long "no-operators" - <> short 'o' - <> help "no report on operators" - <> showDefault - ) - <*> flag - True - False - ( long "no-functions" - <> short 'f' - <> help "no report on external functions used" - <> showDefault - ) - <*> flag - True - False - ( long "no-constructors" - <> short 'c' - <> help "no report on constructors used" - <> showDefault - ) - <*> flag - True - False - ( long "no-locals" - <> short 'l' - <> help "no report on local names" - <> showDefault - ) - -padl :: Int -> Text -> Text -padl n t = Text.replicate (n - Text.length t) " " <> t - -padr :: Int -> Text -> Text -padr n t = t <> Text.replicate (n - Text.length t) " " - -formatResults :: ((Text, Text), Int) -> Text -formatResults ((l, n), x) = padr 10 l <> padr 10 n <> padl 6 (show x) - --- | current personal run --- --- > myhc = HCountConfig ((\fp -> "../" <> fp <> "/.hie") <$> [ "box","box-csv","box-socket","chart-svg","chart-svg-graphviz","ellipse","ephemeral","formatn","hcount","iqfeed","mealy","numhask","numhask-array","numhask-backprop","numhask-bench","numhask-space","perf","readme-lhs","web-rep"]) ["lucid", "web-rep", "backprop"] 100 True True True True True --- > report myhc --- Number of repos: 19 --- Number of files: 102 --- Total names: 31919 --- Unique names: 3103 --- top names --- total names: 31919 --- --- base $ 828 --- local x 696 --- base fromLabel 613 --- base . 536 --- local a 510 --- numhask * 510 --- base & 499 --- lens .~ 483 --- base <$> 479 --- base <> 422 --- local IsLabel 418 --- lens ^. 411 --- local s 400 --- numhask + 378 --- local c 299 --- local n 284 --- local y 263 --- numhask - 254 --- numhask / 252 --- local showList 250 --- local showsPrec 249 --- local show 242 --- base Show 241 --- local /= 236 --- local == 234 --- Eq 234 --- local f 220 --- base Just 218 --- base Generic 216 --- numhask-spacePoint 205 --- base pure 200 --- local r 182 --- local xs 180 --- numhask zero 176 --- base mempty 173 --- local b 172 --- == 172 --- numhask one 168 --- local p 167 --- local t 164 --- base Nothing 161 --- [] 155 --- local d 151 --- protolude show 143 --- local l 141 --- numhask fromIntegral 140 --- chart-svg Chart 131 --- local e 127 --- local i 110 --- local from 108 --- local to 108 --- protolude bool 105 --- base fmap 97 --- local cs 96 --- base maybe 90 --- local o 87 --- local g 86 --- local m 84 --- local w 83 --- local Epsilon 80 --- local x' 80 --- numhask-spacePointXY 78 --- local go 76 --- : 76 --- base id 75 --- base <*> 74 --- lucid with 74 --- base snd 70 --- local cfg 67 --- base otherwise 67 --- local v 66 --- local z 66 --- lucid term 66 --- base fst 65 --- base zipWith 65 --- chart-svg-graphvizDependency 64 --- web-rep class__ 64 --- local step 61 --- local ts 60 --- pack 57 --- base !! 54 --- numhask negate 54 --- local - 53 --- local Norm 51 --- local a' 51 --- local Distributive 50 --- True 50 --- lens %~ 50 --- local h 48 --- local y' 48 --- base mconcat 47 --- local Signed 46 --- base reverse 45 --- local fromIntegral 44 --- False 44 --- box commit 44 --- chart-svg LineA 44 --- numhask FromIntegral 44 --- lucid toHtml 43 --- numhask pi 43 --- top operators --- total operators: 6330 --- --- base $ 828 --- base . 536 --- numhask * 510 --- base & 499 --- lens .~ 483 --- base <$> 479 --- base <> 422 --- lens ^. 411 --- numhask + 378 --- numhask - 254 --- numhask / 252 --- == 172 --- [] 155 --- : 76 --- base <*> 74 --- base !! 54 --- lens %~ 50 --- && 42 --- () 39 --- < 31 --- bifunctors<<*>> 29 --- base <|> 28 --- > 28 --- numhask .* 24 --- base + 22 --- <= 21 --- numhask ^ 21 --- >= 20 --- numhask :% 20 --- lens ?~ 19 --- || 18 --- numhask :+ 17 --- base * 16 --- base ++ 16 --- (,) 15 --- lens _1 15 --- numhask ** 15 --- base *> 14 --- base - 14 --- box <$.> 13 --- /= 12 --- numhask /. 11 --- base :| 9 --- numhask /\ 9 --- numhask \/ 9 --- numhask-space_x 9 --- numhask-space_y 9 --- base >> 8 --- lens _Just 8 --- numhask-space... 8 --- numhask ^^ 7 --- base <* 6 --- lens .= 6 --- numhask-space>.< 6 --- base <$ 5 --- chart-svg $sel:rstyle:AxisBar 5 --- microlens .~ 5 --- numhask-space|.| 5 --- microlens ^. 4 --- numhask-space|. 4 --- ! 3 --- chart-svg $sel:positions:TickComponents 3 --- chart-svg $sel:xys:Chart 3 --- lens _2 3 --- base $! 2 --- base ** 2 --- base / 2 --- |> 2 --- chart-svg $sel:color':Colour' 2 --- chart-svg $sel:unhud:Hud 2 --- clay ? 2 --- lens %= 2 --- numhask ⊕ 2 --- vector ! 2 --- base $> 1 --- base % 1 --- base =<< 1 --- base >=> 1 --- base >>= 1 --- (,,) 1 --- <| 1 --- box <*.> 1 --- chart-svg $sel:annotation:Chart 1 --- chart-svg $sel:labels:TickComponents 1 --- hmatrix <> 1 --- hmatrix >< 1 --- numhask $c:+ 1 --- numhask $cLogField 1 --- numhask $tComplex 1 --- numhask $tLogField 1 --- numhask *. 1 --- numhask-space+/- 1 --- numhask-space<.> 1 --- numhask-space|<| 1 --- numhask-space|>| 1 --- semigroupoids<.> 1 --- unordered-containers! 1 --- top lower case functions --- total functions: 7250 --- --- base fromLabel 613 --- base pure 200 --- numhask zero 176 --- base mempty 173 --- numhask one 168 --- protolude show 143 --- numhask fromIntegral 140 --- protolude bool 105 --- base fmap 97 --- base maybe 90 --- base id 75 --- base snd 70 --- base otherwise 67 --- base fst 65 --- base zipWith 65 --- pack 57 --- numhask negate 54 --- base mconcat 47 --- base reverse 45 --- box commit 44 --- numhask pi 43 --- chart-svg defaultLineStyle 39 --- chart-svg palette1 36 --- numhask sin 36 --- numhask cos 33 --- base const 32 --- unpack 32 --- box emit 32 --- chart-svg writeChartSvg 31 --- base liftIO 30 --- numhask-spacelower 30 --- base fromIntegral 29 --- base length 29 --- base second 29 --- base fromMaybe 28 --- base take 28 --- base abs 27 --- base zip 27 --- chart-svg defaultHudOptions 27 --- chart-svg ellipse 27 --- max 26 --- min 26 --- chart-svg defaultTextStyle 26 --- numhask floor 26 --- numhask-spaceupper 26 --- base return 25 --- base fromInteger 24 --- box glue 24 --- chart-svg fromV2 24 --- numhask-arrayshape 24 --- attoparsectakeText 23 --- chart-svg defaultGlyphStyle 23 --- foldl fold 23 --- lift 22 --- chart-svg fromRGB 22 --- addDays 21 --- base bimap 20 --- chart-svg defaultRectStyle 20 --- attoparsecchar 19 --- numhask exp 19 --- numhask sum 19 --- base drop 18 --- base fromString 18 --- base show 18 --- adjunctionsindex 18 --- numhask abs 18 --- base foldl' 17 --- adjunctionstabulate 17 --- lens use 17 --- numhask sqrt 17 --- numhask two 17 --- numhask-arrayindex 17 --- base either 16 --- box mapE 16 --- box toStdout 16 --- box-csv int' 16 --- base flip 15 --- base natVal 15 --- base throw 15 --- attoparsecstring 15 --- chart-svg defaultSvgOptions 15 --- mmorph hoist 15 --- numhask fromBaseRational 15 --- numhask-arraytabulate 15 --- numhask-spacefoldRect 15 --- profunctorslmap 15 --- base negate 14 --- base signum 14 --- base toRational 14 --- chart-svg defaultTitle 14 --- chart-svg opac 14 --- numhask-spaceaspect 14 --- numhask-spacefromNominalDiffTime 14 --- numhask-spacespace1 14 --- numhask-spacetoNominalDiffTime 14 --- numhask-spacetoPoint 14 --- numhask-spacetoRect 14 --- addUTCTime 13 --- box-csv double' 13 --- chart-svg setOpac 13 --- top upper case constructors --- total constructors: 4109 --- --- base Show 241 --- Eq 234 --- base Just 218 --- base Generic 216 --- numhask-spacePoint 205 --- base Nothing 161 --- chart-svg Chart 131 --- numhask-spacePointXY 78 --- chart-svg-graphvizDependency 64 --- True 50 --- False 44 --- chart-svg LineA 44 --- numhask FromIntegral 44 --- numhask-spaceRect 42 --- chart-svg Colour 40 --- numhask ToIntegral 37 --- chart-svg RectA 35 --- numhask-spaceRange 34 --- base Functor 31 --- box Box 30 --- numhask Additive 29 --- numhask Multiplicative 29 --- base Left 28 --- chart-svg TextA 28 --- numhask Subtractive 28 --- numhask JoinSemiLattice 27 --- numhask MeetSemiLattice 27 --- numhask-spaceRectXY 27 --- box Emitter 26 --- base Right 25 --- chart-svg GlyphA 25 --- numhask Distributive 25 --- numhask Signed 25 --- numhask-spaceP 25 --- Ord 23 --- foldl Fold 22 --- numhask Epsilon 22 --- base Semigroup 21 --- box Committer 21 --- box Cont 21 --- base Proxy 20 --- reanimate-svgNum 20 --- language-javascriptJSSemi 19 --- numhask BoundedJoinSemiLattice 19 --- numhask InvolutiveRing 19 --- numhask ToRatio 19 --- readme-lhsBlock 19 --- chart-svg PlaceBottom 18 --- language-javascriptJSAstProgram 18 --- language-javascriptJSExpressionStatement 18 --- numhask BoundedMeetSemiLattice 18 --- numhask Integral 18 --- base Foldable 17 --- base Traversable 17 --- numhask Norm 17 --- base Last 16 --- base Monoid 16 --- mealy M 16 --- numhask LogField 16 --- numhask-spaceR 16 --- UTCTime 15 --- base Applicative 14 --- base Read 14 --- chart-svg LineI 14 --- numhask Divisive 14 --- numhask FromInteger 14 --- numhask NumHaskException 14 --- numhask-arrayArray 14 --- chart-svg AnchorStart 13 --- chart-svg Hud 12 --- chart-svg LineCapRound 12 --- chart-svg-graphvizRing 12 --- language-javascriptJSNoAnnot 12 --- numhask Field 12 --- readme-lhsCode 12 --- chart-svg FixedAspect 11 --- chart-svg PathA 11 --- chart-svg PlaceLeft 11 --- chart-svg PlaceRight 11 --- chart-svg-graphvizField 11 --- chart-svg-graphvizNumHaskCluster 11 --- chart-svg AnchorEnd 10 --- chart-svg PlaceTop 10 --- numhask ExpField 10 --- numhask UpperBoundedField 10 --- numhask-spaceMidPos 10 --- chart-svg ArcInfo 9 --- chart-svg ArcPosition 9 --- chart-svg-graphvizAdditive 9 --- chart-svg-graphvizAssociative 9 --- chart-svg-graphvizGroupCluster 9 --- chart-svg-graphvizMultiplicative 9 --- chart-svg-graphvizUnital 9 --- numhask LowerBoundedField 9 --- numhask QuotientField 9 --- numhask-spaceOuterPos 9 --- chart-svg BlankA 8 --- chart-svg ChartSvg 8 --- chart-svg RectStyle 8 --- chart-svg StartI 8 --- top local names --- total local names: 13262 --- --- local x 696 --- local a 510 --- local IsLabel 418 --- local s 400 --- local c 299 --- local n 284 --- local y 263 --- local showList 250 --- local showsPrec 249 --- local show 242 --- local /= 236 --- local == 234 --- local f 220 --- local r 182 --- local xs 180 --- local b 172 --- local p 167 --- local t 164 --- local d 151 --- local l 141 --- local e 127 --- local i 110 --- local from 108 --- local to 108 --- local cs 96 --- local o 87 --- local g 86 --- local m 84 --- local w 83 --- local Epsilon 80 --- local x' 80 --- local go 76 --- local cfg 67 --- local v 66 --- local z 66 --- local step 61 --- local ts 60 --- local - 53 --- local Norm 51 --- local a' 51 --- local Distributive 50 --- local h 48 --- local y' 48 --- local Signed 46 --- local fromIntegral 44 --- local sconcat 42 --- local stimes 42 --- local rx 41 --- local pl 40 --- local aboutEqual 39 --- local phi 39 --- local <$ 38 --- local nearZero 37 --- local ps 37 --- local toIntegral 37 --- local zero 37 --- local c' 36 --- local adj 34 --- local ds 34 --- local epsilon 34 --- local one 33 --- local u 33 --- local mconcat 32 --- local div 31 --- local fmap 31 --- local mod 31 --- local quot 31 --- local rem 31 --- local start 31 --- local Field 30 --- local ry 30 --- local so 30 --- local * 29 --- local + 29 --- local x2 29 --- local xs' 29 --- local negate 28 --- local p1 28 --- local /\ 27 --- local QuotientField 27 --- local Subtractive 27 --- local \/ 27 --- local q 27 --- local ann 26 --- local fa 26 --- local JoinSemiLattice 25 --- local MeetSemiLattice 25 --- local abs 25 --- local conn 25 --- local end 25 --- local sign 25 --- local / 24 --- local > 24 --- local >= 24 --- local compare 24 --- local f' 24 --- local max 24 --- local min 24 --- local pc 24 --- local < 23 +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + +import Control.Monad +import Data.Bifunctor +import Data.ByteString qualified as BS +import Data.Char qualified as Char +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Ord +import Data.String.Interpolate +import FlatParse.Basic qualified as FP +import GHC.Data.FastString +import GHC.Iface.Ext.Binary +import GHC.Iface.Ext.Types +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Unit.Module.Name +import GHC.Unit.Types +import NumHask.Prelude +import Optics.Core +import Options.Applicative as OA +import System.Directory +import System.Directory.Recursive +import System.FilePath +import System.Process + +-- import Language.Haskell.Syntax.Module.Name + +data Options = Options + { arg :: ArgType, + run :: RunType, + stem :: String, + directory :: String, + recursive :: Bool, + exclude :: [String], + topN :: Int + } + deriving (Eq, Show, Generic) + +defaultOptions :: Options +defaultOptions = Options ArgReport RunAll ".hie" "." True [] 10 + +options :: Parser Options +options = + Options + <$> parseCommand + <*> parseRun + <*> option str (value (stem defaultOptions) <> short 's' <> long "stem" <> help "hie files directory") + <*> option str (value (directory defaultOptions) <> long "directory" <> short 'd' <> help "base directory") + <*> switch (long "recursize" <> short 'r' <> help "search recursively") + <*> many (option str (short 'e' <> long "exclude" <> help "libraries to exclude")) + <*> option auto (value (topN defaultOptions) <> short 'n' <> long "topn" <> help "report top N results") + +data RunType = RunAll | RunUpper | RunLocal | RunOperators | RunLower deriving (Eq, Show, Generic) + +data ArgType = ArgReport | ArgAddCpl | ArgBuild | ArgRebuild deriving (Eq, Show, Generic) + +parseRun :: Parser RunType +parseRun = + flag' RunAll (long "all" <> help "all names") + <|> flag' RunOperators (long "operators" <> help "operators") + <|> flag' RunLower (long "lower" <> help "lower-case functions") + <|> flag' RunUpper (long "upper" <> help "upper-case constructors") + <|> flag' RunLocal (long "local" <> help "local variable names") + <|> pure RunAll + +parseCommand :: Parser ArgType +parseCommand = + subparser $ + command "report" (info (pure ArgReport) (progDesc "report counts.")) + <> command "build" (info (pure ArgBuild) (progDesc "build projects")) + <> command "rebuild" (info (pure ArgRebuild) (progDesc "rebuild projects.")) + <> command "addcpl" (info (pure ArgAddCpl) (progDesc "Add a CPL file.")) + +infoOptions :: ParserInfo Options +infoOptions = + info + (options <**> helper) + (fullDesc <> progDesc "hcount" <> header "count Haskell artifacts") + +main :: IO () +main = do + o <- execParser infoOptions + case view #arg o of + ArgReport -> report o + ArgRebuild -> do + n <- rebuild o + putStrLn $ "rebuilt " <> show n <> " packages" + ArgBuild -> do + n <- build o + putStrLn $ "built " <> show n <> " packages" + ArgAddCpl -> do + n <- addcpl o + putStrLn $ "added " <> show n <> " cpl's" + +-- | report to stdout +-- >>> report defaultOptions +-- Number of repos: 1 +-- Number of files: 1 +-- CCon ~ 71 +-- CCon Monad 58 +-- CCon Functor 56 +-- CCon Category 54 +-- CCon Semigroup 50 +-- CCon Eq 49 +-- CVars x 37 +-- CCon Ord 34 +-- CCon FromInteger 29 +-- CCon Show 28 +report :: Options -> IO () +report o = do + fs <- getFiles o + let ns = fs & getNodes & fmap astFlatten & mconcat & getNames & getSimplifiedNames + let n = view #topN o + putStrLn $ "Number of repos: " <> show (length fs) + putStrLn $ "Number of files: " <> show (length $ mconcat fs) + case view #run o of + RunAll -> reportTopX n (const True) printName ns + RunOperators -> reportTopX n (not . FP.isLatinLetter . head . snd) printName ns + RunLower -> reportTopX n (\x -> ((CExt ==) . fst) x && (Char.isLower . head . snd) x) printName ns + RunUpper -> reportTopX n (Char.isUpper . head . snd) printName ns + RunLocal -> reportTopX n (\x -> ((CVars ==) . fst) x && (Char.isLower . head . snd) x) printName ns + +reportTopX :: (Ord a) => Int -> (a -> Bool) -> (a -> String) -> [a] -> IO () +reportTopX n p pr xs = mapM_ putStrLn $ formatCount 20 . first pr <$> Main.top n (filter p xs) + +printName :: (NameCats, String) -> String +printName (c, name) = padr 6 (show c) <> name + +-- | Get the hie files, possibly recursively. +getFiles :: Options -> IO [[HieFile]] +getFiles o = do + dirs <- case view #recursive o of + True -> getSubdirsRecursive (view #directory o) + False -> getDirectoryContents (view #directory o) >>= filterM doesDirectoryExist + let hs = filter (List.isSuffixOf (stem o)) dirs + mapM readHieFiles hs + +-- | Extract the Hie AST +getNodes :: [[HieFile]] -> [HieAST TypeIndex] +getNodes fss = + mconcat fss + & fmap (hie_asts >>> getAsts >>> Map.toList) + & mconcat + & fmap snd + +-- | Extract NodeInfo, throwing structural elements (and everything else) away +astFlatten :: HieAST a -> [NodeInfo a] +astFlatten h = Map.elems (getSourcedNodeInfo $ sourcedNodeInfo h) <> mconcat (fmap astFlatten (nodeChildren h)) + +-- | Extract the 'Name's from the 'NodeInfo' +getNames :: [NodeInfo a] -> [Name] +getNames ns = [x | (Right x) <- idents] + where + idents = fmap (Map.toList . nodeIdentifiers) ns & mconcat & fmap fst + +-- | Simplify 'Name' to the hcount categories and a string. +getSimplifiedNames :: [Name] -> [(NameCats, String)] +getSimplifiedNames ids = allNames + where + xs = ids & fmap toNameX + lxs = view #name <$> filter (\x -> module' x == "") xs + exs = filter (\x -> module' x /= "") xs + allNames = + (second FP.utf8ToStr . rp deconstructLocalName <$> lxs) + <> ((CExt,) . view #name <$> exs) + +-- | A simplified categorization of name types +data NameCats + = -- | Operators ("$_in$$c" prefix) + COps + | -- | Contructors ("$_in$$d" prefix) + CCon + | -- | Variables ("$_in$" prefix) + CVars + | COther + | CError + | -- | external project name + CExt + deriving (Generic, Eq, Ord, Show) + +deconstructLocalName :: FP.Parser () (NameCats, BS.ByteString) +deconstructLocalName = + $( FP.switch + [| + case _ of + "$_in$$d" -> (CCon,) <$> FP.takeRest + "$_in$$c" -> (COps,) <$> FP.takeRest + "$_in$$t" -> (COther,) <$> FP.takeRest + "$_in$$maxtag_" -> (COther,) <$> FP.takeRest + "$_in$$tag2con_" -> (COther,) <$> FP.takeRest + "$_in$$" -> (CError,) <$> FP.takeRest + "$_in$" -> (CVars,) <$> FP.takeRest + _ -> (CError,) <$> FP.takeRest + |] + ) + +package' :: FP.Parser () String +package' = reverse . (\x -> bool id (drop 1) (head x == '-') x) . reverse <$> FP.some (FP.satisfy (not . FP.isDigit)) + +-- | The main data of interest in a 'Name' +data NameX = NameX {name :: String, module' :: String, package :: String} deriving (Generic, Eq, Show, Ord) + +-- | xtrct snsbl nms +toNameX :: Name -> NameX +toNameX n = + bool + (NameX (nameStableString n) "" "") + (NameX (occNameString $ nameOccName n) (moduleNameString $ GHC.Unit.Types.moduleName $ nameModule n) (GHC.Data.FastString.unpackFS $ unitIdFS $ GHC.Unit.Types.moduleUnitId $ nameModule n)) + (isExternalName n) + +-- | count occurrences +count :: (Ord a) => [a] -> Map.Map a Int +count = Map.fromListWith (+) . fmap (,1) + +-- | top n occurrences +top :: (Ord k) => Int -> [k] -> [(k, Int)] +top t xs = take t $ List.sortOn (Down . snd) . Map.toList $ count xs + +-- | run an FP.Parser; leftovers is an error +rp :: FP.Parser () a -> String -> a +rp p s = case FP.runParserUtf8 p s of + FP.OK r "" -> r + _ -> error "parser error" + +-- | run an FP.Parser; leftovers are thrown away +rp' :: FP.Parser () a -> String -> a +rp' p s = case FP.runParserUtf8 p s of + FP.OK r _ -> r + _ -> error "parser error" + +padl :: Int -> String -> String +padl n t = replicate (n - length t) ' ' <> t + +padr :: Int -> String -> String +padr n t = t <> replicate (n - length t) ' ' + +formatCount :: Int -> (String, Int) -> String +formatCount n (s, x) = padr n s <> padl 6 (show x) + +-- | get contents of all @.hie@ files recursively in the given directory +readHieFiles :: FilePath -> IO [HieFile] +readHieFiles hieDir = do + nameCache <- initNameCache 'h' [] + hieContent <- getDirRecursive hieDir + let isHieFile f = (&&) (takeExtension f == ".hie") <$> doesFileExist f + hiePaths <- filterM isHieFile hieContent + + forM hiePaths $ \hiePath -> do + hieFileResult <- readHieFile nameCache hiePath + pure $ hie_file_result hieFileResult + +cpl :: String +cpl = + [i|program-options + ghc-options: + -fwrite-ide-info + -hiedir=.hie|] + +hasCabalFile :: FilePath -> IO Bool +hasCabalFile d = d & listDirectory & fmap (filter ((== ".cabal") . takeExtension) >>> null >>> not) + +hasCPL :: FilePath -> IO Bool +hasCPL d = doesFileExist $ d "cabal.project.local" + +getSubdirs :: FilePath -> IO [FilePath] +getSubdirs d = d & (listDirectory >=> filterM (doesDirectoryExist . (d ))) + +addCPL :: FilePath -> IO Bool +addCPL d = do + b <- (\p c -> not p && c) <$> hasCPL d <*> hasCabalFile d + when b (writeFile (d "cabal.project.local") cpl) + return b + +subdirAction :: Options -> (FilePath -> IO a) -> IO [a] +subdirAction o act = do + xs <- getSubdirs (view #directory o) + let xs' = filter (not . (`elem` view #exclude o)) xs + mapM act ((view #directory o ) <$> xs') + +dirAction :: Options -> (FilePath -> IO a) -> IO [a] +dirAction o act = fmap (: []) (act (view #directory o)) + +recursiveAction :: (FilePath -> IO Bool) -> Options -> IO Int +recursiveAction act o = + sum . fmap (bool 0 1) <$> bool dirAction subdirAction (view #recursive o) o act + +addcpl :: Options -> IO Int +addcpl o = recursiveAction addCPL o + +rebuild :: Options -> IO Int +rebuild o = recursiveAction doRebuild o + +build :: Options -> IO Int +build o = recursiveAction doBuild o + +doRebuild :: FilePath -> IO Bool +doRebuild fp = do + b <- hasCabalFile fp + when b $ do + putStrLn ("rebuilding " <> fp) + withCurrentDirectory + fp + (callCommand "cabal clean && cabal build all") + pure b + +doBuild :: FilePath -> IO Bool +doBuild fp = do + b <- hasCabalFile fp + when b $ do + putStrLn ("rebuilding " <> fp) + withCurrentDirectory + fp + (callCommand "cabal build all") + pure b diff --git a/hcount.cabal b/hcount.cabal --- a/hcount.cabal +++ b/hcount.cabal @@ -1,29 +1,12 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: hcount -version: 0.0.1 -synopsis: Haskell name counts. -description: Counting of Haskell names and artifacts usage, based on stan. - . - === Usage - . - 1. Include the following ghc-options in the cabal file of the libraries you want to analyse: - . - > -fwrite-ide-info - > -hiedir=.hie - . - 2. Install hcount - . - > stack install hcount - . - 3. run hcount - . - > cd project - > hcount - +version: 0.0.2 +synopsis: Haskell artifact name counts. +description: Counting of Haskell names and artifacts usage. category: project author: Tony Day maintainer: tonyday567@gmail.com -copyright: Tony Day (c) AfterTimes +copyright: Tony Day (c) 2024 license: BSD-3-Clause homepage: https://github.com/tonyday567/hcount#readme bug-reports: https://github.com/tonyday567/hcount/issues @@ -32,21 +15,35 @@ type: git location: https://github.com/tonyday567/hcount +common ghc-options-stanza + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + +common ghc2021-stanza + default-language: GHC2021 + executable hcount + import: ghc-options-stanza main-is: hcount.hs hs-source-dirs: app + default-language: GHC2021 build-depends: - attoparsec >= 0.13 && < 0.14, + bytestring >= 0.11 && < 0.13, + dir-traverse >= 0.2.3 && < 0.3, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + flatparse >= 0.5.0 && < 0.6, + process >= 1.6.18 && < 1.7, + optics-core >= 0.4.1 && < 0.5, + string-interpolate >= 0.2.0 && < 0.4, base >= 4.7 && < 5, - containers >= 0.6 && < 0.7, - ghc >= 8.10 && < 8.11, - lens > 4.19 && < 4.20, - numhask >= 0.7 && < 0.8, - optparse-applicative >= 0.15 && < 0.16, - stan >= 0.1 && < 0.2, - text >= 1.2 && < 1.3, - default-language: Haskell2010 - default-extensions: - ghc-options: - -fwrite-ide-info - -hiedir=.hie + containers >= 0.6 && < 0.8, + ghc >= 8.10 && < 9.10, + numhask >= 0.9 && < 0.13, + optparse-applicative >= 0.15 && < 0.19,