now-haskell-0.1.0.0: src/CabalScanner.hs

module CabalScanner where

import Data.Aeson
import qualified Data.Text as T

-- Cabal things
import Distribution.Verbosity (normal)
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration (flattenPackageDescription) -- TODO replace with finalizePD
import Distribution.PackageDescription.Parsec
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName (ModuleName, fromComponents)
import Distribution.Simple.Utils

import Data.List (inits)
import System.Directory
import System.Environment
import System.FilePath
import qualified ModuleScanner as Mod

data Output
  = PackageUsedOutput PackageInfo
  | ModuleUsedOutput ModuleInfo

instance ToJSON Output where
  toJSON o = case o of
    PackageUsedOutput p -> object
      [ "type" .= ("package" :: T.Text)
      , "data" .= p
      ]
    ModuleUsedOutput m -> object
      [ "type" .= ("module" :: T.Text)
      , "data" .= m
      ]

data ModulePackage
  = Dangling
  | InPackageLibrary FilePath
  | InPackageExecutable
    String -- ^ Executable name
    FilePath
  | InOtherPackageStanza FilePath

data ModuleInfo = ModuleInfo
  { moduleInfoPackage :: ModulePackage
  , moduleInfoAnalysis :: Mod.Analyze
  }

instance ToJSON ModuleInfo where
  toJSON (ModuleInfo p a) = object
    [ "package" .= case p of
        Dangling -> Null
        InPackageLibrary fp -> object ["library" .= (takeBaseName fp), "path" .= fp]
        InPackageExecutable e fp -> object ["executable" .= e, "path" .= fp]
        InOtherPackageStanza fp -> object ["path" .= fp]
    , "analysis" .= a
    ]

data PackageInfo = PackageInfo
  { packageInfoExecutables :: [String]
  }

instance ToJSON PackageInfo where
  toJSON (PackageInfo exes) = object
    [ "executables" .= exes
    {-
      From cabal:
        executables[].modulePath :: FilePath
        resolve libraries[].modules with buildInfo
        dataFiles :: [FilePath]
        dataDir :: FilePath
        extraSrcFiles :: [FilePath]
        extraTmpFiles :: [FilePath]
        extraDocFiles :: [FilePath]
    -}
    , "files" .= object
      [ "executableModules" .= ([] :: [FilePath])
      ]
    ]

dispatchFileScan :: FilePath -> IO (Either ModuleInfo PackageInfo)
dispatchFileScan fp = case takeFileName fp of
  "package.yml" -> error "hpack package.yml"
  "package.yaml" -> error "hpack package.yaml"
  other -> case takeExtension other of
    ".hs" -> Left <$> performHaskellModuleScan fp
    ".lhs" -> Left <$> performHaskellModuleScan fp
    -- TODO
    -- "chs" -> _
    ".cabal" -> Right <$> (produceFlatPackage fp >>= performCabalPackageScan)
    unsupported -> error ("." ++ unsupported ++ " file extension is not a supported Haskell builder type.")

performHaskellModuleScan :: FilePath -> IO ModuleInfo
performHaskellModuleScan relFp = do
  fp <- canonicalizePath relFp
  mCabalFile <- findClosestAncestorCabalFile fp
  analysis <- Mod.readDesiredModule relFp

  case mCabalFile of
    Nothing -> do
      pure $ ModuleInfo Dangling analysis
    Just cf -> do
      flatPack <- produceFlatPackage cf
      case library flatPack of
        Nothing -> do
          pure $ ModuleInfo (InOtherPackageStanza cf) analysis
        Just l -> do
          let relativeModulePath = makeRelative (takeDirectory cf) fp
              desiredModule = fileToModule (hsSourceDirs $ libBuildInfo l) relativeModulePath
          if desiredModule `isExposedFromLibrary` l
            then do
              pure $ ModuleInfo (InPackageLibrary cf) analysis
            else error "TODO: not sure what to do here..."

getCabalPackage :: FilePath -> IO PackageDescription
getCabalPackage p = do
  efp <- findPackageDesc p
  let fp = either error id efp
  produceFlatPackage fp

produceFlatPackage :: FilePath -> IO PackageDescription
produceFlatPackage fp = do
  gpd <- readGenericPackageDescription normal fp
  pure $ flattenPackageDescription gpd

performCabalPackageScan :: PackageDescription -> IO PackageInfo
performCabalPackageScan gpd = do
  let exes = map (unUnqualComponentName . exeName) $ executables gpd
  pure $ PackageInfo exes

-- Takes a path and searches for a cabal file up the directory hierarchy. returns a cabal file if found
findClosestAncestorCabalFile :: FilePath -> IO (Maybe FilePath)
findClosestAncestorCabalFile fp = do
  isDir <- doesDirectoryExist fp
  let startingDir = if isDir then fp else takeDirectory fp
  dir <- canonicalizePath startingDir
  let chunkedDir = splitPath dir
      allPaths = map joinPath $ reverse $ tail $ inits chunkedDir
  -- print allPaths
  go allPaths
  where
    go [] = pure Nothing
    go (path:ps) = do
      res <- findPackageDesc path
      case res of
        Left _ -> go ps
        Right p -> pure $ Just p


fileToModule
  :: [FilePath] -- Search paths
  -- -> [FilePath] -- Extensions
  -> FilePath -- Haskell File
  -> ModuleName
fileToModule searchPs startP = go searchPs
  where
    extensionless = dropExtension startP
    go [] = fromComponents $ splitDirectories extensionless
    go (p:ps) = let rel = makeRelative p extensionless in
      if rel == extensionless
      then go ps
      else fromComponents $ splitDirectories rel

isExposedFromLibrary :: ModuleName -> Library -> Bool
isExposedFromLibrary m l = m `elem` exposedModules l