{-# 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(..), Language(..), classifyExtension
                 , classifyLanguage )
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 { AppConfig -> Style
appStyle      :: Style
                           , AppConfig -> Language
appLanguage   :: Language
                           , AppConfig -> [Extension]
appExtensions :: [Extension]
                           , AppConfig -> [Fixity]
appFixities   :: [Fixity]
                           }
    deriving ( forall x. Rep AppConfig x -> AppConfig
forall x. AppConfig -> Rep AppConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AppConfig x -> AppConfig
$cfrom :: forall x. AppConfig -> Rep AppConfig x
Generic )

instance ToJSON AppConfig where
    toJSON :: AppConfig -> Value
toJSON AppConfig{[Fixity]
[Extension]
Language
Style
appFixities :: [Fixity]
appExtensions :: [Extension]
appLanguage :: Language
appStyle :: Style
appFixities :: AppConfig -> [Fixity]
appExtensions :: AppConfig -> [Extension]
appLanguage :: AppConfig -> Language
appStyle :: AppConfig -> Style
..} =
        [Pair] -> Value
JSON.object [ Key
"style" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Style -> [Char]
showStyle Style
appStyle
                    , Key
"language" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Language -> [Char]
showLanguage Language
appLanguage
                    , Key
"extensions" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map Extension -> [Char]
showExtension [Extension]
appExtensions
                    , Key
"fixities" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map Fixity -> [Char]
showFixity [Fixity]
appFixities
                    , Key
"formatting" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Style -> Config
styleConfig Style
appStyle
                    ]

instance FromJSON AppConfig where
    parseJSON :: Value -> Parser AppConfig
parseJSON (JSON.Object Object
o) = do
        Style
style <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> Style
appStyle AppConfig
defaultAppConfig) [Char] -> Style
lookupStyle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"style"
        Language
language <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> Language
appLanguage AppConfig
defaultAppConfig) [Char] -> Language
lookupLanguage
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"language"
        [Extension]
extensions <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> [Extension]
appExtensions AppConfig
defaultAppConfig)
                            (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Extension
lookupExtension) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"extensions"
        [Fixity]
fixities <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> [Fixity]
appFixities AppConfig
defaultAppConfig) (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Fixity
lookupFixity)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fixities"
        let fmt :: Config
fmt = Style -> Config
styleConfig Style
style
        Config
fmt' <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe Config
fmt (forall {a} {a}. (FromJSON a, ToJSON a) => a -> Value -> a
updateConfig Config
fmt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"formatting"
        let style' :: Style
style' = Style
style { styleConfig :: Config
styleConfig = Config
fmt' }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Style -> Language -> [Extension] -> [Fixity] -> AppConfig
AppConfig Style
style' Language
language [Extension]
extensions [Fixity]
fixities
      where
        updateConfig :: a -> Value -> a
updateConfig a
cfg Value
v = case forall a. FromJSON a => Value -> Result a
JSON.fromJSON forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeJSON (forall a. ToJSON a => a -> Value
toJSON a
cfg) Value
v of
            JSON.Error [Char]
e -> forall a. HasCallStack => [Char] -> a
error [Char]
e
            JSON.Success a
x -> a
x

        mergeJSON :: Value -> Value -> Value
mergeJSON Value
JSON.Null Value
r = Value
r
        mergeJSON Value
l Value
JSON.Null = Value
l
        mergeJSON (JSON.Object Object
l) (JSON.Object Object
r) =
            Object -> Value
JSON.Object (forall v. (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v
Map.unionWith Value -> Value -> Value
mergeJSON Object
l Object
r)
        mergeJSON Value
_ Value
r = Value
r

    parseJSON Value
v = forall a. [Char] -> Value -> Parser a
JSON.typeMismatch [Char]
"AppConfig" Value
v

-- | Default program configuration.
defaultAppConfig :: AppConfig
defaultAppConfig :: AppConfig
defaultAppConfig = Style -> Language -> [Extension] -> [Fixity] -> AppConfig
AppConfig (forall a. [a] -> a
head [Style]
styles) Language
Haskell2010 [] []

-- | Show name of a style.
showStyle :: Style -> String
showStyle :: Style -> [Char]
showStyle = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> Text
styleName

-- | Show a Haskell language name.
showLanguage :: Language -> String
showLanguage :: Language -> [Char]
showLanguage = forall a. Show a => a -> [Char]
show

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

-- | Show a fixity declaration.
showFixity :: Fixity -> String
showFixity :: Fixity -> [Char]
showFixity (Fixity Assoc ()
assoc Int
prec QName ()
op) =
    forall {a} {l}. IsString a => Assoc l -> a
showAssoc Assoc ()
assoc forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
prec forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall {l}. QName l -> [Char]
showOp QName ()
op
  where
    showAssoc :: Assoc l -> a
showAssoc (HSE.AssocNone l
_) = a
"infix"
    showAssoc (HSE.AssocLeft l
_) = a
"infixl"
    showAssoc (HSE.AssocRight l
_) = a
"infixr"

    showOp :: QName l -> [Char]
showOp (HSE.UnQual l
_ (HSE.Symbol l
_ [Char]
symbol)) = [Char]
symbol
    showOp (HSE.UnQual l
_ (HSE.Ident l
_ [Char]
ident)) = [Char]
"`" forall a. [a] -> [a] -> [a]
++ [Char]
ident forall a. [a] -> [a] -> [a]
++ [Char]
"`"
    showOp QName l
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Operator in fixity list not supported"

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

-- | Lookup a language by name.
lookupLanguage :: String -> Language
lookupLanguage :: [Char] -> Language
lookupLanguage [Char]
name = case [Char] -> Language
classifyLanguage [Char]
name of
    UnknownLanguage [Char]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown language: " forall a. [a] -> [a] -> [a]
++ [Char]
name
    Language
x -> Language
x

-- | Lookup an extension by name.
lookupExtension :: String -> Extension
lookupExtension :: [Char] -> Extension
lookupExtension [Char]
name = case [Char] -> Extension
classifyExtension [Char]
name of
    UnknownExtension [Char]
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unkown extension: " forall a. [a] -> [a] -> [a]
++ [Char]
name
    Extension
x -> Extension
x

-- | Parse a fixity declaration.
lookupFixity :: String -> Fixity
lookupFixity :: [Char] -> Fixity
lookupFixity [Char]
decl =
    let ([Char]
assoc, [Char]
decl') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
decl
        ([Char]
prec, [Char]
decl'') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
decl'
        ([Char]
op, [Char]
_) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace [Char]
decl''
    in
        Assoc () -> Int -> QName () -> Fixity
Fixity ([Char] -> Assoc ()
readAssoc [Char]
assoc) (forall a. Read a => [Char] -> a
read [Char]
prec) ([Char] -> QName ()
readOp [Char]
op)
  where
    readAssoc :: [Char] -> Assoc ()
readAssoc [Char]
"infix" = forall l. l -> Assoc l
HSE.AssocNone ()
    readAssoc [Char]
"infixl" = forall l. l -> Assoc l
HSE.AssocLeft ()
    readAssoc [Char]
"infixr" = forall l. l -> Assoc l
HSE.AssocRight ()
    readAssoc [Char]
assoc = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown associativity: " forall a. [a] -> [a] -> [a]
++ [Char]
assoc

    readOp :: [Char] -> QName ()
readOp [Char]
op = forall l. l -> Name l -> QName l
HSE.UnQual () forall a b. (a -> b) -> a -> b
$ case [Char]
op of
        Char
'(' : [Char]
op' -> forall l. l -> [Char] -> Name l
HSE.Symbol () (forall a. [a] -> [a]
init [Char]
op')
        Char
'`' : [Char]
op' -> forall l. l -> [Char] -> Name l
HSE.Ident () (forall a. [a] -> [a]
init [Char]
op')
        Char
c : [Char]
_ -> if Char -> Bool
isLetter Char
c then forall l. l -> [Char] -> Name l
HSE.Ident () [Char]
op else forall l. l -> [Char] -> Name l
HSE.Symbol () [Char]
op
        [Char]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: IO (Maybe [Char])
findAppConfig = IO [Char]
getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO (Maybe [Char])
findAppConfigIn

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

    [[Char]]
dotfilePaths <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ IO [Char]
getHomeDirectory, XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgConfig [Char]
"" ]
    Maybe [Char]
dotfileConfig <- ([Char] -> IO Bool) -> [[Char]] -> [Char] -> IO (Maybe [Char])
findFileWith [Char] -> IO Bool
doesFileExist [[Char]]
dotfilePaths [Char]
".floskell.json"
    [[Char]]
userPaths <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"floskell"
                          , XdgDirectory -> [Char] -> IO [Char]
getXdgDirectory XdgDirectory
XdgConfig [Char]
"floskell"
                          ]
    Maybe [Char]
userConfig <- ([Char] -> IO Bool) -> [[Char]] -> [Char] -> IO (Maybe [Char])
findFileWith [Char] -> IO Bool
doesFileExist [[Char]]
userPaths [Char]
"config.json"
    let localPaths :: [[Char]]
localPaths =
            forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [Char]
joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
inits forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
splitDirectories forall a b. (a -> b) -> a -> b
$
            [Char]
startFrom
    Maybe [Char]
localConfig <- ([Char] -> IO Bool) -> [[Char]] -> [Char] -> IO (Maybe [Char])
findFileWith [Char] -> IO Bool
doesFileExist [[Char]]
localPaths [Char]
"floskell.json"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe [Char]
localConfig forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [Char]
userConfig forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [Char]
dotfileConfig

-- | Load a configuration file.
readAppConfig :: FilePath -> IO AppConfig
readAppConfig :: [Char] -> IO AppConfig
readAppConfig [Char]
file = do
    ByteString
text <- [Char] -> IO ByteString
BS.readFile [Char]
file
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) ([Char]
file forall a. [a] -> [a] -> [a]
++ [Char]
": ")) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecodeStrict ByteString
text

setStyle :: AppConfig -> Maybe String -> AppConfig
setStyle :: AppConfig -> Maybe [Char] -> AppConfig
setStyle AppConfig
cfg Maybe [Char]
mbStyle =
    AppConfig
cfg { appStyle :: Style
appStyle = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> Style
appStyle AppConfig
cfg) [Char] -> Style
lookupStyle Maybe [Char]
mbStyle }

setLanguage :: AppConfig -> Maybe String -> AppConfig
setLanguage :: AppConfig -> Maybe [Char] -> AppConfig
setLanguage AppConfig
cfg Maybe [Char]
mbLanguage =
    AppConfig
cfg { appLanguage :: Language
appLanguage = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AppConfig -> Language
appLanguage AppConfig
cfg) [Char] -> Language
lookupLanguage Maybe [Char]
mbLanguage }

setExtensions :: AppConfig -> [String] -> AppConfig
setExtensions :: AppConfig -> [[Char]] -> AppConfig
setExtensions AppConfig
cfg [[Char]]
exts =
    AppConfig
cfg { appExtensions :: [Extension]
appExtensions = AppConfig -> [Extension]
appExtensions AppConfig
cfg forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Extension
lookupExtension [[Char]]
exts }

setFixities :: AppConfig -> [String] -> AppConfig
setFixities :: AppConfig -> [[Char]] -> AppConfig
setFixities AppConfig
cfg [[Char]]
fixities =
    AppConfig
cfg { appFixities :: [Fixity]
appFixities = AppConfig -> [Fixity]
appFixities AppConfig
cfg forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Fixity
lookupFixity [[Char]]
fixities }

eitherDecodeStrict :: FromJSON a => BS.ByteString -> Either String a
eitherDecodeStrict :: forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecodeStrict ByteString
i = case forall a. Parser a -> ByteString -> Either [Char] a
parseOnly Parser ByteString Value
jsonEOF' ByteString
i of
    Right Value
x -> case forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
x of
        JSON.Error [Char]
e -> forall a b. a -> Either a b
Left [Char]
e
        JSON.Success a
x' -> forall a b. b -> Either a b
Right a
x'
    Left [Char]
e -> forall a b. a -> Either a b
Left [Char]
e
  where
    jsonEOF' :: Parser ByteString Value
jsonEOF' = Parser ByteString Value
JSON.json' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
AP.endOfInput

    skipSpace :: Parser ()
skipSpace =
        (Word8 -> Bool) -> Parser ()
AP.skipWhile forall a b. (a -> b) -> a -> b
$ \Word8
w -> Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w forall a. Eq a => a -> a -> Bool
== Word8
0x09