content: {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  
  module Floskell.Config
      ( Indent(..)
      , LayoutContext(..)
      , Location(..)
      , WsLoc(..)
      , Whitespace(..)
      , Layout(..)
      , ConfigMapKey(..)
      , ConfigMap(..)
      , PenaltyConfig(..)
      , AlignConfig(..)
      , IndentConfig(..)
      , LayoutConfig(..)
      , OpConfig(..)
      , GroupConfig(..)
      , ImportsGroupOrder(..)
      , ImportsGroup(..)
      , SortImportsRule(..)
      , DeclarationConstruct(..)
      , OptionConfig(..)
      , Config(..)
      , defaultConfig
      , safeConfig
      , cfgMapFind
      , cfgOpWs
      , cfgGroupWs
      , inWs
      , wsSpace
      , wsLinebreak
      ) where
  
  import           Data.Aeson
                   ( FromJSON(..), ToJSON(..), genericParseJSON, genericToJSON )
  import qualified Data.Aeson        as JSON
  import           Data.Aeson.Types  as JSON
                   ( Options(..), camelTo2, typeMismatch )
  import           Data.Default      ( Default(..) )
  import qualified Data.HashMap.Lazy as HashMap
  import           Data.Map.Strict   ( Map )
  import qualified Data.Map.Strict   as Map
  import           Data.Set          ( Set )
  import qualified Data.Set          as Set
  import           Data.Text         ( Text )
  import qualified Data.Text         as T
  
  import           GHC.Generics
  
  data Indent = Align | IndentBy !Int | AlignOrIndentBy !Int
      deriving ( Eq, Ord, Show, Generic )
  
  data LayoutContext = Declaration | Type | Pattern | Expression | Other
      deriving ( Eq, Ord, Bounded, Enum, Show, Generic )
  
  data Location = Before | After
      deriving ( Eq, Ord, Bounded, Enum, Show, Generic )
  
  data WsLoc = WsNone | WsBefore | WsAfter | WsBoth
      deriving ( Eq, Ord, Bounded, Enum, Show, Generic )
  
  data Whitespace = Whitespace { wsSpaces         :: !WsLoc
                               , wsLinebreaks     :: !WsLoc
                               , wsForceLinebreak :: !Bool
                               }
      deriving ( Show, Generic )
  
  data Layout = Flex | Vertical | TryOneline
      deriving ( Eq, Ord, Bounded, Enum, Show, Generic )
  
  data ConfigMapKey = ConfigMapKey !(Maybe Text) !(Maybe LayoutContext)
      deriving ( Eq, Ord, Show )
  
  data ConfigMap a =
      ConfigMap { cfgMapDefault :: !a, cfgMapOverrides :: !(Map ConfigMapKey a) }
      deriving ( Generic )
  
  data PenaltyConfig = PenaltyConfig { penaltyMaxLineLength :: !Int
                                     , penaltyLinebreak     :: !Int
                                     , penaltyIndent        :: !Int
                                     , penaltyOverfull      :: !Int
                                     , penaltyOverfullOnce  :: !Int
                                     }
      deriving ( Generic )
  
  instance Default PenaltyConfig where
      def = PenaltyConfig { penaltyMaxLineLength = 80
                          , penaltyLinebreak     = 100
                          , penaltyIndent        = 1
                          , penaltyOverfull      = 10
                          , penaltyOverfullOnce  = 200
                          }
  
  data AlignConfig =
      AlignConfig { cfgAlignLimits       :: !(Int, Int)
                  , cfgAlignCase         :: !Bool
                  , cfgAlignClass        :: !Bool
                  , cfgAlignImportModule :: !Bool
                  , cfgAlignImportSpec   :: !Bool
                  , cfgAlignLetBinds     :: !Bool
                  , cfgAlignMatches      :: !Bool
                  , cfgAlignRecordFields :: !Bool
                  , cfgAlignWhere        :: !Bool
                  }
      deriving ( Generic )
  
  instance Default AlignConfig where
      def = AlignConfig { cfgAlignLimits       = (10, 25)
                        , cfgAlignCase         = False
                        , cfgAlignClass        = False
                        , cfgAlignImportModule = False
                        , cfgAlignImportSpec   = False
                        , cfgAlignLetBinds     = False
                        , cfgAlignMatches      = False
                        , cfgAlignRecordFields = False
                        , cfgAlignWhere        = False
                        }
  
  data IndentConfig =
      IndentConfig { cfgIndentOnside         :: !Int
                   , cfgIndentDeriving       :: !Int
                   , cfgIndentWhere          :: !Int
                   , cfgIndentApp            :: !Indent
                   , cfgIndentCase           :: !Indent
                   , cfgIndentClass          :: !Indent
                   , cfgIndentDo             :: !Indent
                   , cfgIndentExportSpecList :: !Indent
                   , cfgIndentIf             :: !Indent
                   , cfgIndentImportSpecList :: !Indent
                   , cfgIndentLet            :: !Indent
                   , cfgIndentLetBinds       :: !Indent
                   , cfgIndentLetIn          :: !Indent
                   , cfgIndentMultiIf        :: !Indent
                   , cfgIndentTypesig        :: !Indent
                   , cfgIndentWhereBinds     :: !Indent
                   }
      deriving ( Generic )
  
  instance Default IndentConfig where
      def = IndentConfig { cfgIndentOnside         = 4
                         , cfgIndentDeriving       = 4
                         , cfgIndentWhere          = 2
                         , cfgIndentApp            = IndentBy 4
                         , cfgIndentCase           = IndentBy 4
                         , cfgIndentClass          = IndentBy 4
                         , cfgIndentDo             = IndentBy 4
                         , cfgIndentExportSpecList = IndentBy 4
                         , cfgIndentIf             = IndentBy 4
                         , cfgIndentImportSpecList = IndentBy 4
                         , cfgIndentLet            = IndentBy 4
                         , cfgIndentLetBinds       = IndentBy 4
                         , cfgIndentLetIn          = IndentBy 4
                         , cfgIndentMultiIf        = IndentBy 4
                         , cfgIndentTypesig        = IndentBy 4
                         , cfgIndentWhereBinds     = IndentBy 2
                         }
  
  data LayoutConfig =
      LayoutConfig { cfgLayoutApp            :: !Layout
                   , cfgLayoutConDecls       :: !Layout
                   , cfgLayoutDeclaration    :: !Layout
                   , cfgLayoutExportSpecList :: !Layout
                   , cfgLayoutIf             :: !Layout
                   , cfgLayoutImportSpecList :: !Layout
                   , cfgLayoutInfixApp       :: !Layout
                   , cfgLayoutLet            :: !Layout
                   , cfgLayoutListComp       :: !Layout
                   , cfgLayoutRecord         :: !Layout
                   , cfgLayoutType           :: !Layout
                   }
      deriving ( Generic )
  
  instance Default LayoutConfig where
      def = LayoutConfig { cfgLayoutApp            = Flex
                         , cfgLayoutConDecls       = Flex
                         , cfgLayoutDeclaration    = Flex
                         , cfgLayoutExportSpecList = Flex
                         , cfgLayoutIf             = Flex
                         , cfgLayoutImportSpecList = Flex
                         , cfgLayoutInfixApp       = Flex
                         , cfgLayoutLet            = Flex
                         , cfgLayoutListComp       = Flex
                         , cfgLayoutRecord         = Flex
                         , cfgLayoutType           = Flex
                         }
  
  newtype OpConfig = OpConfig { unOpConfig :: ConfigMap Whitespace }
      deriving ( Generic )
  
  instance Default OpConfig where
      def =
          OpConfig ConfigMap { cfgMapDefault   = Whitespace WsBoth WsBefore False
                             , cfgMapOverrides = Map.empty
                             }
  
  newtype GroupConfig = GroupConfig { unGroupConfig :: ConfigMap Whitespace }
      deriving ( Generic )
  
  instance Default GroupConfig where
      def = GroupConfig ConfigMap { cfgMapDefault   =
                                        Whitespace WsBoth WsAfter False
                                  , cfgMapOverrides = Map.empty
                                  }
  
  data ImportsGroupOrder =
      ImportsGroupKeep | ImportsGroupSorted | ImportsGroupGrouped
      deriving ( Generic )
  
  data ImportsGroup = ImportsGroup { importsPrefixes :: ![String]
                                   , importsOrder    :: !ImportsGroupOrder
                                   }
      deriving ( Generic )
  
  data SortImportsRule =
      NoImportSort | SortImportsByPrefix | SortImportsByGroups ![ImportsGroup]
  
  data DeclarationConstruct = DeclModule | DeclClass | DeclInstance | DeclWhere
      deriving ( Eq, Ord, Generic )
  
  data OptionConfig =
      OptionConfig { cfgOptionSortPragmas            :: !Bool
                   , cfgOptionSplitLanguagePragmas   :: !Bool
                   , cfgOptionSortImports            :: !SortImportsRule
                   , cfgOptionSortImportLists        :: !Bool
                   , cfgOptionAlignSumTypeDecl       :: !Bool
                   , cfgOptionFlexibleOneline        :: !Bool
                   , cfgOptionPreserveVerticalSpace  :: !Bool
                   , cfgOptionDeclNoBlankLines
                         :: !(Set DeclarationConstruct)
                   , cfgOptionAlignLetBindsAndInExpr :: !Bool
                   }
      deriving ( Generic )
  
  instance Default OptionConfig where
      def = OptionConfig { cfgOptionSortPragmas            = False
                         , cfgOptionSplitLanguagePragmas   = False
                         , cfgOptionSortImports            = NoImportSort
                         , cfgOptionSortImportLists        = False
                         , cfgOptionAlignSumTypeDecl       = False
                         , cfgOptionFlexibleOneline        = False
                         , cfgOptionPreserveVerticalSpace  = False
                         , cfgOptionDeclNoBlankLines       = Set.empty
                         , cfgOptionAlignLetBindsAndInExpr = False
                         }
  
  data Config = Config { cfgPenalty :: !PenaltyConfig
                       , cfgAlign   :: !AlignConfig
                       , cfgIndent  :: !IndentConfig
                       , cfgLayout  :: !LayoutConfig
                       , cfgOp      :: !OpConfig
                       , cfgGroup   :: !GroupConfig
                       , cfgOptions :: !OptionConfig
                       }
      deriving ( Generic )
  
  instance Default Config where
      def = Config { cfgPenalty = def
                   , cfgAlign   = def
                   , cfgIndent  = def
                   , cfgLayout  = def
                   , cfgOp      = def
                   , cfgGroup   = def
                   , cfgOptions = def
                   }
  
  defaultConfig :: Config
  defaultConfig =
      def { cfgOp    = OpConfig ((unOpConfig def) { cfgMapOverrides =
                                                        Map.fromList opWsOverrides
                                                  })
          , cfgGroup = GroupConfig ((unGroupConfig def) { cfgMapOverrides = Map.fromList groupWsOverrides
                                                        })
          }
    where
      opWsOverrides =
          [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)
          , ( ConfigMapKey (Just "record") Nothing
            , Whitespace WsAfter WsAfter False
            )
          , ( ConfigMapKey (Just ".") (Just Type)
            , Whitespace WsAfter WsAfter False
            )
          ]
  
      groupWsOverrides =
          [ (ConfigMapKey (Just "[") (Just Type), Whitespace WsBoth WsNone False)
          ]
  
  safeConfig :: Config -> Config
  safeConfig cfg = cfg { cfgGroup = group, cfgOp = op }
    where
      group = GroupConfig $
          updateOverrides (unGroupConfig $ cfgGroup cfg)
                          [ ("(#", Expression, WsBoth), ("(#", Pattern, WsBoth) ]
  
      op = OpConfig $
          updateOverrides (unOpConfig $ cfgOp cfg)
                          [ (".", Expression, WsBoth), ("@", Pattern, WsNone) ]
  
      updateOverrides config overrides =
          config { cfgMapOverrides =
                       foldl (updateWs config) (cfgMapOverrides config) overrides
                 }
  
      updateWs config m (key, ctx, ws) =
          Map.insertWith (flip const)
                         (ConfigMapKey (Just key) (Just ctx))
                         (cfgMapFind ctx key config) { wsSpaces = ws }
                         m
  
  cfgMapFind :: LayoutContext -> Text -> ConfigMap a -> a
  cfgMapFind ctx key ConfigMap{..} =
      let value = cfgMapDefault
          value' = Map.findWithDefault value
                                       (ConfigMapKey Nothing (Just ctx))
                                       cfgMapOverrides
          value'' = Map.findWithDefault value'
                                        (ConfigMapKey (Just key) Nothing)
                                        cfgMapOverrides
          value''' = Map.findWithDefault value''
                                         (ConfigMapKey (Just key) (Just ctx))
                                         cfgMapOverrides
      in
          value'''
  
  cfgOpWs :: LayoutContext -> Text -> OpConfig -> Whitespace
  cfgOpWs ctx op = cfgMapFind ctx op . unOpConfig
  
  cfgGroupWs :: LayoutContext -> Text -> GroupConfig -> Whitespace
  cfgGroupWs ctx op = cfgMapFind ctx op . unGroupConfig
  
  inWs :: Location -> WsLoc -> Bool
  inWs _ WsBoth = True
  inWs Before WsBefore = True
  inWs After WsAfter = True
  inWs _ _ = False
  
  wsSpace :: Location -> Whitespace -> Bool
  wsSpace loc ws = loc `inWs` wsSpaces ws
  
  wsLinebreak :: Location -> Whitespace -> Bool
  wsLinebreak loc ws = loc `inWs` wsLinebreaks ws
  
  ------------------------------------------------------------------------
  readMaybe :: Read a => String -> Maybe a
  readMaybe str = case reads str of
      [ (x, "") ] -> Just x
      _ -> Nothing
  
  enumOptions :: Int -> Options
  enumOptions n =
      JSON.defaultOptions { constructorTagModifier = JSON.camelTo2 '-' . drop n }
  
  recordOptions :: Int -> Options
  recordOptions n =
      JSON.defaultOptions { fieldLabelModifier = JSON.camelTo2 '-' . drop n
                          , unwrapUnaryRecords = True
                          }
  
  instance ToJSON Indent where
      toJSON i = JSON.String $ case i of
          Align -> "align"
          IndentBy x -> "indent-by " `T.append` T.pack (show x)
          AlignOrIndentBy x -> "align-or-indent-by " `T.append` T.pack (show x)
  
  instance FromJSON Indent where
      parseJSON v@(JSON.String t) = maybe (JSON.typeMismatch "Indent" v) return $
          if t == "align"
          then Just Align
          else if "indent-by " `T.isPrefixOf` t
               then IndentBy <$> readMaybe (T.unpack $ T.drop 10 t)
               else if "align-or-indent-by " `T.isPrefixOf` t
                    then AlignOrIndentBy <$> readMaybe (T.unpack $ T.drop 19 t)
                    else Nothing
  
      parseJSON v = JSON.typeMismatch "Indent" v
  
  instance ToJSON LayoutContext where
      toJSON = genericToJSON (enumOptions 0)
  
  instance FromJSON LayoutContext where
      parseJSON = genericParseJSON (enumOptions 0)
  
  instance ToJSON WsLoc where
      toJSON = genericToJSON (enumOptions 2)
  
  instance FromJSON WsLoc where
      parseJSON = genericParseJSON (enumOptions 2)
  
  instance ToJSON Whitespace where
      toJSON = genericToJSON (recordOptions 2)
  
  instance FromJSON Whitespace where
      parseJSON = genericParseJSON (recordOptions 2)
  
  instance ToJSON Layout where
      toJSON = genericToJSON (enumOptions 0)
  
  instance FromJSON Layout where
      parseJSON = genericParseJSON (enumOptions 0)
  
  layoutToText :: LayoutContext -> T.Text
  layoutToText Declaration = "declaration"
  layoutToText Type = "type"
  layoutToText Pattern = "pattern"
  layoutToText Expression = "expression"
  layoutToText Other = "other"
  
  textToLayout :: T.Text -> Maybe LayoutContext
  textToLayout "declaration" = Just Declaration
  textToLayout "type" = Just Type
  textToLayout "pattern" = Just Pattern
  textToLayout "expression" = Just Expression
  textToLayout "other" = Just Other
  textToLayout _ = Nothing
  
  keyToText :: ConfigMapKey -> T.Text
  keyToText (ConfigMapKey Nothing Nothing) = "default"
  keyToText (ConfigMapKey (Just n) Nothing) = n
  keyToText (ConfigMapKey Nothing (Just l)) = "* in " `T.append` layoutToText l
  keyToText (ConfigMapKey (Just n) (Just l)) =
      n `T.append` " in " `T.append` layoutToText l
  
  textToKey :: T.Text -> Maybe ConfigMapKey
  textToKey t = case T.splitOn " in " t of
      [ "default" ] -> Just (ConfigMapKey Nothing Nothing)
      [ "*", "*" ] -> Just (ConfigMapKey Nothing Nothing)
      [ name ] -> Just (ConfigMapKey (Just name) Nothing)
      [ name, "*" ] -> Just (ConfigMapKey (Just name) Nothing)
      [ "*", layout ] -> ConfigMapKey Nothing . Just <$> textToLayout layout
      [ name, layout ] -> ConfigMapKey (Just name) . Just <$> textToLayout layout
      _ -> Nothing
  
  instance ToJSON a => ToJSON (ConfigMap a) where
      toJSON ConfigMap{..} = toJSON $ Map.insert "default" cfgMapDefault $
          Map.mapKeys keyToText cfgMapOverrides
  
  instance FromJSON a => FromJSON (ConfigMap a) where
      parseJSON value = do
          o <- parseJSON value
          cfgMapDefault <- maybe (fail "Missing key: default") return $
              HashMap.lookup "default" o
          cfgMapOverrides <- either fail (return . Map.fromList) $ mapM toKey $
              HashMap.toList $ HashMap.delete "default" o
          return ConfigMap { .. }
        where
          toKey (k, v) = case textToKey k of
              Just k' -> Right (k', v)
              Nothing -> Left ("Invalid key: " ++ T.unpack k)
  
  instance ToJSON PenaltyConfig where
      toJSON = genericToJSON (recordOptions 7)
  
  instance FromJSON PenaltyConfig where
      parseJSON = genericParseJSON (recordOptions 7)
  
  instance ToJSON AlignConfig where
      toJSON = genericToJSON (recordOptions 8)
  
  instance FromJSON AlignConfig where
      parseJSON = genericParseJSON (recordOptions 8)
  
  instance ToJSON IndentConfig where
      toJSON = genericToJSON (recordOptions 9)
  
  instance FromJSON IndentConfig where
      parseJSON = genericParseJSON (recordOptions 9)
  
  instance ToJSON LayoutConfig where
      toJSON = genericToJSON (recordOptions 9)
  
  instance FromJSON LayoutConfig where
      parseJSON = genericParseJSON (recordOptions 9)
  
  instance ToJSON OpConfig where
      toJSON = genericToJSON (recordOptions 0)
  
  instance FromJSON OpConfig where
      parseJSON = genericParseJSON (recordOptions 0)
  
  instance ToJSON GroupConfig where
      toJSON = genericToJSON (recordOptions 0)
  
  instance FromJSON GroupConfig where
      parseJSON = genericParseJSON (recordOptions 0)
  
  instance ToJSON ImportsGroupOrder where
      toJSON = genericToJSON (enumOptions 12)
  
  instance FromJSON ImportsGroupOrder where
      parseJSON = genericParseJSON (enumOptions 12)
  
  instance ToJSON ImportsGroup where
      toJSON = genericToJSON (recordOptions 7)
  
  instance FromJSON ImportsGroup where
      parseJSON x@JSON.Array{} =
          ImportsGroup <$> parseJSON x <*> pure ImportsGroupKeep
      parseJSON x = genericParseJSON (recordOptions 7) x
  
  instance ToJSON SortImportsRule where
      toJSON NoImportSort = toJSON False
      toJSON SortImportsByPrefix = toJSON True
      toJSON (SortImportsByGroups xs) = toJSON xs
  
  instance FromJSON SortImportsRule where
      parseJSON (JSON.Bool False) = return NoImportSort
      parseJSON (JSON.Bool True) = return SortImportsByPrefix
      parseJSON v = SortImportsByGroups <$> parseJSON v
  
  instance ToJSON DeclarationConstruct where
      toJSON = genericToJSON (enumOptions 4)
  
  instance FromJSON DeclarationConstruct where
      parseJSON = genericParseJSON (enumOptions 4)
  
  instance ToJSON OptionConfig where
      toJSON = genericToJSON (recordOptions 9)
  
  instance FromJSON OptionConfig where
      parseJSON = genericParseJSON (recordOptions 9)
  
  instance ToJSON Config where
      toJSON = genericToJSON (recordOptions 3)
  
  instance FromJSON Config where
      parseJSON = genericParseJSON (recordOptions 3)
  