diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2013 Nikolaos Bezirgiannis, Johan Jeuring, Sean Leather +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of Johan Jeuring nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README.html b/README.html new file mode 100644 --- /dev/null +++ b/README.html @@ -0,0 +1,52 @@ + + + + + + + + + +

GP analysis of Hackage README

+

For the report and documentation of the project, check the file report.pdf

+

There is also the presentation we gave at the file presentation.pdf

+

Building

+
runghc Setup.lhs configure
+runghc Setup.lhs build
+runghc Setup.lhs install
+

Before running

+

You have to fetch the the entire hackage repository and its activity log. You can automatically do that with:

+
gpah --fetch
+

Running the analysis

+

After building the program, run it with

+

gpah args

+
Generic Programming Use in Hackage Project v0.0.1
+
+gpah [OPTIONS]
+
+Common flags:
+     --fetch                Fetch the Hackage archive tarball and Hackage
+                            activity log
+  -d --deriving[=FILE]      Run the deriving analysis and output it to the
+                            specified file
+  -f --function[=FILE]      Run the function analysis and output it to the
+                            specified file
+  -u --uniplate[=FILE]      Run the uniplate analysis and output it to the
+                            specified file
+  -h --misc_hackage[=FILE]  Print general analysis info or output it to the
+                            specified file
+  -t --misc_date[=FILE]     Get syb+uniplate date info and output it to the
+                            specified file (implies --misc_hackage)
+     --hackage-dir=DIR      Set the hackage archive directory
+     --hackage-log=FILE     Set the hackage archive log file
+  -c --cpp[=FILE]           Run preprocessing in hackage that yields an
+                            analysis with less failed-to-parse modules
+  -i --interpret[=FILE]     Do type-checking interpretation on modules that
+                            depend on SYB or Uniplate
+  -e --derive[=FILE]        Do analysis on packages that build on derive
+  -? --help                 Display help message
+  -V --version              Print version information
+

For a detailed description of the accepted arguments run:

+

gpah --help

+ + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ +# GP analysis of Hackage README + +For the report and documentation of the project, check the file `report.pdf` + +There is also the presentation we gave at the file `presentation.pdf` + +## Building + +~~~ +runghc Setup.lhs configure +runghc Setup.lhs build +runghc Setup.lhs install +~~~ + + +# Before running + +You have to fetch the the entire hackage repository and its activity log. You can automatically do that with: + +~~~ +gpah --fetch +~~~ + + +## Running the analysis + +After building the program, run it with + +`gpah args` + +~~~ +Generic Programming Use in Hackage Project v0.0.1 + +gpah [OPTIONS] + +Common flags: + --fetch Fetch the Hackage archive tarball and Hackage + activity log + -d --deriving[=FILE] Run the deriving analysis and output it to the + specified file + -f --function[=FILE] Run the function analysis and output it to the + specified file + -u --uniplate[=FILE] Run the uniplate analysis and output it to the + specified file + -h --misc_hackage[=FILE] Print general analysis info or output it to the + specified file + -t --misc_date[=FILE] Get syb+uniplate date info and output it to the + specified file (implies --misc_hackage) + --hackage-dir=DIR Set the hackage archive directory + --hackage-log=FILE Set the hackage archive log file + -c --cpp[=FILE] Run preprocessing in hackage that yields an + analysis with less failed-to-parse modules + -i --interpret[=FILE] Do type-checking interpretation on modules that + depend on SYB or Uniplate + -e --derive[=FILE] Do analysis on packages that build on derive + -? --help Display help message + -V --version Print version information +~~~ + +For a detailed description of the accepted arguments run: + +`gpah --help` diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/gpah.cabal b/gpah.cabal new file mode 100644 --- /dev/null +++ b/gpah.cabal @@ -0,0 +1,79 @@ +name: gpah +version: 0.0.1 +synopsis: Generic Programming Use in Hackage +description: Generic Programming Use in Hackage: +category: Generics +copyright: (c) 2013 Nikolaos Bezirgiannis, Johan Jeuring, Sean Leather +license: BSD3 +license-file: LICENSE +author: Nikolaos Bezirgiannis, Johan Jeuring, Sean Leather +maintainer: n.bezirgiannis@students.uu.nl +stability: provisional +extra-source-files: README.html, + README.md +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.6.1 + +Executable gpah + Main-is: Generics/GPAH/Main.hs + build-depends: base >= 3.0 && < 5, + cmdargs, + haskell-src-exts, + filepath, + Cabal >= 1.16.0, + directory, + deepseq, + bytestring, + containers >= 0.4.2.0, + syb, + uniplate, + process, + csv, + hint, + network, + HTTP, + tar, + zlib, + uu-parsinglib + ghc-options: -rtsopts -with-rtsopts=-K50m + hs-source-dirs: src + other-modules: Generics.GPAH.Base, + Generics.GPAH.Conf, + Generics.GPAH.Cpp, + Generics.GPAH.Cpp.Analyze + Generics.GPAH.Cpp.Base + Generics.GPAH.Cpp.PPrint + Generics.GPAH.Date, + Generics.GPAH.Date.Analyze + Generics.GPAH.Date.Base + Generics.GPAH.Date.PPrint + Generics.GPAH.Derive, + Generics.GPAH.Derive.Analyze + Generics.GPAH.Derive.Base + Generics.GPAH.Derive.PPrint + Generics.GPAH.Deriving, + Generics.GPAH.Deriving.Analyze + Generics.GPAH.Deriving.Base + Generics.GPAH.Deriving.PPrint + Generics.GPAH.Function, + Generics.GPAH.Function.Analyze + Generics.GPAH.Function.Base + Generics.GPAH.Function.PPrint + Generics.GPAH.Hackage, + Generics.GPAH.Hackage.Analyze + Generics.GPAH.Hackage.Base + Generics.GPAH.Hackage.PPrint + Generics.GPAH.Interp, + Generics.GPAH.Interp.Analyze + Generics.GPAH.Interp.Base + Generics.GPAH.Interp.PPrint + Generics.GPAH.Upl, + Generics.GPAH.Upl.Analyze + Generics.GPAH.Upl.Base + Generics.GPAH.Upl.PPrint + Generics.GPAH.Utils + + + + diff --git a/src/Generics/GPAH/Base.hs b/src/Generics/GPAH/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Base.hs @@ -0,0 +1,53 @@ +module Generics.GPAH.Base where + +import qualified Generics.GPAH.Cpp.Base as Cpp +import qualified Generics.GPAH.Deriving.Base as Deriving +import qualified Generics.GPAH.Function.Base as Function +import qualified Generics.GPAH.Upl.Base as Upl +import qualified Generics.GPAH.Hackage.Base as Hackage +import qualified Generics.GPAH.Date.Base as Date +import qualified Generics.GPAH.Interp.Base as Interp +import qualified Generics.GPAH.Derive.Base as Derive + +import Data.Maybe + +import Control.DeepSeq + +import Data.Monoid + +data Analysis = Analysis { + cppAnalysis :: Cpp.Analysis + , derAnalysis :: Deriving.Analysis + , funAnalysis :: Function.Analysis + , uplAnalysis :: Upl.Analysis + , hacAnalysis :: Hackage.Analysis + , dteAnalysis :: Date.Analysis + , intAnalysis :: Interp.Analysis + , dveAnalysis :: Derive.Analysis + } + deriving (Show) + +instance NFData Analysis where + rnf (Analysis a1 a2 a3 a4 a5 a6 a7 a8) = a1 + `deepseq` a2 + `deepseq` a3 + `deepseq` a4 + `deepseq` a5 + `deepseq` a6 + `deepseq` a7 + `deepseq` a8 + `deepseq` () + + +instance Monoid Analysis where + mempty = Analysis mempty mempty mempty mempty mempty mempty mempty mempty + (Analysis x1 x2 x3 x4 x5 x6 x7 x8) `mappend` (Analysis y1 y2 y3 y4 y5 y6 y7 y8) = Analysis + (mappend x1 y1) + (mappend x2 y2) + (mappend x3 y3) + (mappend x4 y4) + (mappend x5 y5) + (mappend x6 y6) + (mappend x7 y7) + (mappend x8 y8) + diff --git a/src/Generics/GPAH/Conf.hs b/src/Generics/GPAH/Conf.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Conf.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Generics.GPAH.Conf where + +import System.IO.Unsafe +import System.Console.CmdArgs +import Control.Monad +import Data.Maybe (maybe) + +-- easier to have a top-level state for the conf +conf = unsafePerformIO getConf + +getConf = cmdArgs confOpt + +data Conf = Conf { + fetchOpt :: Bool + , derivingOpt :: Maybe FilePath + , functionOpt :: Maybe FilePath + , uniplateOpt :: Maybe FilePath + , hackageOpt :: Maybe FilePath + , dateOpt :: Maybe FilePath + , hackageDirOpt :: FilePath + , hackageLogOpt :: FilePath + , cppOpt :: Maybe FilePath + , intOpt :: Maybe FilePath + , dveOpt :: Maybe FilePath + } deriving (Show, Eq, Data, Typeable) + +hasSubComponent :: Conf -> Bool +hasSubComponent (Conf fet der fun upl hac dte _ _ cpp int dve) = + maybe False (const True) + (der `mplus` fun `mplus` upl `mplus` hac `mplus` dte `mplus` cpp `mplus` int `mplus` dve) + +confOpt = Conf { + fetchOpt = def &= explicit &= name "fetch" &= typFile &= help "Fetch the Hackage archive tarball and Hackage activity log" + , derivingOpt = def &= explicit &= name "d" &= name "deriving" &= opt "d_analysis.csv" &= typFile &= help "Run the deriving analysis and output it to the specified file" + , functionOpt = def &= explicit &= name "f" &= name "function" &= opt "f_analysis.csv" &= typFile &= help "Run the function analysis and output it to the specified file" + , uniplateOpt = def &= explicit &= name "u" &= name "uniplate" &= opt "uni_analysis.csv" &= typFile &= help "Run the uniplate analysis and output it to the specified file" + , hackageOpt = def &= explicit &= name "h" &= name "misc_hackage" &= opt "misc_hackage.csv" &= typFile &= help "Print general analysis info or output it to the specified file" + , dateOpt = def &= explicit &= name "t" &= name "misc_date" &= opt "misc_date.csv" &= typFile &= help "Get syb+uniplate date info and output it to the specified file (implies --misc_hackage)" + , hackageDirOpt = "hackage" &= explicit &= name "hackage-dir" &= typDir &= help "Set the hackage archive directory" + , hackageLogOpt = "hackage.log" &= explicit &= name "hackage-log" &= typFile &= help "Set the hackage archive log file" + , cppOpt = def &= explicit &= name "c" &= name "cpp" &= opt "c_analysis.csv" &= typFile &= help "Run preprocessing in hackage that yields an analysis with less failed-to-parse modules" + , intOpt = def &= explicit &= name "i" &= name "interpret" &= opt "i_analysis.csv" &= typFile &= help "Do type-checking interpretation on modules that depend on SYB or Uniplate " + , dveOpt = def &= explicit &= name "e" &= name "derive" &= opt "e_analysis.csv" &= typFile &= help "Do analysis on packages that build on derive" + } &= summary "Generic Programming Use in Hackage Project v0.0.1" &= program "gpah" + + diff --git a/src/Generics/GPAH/Cpp.hs b/src/Generics/GPAH/Cpp.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Cpp.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Cpp ( + module Generics.GPAH.Cpp.Base + ,module Generics.GPAH.Cpp.Analyze + ,module Generics.GPAH.Cpp.PPrint + ) +where + +import Generics.GPAH.Cpp.Base +import Generics.GPAH.Cpp.Analyze +import Generics.GPAH.Cpp.PPrint diff --git a/src/Generics/GPAH/Cpp/Analyze.hs b/src/Generics/GPAH/Cpp/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Cpp/Analyze.hs @@ -0,0 +1,16 @@ +module Generics.GPAH.Cpp.Analyze where + +import Generics.GPAH.Cpp.Base +import System.Process +import System.Exit +import Text.Printf +import Generics.GPAH.Utils +import Distribution.PackageDescription + +analyzeModule :: FilePath -> FilePath -> GenericPackageDescription -> IO Analysis +analyzeModule fp pkgAbsDir cabal = do + let cmd = (shell + (printf "ghc -cpp -E -optP-P %s %s -Wwarn %s" (cppOpts cabal) (ghcOpts cabal) fp) + ) -- {cwd = Just pkgAbsDir} + exitCode <- createProcess cmd >>= \ (_,_,_,ph) -> waitForProcess ph + return $ if exitCode == ExitSuccess then [] else [fp] diff --git a/src/Generics/GPAH/Cpp/Base.hs b/src/Generics/GPAH/Cpp/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Cpp/Base.hs @@ -0,0 +1,3 @@ +module Generics.GPAH.Cpp.Base where + +type Analysis = [String] -- failed-to-cpp modules diff --git a/src/Generics/GPAH/Cpp/PPrint.hs b/src/Generics/GPAH/Cpp/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Cpp/PPrint.hs @@ -0,0 +1,17 @@ +module Generics.GPAH.Cpp.PPrint where + +import Generics.GPAH.Cpp.Base +import Text.CSV +import System.IO + + +pprint :: Analysis -> FilePath -> IO () +pprint x fp = do + let p = [["FailedToCppModules", show $ length x] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Cpp Results:\n###############" + putStrLn pCSV diff --git a/src/Generics/GPAH/Date.hs b/src/Generics/GPAH/Date.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Date.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Date ( + module Generics.GPAH.Date.Base + ,module Generics.GPAH.Date.Analyze + ,module Generics.GPAH.Date.PPrint + ) +where + +import Generics.GPAH.Date.Base +import Generics.GPAH.Date.Analyze +import Generics.GPAH.Date.PPrint diff --git a/src/Generics/GPAH/Date/Analyze.hs b/src/Generics/GPAH/Date/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Date/Analyze.hs @@ -0,0 +1,45 @@ +module Generics.GPAH.Date.Analyze where + +import Generics.GPAH.Utils +import Generics.GPAH.Date.Base +import qualified Generics.GPAH.Base +import qualified Generics.GPAH.Hackage.Base as Hackage + +import Data.List +import qualified Data.Map as M +import Data.Function (on) +import Data.Monoid + + +yearUpdatesToLib :: [String] -> [(Int, String)] -> M.Map Int Int +yearUpdatesToLib favLibs cLog = foldl (\ acc (year, pkg) -> if pkg `elem` favLibs + then M.insertWith (+) year 1 acc + else acc) + M.empty cLog +yearNewToLib favLibs cLog = yearUpdatesToLib favLibs (nubBy ((==) `on` snd) cLog) + + +cleanLog :: [[String]] -> [(Int, String)] +cleanLog = map cleanLog' where + --cleanLog' [String] -> (PackageName, Year, Month) + cleanLog' [_, _, _, _, _, y, _, pkg, _] = (read y :: Int, pkg) + + +analyzeHackageLog :: String -> Generics.GPAH.Base.Analysis -> Generics.GPAH.Base.Analysis +analyzeHackageLog contents a = let hacTime = unwords $ take 6 $ words $ last $ lines contents + log = map words $ lines contents :: [[String]] + cLog = cleanLog log + pus = M.findWithDefault [] "syb" $ (Hackage.reverseDeps . Generics.GPAH.Base.hacAnalysis) a -- packages that use syb + puu = M.findWithDefault [] "uniplate" $ (Hackage.reverseDeps . Generics.GPAH.Base.hacAnalysis) a -- packages that use uniplate + pud = M.findWithDefault [] "derive" $ (Hackage.reverseDeps . Generics.GPAH.Base.hacAnalysis) a -- packages that use uniplate + -- construct a new base analysis and adds the date analysis + in mempty {Generics.GPAH.Base.dteAnalysis = Analysis + (yearUpdatesToLib pus cLog) + (yearUpdatesToLib puu cLog) + (yearNewToLib pus cLog) + (yearNewToLib puu cLog) + hacTime + (yearUpdatesToLib pud cLog) + (yearNewToLib pud cLog) + } + diff --git a/src/Generics/GPAH/Date/Base.hs b/src/Generics/GPAH/Date/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Date/Base.hs @@ -0,0 +1,39 @@ +module Generics.GPAH.Date.Base where + +import Control.DeepSeq +import Data.Monoid + +import qualified Data.Map as M + +data Analysis = Analysis { + yearUpdatesToSyb :: M.Map Int Int + , yearUpdatesToUpl :: M.Map Int Int + , yearNewToSyb :: M.Map Int Int + , yearNewToUpl :: M.Map Int Int + , hackageTime :: String + , yearUpdatesToDerive :: M.Map Int Int + , yearNewToDerive :: M.Map Int Int + } + deriving (Show) + +instance Monoid Analysis where + mempty = Analysis mempty mempty mempty mempty mempty mempty mempty + (Analysis x1 x2 x3 x4 x5 x6 x7) `mappend` (Analysis y1 y2 y3 y4 y5 y6 y7) = Analysis + (M.unionWith (+) x1 y1) + (M.unionWith (+) x2 y2) + (M.unionWith (+) x3 y3) + (M.unionWith (+) x4 y4) + (x5 ++ y5) + (M.unionWith (+) x6 y6) + (M.unionWith (+) x7 y7) + +instance NFData Analysis where + rnf (Analysis a1 a2 a3 a4 a5 a6 a7) = a1 + `deepseq` a2 + `deepseq` a3 + `deepseq` a4 + `deepseq` a5 + `deepseq` a6 + `deepseq` a7 + `deepseq` () + diff --git a/src/Generics/GPAH/Date/PPrint.hs b/src/Generics/GPAH/Date/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Date/PPrint.hs @@ -0,0 +1,23 @@ +module Generics.GPAH.Date.PPrint where + +import Generics.GPAH.Date.Base +import System.IO +import qualified Data.Map as M +import Text.CSV + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis a1 a2 a3 a4 a5 a6 a7) fp = do + let p = [["HackageArchiveCloneTime", a5], + ["YearlyUpdatesToPackagesUsingSyb", show $ M.toList a1], + ["YearlyUpdatesToPackagesUsingUniplate", show $ M.toList a2], + ["YearlyUpdatesToPackagesUsingDerive", show $ M.toList a6], + ["YearlyNewPackagesUsingSyb", show $ M.toList a3], + ["YearlyNewPackagesUsingUniplate", show $ M.toList a4], + ["YearlyNewPackagesUsingDerive", show $ M.toList a7] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Date Results:\n###############" + putStrLn pCSV diff --git a/src/Generics/GPAH/Derive.hs b/src/Generics/GPAH/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Derive.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Derive ( + module Generics.GPAH.Derive.Base + ,module Generics.GPAH.Derive.Analyze + ,module Generics.GPAH.Derive.PPrint + ) +where + +import Generics.GPAH.Derive.Base +import Generics.GPAH.Derive.Analyze +import Generics.GPAH.Derive.PPrint diff --git a/src/Generics/GPAH/Derive/Analyze.hs b/src/Generics/GPAH/Derive/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Derive/Analyze.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} +module Generics.GPAH.Derive.Analyze where + +import Generics.GPAH.Derive.Base +import qualified Generics.GPAH.Hackage.Base as Hackage +import qualified Data.Map as M +import Data.Monoid +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances +import Text.ParserCombinators.UU.Utils + +import Generics.SYB + + +analyzeModule :: ParseResult (Module, [Comment]) -> Hackage.Analysis -> Analysis +analyzeModule (ParseOk (m, c)) hacPkg = Analysis + (runDeriveTH m hacPkg) + (runDerivePP c) + (runDriftPP c) + (runDriftGL c) +analyzeModule _ _ = mempty + +runDeriveTH :: Module -> Hackage.Analysis -> M.Map String Int +runDeriveTH m hacPkg | "derive" `elem` (M.keys (Hackage.reverseDeps hacPkg)) = everything (M.unionWith (+)) (mempty `mkQ` thDecl) m + where + thDecl :: Splice -> M.Map String Int + thDecl (ParenSplice (App (App (Var (UnQual (Ident "derive"))) (Var (UnQual (Ident class_)))) (TypQuote (UnQual (Ident dt))))) = M.singleton class_ 1 + thDecl (ParenSplice (App (App (Var (UnQual (Ident "derive"))) (Var (UnQual (Ident class_)))) (List dts))) = M.singleton class_ (length dts) + thDecl (ParenSplice (App (App (Var (UnQual (Ident "derive"))) (List classes_ids)) (TypQuote (UnQual (Ident dt))))) = let classes = map (\ (Var (UnQual (Ident class_))) -> class_) classes_ids + in + M.fromList (zip classes (repeat 1)) + thDecl (ParenSplice (App (App (Var (UnQual (Ident "derive"))) (List classes_ids)) (List dts))) = let classes = map (\ (Var (UnQual (Ident class_))) -> class_) classes_ids + in + M.fromList (zip classes (repeat (length dts))) + thDecl _ = mempty +runDeriveTH _ _ = mempty + + +runDerivePP :: [Comment] -> M.Map String Int +runDerivePP cs = foldl (\ m r -> M.insertWith (+) r 1 m) mempty $ concatMap (\ (Comment ml _ s) -> case (ml, execParser pDerivePP s) of + (True, (res, [])) -> res + _ -> [] -- error in parsing or single-line + ) cs + +runDriftPP :: [Comment] -> M.Map String Int +runDriftPP cs = foldl (\ m r -> M.insertWith (+) r 1 m) mempty $ concatMap (\ (Comment _ _ s) -> case execParser pDriftPP s of + (res, []) -> res + _ -> [] -- error in parsing + ) cs + + +runDriftGL :: [Comment] -> M.Map String Int +runDriftGL cs =foldl (\ m r -> M.insertWith (+) r 1 m) mempty $ concatMap (\ (Comment _ _ s) -> case execParser pDriftGL s of + (res, []) -> res + _ -> [] -- error in parsing + ) cs + + +pDerivePP :: Parser [String] +pDerivePP = deriveStandalone <|> deriveInline + where + deriveInline :: Parser [String] + deriveInline = pSym '!' *> pList1Sep (pSym ',') pcl <* pSpaces <* pSym '!' + where + pcl :: Parser String + pcl =foldl1 (<|>) (map (\ c -> pSpaces *> pToken c) deriveClasses) + deriveStandalone :: Parser [String] + deriveStandalone = pSym '!' *> pSpaces *> pToken "deriving" *> pSpaces *> pToken "instance" *> pList1Sep (pSym ',') pcl <* pSpaces <* pSym '!' + where + pcl :: Parser String + pcl =foldl1 (<|>) (map (\ c -> pSpaces *> pToken c) deriveClasses) + +pDriftPP :: Parser [String] +pDriftPP = driftInline <|> driftStandalone + where + driftInline :: Parser [String] + driftInline = pSym '!' *> pSpaces *> pToken "derive:" *> pList1Sep (pSym ',') pcl <* pSpaces <* pSym '!' + where + pcl :: Parser String + pcl =foldl1 (<|>) (map (\ c -> pSpaces *> pToken c) driftClasses) + driftStandalone :: Parser [String] + driftStandalone = pSym '!' *> pSpaces *> pToken "for" *> pSpaces *> pMunch (`notElem` " \n\r") *> pSpaces *> pToken "derive:" *> pList1Sep (pSym ',') pcl <* pSpaces <* pSym '!' + where + pcl :: Parser String + pcl =foldl1 (<|>) (map (\ c -> pSpaces *> pToken c) driftClasses) + +pDriftGL :: Parser [String] +pDriftGL = driftGlobal + where + driftGlobal :: Parser [String] + driftGlobal = pSym '!' *> pSpaces *> pToken "global:" *> pList1Sep (pSym ',') pcl <* pSpaces <* pSym '!' + where + pcl :: Parser String + pcl =foldl1 (<|>) (map (\ c -> pSpaces *> pToken c) driftClasses) + diff --git a/src/Generics/GPAH/Derive/Base.hs b/src/Generics/GPAH/Derive/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Derive/Base.hs @@ -0,0 +1,131 @@ +module Generics.GPAH.Derive.Base where + +import qualified Data.Map as M +import Control.DeepSeq +import Data.Monoid + +data Analysis = Analysis { + deriveTH :: M.Map String Int-- derive directive strings + , derivePP :: M.Map String Int + , driftPP :: M.Map String Int + , driftGL :: M.Map String Int + } + deriving (Show) + +instance Monoid Analysis where + mempty = Analysis mempty mempty mempty mempty + (Analysis x1 x2 x3 x4) `mappend` (Analysis y1 y2 y3 y4) = Analysis + (M.unionWith (+) x1 y1) + (M.unionWith (+) x2 y2) + (M.unionWith (+) x3 y3) + (M.unionWith (+) x4 y4) +instance NFData Analysis where + rnf (Analysis a1 a2 a3 a4) = a1 + `deepseq` a2 + `deepseq` a3 + `deepseq` a4 + `deepseq` () + + + +deriveClasses = ["Arbitrary", + "ArbitraryOld", + "Arities", + "Binary", + "BinaryDefer", + "Bounded", + "Data", + "DataAbstract", + "Default", + "Enum", + "EnumCyclic", + "Eq", + "Fold", + "Foldable", + "From", + "Fucntor", + "Has", + "Is", + "JSON", + "LazySet", + "Lens", + "Monoid", + "NFData", + "Ord", + "Read", + "Ref", + "Serial", + "Serialize", + "Set", + "Show", + "Traversable", + "Typeable", + "UniplateDirect", + "UniplateTypeable", + "Update"] + + +driftClasses = ["Binary", + "GhcBinary", + "Observable", + "NFData", + "Typeable", + "FuncotrM", + "HFoldable", + "Monoid", + "RMapM", + "Term", + "Bounded", + "Enum", + "Eq", + "Ord", + "Read", + "Show", + "ATermConvertible", + "Haskell2Xml", + "XmlContent", + "Parse", + "Query", + "from", + "get", + "has", + "is", + "test", + "un", + "update"] + + +defaultDerivations = ["makeArbitrary", + "makeArbitraryOld", + "makeArities", + "makeBinary", + "makeBinaryDefer", + "makeBounded", + "makeData", + "makeDataAbstract", + "makeDefault", + "makeEnum", + "makeEnumCyclic", + "makeEq", + "makeFold", + "makeFoldable", + "makeFrom", + "makeFunctor", + "makeHas", + "makeIs", + "makeJSON", + "makeLazySet", + "makeMonoid", + "makeNFData", + "makeOrd", + "makeRead", + "makeRef", + "makeSerial", + "makeSerialize", + "makeSet", + "makeShow", + "makeTraversable", + "makeTypeable", + "makeUniplateDirect", + "makeUniplateTypeable", + "makeUpdate"] diff --git a/src/Generics/GPAH/Derive/PPrint.hs b/src/Generics/GPAH/Derive/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Derive/PPrint.hs @@ -0,0 +1,22 @@ +module Generics.GPAH.Derive.PPrint where + +import Generics.GPAH.Derive.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.Function +import Data.List + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis a1 a2 a3 a4) fp = do + let p = [["DeriveTemplateHaskellDirectives", show $ sortBy (flip compare `on` snd) $ M.toList a1] + ,["DerivePreprocessingDirectives", show $ sortBy (flip compare `on` snd) $ M.toList a2] + ,["DrIFTNormalDirectives", show $ sortBy (flip compare `on` snd) $ M.toList a3] + ,["DrIFTGlobalDirectives", show $ sortBy (flip compare `on` snd) $ M.toList a4] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Derive+DrIFT Results:\n###############" + putStrLn pCSV diff --git a/src/Generics/GPAH/Deriving.hs b/src/Generics/GPAH/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Deriving.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Deriving ( + module Generics.GPAH.Deriving.Base + ,module Generics.GPAH.Deriving.Analyze + ,module Generics.GPAH.Deriving.PPrint + ) +where + +import Generics.GPAH.Deriving.Base +import Generics.GPAH.Deriving.Analyze +import Generics.GPAH.Deriving.PPrint diff --git a/src/Generics/GPAH/Deriving/Analyze.hs b/src/Generics/GPAH/Deriving/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Deriving/Analyze.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, ScopedTypeVariables #-} +module Generics.GPAH.Deriving.Analyze where + +import Generics.GPAH.Deriving.Base +import Generics.GPAH.Utils +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import qualified Data.Map as M + +import Data.List + +import Data.Monoid + +analyzeModule :: ParseResult (Module, [Comment]) -> Analysis +analyzeModule (ParseOk ((Module _ _ _ _ _ _ decls),_)) = foldr (\ decl acc -> analyzeDecl decl `mappend` acc) mempty decls +analyzeModule _ = mempty + +analyzeDecl :: Decl -> Analysis + +-- NORMAL +--------- + +-- data +analyzeDecl (DataDecl _ DataType _ _ name _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , normalStruct = 1 + , sizePos = (fromBool $ not $ null ds) + , normalPos = (fromBool $ not $ null ds) + , sizeDer = lds + , normalDer = lds + , topDer = (M.fromList $ zip nds (repeat 1)) + } +-- ok + +-- newtype +analyzeDecl (DataDecl _ NewType _ _ name _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , normalStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , normalPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , normalDer = lds + , newtypeDerContains = lds + } + +-- ok + +-- GADT +------- + +-- data +analyzeDecl (GDataDecl _ DataType _ name _ _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , gadtStruct = 1 + , sizePos = (fromBool $ not $ null ds) + , gadtPos = (fromBool $ not $ null ds) + , sizeDer = lds + , gadtDer = lds + , topDer = (M.fromList $ zip nds (repeat 1)) + } + +-- ok + +-- newtype +analyzeDecl (GDataDecl _ NewType _ name _ _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , gadtStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , gadtPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , gadtDer = lds + , newtypeDerContains = lds + } +-- ok + +-- FAMSTRUCT +------------ + +-- data +analyzeDecl (DataInsDecl _ DataType _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , famStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , famPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , famDer = lds + , newtypeDerContains = lds + } + +-- ok + +-- newtype +analyzeDecl (DataInsDecl _ NewType _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , famStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , famPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , famDer = lds + , newtypeDerContains = lds + } + +-- ok + +-- GADTFAMSTRUCT +---------------- + +-- data +analyzeDecl (GDataInsDecl _ DataType typeParams _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , gadtFamStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , gadtFamPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , gadtFamDer = lds + , newtypeDerContains = lds + } + +-- ok + +-- newtype +analyzeDecl (GDataInsDecl _ NewType typeParams _ _ ds) = let lds = length ds + nds = map derivingName ds + in mempty { + sizeStruct = 1 + , gadtFamStruct = 1 + , newtypeStructContains = 1 + , sizePos = (fromBool $ not $ null ds) + , gadtFamPos = (fromBool $ not $ null ds) + , newtypePosContains = (fromBool $ not $ null ds) + , sizeDer = lds + , gadtFamDer = lds + , newtypeDerContains = lds + } + +-- ok + +-- standalone deriving +analyzeDecl (DerivDecl _ _ derClass typeParams) = mempty { stdAloneDecl = 1} + +analyzeDecl (InstDecl _ _ derClass typeParams _) = let isDeriveableInstance = qNameToString derClass `elem` deriveableClasses + in mempty { + sizeInst = 1 + , overloadInst = fromBool isDeriveableInstance + , topOverload = if isDeriveableInstance + then M.singleton (qNameToString derClass) 1 + else M.empty + } + +analyzeDecl _ = mempty diff --git a/src/Generics/GPAH/Deriving/Base.hs b/src/Generics/GPAH/Deriving/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Deriving/Base.hs @@ -0,0 +1,115 @@ +module Generics.GPAH.Deriving.Base where + +import Language.Haskell.Exts +import Generics.GPAH.Utils +import Control.DeepSeq +import qualified Data.Map as M +import Data.Monoid + +data Analysis = Analysis { + sizeStruct :: Int + , normalStruct :: Int + , gadtStruct :: Int + , famStruct :: Int + , gadtFamStruct :: Int + , newtypeStructContains :: Int + , sizePos :: Int + , normalPos :: Int + , gadtPos :: Int + , famPos :: Int + , gadtFamPos :: Int + , newtypePosContains :: Int + , sizeDer :: Int + , normalDer :: Int + , gadtDer :: Int + , famDer :: Int + , gadtFamDer :: Int + , newtypeDerContains :: Int + , stdAloneDecl :: Int -- == stdAloneStruct == stdAlonePos + , topDer :: M.Map ClassName Int + , sizeInst :: Int + , overloadInst :: Int + , topOverload :: M.Map ClassName Int + } + deriving (Show) + +instance Monoid Analysis where + mempty = Analysis 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 mempty 0 0 mempty + (Analysis x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23) `mappend` (Analysis y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 y21 y22 y23) = Analysis + (x1+y1) + (x2+y2) + (x3+y3) + (x4+y4) + (x5+y5) + (x6+y6) + (x7+y7) + (x8+y8) + (x9+y9) + (x10+y10) + (x11+y11) + (x12+y12) + (x13+y13) + (x14+y14) + (x15+y15) + (x16+y16) + (x17+y17) + (x18+y18) + (x19+y19) + (M.unionWith (+) x20 y20) + (x21+y21) + (x22+y22) + (M.unionWith (+) x23 y23) + + +instance NFData Analysis where + rnf (Analysis a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23) = a1 + `deepseq` a2 + `deepseq` a3 + `deepseq` a4 + `deepseq` a5 + `deepseq` a6 + `deepseq` a7 + `deepseq` a8 + `deepseq` a9 + `deepseq` a10 + `deepseq` a11 + `deepseq` a12 + `deepseq` a13 + `deepseq` a14 + `deepseq` a15 + `deepseq` a16 + `deepseq` a17 + `deepseq` a18 + `deepseq` a19 + `deepseq` a20 + `deepseq` a21 + `deepseq` a22 + `deepseq` a23 + `deepseq` () + + +-- instead of Normal, more precise DataDecl, GDataDecl, GDataInsDecl +data DerivingType = Normal | StandAlone | Overload + deriving (Eq, Read, Show) + +instance NFData DerivingType where + rnf a = a `seq` () + +-- haskell98 [Eq, Ord, Enum, Ix Bounded, Show, Read] +-- ghc [Data, Typeable, Generic, Functor, Foldable, Traversable] + +deriveableClasses = ["Bounded", "Data", "Enum", "Eq", "Functor", "Foldable", "Ix", "Ord", "Read", "Show", "Traversable", "Typeable", "Generic"] +nonGNDClasses = ["Read", "Show", "Typeable","Data"] -- classes that are not **inherited** when in generalized newtype deriving, but instead derived + +derivingName :: Deriving -> String +derivingName (qName, _) = qNameToString qName + +nameToString :: Name -> String +nameToString (Ident s) = s +nameToString (Symbol s) = s + +qNameToString :: QName -> String +qNameToString (UnQual name) = nameToString name +qNameToString (Qual (ModuleName _mname) name) = nameToString name -- we don't have to care about qualified probably +qNameToString (Special specialCon) = show specialCon + diff --git a/src/Generics/GPAH/Deriving/PPrint.hs b/src/Generics/GPAH/Deriving/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Deriving/PPrint.hs @@ -0,0 +1,43 @@ +module Generics.GPAH.Deriving.PPrint where + +import Generics.GPAH.Deriving.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.Function +import Data.List + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23) fp = do + let p = [["NumberOfDataStructures (Normal+GADT+FamStruct+GADTFamStruct)", show a1], + ["NormalStructures", show a2], + ["GadtStructures", show a3], + ["FamStructures", show a4], + ["GadtFamStructures", show a5], + ["StructuresThatAreNewtype", show a6], + ["StructuresThatContainAnInlineDeriving", show a7], + ["NormalThatContainAnInlineDeriving", show a8], + ["GadtThatContainAnInlineDeriving", show a9], + ["FamStructThatContainAnInlineDeriving", show a10], + ["GadtFamStructThatContainAnInlineDeriving", show a11], + ["NewtypeThatContainAnInlineDeriving", show a12], + ["NumberOfDerivedInstancesInAnyStruct", show a13], + ["DerivedInstancesInNormal", show a14], + ["DerivedInstancesInGadt", show a15], + ["DerivedInstancesInFamStruct", show a16], + ["DerivedInstancesInGadtFamStruct", show a17], + ["DerivedInstancesInNewtype", show a18], + ["StandaloneDerivingDeclarations", show a19], + ["TopDerivedClasses", show $ sortBy (flip compare `on` snd) $ M.toList a20], + ["InstancesChecked", show a21], + ["InstancesPreferredToWriteManualThanAutoDerive", show $ a22], + ["TopManual", show $ sortBy (flip compare `on` snd) $ M.toList a23], + ["PossibleGenericity (Data+Typeable+Generic) Derived", show $ sum $ map (flip (M.findWithDefault 0) a20) ["Data","Typeable","Generic"]], + ["PossibleGenericity (Data+Typeable+Generic) Manual", show $ sum $ map (flip (M.findWithDefault 0) a23) ["Data","Typeable","Generic"]] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Deriving Results:\n###############" + putStrLn pCSV diff --git a/src/Generics/GPAH/Function.hs b/src/Generics/GPAH/Function.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Function.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Function ( + module Generics.GPAH.Function.Base + ,module Generics.GPAH.Function.Analyze + ,module Generics.GPAH.Function.PPrint + ) +where + +import Generics.GPAH.Function.Base +import Generics.GPAH.Function.Analyze +import Generics.GPAH.Function.PPrint diff --git a/src/Generics/GPAH/Function/Analyze.hs b/src/Generics/GPAH/Function/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Function/Analyze.hs @@ -0,0 +1,47 @@ +module Generics.GPAH.Function.Analyze where + +import Generics.GPAH.Function.Base +import Generics.GPAH.Utils +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import Generics.GPAH.Hackage.Analyze + +-- Cabal-related imports +import Distribution.PackageDescription hiding (Var) + +import Data.Generics +import qualified Data.List as L +import qualified Data.Map as M + +import Data.Monoid + +-- | Constructs a list of keywords to search for +constructSearchList :: M.Map String [String] -> [String] +constructSearchList m = foldr (++) [] $ M.elems m + +-- | if the given variable is the given function to search for a 1 is returned else a 0 +findN :: FavFunction -> Exp -> Int +findN n e@(Var n') = case n' of + UnQual i -> case i of + Ident a -> if a == n then 1 else 0 + Symbol a -> if a == n then 1 else 0 + Qual _ i -> case i of + Ident a -> if a == n then 1 else 0 + Symbol a -> if a == n then 1 else 0 + _ -> 0 +findN _ _ = 0 + +-- | collects for a given module the number of occurences of a given function +collectOccs :: Module -> FavFunction -> Int +collectOccs m n = everything (+) (0 `mkQ` findN n) m + +-- | executes the function analysis on a given module +analyzeModule :: ParseResult (Module, [Comment]) -> GenericPackageDescription -> Analysis +analyzeModule (ParseOk (modul@(Module sloc _ _ _ _ _ _),_)) gpkgdesc = + let toSearch = L.nub $ constructSearchList {-(getImportNames modul)-} favorites + ds = cabalDepends gpkgdesc + in if "uniplate" `elem` ds || "syb" `elem` ds -- if uniplate or syb as dep + then Analysis $ M.fromList $ filter (\(_,nr) -> nr > 0) $ map (\x -> (x, collectOccs modul x)) toSearch + else mempty + +analyzeModule _ _ = mempty diff --git a/src/Generics/GPAH/Function/Base.hs b/src/Generics/GPAH/Function/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Function/Base.hs @@ -0,0 +1,46 @@ +module Generics.GPAH.Function.Base where + +import Generics.GPAH.Utils +import qualified Data.Map as M +import Control.DeepSeq +import Data.Monoid + +type Import = String + +type FavFunction = String -- Function-name to search for +type OneLvlUp = String -- Function one level up from where a match was found + +newtype Analysis = Analysis (M.Map FavFunction Int) -- wrap it as a newtype, because we want to override Data.Map 's Monoid instance + deriving (Show) + +instance Monoid Analysis where + mempty = Analysis mempty + (Analysis x) `mappend` (Analysis y) = Analysis $ M.unionWith (+) x y + +instance NFData Analysis where + rnf (Analysis x) = x `deepseq` () + +-- | Functions to search for sorted per module +favorites :: M.Map String [String] +favorites = + M.fromList + [("Data.Generics.Aliases" , ["mkT", "mkQ", "mkM", "mkMp", "mkR", "ext0", "extT", "extQ", "extM", "extMp", "extB", "extR", "orElse", "recoverMp", "recoverQ", "choiceMp", "choiceQ", "ext1", "ext1T", "ext1M", "ext1Q", "ext1R", "ext1B", "ext2T", "ext2M", "ext2Q", "ext2R", "ext2B"]), + ("Data.Generics.Schemes" , ["everywhere","everywhere'","everywhereBut","everywhereM","somewhere","everything","everythingBut","listify","something","synthesize","gsize","glength","gdepth","gcount","gnodecount","gtypecount","gfindtype"]), + ("Data.Generics.Text" , ["gshow", "gshows", "gread"]), + ("Data.Generics.Twins" , ["gfoldlAccum","gmapAccumT","gmapAccumM","gmapAccumQl","gmapAccumQr","gmapAccumQ","gmapAccumA","gzipWithT","gzipWithM","gzipWithQ","geq","gzip"]), + ("Data.Generics.Builders" , ["empty", "constrs"]), + ("Generics.SYB.Aliases" , ["mkT", "mkQ", "mkM", "mkMp", "mkR", "ext0", "extT", "extQ", "extM", "extMp", "extB", "extR", "orElse", "recoverMp", "recoverQ", "choiceMp", "choiceQ", "ext1", "ext1T", "ext1M", "ext1Q", "ext1R", "ext1B", "ext2T", "ext2M", "ext2Q", "ext2R", "ext2B"]), + ("Generics.SYB.Schemes" , ["everywhere","everywhere'","everywhereBut","everywhereM","somewhere","everything","everythingBut","listify","something","synthesize","gsize","glength","gdepth","gcount","gnodecount","gtypecount","gfindtype"]), + ("Generics.SYB.Text" , ["gshow", "gshows", "gread"]), + ("Generics.SYB.Twins" , ["gfoldlAccum","gmapAccumT","gmapAccumM","gmapAccumQl","gmapAccumQr","gmapAccumQ","gmapAccumA","gzipWithT","gzipWithM","gzipWithQ","geq","gzip"]), + ("Generics.SYB.Builders" , ["empty", "constrs"]), + ("Data.Data" , ["gfoldl","gunfold","toConstr", "dataTypeOf","dataCast1", "dataCast2", "gmapT","gmapQ","gmapQl","gmapQr","gmapQi","gmapM","gmapMp","gmapMo", "mkDataType","mkIntType", "mkFloatType","mkStringType", "mkCharType", "mkNoRepType", "mkNorepType", "dataTypeName","dataTypeRep","repConstr", "isAlgType", "dataTypeConstrs","indexConstr", "maxConstrIndex", "isNorepType","mkConstr", "mkIntConstr", "mkFloatConstr", "mkIntegralConstr","mkRealConstr", "mkStringConstr", "mkCharConstr", "constrType", "ConstrRep", "constrRep", "constrFields", "constrFixity", "constrIndex", "showConstr", "readConstr", "tyconUQname", "tyconModule", "fromConstr", "fromConstrB", "fromConstrM"]), + ("Data.Typeable" , ["mkTyCon","mkTyCon3","mkTyConApp","mkAppTy","typeRepTyCon","typeOfDefault","typeOf1Default","typeOf2Default","typeOf3Default","typeOf4Default","typeOf5Default","typeOf6Default","mkFunTy","splitTyConApp","funResultTy","typeRepArgs","showsTypeRep","tyConString","listTc","funTc"]), + ("Data.Generics.Uniplate.Operations", ["uniplate","descend","descendM","biplate","descendBi","descendBiM","universe","children","transform","transformM","rewrite","rewriteM","contexts","holes","para","universeBi","childrenBi","transformBi","transformBiM","rewriteBi","rewriteBiM","contextsBi","holesBi"]), + ("Data.Generics.Uniplate.Direct" , ["plate", "plateSelf", "|+", "|-", "|*", "||+", "||*", "plateProject"]), + ("Data.Generics.Uniplate.Zipper" , ["zipper", "zipperBi", "fromZipper","left", "right","up", "down","hole","replaceHole"]), + ("Data.Generics.Uniplate.Data" , ["transformBis", "transformer"]), + ("Data.Generics.SYB" , ["gmapT", "gmapQl", "gmapQr", "gmapQ", "gmapQi", "gmapM", "mkT", "everywhere", "mkM", "everywhereM", "mkQ", "everything"]), + ("Data.Generics.Compos" , ["composOp", "composOpM", "composOpM_", "composOpMonoid", "composOpMPlus", "composOpFold"]) + ] + diff --git a/src/Generics/GPAH/Function/PPrint.hs b/src/Generics/GPAH/Function/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Function/PPrint.hs @@ -0,0 +1,35 @@ +module Generics.GPAH.Function.PPrint where + +import Generics.GPAH.Function.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.Function +import Data.List + +import System.IO + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis m) fp = do + let p = [["TotalFunctionOccurences", show $ M.foldl (+) 0 m], + ["TopFunctions", show $ sortBy (flip compare `on` snd) $ M.toList m], + ["Transformation/QueryRatio", show $ countT m / countQ m] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Function Results:\n###############" + putStrLn pCSV + + +countT :: M.Map FavFunction Int -> Double +countT m = count m tList +countQ :: M.Map FavFunction Int -> Double +countQ m = count m qList +-- | the list of transformation-functions to search for +tList = ["mkT","mkM","gmapT","everywhere", "everywhereM", "transform", "transformBi"] +-- | the list of query-functions to search for +qList = ["mkQ","gmapQ","everything", "universe", "universeBi"] + +count m fs = toEnum $ foldl (\ acc f -> acc + M.findWithDefault 0 f m) 0 fs diff --git a/src/Generics/GPAH/Hackage.hs b/src/Generics/GPAH/Hackage.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Hackage.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Hackage ( + module Generics.GPAH.Hackage.Base + ,module Generics.GPAH.Hackage.Analyze + ,module Generics.GPAH.Hackage.PPrint + ) +where + +import Generics.GPAH.Hackage.Base +import Generics.GPAH.Hackage.Analyze +import Generics.GPAH.Hackage.PPrint diff --git a/src/Generics/GPAH/Hackage/Analyze.hs b/src/Generics/GPAH/Hackage/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Hackage/Analyze.hs @@ -0,0 +1,61 @@ +module Generics.GPAH.Hackage.Analyze where + +import Generics.GPAH.Hackage.Base +import Generics.GPAH.Utils +import qualified Data.Map as M + +import Data.List (nub, intersect) +import Data.Monoid + + +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import Distribution.PackageDescription +import Distribution.Package + +analyzeModule :: ParseResult (Module, [Comment]) -> Analysis +analyzeModule (ParseOk _) = mempty {parsedModules=1} +analyzeModule (ParseFailed (SrcLoc {srcFilename = hs}) _) = mempty {failedModules = [hs]} + +analyzePackage :: String -> GenericPackageDescription -> Analysis +analyzePackage pkgname gpkgdesc = Analysis + 1 + 0 + [] + (fromBool usesGP) + (fromBool isExe) + reverseDeps + where + ds = cabalDepends gpkgdesc + usesGP = any (`elem` ds) libsGP + isExe = cabalHasExecs gpkgdesc && usesGP + reverseDeps = M.fromList (zip + (ds `intersect` libsGP) -- the gp deps of the pkg + (repeat [pkgname]) + ) + + + + +cabalHasExecs :: GenericPackageDescription -> Bool +cabalHasExecs (GenericPackageDescription _ _ _ execs _ _) = not $ null execs + +cabalDepends :: GenericPackageDescription -> [String] +cabalDepends gpkgdesc = + let pds = pkgDepends gpkgdesc + dName :: Dependency -> String + dName (Dependency (PackageName s) _) = s + dNames = nub $ map dName pds + in dNames + + +-- Takes a parsed Cabal GenericPackageDescription and return a list of Dependencies +pkgDepends :: GenericPackageDescription -> [Dependency] +pkgDepends (GenericPackageDescription pkgdesc _ lib execs tests _) = pkgdescDepends pkgdesc ++ libDepends lib ++ execsDepends execs ++ testsDepends tests + where + pkgdescDepends = buildDepends + libDepends mnode = maybe [] nodeDepends mnode + execsDepends es = concatMap (nodeDepends . snd) es + testsDepends = execsDepends + nodeDepends :: CondTree v [Dependency] a -> [Dependency] + nodeDepends (CondNode {condTreeConstraints = ds}) = ds diff --git a/src/Generics/GPAH/Hackage/Base.hs b/src/Generics/GPAH/Hackage/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Hackage/Base.hs @@ -0,0 +1,35 @@ +module Generics.GPAH.Hackage.Base where + + +import Control.DeepSeq +import Data.Monoid +import qualified Data.Map as M + +data Analysis = Analysis { + totalPackages :: Int + , parsedModules :: Int + , failedModules :: [String] + , pkgsUsingGP :: Int + , exesUsingGP :: Int + , reverseDeps :: M.Map String [String] + } + deriving (Show) + +instance NFData Analysis where + rnf (Analysis a1 a2 a3 a4 a5 a6) = a1 + `deepseq` a2 + `deepseq` a3 + `deepseq` a4 + `deepseq` a5 + `deepseq` a6 + `deepseq` () + +instance Monoid Analysis where + mempty = Analysis 0 0 [] 0 0 M.empty + (Analysis x1 x2 x3 x4 x5 x6) `mappend` (Analysis y1 y2 y3 y4 y5 y6) = Analysis + (x1+y1) + (x2+y2) + (x3++y3) + (x4+y4) + (x5+y5) + (M.unionWith (++) x6 y6) diff --git a/src/Generics/GPAH/Hackage/PPrint.hs b/src/Generics/GPAH/Hackage/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Hackage/PPrint.hs @@ -0,0 +1,28 @@ +module Generics.GPAH.Hackage.PPrint where + +import Generics.GPAH.Hackage.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.List +import Data.Function (on) + + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis a1 a2 a3 a4 a5 a6) fp = do + let p = [["TotalNumberOfPackagesInHackage", show a1], + ["SuccessfullyParsedModules", show a2], + ["FailedToParseModules", show $ length a3], + ["PackagesUsingGP", show a4], + ["PackagesUsingGPwithAnExe", show a5], + ["PackagesUsingSyb", show $ maybe 0 length $ M.lookup "syb" a6], + ["PackagesUsingUniplate", show $ maybe 0 length $ M.lookup "uniplate" a6], + ["ReverseDeps", show $ sortBy (flip compare `on` snd) $ M.toList $ M.map length a6] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Hackage Results:\n###############" + putStrLn pCSV + diff --git a/src/Generics/GPAH/Interp.hs b/src/Generics/GPAH/Interp.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Interp.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Interp ( + module Generics.GPAH.Interp.Base + ,module Generics.GPAH.Interp.Analyze + ,module Generics.GPAH.Interp.PPrint + ) +where + +import Generics.GPAH.Interp.Base +import Generics.GPAH.Interp.Analyze +import Generics.GPAH.Interp.PPrint diff --git a/src/Generics/GPAH/Interp/Analyze.hs b/src/Generics/GPAH/Interp/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Interp/Analyze.hs @@ -0,0 +1,31 @@ +module Generics.GPAH.Interp.Analyze where + +import Generics.GPAH.Interp.Base +import qualified Generics.GPAH.Hackage.Base as Hackage + +import Generics.GPAH.Utils +import qualified Data.Map as M +import Data.List +import System.FilePath +import Data.Monoid +import Language.Haskell.Interpreter + +analyzeModule :: FilePath -> FilePath -> FilePath -> Hackage.Analysis -> IO Analysis +analyzeModule hs pkgName pkgAbsSrcDir hacPkg | pkgName `elem` excludePkgs = return mempty -- some pkgs are excluded + | otherwise = let moduleName = map (\ c -> if isPathSeparator c then '.' else c) -- make the / to . + (dropExtension (makeRelative pkgAbsSrcDir hs)) + interpr :: Interpreter [String] + interpr = do + set [searchPath:=[pkgAbsSrcDir]] + -- the interpreter takes .hs not .hspp + loadModules [replaceExtension hs (if pkgName `elem` ["HaRe","KiCS-debugger","couchdb-conduit"] then ".lhs" else ".hs")] + setTopLevelModules [moduleName] + es <- getModuleExports moduleName -- :browse equivalent + ts <- sequence [typeOf x | e@(Fun x) <- es] -- typecheck the function of the module + let fts = filter (\ t -> any (`isInfixOf` t) intTypes) ts -- the type signatures that contain syb or uniplate + return fts + in if any (`elem` (M.keys (Hackage.reverseDeps hacPkg))) ["syb","uniplate"] -- does the package have syb or uniplate as revdep + then print hs >> runInterpreter interpr >>= either + (\ res -> print res >> return mempty) -- failed to interpret + (\ res -> return $ Analysis $ if null res then M.empty else M.singleton pkgName res) + else return mempty -- module skipped diff --git a/src/Generics/GPAH/Interp/Base.hs b/src/Generics/GPAH/Interp/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Interp/Base.hs @@ -0,0 +1,25 @@ +module Generics.GPAH.Interp.Base where + + +import Control.DeepSeq +import Data.Monoid +import qualified Data.Map as M + +newtype Analysis = Analysis (M.Map String [String]) -- PackageName to TypeSignatures + deriving (Show) + + +instance Monoid Analysis where + mempty = Analysis mempty + (Analysis x) `mappend` (Analysis y) = Analysis $ M.unionWith (++) x y + +instance NFData Analysis where + rnf (Analysis x) = x `deepseq` () + +intTypes = sybTypes ++ uplTypes + +sybTypes = ["GenericQ", "GenericT", "GenericM", "GenericB", "GenericR", "Generic'", "Generic ", "GenericT'", "GenericQ'", "GenericM'" ] + +uplTypes = ["Uniplate", "Biplate"] + +excludePkgs = ["DSH", "freesect"] -- these pkgs contain modules that cannot be interpreted diff --git a/src/Generics/GPAH/Interp/PPrint.hs b/src/Generics/GPAH/Interp/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Interp/PPrint.hs @@ -0,0 +1,22 @@ +module Generics.GPAH.Interp.PPrint where + +import Generics.GPAH.Interp.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.List +import Data.Function (on) + + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis a1) fp = do + let p = [["NrTypes", show $ length $ concat $ M.elems a1], + ["AssocTypes", show $ map (\ t -> (t, length $ filter (t `isInfixOf`) $ concat $ M.elems a1)) intTypes] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Interpretation Results:\n###############" + putStrLn pCSV + diff --git a/src/Generics/GPAH/Main.hs b/src/Generics/GPAH/Main.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Main.hs @@ -0,0 +1,140 @@ +module Main where + +import Generics.GPAH.Base +import Generics.GPAH.Conf +import Generics.GPAH.Utils + +-- the sub-components +import qualified Generics.GPAH.Cpp +import qualified Generics.GPAH.Deriving +import qualified Generics.GPAH.Function +import qualified Generics.GPAH.Date +import qualified Generics.GPAH.Hackage +import qualified Generics.GPAH.Upl +import qualified Generics.GPAH.Interp +import qualified Generics.GPAH.Derive + +import Control.Exception (catch, SomeException (..), evaluate) +import Control.DeepSeq (force) + +import Control.Monad +import Data.Monoid +import System.IO + +-- Cabal-related imports +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Verbosity (silent) +import Distribution.Package + +import System.FilePath +import System.Directory (removeDirectoryRecursive) + +-- for doing the python job +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy.Char8 as BS + +main = tryFetch >> analyze >>= pprint + +tryFetch :: IO () +tryFetch = when (fetchOpt conf) $ do + log <- downloadURL "http://hackage.haskell.org/packages/archive/log" + case log of + Right res -> do + -- Write the hackage log + file <- openBinaryFile (hackageLogOpt conf) WriteMode + hPutStr file res + hClose file + Left x -> error x + tar <- downloadURL "http://hackage.haskell.org/packages/archive/00-archive.tar" + case tar of + Right res -> do + -- Unpack the hackage archive tar + Tar.unpack (hackageDirOpt conf) $ Tar.read $ BS.pack res + -- Unpack each package in the hackage dir + pkgNames <- getHackagePkgsNames + + mapM_ (\ pkgName -> do + pkgVersion <- getPkgVersion pkgName + let fp = (hackageDirOpt conf pkgName pkgVersion) + catch (do + h <- openBinaryFile (fp (pkgName ++ "-" ++ pkgVersion) <.> "tar.gz") ReadMode + c <- BS.hGetContents h + catch (Tar.unpack fp (Tar.read ( GZip.decompress c)) >> hClose h) + (\ (SomeException _) -> do + hClose h + removeDirectoryRecursive (hackageDirOpt conf pkgName) + ) + ) + (\ (SomeException _) -> + removeDirectoryRecursive (hackageDirOpt conf pkgName) + ) + ) pkgNames + + Left x -> error x + + print "Done Fetching & Unpacking" + +analyze :: IO Analysis +analyze = if hasSubComponent conf -- check for enabled subcomponents, so not to pointlessly traverse the modules + then (print "Running the analysis" >> getHackagePkgsNames >>= mapM analyzePkg >>= return . mconcat >>= appendAnalyzeDate) + else return mempty + +appendAnalyzeDate :: Analysis -> IO Analysis +appendAnalyzeDate a = maybe + (return a) -- not enabled in the conf, skip + (const $ do + contents <- readFile (hackageLogOpt conf) + return $ Generics.GPAH.Date.analyzeHackageLog contents a `mappend` a -- appends it to the main analysis + ) + (dateOpt conf) + + +analyzePkg :: String -> IO Analysis +analyzePkg pkgName = do + vsn <- getPkgVersion pkgName + + let cabal = pkgCabal pkgName vsn :: FilePath -- absolute cabal files + parsedCabal <- readPackageDescription silent cabal :: IO GenericPackageDescription + + let pkgAbsDir = pkgDir pkgName vsn -- the absolute directories of package + let pkgSrcDirs = getSrcDirs parsedCabal :: [FilePath] -- fetch the source directories , relevant to package + let pkgAbsSrcDirs = map (pkgAbsDir ) pkgSrcDirs :: [FilePath] -- absolute source directories + + haskellSrcs <- return . concat . zipWith (\ abssrcdir srcs -> zip (repeat abssrcdir) srcs) pkgAbsSrcDirs =<< mapM getHaskellSrcs pkgAbsSrcDirs + + let hacPkg = maybe mempty (const $ Generics.GPAH.Hackage.analyzePackage pkgName parsedCabal) (hackageOpt conf `mplus` dateOpt conf `mplus` intOpt conf `mplus` dveOpt conf) -- -t or -i or -e, imply -h + + let analyzeModule (pkgAbsSrcDir, hs) = do + cpp <- maybe (return mempty) (const $ Generics.GPAH.Cpp.analyzeModule hs pkgAbsDir parsedCabal) (cppOpt conf) + + int <- maybe (return mempty) (const $ Generics.GPAH.Interp.analyzeModule hs pkgName pkgAbsSrcDir hacPkg) (intOpt conf) + + parseRes <- parseModuleFile hs + + -- turn on specific sub analyses based on user-provided conf + let der = maybe mempty (const $ Generics.GPAH.Deriving.analyzeModule parseRes) (derivingOpt conf) + fun = maybe mempty (const $ Generics.GPAH.Function.analyzeModule parseRes parsedCabal) (functionOpt conf) + upl = maybe mempty (const $ Generics.GPAH.Upl.analyzeModule parseRes parsedCabal) (uniplateOpt conf) + hac = maybe mempty (const $ Generics.GPAH.Hackage.analyzeModule parseRes) (hackageOpt conf) + dve = maybe mempty (const $ Generics.GPAH.Derive.analyzeModule parseRes hacPkg) (dveOpt conf) + evaluate . force $ Analysis cpp der fun upl hac mempty int dve + + + let appendAnalyzeHacPkg a = a { hacAnalysis = hacAnalysis a `mappend` hacPkg } + + return . appendAnalyzeHacPkg . mconcat =<< mapM analyzeModule haskellSrcs + + + +pprint :: Analysis -> IO () +pprint (Analysis cpp der fun upl hac dte int dve) = do + maybe (return ()) (Generics.GPAH.Cpp.pprint cpp) (cppOpt conf) + maybe (return ()) (Generics.GPAH.Hackage.pprint hac) (hackageOpt conf) + maybe (return ()) (Generics.GPAH.Deriving.pprint der) (derivingOpt conf) + maybe (return ()) (Generics.GPAH.Function.pprint fun) (functionOpt conf) + maybe (return ()) (Generics.GPAH.Upl.pprint upl) (uniplateOpt conf) + maybe (return ()) (Generics.GPAH.Date.pprint dte) (dateOpt conf) + maybe (return ()) (Generics.GPAH.Interp.pprint int) (intOpt conf) + maybe (return ()) (Generics.GPAH.Derive.pprint dve) (dveOpt conf) diff --git a/src/Generics/GPAH/Upl.hs b/src/Generics/GPAH/Upl.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Upl.hs @@ -0,0 +1,10 @@ +module Generics.GPAH.Upl ( + module Generics.GPAH.Upl.Base + ,module Generics.GPAH.Upl.Analyze + ,module Generics.GPAH.Upl.PPrint + ) +where + +import Generics.GPAH.Upl.Base +import Generics.GPAH.Upl.Analyze +import Generics.GPAH.Upl.PPrint diff --git a/src/Generics/GPAH/Upl/Analyze.hs b/src/Generics/GPAH/Upl/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Upl/Analyze.hs @@ -0,0 +1,34 @@ +module Generics.GPAH.Upl.Analyze where + +import Generics.GPAH.Upl.Base +import Generics.GPAH.Utils +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import qualified Data.Map as M +import Generics.GPAH.Hackage.Analyze + +import Data.Monoid + +-- Cabal-related imports +import Distribution.PackageDescription +import Distribution.Package + +analyseImports :: [ImportDecl] -> Maybe UniStyle +analyseImports is = if isMixed is + then Just Mixed + else analyseImports' is where + isMixed is = any (\ (ImportDecl { importModule = ModuleName mn }) -> mn == mixed) is + analyseImports' (ImportDecl { importModule = ModuleName mn} :xs) | mn `elem` manualSpeed = Just ManualSpeed + analyseImports' (ImportDecl { importModule = ModuleName mn} :xs) | mn `elem` automatic = Just Automatic + analyseImports' (ImportDecl { importModule = ModuleName mn} :xs) | mn `elem` manualPointless = Just ManualPointless + analyseImports' (_:xs) = analyseImports' xs + analyseImports' [] = Nothing + + +analyzeModule :: ParseResult (Module, [Comment]) -> GenericPackageDescription -> Analysis +analyzeModule (ParseOk ((Module (SrcLoc {srcFilename = fn}) _ _ _ _ imports _),_)) gpkgdesc = + if "uniplate" `elem` cabalDepends gpkgdesc -- if has uniplate as dep + then Analysis $ maybe M.empty (\ s -> M.singleton s [fn]) $ analyseImports imports + else mempty +analyzeModule _ _ = mempty + diff --git a/src/Generics/GPAH/Upl/Base.hs b/src/Generics/GPAH/Upl/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Upl/Base.hs @@ -0,0 +1,30 @@ +module Generics.GPAH.Upl.Base where + +import Generics.GPAH.Utils +import qualified Data.Map as M +import Control.DeepSeq +import Data.Monoid + +manualSpeed = ["Data.Generics.Uniplate.Direct", + "Data.Generics.PlateDirect"] +automatic = ["Data.Generics.Uniplate.Data", + "Data.Generics.PlateData"] +manualPointless = ["Data.Generics.Uniplate.Typeable", + "Data.Generics.PlateTypeable"] +mixed = "Data.Generics.Uniplate.DataOnly" + +data UniStyle = ManualSpeed | Automatic | ManualPointless | Mixed + deriving (Read, Show, Eq, Ord) + +instance NFData UniStyle -- enumeration type, so default instance + +newtype Analysis = Analysis (M.Map UniStyle [ModuleFileName]) + deriving (Show) + +instance NFData Analysis where + rnf (Analysis x) = x `deepseq` () + +instance Monoid Analysis where + mempty = Analysis (mempty) + (Analysis x) `mappend` (Analysis y) = Analysis $ M.unionWith (++) x y + diff --git a/src/Generics/GPAH/Upl/PPrint.hs b/src/Generics/GPAH/Upl/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Upl/PPrint.hs @@ -0,0 +1,22 @@ +module Generics.GPAH.Upl.PPrint where + +import Generics.GPAH.Upl.Base +import Text.CSV +import System.IO +import qualified Data.Map as M +import Data.Function + +pprint :: Analysis -> FilePath -> IO () +pprint (Analysis m) fp = do + let p = [["ModulesUsingManualSpeed(Direct)", show $ maybe 0 length $ M.lookup ManualSpeed m], + ["ModulesUsingManualPointless(PlateTypeable)", show $ maybe 0 length $ M.lookup ManualPointless m], + ["ModulesUsingAutomatic(PlateData)", show $ maybe 0 length $ M.lookup Automatic m], + ["ModulesUsingMixed(DataOnly)", show $ maybe 0 length $ M.lookup Mixed m] + ] + pCSV = printCSV p + + writeFile fp pCSV + + putStrLn "Uniplate Results:\n###############" + putStrLn pCSV + diff --git a/src/Generics/GPAH/Utils.hs b/src/Generics/GPAH/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Generics/GPAH/Utils.hs @@ -0,0 +1,262 @@ +module Generics.GPAH.Utils where + +import Generics.GPAH.Conf + +import System.FilePath +import System.Directory +import Data.List +import Control.Monad (filterM, liftM) +import Data.Char (isSpace) +import Language.Haskell.Exts +import Language.Haskell.Exts.Comments +import Network.HTTP +import Network.URI +import Data.Maybe (fromJust) + +import System.IO +import qualified Data.ByteString.Char8 as B + +-- Cabal-related imports +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Verbosity (silent) +import Distribution.Package +import qualified Distribution.Compiler as Compiler (CompilerFlavor (GHC)) + +type ClassName = String +type DataName = String +type LineNumber = Int +type ModuleFileName = String + +fromBool :: Bool -> Int +fromBool True = 1 +fromBool False = 0 + +toBool :: Int -> Bool +toBool 1 = True +toBool 0 = False + +-- returns the package directory relative to the hackage archive +-- e.g. hackage/syb/0.3.6/ACTUAL_PKG_DIR +pkgDir :: String -> String -> FilePath +pkgDir pkg vsn = hackageDirOpt conf pkg vsn pkg ++ "-" ++ vsn + +pkgCabal :: FilePath -> FilePath -> FilePath +pkgCabal pkg vsn = pkgDir pkg vsn pkg ++ ".cabal" + +-- ignore package hsc3, because of error: +-- gpanalysis.exe: In file hackage\hsc3\0.14\hsc3-0.14\Help\UGen\Panner\splay.help.lhs at line 1: program line before comment line. +-- +getHackagePkgsNames :: IO [String] +getHackagePkgsNames = liftM (delete "hsc3") $ getSubDirs (hackageDirOpt conf) + + +getPkgVersion :: String -> IO String +getPkgVersion pkgName = liftM head $ getSubDirs (hackageDirOpt conf pkgName) + +getSubDirs fp = do + ls <- getDirectoryContents fp + let clean_ls = ls \\ [".",".."] + subdirs <- filterM (doesDirectoryExist . (fp )) clean_ls + return subdirs + + +getSrcDirs :: GenericPackageDescription -> [FilePath] +getSrcDirs (GenericPackageDescription {condLibrary = l, condExecutables = es, condTestSuites = ts}) = + let getSrcDirsLib = hsSourceDirs . libBuildInfo + getSrcDirsExec = hsSourceDirs . buildInfo + getSrcDirsTest = hsSourceDirs . testBuildInfo + pkgSrcDirs = nub $ concat $ + maybe [[]] ((: []) . getSrcDirsLib . condTreeData) l ++ + map (getSrcDirsExec . condTreeData . snd) es ++ + map (getSrcDirsTest . condTreeData . snd) ts + in if null pkgSrcDirs + then [""] -- the srcdir of the package is its home dir + else pkgSrcDirs + +-- if using Data.Text, this function is provided +-- and is more efficient +strip :: String -> String +strip = f . f + where f = reverse . dropWhile isSpace + + +ghcOpts :: GenericPackageDescription -> String +ghcOpts (GenericPackageDescription {condLibrary = l, condExecutables = es, condTestSuites = ts}) = + unwords [libGhcOptions, + exesGhcOptions, + testsGhcOptions] + where + libGhcOptions = maybe "" (ghcOptionsBI . libBuildInfo . condTreeData) l + exesGhcOptions = unwords $ map (ghcOptionsBI . buildInfo . condTreeData . snd) es + testsGhcOptions = unwords $ map (ghcOptionsBI . testBuildInfo . condTreeData . snd) ts + ghcOptionsBI :: BuildInfo -> String + ghcOptionsBI (BuildInfo {options = opts}) = maybe "" unwords $ lookup Compiler.GHC opts + + + +cppOpts :: GenericPackageDescription -> String +cppOpts (GenericPackageDescription {condLibrary = l, condExecutables = es, condTestSuites = ts}) = + (strip . unwords) [libCppOptions, + exesCppOptions, + testsCppOptions, + libIncludeDirs, + exesIncludeDirs, + testsIncludeDirs] + where + libCppOptions = maybe "" (cppOptionsBI . libBuildInfo . condTreeData) l + exesCppOptions = unwords $ map (cppOptionsBI . buildInfo . condTreeData . snd) es + testsCppOptions = unwords $ map (cppOptionsBI . testBuildInfo . condTreeData . snd) ts + cppOptionsBI :: BuildInfo -> String + cppOptionsBI (BuildInfo {cppOptions = opts}) = unwords opts + + libIncludeDirs = maybe "" (includeDirsBI . libBuildInfo . condTreeData) l + exesIncludeDirs = unwords $ map (includeDirsBI . buildInfo . condTreeData . snd) es + testsIncludeDirs = unwords $ map (includeDirsBI . testBuildInfo . condTreeData . snd) ts + includeDirsBI :: BuildInfo -> String + includeDirsBI (BuildInfo {includeDirs = opts}) = unwords $ map ("-I" ++) opts + + + +parseCabalSrcDirs :: FilePath -> IO [String] +parseCabalSrcDirs fp = do + gpkgdesc <- readPackageDescription silent fp + return (getSrcDirs gpkgdesc) + + +getHaskellSrcs :: FilePath -> IO [FilePath] +getHaskellSrcs fp = do + existsDir <- doesDirectoryExist fp -- it's possible that the srcdir is not there + if existsDir + then do + ls <- getDirectoryContents fp + -- filter hs, lhs and not Setup.hs and Setup.lhs and no hidden + let hs_lhs = filter (\ l -> (".hs" `isSuffixOf` l || ".lhs" `isSuffixOf` l) && not ("." `isPrefixOf` l) && (l /= "Setup.hs") && (l /= "Setup.lhs")) ls + + -- It prefers the ".hspp" version of the source file, over the ".hs" or ".lhs" version of it + hs_lhs_hspp <- mapM (\ hsOrlhsFile -> do + let hsppFile = addExtension (dropExtension hsOrlhsFile) ".hspp" + p <- doesFileExist (fp hsppFile) + return $ if p then hsppFile else hsOrlhsFile) + hs_lhs + + subDirs <- getSubDirs fp + + if null subDirs + then do + return $ map (fp ) hs_lhs_hspp + else do + hs_lhs_hspp' <- mapM getHaskellSrcs (map (fp ) subDirs) + return $ map (fp ) hs_lhs_hspp ++ (concat hs_lhs_hspp') + else do + return [] + + +parseModuleFile :: FilePath -> IO (ParseResult (Module, [Comment])) +parseModuleFile fp = do + + h <- openFile fp ReadMode + + te <- mkTextEncoding "UTF-8//IGNORE" + hSetEncoding h te + + contents <- return . B.unpack =<< B.hGetContents h + + hClose h + + -- remove pragmas + let clearedContents = removePragmas contents + + -- set parsing mode + let parseMode = defaultParseMode { parseFilename = fp + , extensions = knownExtensions -- support extensions + , fixities = Nothing } -- no infix operators + return $ parseFileContentsWithComments parseMode clearedContents + + +removePragmas :: String -> String +removePragmas s = unlines $ map removePragma (lines s) where + removePragma ('#':xs) = "" + removePragma xs = xs + + +downloadURL :: String -> IO (Either String String) +downloadURL url = + do resp <- simpleHTTP request + case resp of + Left x -> return $ Left ("Error connecting: " ++ show x) + Right r -> + case rspCode r of + (2,_,_) -> return $ Right (rspBody r) + (3,_,_) -> -- A HTTP redirect + case findHeader HdrLocation r of + Nothing -> return $ Left (show r) + Just url -> downloadURL url + _ -> return $ Left (show r) + where request = Request {rqURI = uri, + rqMethod = GET, + rqHeaders = [], + rqBody = ""} + uri = fromJust $ parseURI url + + +-- Libraries under the "Generics" , "Generic" categories of HackageDB + "syb-with-class" + "derive" + "DrIFT-cabalized" +libsGP = ["HsTools", + "syb-extras", + "algebraic-classes", + "alloy", + "alloy-proxy-fd", + "Annotations", + "compdata", + "derive-IG", + "emgm", + "fixplate", + "functorm", + "gdiff-ig", + "gdiff-th", + "generic-binary", + "generic-deepseq", + "generic-deriving", + "GenericPretty", + "geniplate", + "guarded-rewriting", + "instant-generics", + "instant-zipper", + "ligd", + "ListLike", + "listlike-instances", + "multifocal", + "multiplate", + "multiplate-simplified", + "multirec", + "multirec-alt-deriver", + "multirec-binary", + "one-liner", + "pointless-haskell", + "pointless-lenses", + "pointless-rewrite", + "putlenses", + "regular", + "regular-extras", + "regular-web", + "RepLib", + "rewriting", + "special-functors", + "spine", + "Strafunski-StrategyLib", + "StrategyLib", + "syb", + "syz", + "TYB", + "unbound", + "unfoldable", + "uniplate", + "xformat", + "yoko", + "zipper", + "syb-with-class", + "derive", + "DrIFT-cabalized" + ] + +