content: {-# 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
    { rootPatterns :: [a]
      -- ^ Any declarations matching these regular expressions will be added to
      -- the root set.
    , typeClassRoots :: Bool
      -- ^ If True, consider all declarations in a type class as part of the root
      -- set. Overrides root-instances.
    , rootInstances :: [InstancePattern a]
      -- ^ All matching instances will be added to the root set. An absent field
      -- will always match.
    , unusedTypes :: Bool
      -- ^ Toggle to look for and output unused types. Type family instances will
      -- be marked as implicit roots.
    , rootModules :: [a]
      -- ^ All matching modules will be added to the root set.
    } deriving (Eq, Show, Functor, Foldable, 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
    { instancePattern :: Maybe a
    , classPattern :: Maybe a
    , modulePattern :: Maybe a
    } deriving (Eq, Show, Ord, Functor, Foldable, Traversable)
  
  
  instance Semigroup (InstancePattern a) where
    InstancePattern i c m <> InstancePattern i' c' m' =
      InstancePattern (i <|> i') (c <|> c') (m <|> m')
  
  
  pattern InstanceOnly, ClassOnly, ModuleOnly :: a -> InstancePattern a
  pattern InstanceOnly t = InstancePattern (Just t) Nothing Nothing
  pattern ClassOnly c = InstancePattern Nothing (Just c) Nothing
  pattern ModuleOnly m = InstancePattern Nothing Nothing (Just m)
  
  
  defaultConfig :: ConfigParsed
  defaultConfig = Config
    { rootPatterns = [ "Main.main", "^Paths_.*"]
    , typeClassRoots = False
    , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ]
    , unusedTypes = False
    , rootModules = mempty
    }
  
  
  instance TOML.DecodeTOML Config where
    tomlDecoder = do
      conf <- TOML.tomlDecoder
      either fail pure $ compileConfig conf
  
  
  instance TOML.DecodeTOML ConfigParsed where
    tomlDecoder = do
      rootPatterns <- TOML.getFieldOr (rootPatterns defaultConfig) "roots"
      typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots"
      rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances"
      unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types"
      rootModules <- TOML.getFieldOr (rootModules defaultConfig) "root-modules"
  
      pure Config{..}
  
  
  decodeNoDefaults :: TOML.Decoder Config
  decodeNoDefaults = do
    rootPatterns <- TOML.getField "roots"
    typeClassRoots <- TOML.getField "type-class-roots"
    rootInstances <- TOML.getField "root-instances"
    unusedTypes <- TOML.getField "unused-types"
    rootModules <- TOML.getField "root-modules"
  
    either fail pure $ compileConfig Config{..}
  
  
  instance TOML.DecodeTOML (InstancePattern String) where
    tomlDecoder = 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 = decodeTable <|> decodeStringLiteral <|> decodeInstanceError
  
    where
  
      decodeStringLiteral = InstanceOnly <$> TOML.tomlDecoder
  
      decodeTable = do
        t <- fmap InstanceOnly <$> TOML.getFieldOpt "instance"
        c <- fmap ClassOnly <$> TOML.getFieldOpt "class"
        m <- fmap ModuleOnly <$> TOML.getFieldOpt "module"
        maybe empty pure (t <> c <> m)
  
      decodeInstanceError = TOML.makeDecoder $
        TOML.invalidValue "Need to specify at least one of 'instance', 'class', or 'module'"
  
  
  showInstancePattern :: Show a => InstancePattern a -> String
  showInstancePattern = \case
    InstanceOnly a -> show a
    p -> "{ " ++ table ++ " }"
      where
        table = intercalate ", " . filter (not . null) $
            [ maybe mempty typeField (instancePattern p)
            , maybe mempty classField (classPattern p)
            , maybe mempty moduleField (modulePattern p)
            ]
        typeField t = "instance = " ++ show t
        classField c = "class = " ++ show c
        moduleField m = "module = " ++ show m
  
  
  compileRegex :: String -> Either String Regex
  compileRegex = bimap show (\p -> patternToRegex p defaultCompOpt defaultExecOpt) . parseRegex
  
  
  compileConfig :: ConfigParsed -> Either String Config
  compileConfig conf@Config{ rootInstances, rootPatterns, rootModules } =
    traverse compileRegex conf'
    where
      rootInstances' = nubOrd rootInstances
      rootPatterns' = nubOrd rootPatterns
      rootModules' = nubOrd rootModules
      conf' = conf{ rootInstances = rootInstances', rootPatterns = rootPatterns', rootModules = rootModules' }
  
  
  configToToml :: ConfigParsed -> String
  configToToml Config{..}
    = unlines . intersperse mempty $
        [ "roots = " ++ show rootPatterns
        , "type-class-roots = " ++ map toLower (show typeClassRoots)
        , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]"
        , "unused-types = " ++ map toLower (show unusedTypes)
        , "root-modules = " ++ show rootModules
        ]
    where
      rootInstances' = rootInstances
  