{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Parse Cabal files.
module FastTags.Cabal (parse) where

#if ! MIN_VERSION_Cabal(2, 2, 0)

parse :: FilePath -> IO (Either String (FilePath, [FilePath]))
parse = const $ return $ Left "cabal parsing not supported <Cabal-2.2.0"

#else

import qualified Control.Monad as Monad
import Control.Applicative ((<*>))
import Control.Monad ((<=<))
import qualified Data.ByteString as ByteString
import Data.Functor ((<$>))
import Data.Monoid ((<>))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Data.Text.Encoding.Error as Encoding.Error

#if MIN_VERSION_Cabal(3, 0, 0)
import qualified Distribution.Fields.Parser as Parser
#else
import qualified Distribution.Parsec.Parser as Parser
#endif


parse :: FilePath -> IO (Either String (FilePath, [FilePath]))
parse :: FilePath -> IO (Either FilePath (FilePath, [FilePath]))
parse FilePath
fname =
    (FilePath -> FilePath)
-> Either FilePath (FilePath, [FilePath])
-> Either FilePath (FilePath, [FilePath])
forall a c b. (a -> c) -> Either a b -> Either c b
first ((FilePath
fname FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": ")FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) (Either FilePath (FilePath, [FilePath])
 -> Either FilePath (FilePath, [FilePath]))
-> (ByteString -> Either FilePath (FilePath, [FilePath]))
-> ByteString
-> Either FilePath (FilePath, [FilePath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Field Position] -> Either FilePath (FilePath, [FilePath])
forall ann.
Show ann =>
[Field ann] -> Either FilePath (FilePath, [FilePath])
extract ([Field Position] -> Either FilePath (FilePath, [FilePath]))
-> (ByteString -> Either FilePath [Field Position])
-> ByteString
-> Either FilePath (FilePath, [FilePath])
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ParseError -> FilePath)
-> Either ParseError [Field Position]
-> Either FilePath [Field Position]
forall a c b. (a -> c) -> Either a b -> Either c b
first ParseError -> FilePath
forall a. Show a => a -> FilePath
show (Either ParseError [Field Position]
 -> Either FilePath [Field Position])
-> (ByteString -> Either ParseError [Field Position])
-> ByteString
-> Either FilePath [Field Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ParseError [Field Position]
Parser.readFields) (ByteString -> Either FilePath (FilePath, [FilePath]))
-> IO ByteString -> IO (Either FilePath (FilePath, [FilePath]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    FilePath -> IO ByteString
ByteString.readFile FilePath
fname

{- | First I look for the library section, then get two things from it:

    > Section (Name _ "library") [] fields
    > Field (Name _ "hs-source-dirs") [FieldLine _ dir]
    > Field (Name _ "exposed-modules") [name | FieldLine _ name]
-}
extract :: Show ann => [Parser.Field ann]
    -> Either String (FilePath, [FilePath]) -- ^ (hsSrcDir, modulePath)
extract :: [Field ann] -> Either FilePath (FilePath, [FilePath])
extract [Field ann]
parsed = do
    [Field ann]
fields <- [Field ann] -> Either FilePath [Field ann]
forall ann a. [Field ann] -> Either a [Field ann]
library [Field ann]
parsed
    (,) (FilePath -> [FilePath] -> (FilePath, [FilePath]))
-> Either FilePath FilePath
-> Either FilePath ([FilePath] -> (FilePath, [FilePath]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field ann] -> Either FilePath FilePath
forall ann a. [Field ann] -> Either a FilePath
hsSourceDir [Field ann]
fields Either FilePath ([FilePath] -> (FilePath, [FilePath]))
-> Either FilePath [FilePath]
-> Either FilePath (FilePath, [FilePath])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FilePath] -> Either FilePath [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Field ann] -> [FilePath]
forall ann. [Field ann] -> [FilePath]
exposed [Field ann]
fields)
    where
    hsSourceDir :: [Field ann] -> Either a FilePath
hsSourceDir [Field ann]
fields = case Text -> [Text]
commaField (Text -> [Field ann] -> Text
forall ann. Text -> [Field ann] -> Text
findField Text
"hs-source-dirs" [Field ann]
fields) of
        [] -> FilePath -> Either a FilePath
forall a b. b -> Either a b
Right FilePath
"."
        [Text
dir] -> FilePath -> Either a FilePath
forall a b. b -> Either a b
Right (FilePath -> Either a FilePath) -> FilePath -> Either a FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
dir
        -- to support it, I'd have to search myself.  Too much bother.
        Text
dir : [Text]
_ -> FilePath -> Either a FilePath
forall a b. b -> Either a b
Right (FilePath -> Either a FilePath) -> FilePath -> Either a FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
dir
        -- dirs -> Left $ "multiple hs-source-dirs: " <> show dirs
    exposed :: [Field ann] -> [FilePath]
exposed = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
moduleToFile ([Text] -> [FilePath])
-> ([Field ann] -> [Text]) -> [Field ann] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
commaField (Text -> [Text]) -> ([Field ann] -> Text) -> [Field ann] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Field ann] -> Text
forall ann. Text -> [Field ann] -> Text
findField Text
"exposed-modules"
    -- executable-only packages have no library section
    library :: [Field ann] -> Either a [Field ann]
library = Either a [Field ann]
-> ([Field ann] -> Either a [Field ann])
-> Maybe [Field ann]
-> Either a [Field ann]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Field ann] -> Either a [Field ann]
forall a b. b -> Either a b
Right []) [Field ann] -> Either a [Field ann]
forall a b. b -> Either a b
Right (Maybe [Field ann] -> Either a [Field ann])
-> ([Field ann] -> Maybe [Field ann])
-> [Field ann]
-> Either a [Field ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field ann -> Maybe [Field ann])
-> [Field ann] -> Maybe [Field ann]
forall a b. (a -> Maybe b) -> [a] -> Maybe b
find Field ann -> Maybe [Field ann]
forall ann. Field ann -> Maybe [Field ann]
isLibrary
    isLibrary :: Field ann -> Maybe [Field ann]
isLibrary (Parser.Section (Parser.Name ann
_ ByteString
name) [] [Field ann]
fields)
        | ByteString -> Text -> Bool
caseEq ByteString
name Text
"library" = [Field ann] -> Maybe [Field ann]
forall a. a -> Maybe a
Just [Field ann]
fields
    isLibrary Field ann
_ = Maybe [Field ann]
forall a. Maybe a
Nothing

-- | exposed-modules might be comma separated.  It might not.  It might have
-- spaces.  Or it might not.  Who knows, it's cabal!
commaField :: Text.Text -> [Text.Text]
commaField :: Text -> [Text]
commaField = Text -> [Text]
Text.words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"," Text
" "

moduleToFile :: Text.Text -> FilePath
moduleToFile :: Text -> FilePath
moduleToFile = Text -> FilePath
Text.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
".hs") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"." Text
"/"

findField :: Text.Text -> [Parser.Field ann] -> Text.Text
findField :: Text -> [Field ann] -> Text
findField Text
name = [Text] -> Text
Text.unwords ([Text] -> Text) -> ([Field ann] -> [Text]) -> [Field ann] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> ([FieldLine ann] -> [Text]) -> Maybe [FieldLine ann] -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FieldLine ann -> Text) -> [FieldLine ann] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldLine ann -> Text
forall ann. FieldLine ann -> Text
get) (Maybe [FieldLine ann] -> [Text])
-> ([Field ann] -> Maybe [FieldLine ann]) -> [Field ann] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field ann -> Maybe [FieldLine ann])
-> [Field ann] -> Maybe [FieldLine ann]
forall a b. (a -> Maybe b) -> [a] -> Maybe b
find (Text -> Field ann -> Maybe [FieldLine ann]
forall ann. Text -> Field ann -> Maybe [FieldLine ann]
isField Text
name)
    where
    get :: FieldLine ann -> Text
get (Parser.FieldLine ann
_ ByteString
fieldName) = ByteString -> Text
utf8 ByteString
fieldName
    isField :: Text -> Field ann -> Maybe [FieldLine ann]
isField Text
name (Parser.Field (Parser.Name ann
_ ByteString
fieldName) [FieldLine ann]
lines)
        | ByteString -> Text -> Bool
caseEq ByteString
fieldName Text
name = [FieldLine ann] -> Maybe [FieldLine ann]
forall a. a -> Maybe a
Just [FieldLine ann]
lines
    isField Text
_ Field ann
_ = Maybe [FieldLine ann]
forall a. Maybe a
Nothing

find :: (a -> Maybe b) -> [a] -> Maybe b
find :: (a -> Maybe b) -> [a] -> Maybe b
find a -> Maybe b
f = [Maybe b] -> Maybe b
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
Monad.msum ([Maybe b] -> Maybe b) -> ([a] -> [Maybe b]) -> [a] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [a] -> [Maybe b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe b
f

caseEq :: ByteString.ByteString -> Text.Text -> Bool
caseEq :: ByteString -> Text -> Bool
caseEq ByteString
bytes Text
text = Text -> Text
Text.toLower (ByteString -> Text
utf8 ByteString
bytes) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
text

utf8 :: ByteString.ByteString -> Text.Text
utf8 :: ByteString -> Text
utf8 = OnDecodeError -> ByteString -> Text
Encoding.decodeUtf8With OnDecodeError
Encoding.Error.lenientDecode

-- | Ancient ghc doesn't have Data.Bifunctor.
first :: (a -> c) -> Either a b -> Either c b
first :: (a -> c) -> Either a b -> Either c b
first a -> c
f (Left a
a) = c -> Either c b
forall a b. a -> Either a b
Left (a -> c
f a
a)
first a -> c
_ (Right b
b) = b -> Either c b
forall a b. b -> Either a b
Right b
b

#endif