ConfigFile.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Floskell.ConfigFile
    ( AppConfig(..)
    , defaultAppConfig
    , findAppConfig
    , findAppConfigIn
    , readAppConfig
    , showStyle
    , showLanguage
    , showExtension
    , showFixity
    , lookupStyle
    , lookupLanguage
    , lookupExtension
    , lookupFixity
    , setStyle
    , setLanguage
    , setExtensions
    , setFixities
    ) where

import           Control.Applicative        ( (<|>) )

import           Data.Aeson
                 ( (.:?), (.=), FromJSON(..), ToJSON(..) )
import qualified Data.Aeson                 as JSON
import qualified Data.Aeson.Parser          as JSON ( json' )
import qualified Data.Aeson.Types           as JSON ( typeMismatch )
import qualified Data.Attoparsec.ByteString as AP
import qualified Data.ByteString            as BS
import           Data.Char                  ( isLetter, isSpace )
import           Data.List                  ( (\\), inits )
import qualified Data.Text                  as T

import           Floskell.Attoparsec        ( parseOnly )
import           Floskell.Styles            ( Style(..), styles )

import           GHC.Generics               ( Generic )

import           Language.Haskell.Exts
                 ( Extension(..), Fixity(..), KnownExtension(..)
                 , Language(..), classifyExtension, classifyLanguage
                 , knownExtensions )
import qualified Language.Haskell.Exts      as HSE

import           System.Directory
                 ( XdgDirectory(..), doesFileExist, findFileWith
                 , getAppUserDataDirectory, getCurrentDirectory
                 , getHomeDirectory, getXdgDirectory )
import           System.FilePath
                 ( joinPath, splitDirectories, takeDirectory )

{- floskell-disable -}
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap          as Map
#else
import qualified Data.HashMap.Lazy          as Map
#endif
{- floskell-enable -}

data AppConfig = AppConfig { appStyle      :: Style
                           , appLanguage   :: Language
                           , appExtensions :: [Extension]
                           , appFixities   :: [Fixity]
                           }
    deriving ( Generic )

instance ToJSON AppConfig where
    toJSON AppConfig{..} =
        JSON.object [ "style" .= showStyle appStyle
                    , "language" .= showLanguage appLanguage
                    , "extensions" .= map showExtension appExtensions
                    , "fixities" .= map showFixity appFixities
                    , "formatting" .= styleConfig appStyle
                    ]

instance FromJSON AppConfig where
    parseJSON (JSON.Object o) = do
        style <- maybe (appStyle defaultAppConfig) lookupStyle <$> o .:? "style"
        language <- maybe (appLanguage defaultAppConfig) lookupLanguage
            <$> o .:? "language"
        extensions <- maybe (appExtensions defaultAppConfig)
                            ((appExtensions defaultAppConfig ++) . map lookupExtension)
                            <$> o .:? "extensions"
        fixities <- maybe (appFixities defaultAppConfig) (map lookupFixity)
            <$> o .:? "fixities"
        let fmt = styleConfig style
        fmt' <- maybe fmt (updateConfig fmt) <$> o .:? "formatting"
        let style' = style { styleConfig = fmt' }
        return $ AppConfig style' language extensions fixities
      where
        updateConfig cfg v = case JSON.fromJSON $ mergeJSON (toJSON cfg) v of
            JSON.Error e -> error e
            JSON.Success x -> x

        mergeJSON JSON.Null r = r
        mergeJSON l JSON.Null = l
        mergeJSON (JSON.Object l) (JSON.Object r) =
            JSON.Object (Map.unionWith mergeJSON l r)
        mergeJSON _ r = r

    parseJSON v = JSON.typeMismatch "AppConfig" v

-- | Default program configuration.
defaultAppConfig :: AppConfig
defaultAppConfig = AppConfig (head styles) Haskell2010 defaultExtensions []

defaultExtensions :: [Extension]
defaultExtensions = [ e | e@EnableExtension{} <- knownExtensions ]
    \\ map EnableExtension badExtensions

badExtensions :: [KnownExtension]
badExtensions =
    [ Arrows -- steals proc
    , TransformListComp -- steals the group keyword
    , XmlSyntax
    , RegularPatterns -- steals a-b
    , UnboxedTuples -- breaks (#) lens operator
    , PatternSynonyms -- steals the pattern keyword
    , RecursiveDo -- steals the rec keyword
    , DoRec -- same
    , TypeApplications -- since GHC 8 and haskell-src-exts-1.19
    ]

-- | Show name of a style.
showStyle :: Style -> String
showStyle = T.unpack . styleName

-- | Show a Haskell language name.
showLanguage :: Language -> String
showLanguage = show

-- | Show a Haskell language extension.
showExtension :: Extension -> String
showExtension (EnableExtension x) = show x
showExtension (DisableExtension x) = "No" ++ show x
showExtension (UnknownExtension x) = x

-- | Show a fixity declaration.
showFixity :: Fixity -> String
showFixity (Fixity assoc prec op) =
    showAssoc assoc ++ " " ++ show prec ++ " " ++ showOp op
  where
    showAssoc (HSE.AssocNone _) = "infix"
    showAssoc (HSE.AssocLeft _) = "infixl"
    showAssoc (HSE.AssocRight _) = "infixr"

    showOp (HSE.UnQual _ (HSE.Symbol _ symbol)) = symbol
    showOp (HSE.UnQual _ (HSE.Ident _ ident)) = "`" ++ ident ++ "`"
    showOp _ = error "Operator in fixity list not supported"

-- | Lookup a style by name.
lookupStyle :: String -> Style
lookupStyle name = case filter ((== T.pack name) . styleName) styles of
    [] -> error $ "Unknown style: " ++ name
    x : _ -> x

-- | Lookup a language by name.
lookupLanguage :: String -> Language
lookupLanguage name = case classifyLanguage name of
    UnknownLanguage _ -> error $ "Unknown language: " ++ name
    x -> x

-- | Lookup an extension by name.
lookupExtension :: String -> Extension
lookupExtension "ImportQualifiedPost" = UnknownExtension "ImportQualifiedPost"
lookupExtension "NoImportQualifiedPost" = UnknownExtension "NoImportQualifiedPost"
lookupExtension name = case classifyExtension name of
    UnknownExtension _ -> error $ "Unkown extension: " ++ name
    x -> x

-- | Parse a fixity declaration.
lookupFixity :: String -> Fixity
lookupFixity decl =
    let (assoc, decl') = break isSpace $ dropWhile isSpace decl
        (prec, decl'') = break isSpace $ dropWhile isSpace decl'
        (op, _) = break isSpace $ dropWhile isSpace decl''
    in
        Fixity (readAssoc assoc) (read prec) (readOp op)
  where
    readAssoc "infix" = HSE.AssocNone ()
    readAssoc "infixl" = HSE.AssocLeft ()
    readAssoc "infixr" = HSE.AssocRight ()
    readAssoc assoc = error $ "Unknown associativity: " ++ assoc

    readOp op = HSE.UnQual () $ case op of
        '(' : op' -> HSE.Symbol () (init op')
        '`' : op' -> HSE.Ident () (init op')
        c : _ -> if isLetter c then HSE.Ident () op else HSE.Symbol () op
        _ -> error "Missing operator in infix declaration"

-- | Try to find a configuration file based on current working
-- directory, or in one of the application configuration directories.
findAppConfig :: IO (Maybe FilePath)
findAppConfig = getCurrentDirectory >>= findAppConfigIn

findAppConfigIn :: FilePath -> IO (Maybe FilePath)
findAppConfigIn src = do
    isFile <- doesFileExist src
    let startFrom = if isFile then takeDirectory src else src

    dotfilePaths <- sequence [ getHomeDirectory, getXdgDirectory XdgConfig "" ]
    dotfileConfig <- findFileWith doesFileExist dotfilePaths ".floskell.json"
    userPaths <- sequence [ getAppUserDataDirectory "floskell"
                          , getXdgDirectory XdgConfig "floskell"
                          ]
    userConfig <- findFileWith doesFileExist userPaths "config.json"
    let localPaths =
            map joinPath . reverse . drop 1 . inits . splitDirectories $
            startFrom
    localConfig <- findFileWith doesFileExist localPaths "floskell.json"
    return $ localConfig <|> userConfig <|> dotfileConfig

-- | Load a configuration file.
readAppConfig :: FilePath -> IO AppConfig
readAppConfig file = do
    text <- BS.readFile file
    either (error . (++) (file ++ ": ")) return $ eitherDecodeStrict text

setStyle :: AppConfig -> Maybe String -> AppConfig
setStyle cfg mbStyle =
    cfg { appStyle = maybe (appStyle cfg) lookupStyle mbStyle }

setLanguage :: AppConfig -> Maybe String -> AppConfig
setLanguage cfg mbLanguage =
    cfg { appLanguage = maybe (appLanguage cfg) lookupLanguage mbLanguage }

setExtensions :: AppConfig -> [String] -> AppConfig
setExtensions cfg exts =
    cfg { appExtensions = appExtensions cfg ++ map lookupExtension exts }

setFixities :: AppConfig -> [String] -> AppConfig
setFixities cfg fixities =
    cfg { appFixities = appFixities cfg ++ map lookupFixity fixities }

eitherDecodeStrict :: FromJSON a => BS.ByteString -> Either String a
eitherDecodeStrict i = case parseOnly jsonEOF' i of
    Right x -> case JSON.fromJSON x of
        JSON.Error e -> Left e
        JSON.Success x' -> Right x'
    Left e -> Left e
  where
    jsonEOF' = JSON.json' <* skipSpace <* AP.endOfInput

    skipSpace =
        AP.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09