4072b92019126b3b6a71c49d1d5701e37aaa9eae
[darcs-mirror-import-analyzer.git] / import-report.hs
1 {-# LANGUAGE RecordWildCards #-}
2
3 import Control.Monad
4 import System.Environment
5 import System.Exit
6 import System.Process
7 import System.IO
8 import System.FilePath
9 import Text.Printf
10 import Text.Parsec
11 import Text.Parsec.Language
12 import Text.Parsec.String
13 import qualified Text.Parsec.Token as T
14 import Data.List
15 import Data.Functor
16 import qualified Data.Map as M
17 import Data.Map (Map)
18 import qualified Data.Set as S
19 import Data.Set (Set)
20 import Data.Maybe
21 import qualified Data.Text.Lazy.IO as Text
22 import qualified Data.Text.Lazy as Text
23 import Data.Char
24 import Data.Either
25 import System.Console.GetOpt
26 import Text.Blaze.Html5 hiding (head, option)
27 import Text.Blaze.Html5.Attributes hiding (id, title, style)
28 import qualified Text.Blaze.Html5 as HTML
29 import qualified Text.Blaze.Html5.Attributes as HTML
30 import Text.Blaze.Renderer.Text (renderMarkup)
31 import Data.Monoid
32
33 options =
34     [ Option [] ["package"] (ReqArg Left "PKG") "package of interest"
35     , Option [] ["html"] (NoArg (Right True))   "html output"
36     ]
37     
38
39 descr = usageInfo "Usage: import-report [OPTION...] pkg-id/mod1.imports pkg-id/mod2.imports ...\n" options
40     ++ unlines [
41         "",
42         "This program analyizes Haskell import statements.",
43         "",
44         "The --package argument can restrict the set of modules we are interested in.",
45         "It will use ghc-pkg to find out the list of modules in that package.",
46         "",
47         "The remaining parameters should be paths to *.imports files as created by",
48         "ghc -ddump-minimal-imports. It is asssumed that the directory name of these",
49         "files is their package name.",
50         "",
51         "It will then generate a CSV value file with these columns:",
52         "module,identifier,number of packages using it",
53         "An artificial entry for module Anything is included to contain the total number",
54         "of packages.",
55         "",
56         "With --html, a shiny HTML report is generated instead."
57         ]
58
59 modulesOf :: String -> IO [String]
60 modulesOf pkg = do
61     let opts = ["field",pkg,"exposed-modules"]
62     output <- readProcess "ghc-pkg" opts ""
63     when (null (words output)) $ do
64         putStr $ "Empty output of ghc-pkg " ++ unwords opts
65         exitFailure
66     when (head (words output) /= "exposed-modules:") $ do
67         putStr $ "Failed to parse output of ghc-pkg " ++ unwords opts
68         exitFailure
69     return (tail (words output))
70
71
72 type Import = (String, Maybe String)
73
74 -- Map from package
75 type ImportMap = Map String (Set Import)
76
77 -- Map from id
78 type ImportStats = [(Import, Int)]
79
80 -- Fix haskell (_ may be the beginning of an identifier)
81 T.TokenParser {..} = T.makeTokenParser (haskellDef {
82     T.identStart = letter <|> oneOf "_",
83     T.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" <|> satisfy (not.isAscii),
84     T.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" <|> satisfy (not.isAscii),
85     T.reservedNames = []
86     })
87
88 parseModuleName :: Parser String
89 parseModuleName = intercalate "." <$> identifier `sepBy` char '.'
90
91 parseOp :: Parser String
92 parseOp =
93     ((\s -> "(" ++ s ++ ")") <$> (lexeme $ between (char '(') (char ')') operator)) <?> "operator"
94
95 parseName :: Parser String
96 parseName = do
97     optional (reserved "type")
98     parseOp <|> identifier
99
100 parseId :: Parser [String]
101 parseId = do
102     i <- parseName
103     more <- option [] (parens (commaSep (reservedOp ".." <|> void parseName)))
104     return $ if null more then [i] else [i, i++"(..)"]
105
106 importParser :: Parser [Import]
107 importParser = do
108     reserved "import"
109     optional $ reserved "safe"
110     optional $ reserved "qualified"
111     optional $ stringLiteral
112     mod <- parseModuleName
113     optional $ reserved "as" >> parseModuleName
114     ids <- concat <$> parens (commaSep parseId)
115     return $ (mod, Nothing) : [ (mod, Just id) | id <- ids ]
116
117
118 importsParser :: Parser [Import]
119 importsParser = between whiteSpace eof (concat <$> many importParser)
120
121 readImports :: FilePath -> IO ImportMap
122 readImports fn = do
123     let pkgName = last $ init $ splitDirectories $ fn
124     contents <- Text.unpack <$> Text.readFile fn
125     case parse importsParser fn contents of
126         Left err -> do
127             hPrintf stderr "Failed to parse import specification:\n"
128             hPutStrLn stderr (show err)
129             exitFailure
130         Right imps -> do
131             let imps = either (error.show) id $ parse importsParser fn contents
132             return $ M.singleton pkgName $ S.fromList imps
133
134 printCSV :: [String] -> [String] -> ImportStats -> IO ()
135 printCSV _ pkg stats = do
136     printf "%s,%s,%d\n" "Anything" "" (length pkg)
137     forM_ stats $ \((m,i),n) -> 
138         printf "%s,%s,%d\n" m (fromMaybe "" i) (n::Int)
139     
140
141 printHTML :: [String] -> [String] -> ImportStats -> IO ()
142 printHTML interesting pkgs stats = do
143     Text.putStr $ renderMarkup $ do
144     docType
145     html $ do
146         HTML.head $ do
147             title $ toMarkup "Import analyis"
148             link ! rel (toValue "stylesheet") ! type_ (toValue "text/css") ! href (toValue "style.css")
149             script ! src (toValue "jquery.js") $ mempty
150             script ! src (toValue "script.js") $ mempty
151         body $ HTML.div ! HTML.id (toValue "content") $ do
152             h1 $ toMarkup "Import analysis"
153             p $ toMarkup $ "This page analyses the import statements of " ++ show (length pkgs) ++ " Haskell packages and counts the number of imports of each module and symbol from the list of interesting packages (in this case: " ++ concat (intersperse ", " interesting) ++ ")."
154             table $ do
155                 thead $ tr $ do
156                     th mempty
157                     th (toMarkup "Module/symbol")
158                     th (toMarkup "used by")
159                     th mempty
160                 tbody $ do
161                     modRow "Anything" (length pkgs)
162                     mconcat [ case i of
163                                 Just i -> idRow i n
164                                 Nothing -> modRow m n
165                             | ((m,i),n) <- stats ]
166             p $ do
167                 toMarkup $ "These packages were analized in the making of this report: "
168                 toMarkup $ concat $ intersperse ", " pkgs
169             HTML.div ! HTML.id (toValue "footer") $ do
170                 p $ do
171                     toMarkup "Report generated by "
172                     a ! href (toValue "mailto:mail@joachim-breitner.de") $
173                         toMarkup "Joachim Breitner"
174                     toMarkup ". "
175                     a ! href (toValue "http://darcs.nomeata.de/import-analizer") $ 
176                         toMarkup "Source"
177                     toMarkup " available."
178  where
179     collapse = toMarkup ""
180     modRow m n = 
181         tr ! class_ (toValue "modrow") $ do
182             td ! class_ (toValue "expander") $ collapse
183             td ! class_ (toValue "name")     $ toMarkup m
184             td ! class_ (toValue "count")    $ toMarkup n
185             td ! class_ (toValue "graph")    $ mempty
186     idRow i n = 
187         tr ! class_ (toValue "idrow") ! hidden (toValue "hidden")  $ do
188             td mempty
189             td ! class_ (toValue "name")     $ toMarkup i
190             td ! class_ (toValue "count")    $ toMarkup n
191             td ! class_ (toValue "graph")    $ mempty
192
193 main = do
194     argv <- getArgs
195     (pkgs, html, importFiles) <- case getOpt RequireOrder options argv of
196         (o,n,[]) | not (null n) -> return (lefts o, or (rights o), n)  
197         (o,_,e) -> do
198             hPutStr stderr (concat e)
199             hPutStr stderr descr
200             exitFailure
201             
202     interestingModules <- S.fromList . concat <$> mapM modulesOf pkgs
203     unless (null pkgs) $
204         hPrintf stderr "Found %d interesting modules.\n" (S.size interestingModules)
205
206     importMap <- M.unionsWith (S.union) <$> mapM readImports importFiles
207     hPrintf stderr "Analized imports from %d packages.\n" (M.size importMap)
208     -- Invert the stats
209     let stats = M.unionsWith (+) [
210             M.singleton imp 1
211             |   imps <- M.elems importMap
212             ,   imp <- S.toList imps
213             ]
214     hPrintf stderr "Found %d imported symbols in total.\n" (M.size stats)
215     let filtered =
216             if null pkgs
217             then stats
218             else  M.filterWithKey (\(m,_) _ -> m `S.member` interestingModules) stats
219     unless (null pkgs) $
220         hPrintf stderr "Found %d imported symbols from selected packages.\n" (M.size filtered)
221
222     let sorted = flip sortBy (M.toAscList filtered) $ \((m1,i1),n1) ((m2,i2),n2) ->
223             if m1 == m2 then
224                 if isNothing i1 then LT else
225                 if isNothing i2 then GT else
226                 n2 `compare` n1
227             else (filtered M.! (m2,Nothing)) `compare` (filtered M.! (m1,Nothing))
228
229     (if html then printHTML else printCSV) pkgs (M.keys importMap) sorted