Utils.hs

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"
         ]