Parser.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Hie.Cabal.Parser
( Package(..)
, Component(..)
, CompType(..)
, Name
, extractPkgs
, parsePackage'
) where

import           Control.Applicative
import           Control.Monad
import           Data.Attoparsec.Text
import           Data.Char
import           Data.Foldable                                 (asum)
import           Data.Maybe                                    (catMaybes,
                                                                maybeToList)
import           Data.Text                                     (Text)
import qualified Data.Text                                     as T
import           Data.Text.Encoding                            (encodeUtf8)
import           Distribution.ModuleName                       (ModuleName,
                                                                toFilePath)
import           Distribution.Package                          (pkgName,
                                                                unPackageName)
import           Distribution.PackageDescription               (Benchmark (benchmarkBuildInfo, benchmarkInterface, benchmarkName),
                                                                BenchmarkInterface (BenchmarkExeV10),
                                                                Executable (buildInfo, exeName, modulePath),
                                                                ForeignLib (foreignLibBuildInfo, foreignLibName),
                                                                Library (libBuildInfo, libName),
                                                                LibraryName (..),
                                                                TestSuiteInterface (TestSuiteExeV10),
                                                                benchmarkModules,
                                                                exeModules,
                                                                explicitLibModules,
                                                                foreignLibModules)
import           Distribution.PackageDescription.Configuration
import           Distribution.PackageDescription.Parsec
import           Distribution.Types.BuildInfo
import           Distribution.Types.PackageDescription
import           Distribution.Types.TestSuite
import           Distribution.Types.UnqualComponentName
import           Distribution.Utils.Path                       (getSymbolicPath)
import           GHC.IO                                        (unsafePerformIO)
import           System.Directory                              (doesFileExist)
import           System.FilePath                               ((<.>), (</>))


type Name = Text

type Path = Text

type Indent = Int

data Package = Package Name [Component]
  deriving (Show, Eq, Ord)

data CompType = Lib | Exe | Test | Bench
  deriving (Show, Eq, Ord)

data Component
  = Comp CompType Name Path
  deriving (Show, Eq, Ord)

parseQuoted :: Parser Text
parseQuoted = do
  q <- char '"' <|> char '\''
  s <- takeTill (== q)
  _ <- char q
  pure s

parseString :: Parser Name
parseString = parseQuoted <|> unqualName

unqualName :: Parser Text
unqualName = takeWhile1 (not . (\c -> isSpace c || c == ','))

-- | Comma or space separated list, with optional new lines.
parseList :: Indent -> Parser [Text]
parseList i = many (nl <|> sl)
  where
    sep = skipMany (char ',' <|> tabOrSpace)
    com = skipMany tabOrSpace >> "--" >> skipWhile (not . isEndOfLine)
    sl = do
      sep
      x <- parseString
      sep
      skipMany com
      pure x

    nl = do
      skipMany emptyOrComLine <|> endOfLine
      _ <- indent i
      sep
      skipMany com
      x <- parseString
      sep
      skipMany com
      pure x

skipToNextLine :: Parser ()
skipToNextLine = skipWhile (not . isEndOfLine) >> endOfLine

comment :: Parser ()
comment = skipMany tabOrSpace >> "--" >> skipToNextLine

emptyOrComLine :: Parser ()
emptyOrComLine = (skipMany tabOrSpace >> endOfLine) <|> comment

tabOrSpace :: Parser Char
tabOrSpace = char ' ' <|> char '\t'

-- field :: Indent -> Text -> Parser Text
field ::
  Indent ->
  [Text] ->
  (Indent -> Parser a) ->
  Parser a
field i f p =
  do
    i' <- indent i
    _ <- asum $ map asciiCI f
    skipMany tabOrSpace
    _ <- char ':'
    skipMany tabOrSpace
    p' <- p $ i' + 1
    skipToNextLine
    pure p'

-- | Skip at least n spaces
indent :: Indent -> Parser Int
indent i = do
  c <- length <$> many' tabOrSpace
  if c >= i then pure c else fail "insufficient indent"

extractPkgs :: Parser [T.Text]
extractPkgs = join . catMaybes <$> many' (Just <$> field 0 ["packages"] parseList <|> (skipToNextLine >> pure Nothing))

parsePackage' :: T.Text -> Either String Package
parsePackage' t = do
  let bytes = encodeUtf8 t
  case runParseResult (parseGenericPackageDescription bytes) of
    (_warnings, Left err) ->
        error $ "Cannot parse Cabal file: " <> show err
    (_warnings, Right res) -> do
      let pkg = flattenPackageDescription res
      Right $ extractPackage pkg

extractPackage :: PackageDescription -> Package
extractPackage PackageDescription{..} = Package n cc where
  n = T.pack . unPackageName $ pkgName package

  cc = concat $
    [mkComp Test (unqName $ testName t) (testBuildInfo t) (testExePath t) (testModules t) | t <- testSuites] ++
    [mkComp Bench (unqName $ benchmarkName b) (benchmarkBuildInfo b) (benchmarkExePath b) (benchmarkModules b) | b <- benchmarks] ++
    [mkComp Exe (unqName $ exeName e) (buildInfo e) [modulePath e] (exeModules e) | e <- executables] ++
    [mkComp Lib (libName' l) (libBuildInfo l) [] (explicitLibModules l) | l <- maybeToList library ++ subLibraries ] ++
    [mkComp Lib (unqName $ foreignLibName f) (foreignLibBuildInfo f) [] (foreignLibModules f) | f <- foreignLibs]

  mkComp :: CompType -> T.Text -> BuildInfo -> [FilePath] -> [ModuleName] -> [Component]
  mkComp typ name bi fps mods =
    [Comp typ name (T.pack fp)
    | fp0 <- fps <> concatMap toFilePath' mods
    , srcDir <- map getSymbolicPath $ hsSourceDirs bi
    , let fp = srcDir </> fp0
    , unsafePerformIO $ doesFileExist fp
    ]

  unqName = T.pack . unUnqualComponentName
  libName' x = case libName x of
    LMainLibName  -> ""
    LSubLibName u -> unqName u

benchmarkExePath :: Benchmark -> [FilePath]
benchmarkExePath b = case benchmarkInterface b of
  BenchmarkExeV10 _ f -> [f]
  _                   -> []

toFilePath' :: ModuleName -> [FilePath]
toFilePath' mod = [ toFilePath mod <.> ext | ext <- ["hs", "lhs"]]

testExePath :: TestSuite -> [FilePath]
testExePath t = case testInterface t of
    TestSuiteExeV10 _ fp -> [fp]
    _                    -> []