content: {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE RecordWildCards #-}
  
  -- | Given a file, guess settings from it by looking at the hints.
  module Config.Compute(computeSettings) where
  
  import GHC.All
  import GHC.Util
  import Config.Type
  import Fixity
  import Data.Generics.Uniplate.DataOnly
  import GHC.Hs hiding (Warning)
  import GHC.Types.Name.Reader
  import GHC.Types.Name
  import GHC.Types.SrcLoc
  import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
  import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
  import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
  import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
  import Prelude
  
  
  -- | Given a source file, guess some hints that might apply.
  --   Returns the text of the hints (if you want to save it down) along with the settings to be used.
  computeSettings :: ParseFlags -> FilePath -> IO (String, [Setting])
  computeSettings flags file = do
      x <- parseModuleEx flags file Nothing
      case x of
          Left (ParseError sl msg _) ->
              pure ("# Parse error " ++ showSrcSpan sl ++ ": " ++ msg, [])
          Right ModuleEx{ghcModule=m} -> do
              let xs = concatMap findSetting (hsmodDecls $ unLoc m)
                  s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs]
              pure (s,xs)
  
  
  renderSetting :: Setting -> [String]
  -- Only need to convert the subset of Setting we generate
  renderSetting (SettingMatchExp HintRule{..}) =
      ["- warn: {lhs: " ++ show (unsafePrettyPrint hintRuleLHS) ++ ", rhs: " ++ show (unsafePrettyPrint hintRuleRHS) ++ "}"]
  renderSetting (Infix x) =
      ["- fixity: " ++ show (unsafePrettyPrint $ toFixitySig x)]
  renderSetting _ = []
  
  findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
  findSetting (L _ (ValD _ x)) = findBind x
  findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
      concatMap (findBind . unLoc) cid_binds
  findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x
  findSetting x = []
  
  
  findBind :: HsBind GhcPs -> [Setting]
  findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs
  findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn LamSingle fun_matches
  findBind _ = []
  
  findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
  findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
      = if length pats == length ps then findExp name (vs++ps) $ unLoc x else []
      where ps = [rdrNameStr x | L _ (VarPat _ x) <- pats]
  findExp name vs HsLam{} = []
  findExp name vs HsVar{} = []
  findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
      HsApp noExtField x $ nlHsPar $ noLocA $ HsApp noExtField y $ noLocA $ mkVar "_hlint"
  
  findExp name vs bod = [SettingMatchExp $
          HintRule Warning defaultHintName []
          mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing]
      where
          lhs = fromParen $ noLocA $ transform f bod
          rhs = apps $ map noLocA $ HsVar noExtField (noLocA name) : map snd rep
  
          rep = zip vs $ map (mkVar . pure) ['a'..]
          f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y
          f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar y
          f x = x
  
  
  mkVar :: String -> HsExpr GhcPs
  mkVar = HsVar noExtField . noLocA . Unqual . mkVarOcc
  