module CabalGild.Action.EvaluatePragmas where
import qualified CabalGild.Class.MonadWalk as MonadWalk
import qualified CabalGild.Extra.ModuleName as ModuleName
import qualified CabalGild.Extra.Name as Name
import qualified CabalGild.Extra.String as String
import qualified CabalGild.Type.Comment as Comment
import qualified CabalGild.Type.Pragma as Pragma
import qualified Control.Monad.Trans.Class as Trans
import qualified Control.Monad.Trans.Maybe as MaybeT
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Distribution.Fields as Fields
import qualified Distribution.Parsec as Parsec
import qualified Distribution.Utils.Generic as Utils
import qualified System.FilePath as FilePath
run ::
(MonadWalk.MonadWalk m) =>
FilePath ->
([Fields.Field [Comment.Comment a]], cs) ->
m ([Fields.Field [Comment.Comment a]], cs)
run :: forall (m :: * -> *) a cs.
MonadWalk m =>
String -> ([Field [Comment a]], cs) -> m ([Field [Comment a]], cs)
run String
p ([Field [Comment a]]
fs, cs
cs) = (,) ([Field [Comment a]] -> cs -> ([Field [Comment a]], cs))
-> m [Field [Comment a]] -> m (cs -> ([Field [Comment a]], cs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Field [Comment a]] -> m [Field [Comment a]]
forall (m :: * -> *) a.
MonadWalk m =>
String -> [Field [Comment a]] -> m [Field [Comment a]]
fields String
p [Field [Comment a]]
fs m (cs -> ([Field [Comment a]], cs))
-> m cs -> m ([Field [Comment a]], cs)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> cs -> m cs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs
fields ::
(MonadWalk.MonadWalk m) =>
FilePath ->
[Fields.Field [Comment.Comment a]] ->
m [Fields.Field [Comment.Comment a]]
fields :: forall (m :: * -> *) a.
MonadWalk m =>
String -> [Field [Comment a]] -> m [Field [Comment a]]
fields = (Field [Comment a] -> m (Field [Comment a]))
-> [Field [Comment a]] -> m [Field [Comment a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Field [Comment a] -> m (Field [Comment a]))
-> [Field [Comment a]] -> m [Field [Comment a]])
-> (String -> Field [Comment a] -> m (Field [Comment a]))
-> String
-> [Field [Comment a]]
-> m [Field [Comment a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Field [Comment a] -> m (Field [Comment a])
forall (m :: * -> *) a.
MonadWalk m =>
String -> Field [Comment a] -> m (Field [Comment a])
field
field ::
(MonadWalk.MonadWalk m) =>
FilePath ->
Fields.Field [Comment.Comment a] ->
m (Fields.Field [Comment.Comment a])
field :: forall (m :: * -> *) a.
MonadWalk m =>
String -> Field [Comment a] -> m (Field [Comment a])
field String
p Field [Comment a]
f = case Field [Comment a]
f of
Fields.Field Name [Comment a]
n [FieldLine [Comment a]]
_ -> (Maybe (Field [Comment a]) -> Field [Comment a])
-> m (Maybe (Field [Comment a])) -> m (Field [Comment a])
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Field [Comment a] -> Maybe (Field [Comment a]) -> Field [Comment a]
forall a. a -> Maybe a -> a
Maybe.fromMaybe Field [Comment a]
f) (m (Maybe (Field [Comment a])) -> m (Field [Comment a]))
-> (MaybeT m (Field [Comment a]) -> m (Maybe (Field [Comment a])))
-> MaybeT m (Field [Comment a])
-> m (Field [Comment a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT m (Field [Comment a]) -> m (Maybe (Field [Comment a]))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
MaybeT.runMaybeT (MaybeT m (Field [Comment a]) -> m (Field [Comment a]))
-> MaybeT m (Field [Comment a]) -> m (Field [Comment a])
forall a b. (a -> b) -> a -> b
$ do
Set String
es <- Maybe (Set String) -> MaybeT m (Set String)
forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe (Maybe (Set String) -> MaybeT m (Set String))
-> (Map FieldName (Set String) -> Maybe (Set String))
-> Map FieldName (Set String)
-> MaybeT m (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Map FieldName (Set String) -> Maybe (Set String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name [Comment a] -> FieldName
forall a. Name a -> FieldName
Name.value Name [Comment a]
n) (Map FieldName (Set String) -> MaybeT m (Set String))
-> Map FieldName (Set String) -> MaybeT m (Set String)
forall a b. (a -> b) -> a -> b
$ Map FieldName (Set String)
extensions
Comment a
c <- Maybe (Comment a) -> MaybeT m (Comment a)
forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe (Maybe (Comment a) -> MaybeT m (Comment a))
-> ([Comment a] -> Maybe (Comment a))
-> [Comment a]
-> MaybeT m (Comment a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment a] -> Maybe (Comment a)
forall a. [a] -> Maybe a
Utils.safeLast ([Comment a] -> MaybeT m (Comment a))
-> [Comment a] -> MaybeT m (Comment a)
forall a b. (a -> b) -> a -> b
$ Name [Comment a] -> [Comment a]
forall a. Name a -> a
Name.annotation Name [Comment a]
n
Pragma
x <- Maybe Pragma -> MaybeT m Pragma
forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe (Maybe Pragma -> MaybeT m Pragma)
-> (FieldName -> Maybe Pragma) -> FieldName -> MaybeT m Pragma
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Maybe Pragma
forall a. Parsec a => FieldName -> Maybe a
Parsec.simpleParsecBS (FieldName -> MaybeT m Pragma) -> FieldName -> MaybeT m Pragma
forall a b. (a -> b) -> a -> b
$ Comment a -> FieldName
forall a. Comment a -> FieldName
Comment.value Comment a
c
String
y <- case Pragma
x of
Pragma.Discover String
y -> String -> MaybeT m String
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
y
let d :: String
d = String -> String -> String
FilePath.combine (String -> String
FilePath.takeDirectory String
p) String
y
[String]
fs <- m [String] -> MaybeT m [String]
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m [String] -> MaybeT m [String])
-> m [String] -> MaybeT m [String]
forall a b. (a -> b) -> a -> b
$ String -> m [String]
forall (m :: * -> *). MonadWalk m => String -> m [String]
MonadWalk.walk String
d
Field [Comment a] -> MaybeT m (Field [Comment a])
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Field [Comment a] -> MaybeT m (Field [Comment a]))
-> ([String] -> Field [Comment a])
-> [String]
-> MaybeT m (Field [Comment a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name [Comment a] -> [FieldLine [Comment a]] -> Field [Comment a]
forall ann. Name ann -> [FieldLine ann] -> Field ann
Fields.Field Name [Comment a]
n
([FieldLine [Comment a]] -> Field [Comment a])
-> ([String] -> [FieldLine [Comment a]])
-> [String]
-> Field [Comment a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName -> FieldLine [Comment a])
-> [ModuleName] -> [FieldLine [Comment a]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Comment a] -> ModuleName -> FieldLine [Comment a]
forall a. a -> ModuleName -> FieldLine a
ModuleName.toFieldLine [])
([ModuleName] -> [FieldLine [Comment a]])
-> ([String] -> [ModuleName])
-> [String]
-> [FieldLine [Comment a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe ModuleName) -> [String] -> [ModuleName]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (String -> Maybe ModuleName
ModuleName.fromFilePath (String -> Maybe ModuleName)
-> (String -> String) -> String -> Maybe ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
FilePath.makeRelative String
d)
([String] -> MaybeT m (Field [Comment a]))
-> [String] -> MaybeT m (Field [Comment a])
forall a b. (a -> b) -> a -> b
$ (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (Set String -> String -> Maybe String
stripAnyExtension Set String
es) [String]
fs
Fields.Section Name [Comment a]
n [SectionArg [Comment a]]
sas [Field [Comment a]]
fs -> Name [Comment a]
-> [SectionArg [Comment a]]
-> [Field [Comment a]]
-> Field [Comment a]
forall ann.
Name ann -> [SectionArg ann] -> [Field ann] -> Field ann
Fields.Section Name [Comment a]
n [SectionArg [Comment a]]
sas ([Field [Comment a]] -> Field [Comment a])
-> m [Field [Comment a]] -> m (Field [Comment a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [Field [Comment a]] -> m [Field [Comment a]]
forall (m :: * -> *) a.
MonadWalk m =>
String -> [Field [Comment a]] -> m [Field [Comment a]]
fields String
p [Field [Comment a]]
fs
stripAnyExtension :: Set.Set String -> FilePath -> Maybe String
stripAnyExtension :: Set String -> String -> Maybe String
stripAnyExtension Set String
es String
p =
[String] -> Maybe String
forall a. [a] -> Maybe a
Maybe.listToMaybe
([String] -> Maybe String)
-> ([String] -> [String]) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (String -> String -> Maybe String
`FilePath.stripExtension` String
p)
([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
es
extensions :: Map.Map Fields.FieldName (Set.Set String)
extensions :: Map FieldName (Set String)
extensions =
let (=:) :: String -> [String] -> (Fields.FieldName, Set.Set String)
String
k =: :: String -> [String] -> (FieldName, Set String)
=: [String]
v = (String -> FieldName
String.toUtf8 String
k, [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
v)
in [(FieldName, Set String)] -> Map FieldName (Set String)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ String
"exposed-modules" String -> [String] -> (FieldName, Set String)
=: [String
"hs", String
"lhs"],
String
"other-modules" String -> [String] -> (FieldName, Set String)
=: [String
"hs", String
"lhs"]
]
hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a
hoistMaybe :: forall (f :: * -> *) a. Applicative f => Maybe a -> MaybeT f a
hoistMaybe = f (Maybe a) -> MaybeT f a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT.MaybeT (f (Maybe a) -> MaybeT f a)
-> (Maybe a -> f (Maybe a)) -> Maybe a -> MaybeT f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure