{-# language ApplicativeDo #-}
{-# language BlockArguments #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language LambdaCase #-}
{-# language PatternSynonyms #-}
{-# language FlexibleInstances #-}
{-# language DeriveTraversable #-}
{-# language NamedFieldPuns #-}

module Weeder.Config
  ( -- * Config
    Config
  , ConfigParsed
  , ConfigType(..)
  , compileConfig
  , configToToml
  , decodeNoDefaults
  , defaultConfig
    -- * Marking instances as roots
  , InstancePattern
  , modulePattern
  , instancePattern
  , classPattern
  , pattern InstanceOnly
  , pattern ClassOnly
  , pattern ModuleOnly
  )
   where

-- base
import Control.Applicative ((<|>), empty)
import Data.Bifunctor (bimap)
import Data.Char (toLower)
import Data.List (intersperse, intercalate)

-- containers
import Data.Containers.ListUtils (nubOrd)

-- regex-tdfa
import Text.Regex.TDFA ( Regex, RegexOptions ( defaultExecOpt, defaultCompOpt ) )
import Text.Regex.TDFA.TDFA ( patternToRegex )
import Text.Regex.TDFA.ReadRegex ( parseRegex )

-- toml-reader
import qualified TOML


-- | Configuration for Weeder analysis.
type Config = ConfigType Regex


-- | Configuration that has been parsed from TOML (and can still be 
-- converted back), but not yet compiled to a 'Config'.
type ConfigParsed = ConfigType String


-- | Underlying type for 'Config' and 'ConfigParsed'.
data ConfigType a = Config
  { forall a. ConfigType a -> [a]
rootPatterns :: [a]
    -- ^ Any declarations matching these regular expressions will be added to
    -- the root set.
  , forall a. ConfigType a -> Bool
typeClassRoots :: Bool
    -- ^ If True, consider all declarations in a type class as part of the root
    -- set. Overrides root-instances.
  , forall a. ConfigType a -> [InstancePattern a]
rootInstances :: [InstancePattern a]
    -- ^ All matching instances will be added to the root set. An absent field
    -- will always match.
  , forall a. ConfigType a -> Bool
unusedTypes :: Bool
    -- ^ Toggle to look for and output unused types. Type family instances will
    -- be marked as implicit roots.
  , forall a. ConfigType a -> [a]
rootModules :: [a]
    -- ^ All matching modules will be added to the root set.
  } deriving (ConfigType a -> ConfigType a -> Bool
(ConfigType a -> ConfigType a -> Bool)
-> (ConfigType a -> ConfigType a -> Bool) -> Eq (ConfigType a)
forall a. Eq a => ConfigType a -> ConfigType a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ConfigType a -> ConfigType a -> Bool
== :: ConfigType a -> ConfigType a -> Bool
$c/= :: forall a. Eq a => ConfigType a -> ConfigType a -> Bool
/= :: ConfigType a -> ConfigType a -> Bool
Eq, Int -> ConfigType a -> ShowS
[ConfigType a] -> ShowS
ConfigType a -> String
(Int -> ConfigType a -> ShowS)
-> (ConfigType a -> String)
-> ([ConfigType a] -> ShowS)
-> Show (ConfigType a)
forall a. Show a => Int -> ConfigType a -> ShowS
forall a. Show a => [ConfigType a] -> ShowS
forall a. Show a => ConfigType a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ConfigType a -> ShowS
showsPrec :: Int -> ConfigType a -> ShowS
$cshow :: forall a. Show a => ConfigType a -> String
show :: ConfigType a -> String
$cshowList :: forall a. Show a => [ConfigType a] -> ShowS
showList :: [ConfigType a] -> ShowS
Show, (forall a b. (a -> b) -> ConfigType a -> ConfigType b)
-> (forall a b. a -> ConfigType b -> ConfigType a)
-> Functor ConfigType
forall a b. a -> ConfigType b -> ConfigType a
forall a b. (a -> b) -> ConfigType a -> ConfigType b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ConfigType a -> ConfigType b
fmap :: forall a b. (a -> b) -> ConfigType a -> ConfigType b
$c<$ :: forall a b. a -> ConfigType b -> ConfigType a
<$ :: forall a b. a -> ConfigType b -> ConfigType a
Functor, (forall m. Monoid m => ConfigType m -> m)
-> (forall m a. Monoid m => (a -> m) -> ConfigType a -> m)
-> (forall m a. Monoid m => (a -> m) -> ConfigType a -> m)
-> (forall a b. (a -> b -> b) -> b -> ConfigType a -> b)
-> (forall a b. (a -> b -> b) -> b -> ConfigType a -> b)
-> (forall b a. (b -> a -> b) -> b -> ConfigType a -> b)
-> (forall b a. (b -> a -> b) -> b -> ConfigType a -> b)
-> (forall a. (a -> a -> a) -> ConfigType a -> a)
-> (forall a. (a -> a -> a) -> ConfigType a -> a)
-> (forall a. ConfigType a -> [a])
-> (forall a. ConfigType a -> Bool)
-> (forall a. ConfigType a -> Int)
-> (forall a. Eq a => a -> ConfigType a -> Bool)
-> (forall a. Ord a => ConfigType a -> a)
-> (forall a. Ord a => ConfigType a -> a)
-> (forall a. Num a => ConfigType a -> a)
-> (forall a. Num a => ConfigType a -> a)
-> Foldable ConfigType
forall a. Eq a => a -> ConfigType a -> Bool
forall a. Num a => ConfigType a -> a
forall a. Ord a => ConfigType a -> a
forall m. Monoid m => ConfigType m -> m
forall a. ConfigType a -> Bool
forall a. ConfigType a -> Int
forall a. ConfigType a -> [a]
forall a. (a -> a -> a) -> ConfigType a -> a
forall m a. Monoid m => (a -> m) -> ConfigType a -> m
forall b a. (b -> a -> b) -> b -> ConfigType a -> b
forall a b. (a -> b -> b) -> b -> ConfigType a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => ConfigType m -> m
fold :: forall m. Monoid m => ConfigType m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ConfigType a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ConfigType a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ConfigType a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ConfigType a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ConfigType a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ConfigType a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ConfigType a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ConfigType a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ConfigType a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ConfigType a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ConfigType a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ConfigType a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ConfigType a -> a
foldr1 :: forall a. (a -> a -> a) -> ConfigType a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ConfigType a -> a
foldl1 :: forall a. (a -> a -> a) -> ConfigType a -> a
$ctoList :: forall a. ConfigType a -> [a]
toList :: forall a. ConfigType a -> [a]
$cnull :: forall a. ConfigType a -> Bool
null :: forall a. ConfigType a -> Bool
$clength :: forall a. ConfigType a -> Int
length :: forall a. ConfigType a -> Int
$celem :: forall a. Eq a => a -> ConfigType a -> Bool
elem :: forall a. Eq a => a -> ConfigType a -> Bool
$cmaximum :: forall a. Ord a => ConfigType a -> a
maximum :: forall a. Ord a => ConfigType a -> a
$cminimum :: forall a. Ord a => ConfigType a -> a
minimum :: forall a. Ord a => ConfigType a -> a
$csum :: forall a. Num a => ConfigType a -> a
sum :: forall a. Num a => ConfigType a -> a
$cproduct :: forall a. Num a => ConfigType a -> a
product :: forall a. Num a => ConfigType a -> a
Foldable, Functor ConfigType
Foldable ConfigType
(Functor ConfigType, Foldable ConfigType) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> ConfigType a -> f (ConfigType b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ConfigType (f a) -> f (ConfigType a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ConfigType a -> m (ConfigType b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ConfigType (m a) -> m (ConfigType a))
-> Traversable ConfigType
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ConfigType (m a) -> m (ConfigType a)
forall (f :: * -> *) a.
Applicative f =>
ConfigType (f a) -> f (ConfigType a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConfigType a -> m (ConfigType b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ConfigType a -> f (ConfigType b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ConfigType a -> f (ConfigType b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ConfigType a -> f (ConfigType b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ConfigType (f a) -> f (ConfigType a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ConfigType (f a) -> f (ConfigType a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConfigType a -> m (ConfigType b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConfigType a -> m (ConfigType b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ConfigType (m a) -> m (ConfigType a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ConfigType (m a) -> m (ConfigType a)
Traversable)


-- | Construct via InstanceOnly, ClassOnly or ModuleOnly, 
-- and combine with the Semigroup instance. The Semigroup
-- instance ignores duplicate fields, prioritising the 
-- left argument.
data InstancePattern a = InstancePattern
  { forall a. InstancePattern a -> Maybe a
instancePattern :: Maybe a
  , forall a. InstancePattern a -> Maybe a
classPattern :: Maybe a
  , forall a. InstancePattern a -> Maybe a
modulePattern :: Maybe a
  } deriving (InstancePattern a -> InstancePattern a -> Bool
(InstancePattern a -> InstancePattern a -> Bool)
-> (InstancePattern a -> InstancePattern a -> Bool)
-> Eq (InstancePattern a)
forall a. Eq a => InstancePattern a -> InstancePattern a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => InstancePattern a -> InstancePattern a -> Bool
== :: InstancePattern a -> InstancePattern a -> Bool
$c/= :: forall a. Eq a => InstancePattern a -> InstancePattern a -> Bool
/= :: InstancePattern a -> InstancePattern a -> Bool
Eq, Int -> InstancePattern a -> ShowS
[InstancePattern a] -> ShowS
InstancePattern a -> String
(Int -> InstancePattern a -> ShowS)
-> (InstancePattern a -> String)
-> ([InstancePattern a] -> ShowS)
-> Show (InstancePattern a)
forall a. Show a => Int -> InstancePattern a -> ShowS
forall a. Show a => [InstancePattern a] -> ShowS
forall a. Show a => InstancePattern a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> InstancePattern a -> ShowS
showsPrec :: Int -> InstancePattern a -> ShowS
$cshow :: forall a. Show a => InstancePattern a -> String
show :: InstancePattern a -> String
$cshowList :: forall a. Show a => [InstancePattern a] -> ShowS
showList :: [InstancePattern a] -> ShowS
Show, Eq (InstancePattern a)
Eq (InstancePattern a) =>
(InstancePattern a -> InstancePattern a -> Ordering)
-> (InstancePattern a -> InstancePattern a -> Bool)
-> (InstancePattern a -> InstancePattern a -> Bool)
-> (InstancePattern a -> InstancePattern a -> Bool)
-> (InstancePattern a -> InstancePattern a -> Bool)
-> (InstancePattern a -> InstancePattern a -> InstancePattern a)
-> (InstancePattern a -> InstancePattern a -> InstancePattern a)
-> Ord (InstancePattern a)
InstancePattern a -> InstancePattern a -> Bool
InstancePattern a -> InstancePattern a -> Ordering
InstancePattern a -> InstancePattern a -> InstancePattern a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (InstancePattern a)
forall a. Ord a => InstancePattern a -> InstancePattern a -> Bool
forall a.
Ord a =>
InstancePattern a -> InstancePattern a -> Ordering
forall a.
Ord a =>
InstancePattern a -> InstancePattern a -> InstancePattern a
$ccompare :: forall a.
Ord a =>
InstancePattern a -> InstancePattern a -> Ordering
compare :: InstancePattern a -> InstancePattern a -> Ordering
$c< :: forall a. Ord a => InstancePattern a -> InstancePattern a -> Bool
< :: InstancePattern a -> InstancePattern a -> Bool
$c<= :: forall a. Ord a => InstancePattern a -> InstancePattern a -> Bool
<= :: InstancePattern a -> InstancePattern a -> Bool
$c> :: forall a. Ord a => InstancePattern a -> InstancePattern a -> Bool
> :: InstancePattern a -> InstancePattern a -> Bool
$c>= :: forall a. Ord a => InstancePattern a -> InstancePattern a -> Bool
>= :: InstancePattern a -> InstancePattern a -> Bool
$cmax :: forall a.
Ord a =>
InstancePattern a -> InstancePattern a -> InstancePattern a
max :: InstancePattern a -> InstancePattern a -> InstancePattern a
$cmin :: forall a.
Ord a =>
InstancePattern a -> InstancePattern a -> InstancePattern a
min :: InstancePattern a -> InstancePattern a -> InstancePattern a
Ord, (forall a b. (a -> b) -> InstancePattern a -> InstancePattern b)
-> (forall a b. a -> InstancePattern b -> InstancePattern a)
-> Functor InstancePattern
forall a b. a -> InstancePattern b -> InstancePattern a
forall a b. (a -> b) -> InstancePattern a -> InstancePattern b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> InstancePattern a -> InstancePattern b
fmap :: forall a b. (a -> b) -> InstancePattern a -> InstancePattern b
$c<$ :: forall a b. a -> InstancePattern b -> InstancePattern a
<$ :: forall a b. a -> InstancePattern b -> InstancePattern a
Functor, (forall m. Monoid m => InstancePattern m -> m)
-> (forall m a. Monoid m => (a -> m) -> InstancePattern a -> m)
-> (forall m a. Monoid m => (a -> m) -> InstancePattern a -> m)
-> (forall a b. (a -> b -> b) -> b -> InstancePattern a -> b)
-> (forall a b. (a -> b -> b) -> b -> InstancePattern a -> b)
-> (forall b a. (b -> a -> b) -> b -> InstancePattern a -> b)
-> (forall b a. (b -> a -> b) -> b -> InstancePattern a -> b)
-> (forall a. (a -> a -> a) -> InstancePattern a -> a)
-> (forall a. (a -> a -> a) -> InstancePattern a -> a)
-> (forall a. InstancePattern a -> [a])
-> (forall a. InstancePattern a -> Bool)
-> (forall a. InstancePattern a -> Int)
-> (forall a. Eq a => a -> InstancePattern a -> Bool)
-> (forall a. Ord a => InstancePattern a -> a)
-> (forall a. Ord a => InstancePattern a -> a)
-> (forall a. Num a => InstancePattern a -> a)
-> (forall a. Num a => InstancePattern a -> a)
-> Foldable InstancePattern
forall a. Eq a => a -> InstancePattern a -> Bool
forall a. Num a => InstancePattern a -> a
forall a. Ord a => InstancePattern a -> a
forall m. Monoid m => InstancePattern m -> m
forall a. InstancePattern a -> Bool
forall a. InstancePattern a -> Int
forall a. InstancePattern a -> [a]
forall a. (a -> a -> a) -> InstancePattern a -> a
forall m a. Monoid m => (a -> m) -> InstancePattern a -> m
forall b a. (b -> a -> b) -> b -> InstancePattern a -> b
forall a b. (a -> b -> b) -> b -> InstancePattern a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => InstancePattern m -> m
fold :: forall m. Monoid m => InstancePattern m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> InstancePattern a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> InstancePattern a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> InstancePattern a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> InstancePattern a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> InstancePattern a -> b
foldr :: forall a b. (a -> b -> b) -> b -> InstancePattern a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> InstancePattern a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> InstancePattern a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> InstancePattern a -> b
foldl :: forall b a. (b -> a -> b) -> b -> InstancePattern a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> InstancePattern a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> InstancePattern a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> InstancePattern a -> a
foldr1 :: forall a. (a -> a -> a) -> InstancePattern a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> InstancePattern a -> a
foldl1 :: forall a. (a -> a -> a) -> InstancePattern a -> a
$ctoList :: forall a. InstancePattern a -> [a]
toList :: forall a. InstancePattern a -> [a]
$cnull :: forall a. InstancePattern a -> Bool
null :: forall a. InstancePattern a -> Bool
$clength :: forall a. InstancePattern a -> Int
length :: forall a. InstancePattern a -> Int
$celem :: forall a. Eq a => a -> InstancePattern a -> Bool
elem :: forall a. Eq a => a -> InstancePattern a -> Bool
$cmaximum :: forall a. Ord a => InstancePattern a -> a
maximum :: forall a. Ord a => InstancePattern a -> a
$cminimum :: forall a. Ord a => InstancePattern a -> a
minimum :: forall a. Ord a => InstancePattern a -> a
$csum :: forall a. Num a => InstancePattern a -> a
sum :: forall a. Num a => InstancePattern a -> a
$cproduct :: forall a. Num a => InstancePattern a -> a
product :: forall a. Num a => InstancePattern a -> a
Foldable, Functor InstancePattern
Foldable InstancePattern
(Functor InstancePattern, Foldable InstancePattern) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> InstancePattern a -> f (InstancePattern b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    InstancePattern (f a) -> f (InstancePattern a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> InstancePattern a -> m (InstancePattern b))
-> (forall (m :: * -> *) a.
    Monad m =>
    InstancePattern (m a) -> m (InstancePattern a))
-> Traversable InstancePattern
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
InstancePattern (m a) -> m (InstancePattern a)
forall (f :: * -> *) a.
Applicative f =>
InstancePattern (f a) -> f (InstancePattern a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InstancePattern a -> m (InstancePattern b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InstancePattern a -> f (InstancePattern b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InstancePattern a -> f (InstancePattern b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InstancePattern a -> f (InstancePattern b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
InstancePattern (f a) -> f (InstancePattern a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
InstancePattern (f a) -> f (InstancePattern a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InstancePattern a -> m (InstancePattern b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InstancePattern a -> m (InstancePattern b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
InstancePattern (m a) -> m (InstancePattern a)
sequence :: forall (m :: * -> *) a.
Monad m =>
InstancePattern (m a) -> m (InstancePattern a)
Traversable)


instance Semigroup (InstancePattern a) where
  InstancePattern Maybe a
i Maybe a
c Maybe a
m <> :: InstancePattern a -> InstancePattern a -> InstancePattern a
<> InstancePattern Maybe a
i' Maybe a
c' Maybe a
m' =
    Maybe a -> Maybe a -> Maybe a -> InstancePattern a
forall a. Maybe a -> Maybe a -> Maybe a -> InstancePattern a
InstancePattern (Maybe a
i Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
i') (Maybe a
c Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
c') (Maybe a
m Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
m')


pattern InstanceOnly, ClassOnly, ModuleOnly :: a -> InstancePattern a
pattern $mInstanceOnly :: forall {r} {a}. InstancePattern a -> (a -> r) -> ((# #) -> r) -> r
$bInstanceOnly :: forall a. a -> InstancePattern a
InstanceOnly t = InstancePattern (Just t) Nothing Nothing
pattern $mClassOnly :: forall {r} {a}. InstancePattern a -> (a -> r) -> ((# #) -> r) -> r
$bClassOnly :: forall a. a -> InstancePattern a
ClassOnly c = InstancePattern Nothing (Just c) Nothing
pattern $mModuleOnly :: forall {r} {a}. InstancePattern a -> (a -> r) -> ((# #) -> r) -> r
$bModuleOnly :: forall a. a -> InstancePattern a
ModuleOnly m = InstancePattern Nothing Nothing (Just m)


defaultConfig :: ConfigParsed
defaultConfig :: ConfigParsed
defaultConfig = Config
  { rootPatterns :: [String]
rootPatterns = [ String
"Main.main", String
"^Paths_.*"]
  , typeClassRoots :: Bool
typeClassRoots = Bool
False
  , rootInstances :: [InstancePattern String]
rootInstances = [ String -> InstancePattern String
forall a. a -> InstancePattern a
ClassOnly String
"\\.IsString$", String -> InstancePattern String
forall a. a -> InstancePattern a
ClassOnly String
"\\.IsList$" ]
  , unusedTypes :: Bool
unusedTypes = Bool
False
  , rootModules :: [String]
rootModules = [String]
forall a. Monoid a => a
mempty
  }


instance TOML.DecodeTOML Config where
  tomlDecoder :: Decoder Config
tomlDecoder = do
    ConfigParsed
conf <- Decoder ConfigParsed
forall a. DecodeTOML a => Decoder a
TOML.tomlDecoder
    (String -> Decoder Config)
-> (Config -> Decoder Config)
-> Either String Config
-> Decoder Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Decoder Config
forall a. String -> Decoder a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Config -> Decoder Config
forall a. a -> Decoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Config -> Decoder Config)
-> Either String Config -> Decoder Config
forall a b. (a -> b) -> a -> b
$ ConfigParsed -> Either String Config
compileConfig ConfigParsed
conf


instance TOML.DecodeTOML ConfigParsed where
  tomlDecoder :: Decoder ConfigParsed
tomlDecoder = do
    [String]
rootPatterns <- [String] -> Text -> Decoder [String]
forall a. DecodeTOML a => a -> Text -> Decoder a
TOML.getFieldOr (ConfigParsed -> [String]
forall a. ConfigType a -> [a]
rootPatterns ConfigParsed
defaultConfig) Text
"roots"
    Bool
typeClassRoots <- Bool -> Text -> Decoder Bool
forall a. DecodeTOML a => a -> Text -> Decoder a
TOML.getFieldOr (ConfigParsed -> Bool
forall a. ConfigType a -> Bool
typeClassRoots ConfigParsed
defaultConfig) Text
"type-class-roots"
    [InstancePattern String]
rootInstances <- [InstancePattern String]
-> Text -> Decoder [InstancePattern String]
forall a. DecodeTOML a => a -> Text -> Decoder a
TOML.getFieldOr (ConfigParsed -> [InstancePattern String]
forall a. ConfigType a -> [InstancePattern a]
rootInstances ConfigParsed
defaultConfig) Text
"root-instances" 
    Bool
unusedTypes <- Bool -> Text -> Decoder Bool
forall a. DecodeTOML a => a -> Text -> Decoder a
TOML.getFieldOr (ConfigParsed -> Bool
forall a. ConfigType a -> Bool
unusedTypes ConfigParsed
defaultConfig) Text
"unused-types"
    [String]
rootModules <- [String] -> Text -> Decoder [String]
forall a. DecodeTOML a => a -> Text -> Decoder a
TOML.getFieldOr (ConfigParsed -> [String]
forall a. ConfigType a -> [a]
rootModules ConfigParsed
defaultConfig) Text
"root-modules"

    pure Config{Bool
[String]
[InstancePattern String]
rootPatterns :: [String]
typeClassRoots :: Bool
rootInstances :: [InstancePattern String]
unusedTypes :: Bool
rootModules :: [String]
rootPatterns :: [String]
typeClassRoots :: Bool
rootInstances :: [InstancePattern String]
unusedTypes :: Bool
rootModules :: [String]
..}


decodeNoDefaults :: TOML.Decoder Config
decodeNoDefaults :: Decoder Config
decodeNoDefaults = do
  [String]
rootPatterns <- Text -> Decoder [String]
forall a. DecodeTOML a => Text -> Decoder a
TOML.getField Text
"roots"
  Bool
typeClassRoots <- Text -> Decoder Bool
forall a. DecodeTOML a => Text -> Decoder a
TOML.getField Text
"type-class-roots"
  [InstancePattern String]
rootInstances <- Text -> Decoder [InstancePattern String]
forall a. DecodeTOML a => Text -> Decoder a
TOML.getField Text
"root-instances"
  Bool
unusedTypes <- Text -> Decoder Bool
forall a. DecodeTOML a => Text -> Decoder a
TOML.getField Text
"unused-types"
  [String]
rootModules <- Text -> Decoder [String]
forall a. DecodeTOML a => Text -> Decoder a
TOML.getField Text
"root-modules"

  (String -> Decoder Config)
-> (Config -> Decoder Config)
-> Either String Config
-> Decoder Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Decoder Config
forall a. String -> Decoder a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Config -> Decoder Config
forall a. a -> Decoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Config -> Decoder Config)
-> Either String Config -> Decoder Config
forall a b. (a -> b) -> a -> b
$ ConfigParsed -> Either String Config
compileConfig Config{Bool
[String]
[InstancePattern String]
rootPatterns :: [String]
typeClassRoots :: Bool
rootInstances :: [InstancePattern String]
unusedTypes :: Bool
rootModules :: [String]
rootPatterns :: [String]
typeClassRoots :: Bool
rootInstances :: [InstancePattern String]
unusedTypes :: Bool
rootModules :: [String]
..}


instance TOML.DecodeTOML (InstancePattern String) where
  tomlDecoder :: Decoder (InstancePattern String)
tomlDecoder = Decoder (InstancePattern String)
decodeInstancePattern


-- | Decoder for a value of any of the forms:
--
-- @{instance = t, class = c, module = m} -> InstanceClassAndModule t c m@
--
-- @a -> InstanceOnly a@
--
-- @{instance = t} -> InstanceOnly t@
--
-- @{class = m} -> ClassOnly c@
--
-- etc.
decodeInstancePattern :: TOML.Decoder (InstancePattern String)
decodeInstancePattern :: Decoder (InstancePattern String)
decodeInstancePattern = Decoder (InstancePattern String)
decodeTable Decoder (InstancePattern String)
-> Decoder (InstancePattern String)
-> Decoder (InstancePattern String)
forall a. Decoder a -> Decoder a -> Decoder a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Decoder (InstancePattern String)
decodeStringLiteral Decoder (InstancePattern String)
-> Decoder (InstancePattern String)
-> Decoder (InstancePattern String)
forall a. Decoder a -> Decoder a -> Decoder a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Decoder (InstancePattern String)
forall {a}. Decoder a
decodeInstanceError

  where

    decodeStringLiteral :: Decoder (InstancePattern String)
decodeStringLiteral = String -> InstancePattern String
forall a. a -> InstancePattern a
InstanceOnly (String -> InstancePattern String)
-> Decoder String -> Decoder (InstancePattern String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder String
forall a. DecodeTOML a => Decoder a
TOML.tomlDecoder

    decodeTable :: Decoder (InstancePattern String)
decodeTable = do
      Maybe (InstancePattern String)
t <- (String -> InstancePattern String)
-> Maybe String -> Maybe (InstancePattern String)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> InstancePattern String
forall a. a -> InstancePattern a
InstanceOnly (Maybe String -> Maybe (InstancePattern String))
-> Decoder (Maybe String)
-> Decoder (Maybe (InstancePattern String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Decoder (Maybe String)
forall a. DecodeTOML a => Text -> Decoder (Maybe a)
TOML.getFieldOpt Text
"instance"
      Maybe (InstancePattern String)
c <- (String -> InstancePattern String)
-> Maybe String -> Maybe (InstancePattern String)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> InstancePattern String
forall a. a -> InstancePattern a
ClassOnly (Maybe String -> Maybe (InstancePattern String))
-> Decoder (Maybe String)
-> Decoder (Maybe (InstancePattern String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Decoder (Maybe String)
forall a. DecodeTOML a => Text -> Decoder (Maybe a)
TOML.getFieldOpt Text
"class"
      Maybe (InstancePattern String)
m <- (String -> InstancePattern String)
-> Maybe String -> Maybe (InstancePattern String)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> InstancePattern String
forall a. a -> InstancePattern a
ModuleOnly (Maybe String -> Maybe (InstancePattern String))
-> Decoder (Maybe String)
-> Decoder (Maybe (InstancePattern String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Decoder (Maybe String)
forall a. DecodeTOML a => Text -> Decoder (Maybe a)
TOML.getFieldOpt Text
"module"
      Decoder (InstancePattern String)
-> (InstancePattern String -> Decoder (InstancePattern String))
-> Maybe (InstancePattern String)
-> Decoder (InstancePattern String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Decoder (InstancePattern String)
forall {a}. Decoder a
forall (f :: * -> *) a. Alternative f => f a
empty InstancePattern String -> Decoder (InstancePattern String)
forall a. a -> Decoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (InstancePattern String)
t Maybe (InstancePattern String)
-> Maybe (InstancePattern String) -> Maybe (InstancePattern String)
forall a. Semigroup a => a -> a -> a
<> Maybe (InstancePattern String)
c Maybe (InstancePattern String)
-> Maybe (InstancePattern String) -> Maybe (InstancePattern String)
forall a. Semigroup a => a -> a -> a
<> Maybe (InstancePattern String)
m)

    decodeInstanceError :: Decoder a
decodeInstanceError = (Value -> DecodeM a) -> Decoder a
forall a. (Value -> DecodeM a) -> Decoder a
TOML.makeDecoder ((Value -> DecodeM a) -> Decoder a)
-> (Value -> DecodeM a) -> Decoder a
forall a b. (a -> b) -> a -> b
$
      Text -> Value -> DecodeM a
forall a. Text -> Value -> DecodeM a
TOML.invalidValue Text
"Need to specify at least one of 'instance', 'class', or 'module'"


showInstancePattern :: Show a => InstancePattern a -> String
showInstancePattern :: forall a. Show a => InstancePattern a -> String
showInstancePattern = \case
  InstanceOnly a
a -> a -> String
forall a. Show a => a -> String
show a
a
  InstancePattern a
p -> String
"{ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
table String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
    where
      table :: String
table = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          [ String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty a -> String
forall a. Show a => a -> String
typeField (InstancePattern a -> Maybe a
forall a. InstancePattern a -> Maybe a
instancePattern InstancePattern a
p)
          , String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty a -> String
forall a. Show a => a -> String
classField (InstancePattern a -> Maybe a
forall a. InstancePattern a -> Maybe a
classPattern InstancePattern a
p)
          , String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty a -> String
forall a. Show a => a -> String
moduleField (InstancePattern a -> Maybe a
forall a. InstancePattern a -> Maybe a
modulePattern InstancePattern a
p)
          ]
      typeField :: a -> String
typeField a
t = String
"instance = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
t
      classField :: a -> String
classField a
c = String
"class = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c
      moduleField :: a -> String
moduleField a
m = String
"module = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
m


compileRegex :: String -> Either String Regex
compileRegex :: String -> Either String Regex
compileRegex = (ParseError -> String)
-> ((Pattern, (Int, DoPa)) -> Regex)
-> Either ParseError (Pattern, (Int, DoPa))
-> Either String Regex
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ParseError -> String
forall a. Show a => a -> String
show (\(Pattern, (Int, DoPa))
p -> (Pattern, (Int, DoPa)) -> CompOption -> ExecOption -> Regex
patternToRegex (Pattern, (Int, DoPa))
p CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt) (Either ParseError (Pattern, (Int, DoPa)) -> Either String Regex)
-> (String -> Either ParseError (Pattern, (Int, DoPa)))
-> String
-> Either String Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either ParseError (Pattern, (Int, DoPa))
parseRegex


compileConfig :: ConfigParsed -> Either String Config
compileConfig :: ConfigParsed -> Either String Config
compileConfig conf :: ConfigParsed
conf@Config{ [InstancePattern String]
rootInstances :: forall a. ConfigType a -> [InstancePattern a]
rootInstances :: [InstancePattern String]
rootInstances, [String]
rootPatterns :: forall a. ConfigType a -> [a]
rootPatterns :: [String]
rootPatterns, [String]
rootModules :: forall a. ConfigType a -> [a]
rootModules :: [String]
rootModules } = 
  (String -> Either String Regex)
-> ConfigParsed -> Either String Config
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ConfigType a -> f (ConfigType b)
traverse String -> Either String Regex
compileRegex ConfigParsed
conf'
  where
    rootInstances' :: [InstancePattern String]
rootInstances' = [InstancePattern String] -> [InstancePattern String]
forall a. Ord a => [a] -> [a]
nubOrd [InstancePattern String]
rootInstances
    rootPatterns' :: [String]
rootPatterns' = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
rootPatterns
    rootModules' :: [String]
rootModules' = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd [String]
rootModules
    conf' :: ConfigParsed
conf' = ConfigParsed
conf{ rootInstances = rootInstances', rootPatterns = rootPatterns', rootModules = rootModules' }


configToToml :: ConfigParsed -> String
configToToml :: ConfigParsed -> String
configToToml Config{Bool
[String]
[InstancePattern String]
rootPatterns :: forall a. ConfigType a -> [a]
typeClassRoots :: forall a. ConfigType a -> Bool
rootInstances :: forall a. ConfigType a -> [InstancePattern a]
unusedTypes :: forall a. ConfigType a -> Bool
rootModules :: forall a. ConfigType a -> [a]
rootPatterns :: [String]
typeClassRoots :: Bool
rootInstances :: [InstancePattern String]
unusedTypes :: Bool
rootModules :: [String]
..}
  = [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
forall a. Monoid a => a
mempty ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      [ String
"roots = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
rootPatterns
      , String
"type-class-roots = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Bool -> String
forall a. Show a => a -> String
show Bool
typeClassRoots)
      , String
"root-instances = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((InstancePattern String -> String)
-> [InstancePattern String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map InstancePattern String -> String
forall a. Show a => InstancePattern a -> String
showInstancePattern [InstancePattern String]
rootInstances') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
      , String
"unused-types = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Bool -> String
forall a. Show a => a -> String
show Bool
unusedTypes)
      , String
"root-modules = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
rootModules
      ]
  where
    rootInstances' :: [InstancePattern String]
rootInstances' = [InstancePattern String]
rootInstances