content: {-# LANGUAGE FlexibleInstances #-}
  
  module Unused.ResultsClassifier.Types
      ( LanguageConfiguration(..)
      , LowLikelihoodMatch(..)
      , TermAlias(..)
      , Position(..)
      , Matcher(..)
      , ParseConfigError(..)
      ) where
  
  import qualified Control.Applicative as A
  import qualified Control.Monad as M
  import qualified Data.HashMap.Strict as HM
  import qualified Data.List as L
  import           Data.Text (Text)
  import qualified Data.Text as T
  import           Data.Yaml (FromJSON(..), (.:), (.:?), (.!=))
  import qualified Data.Yaml as Y
  import           Unused.Projection
  
  data LanguageConfiguration = LanguageConfiguration
      { lcName :: String
      , lcAllowedTerms :: [String]
      , lcAutoLowLikelihood :: [LowLikelihoodMatch]
      , lcTermAliases :: [TermAlias]
      }
  
  data LowLikelihoodMatch = LowLikelihoodMatch
      { smName :: String
      , smMatchers :: [Matcher]
      , smClassOrModule :: Bool
      }
  
  data TermAlias = TermAlias
      { taFrom :: String
      , taTo :: String
      , taTransform :: Text -> Text
      }
  
  data ParseConfigError = ParseConfigError
      { pcePath :: String
      , pceParseError :: String
      }
  
  data Position = StartsWith | EndsWith | Equals
  data Matcher = Term Position String | Path Position String | AppOccurrences Int | AllowedTerms [String]
  
  instance FromJSON LanguageConfiguration where
      parseJSON (Y.Object o) = LanguageConfiguration
          <$> o .: "name"
          <*> o .:? "allowedTerms" .!= []
          <*> o .:? "autoLowLikelihood" .!= []
          <*> o .:? "aliases" .!= []
      parseJSON _ = M.mzero
  
  instance FromJSON LowLikelihoodMatch where
      parseJSON (Y.Object o) = LowLikelihoodMatch
          <$> o .: "name"
          <*> parseMatchers o
          <*> o .:? "classOrModule" .!= False
      parseJSON _ = M.mzero
  
  instance FromJSON TermAlias where
      parseJSON (Y.Object o) = TermAlias
          <$> o .: "from"
          <*> o .: "to"
          <*> (either fail return =<< (translate . T.pack <$> (o .: "to")))
      parseJSON _ = M.mzero
  
  data MatchHandler a = MatchHandler
      { mhKeys :: [String]
      , mhKeyToMatcher :: T.Text -> Either T.Text (a -> Matcher)
      }
  
  intHandler :: MatchHandler Int
  intHandler = MatchHandler
      { mhKeys = ["appOccurrences"]
      , mhKeyToMatcher = keyToMatcher
      }
    where
      keyToMatcher "appOccurrences" = Right AppOccurrences
      keyToMatcher t                = Left t
  
  stringHandler :: MatchHandler String
  stringHandler = MatchHandler
      { mhKeys = ["pathStartsWith", "pathEndsWith", "termStartsWith", "termEndsWith", "termEquals"]
      , mhKeyToMatcher = keyToMatcher
      }
    where
      keyToMatcher "pathStartsWith" = Right $ Path StartsWith
      keyToMatcher "pathEndsWith"   = Right $ Path EndsWith
      keyToMatcher "termStartsWith" = Right $ Term StartsWith
      keyToMatcher "termEndsWith"   = Right $ Term EndsWith
      keyToMatcher "termEquals"     = Right $ Term Equals
      keyToMatcher t                = Left t
  
  stringListHandler :: MatchHandler [String]
  stringListHandler = MatchHandler
      { mhKeys = ["allowedTerms"]
      , mhKeyToMatcher = keyToMatcher
      }
    where
      keyToMatcher "allowedTerms" = Right AllowedTerms
      keyToMatcher t              = Left t
  
  lowLikelihoodMatchKeys :: [T.Text]
  lowLikelihoodMatchKeys =
      map T.pack $ ["name", "classOrModule"] ++ mhKeys intHandler ++ mhKeys stringHandler ++ mhKeys stringListHandler
  
  validateLowLikelihoodKeys :: Y.Object -> Y.Parser [Matcher] -> Y.Parser [Matcher]
  validateLowLikelihoodKeys o ms =
      if fullOverlap
          then ms
          else fail $ "The following keys are unsupported: " ++ L.intercalate ", " (T.unpack <$> unsupportedKeys)
    where
      fullOverlap = null unsupportedKeys
      unsupportedKeys = HM.keys o L.\\ lowLikelihoodMatchKeys
  
  parseMatchers :: Y.Object -> Y.Parser [Matcher]
  parseMatchers o =
      validateLowLikelihoodKeys o $ myFold (++) [buildMatcherList o intHandler, buildMatcherList o stringHandler, buildMatcherList o stringListHandler]
    where
      myFold :: (Foldable t, Monad m) => (a -> a -> a) -> t (m a) -> m a
      myFold f = foldl1 (\acc i -> acc >>= (\l -> f l <$> i))
  
  buildMatcherList :: FromJSON a => Y.Object -> MatchHandler a -> Y.Parser [Matcher]
  buildMatcherList o mh =
      sequenceA $ matcherParserForKey <$> keysToParse
    where
      matcherParserForKey k = extractMatcher (mhKeyToMatcher mh k) $ mKey k
      keysToParse = positionKeysforMatcher o (mhKeys mh)
      mKey = (.:?) o
  
  positionKeysforMatcher :: Y.Object -> [String] -> [T.Text]
  positionKeysforMatcher o ls = L.intersect (T.pack <$> ls) $ HM.keys o
  
  extractMatcher :: Either T.Text (a -> Matcher) -> Y.Parser (Maybe a) -> Y.Parser Matcher
  extractMatcher e p = either displayFailure (convertFoundObjectToMatcher p) e
  
  convertFoundObjectToMatcher :: (Monad m, A.Alternative m) => m (Maybe a) -> (a -> b) -> m b
  convertFoundObjectToMatcher p f = maybe A.empty (pure . f) =<< p
  
  displayFailure :: T.Text -> Y.Parser a
  displayFailure t = fail $ "Parse error: '" ++ T.unpack t ++ "' is not a valid key in a singleOnly matcher"
  