{-# LANGUAGE DataKinds, GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards, OverloadedStrings, LambdaCase #-}
module Clang.Format.YamlConversions
( fillConfigItems
, FillError
, YamlConfigType(..)
, preprocessYaml
, collectConfigItems
, formatClangFormat
) where
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Data.HashMap.Strict as HM
import Control.Monad.Except.CoHas
import Data.Either
import Data.Scientific
import Data.Yaml
import Data.Yaml.Pretty
import GHC.Generics
import Clang.Format.StyOpts
import Language.Coformat.Descr
data FillError
= YamlParseError ParseException
| YamlAnalysisError YamlAnalysisError
| YamlValueNotFound ValueNotFound
deriving (Show, Generic, CoHas ParseException, CoHas YamlAnalysisError, CoHas ValueNotFound)
data YamlConfigType = StyleDump | PartialConfig
preprocessYaml :: (MonadError e m, CoHas ParseException e, CoHas YamlAnalysisError e, CoHas ValueNotFound e)
=> YamlConfigType -> BS.ByteString -> m Object
preprocessYaml configType yamlContents = liftEither (decodeEither' yamlContents)
>>= extractMap
>>= bwWithFailure configType
where
bwWithFailure StyleDump = braceWrappingKludge >=> liftEither
bwWithFailure PartialConfig = \obj -> braceWrappingKludge obj
>>= \case Left _ -> pure obj
Right obj' -> pure obj'
fillConfigItems :: (MonadError e m, CoHas ParseException e, CoHas YamlAnalysisError e, CoHas ValueNotFound e)
=> [ConfigItemT 'Supported] -> BS.ByteString -> m [ConfigItemT 'Value]
fillConfigItems supported yamlContents = preprocessYaml StyleDump yamlContents
>>= fillConfigItemsFromObj supported
>>= liftEither . sequence
collectConfigItems :: (MonadError e m, CoHas ParseException e, CoHas YamlAnalysisError e)
=> [ConfigItemT 'Supported] -> Object -> m [ConfigItemT 'Value]
collectConfigItems supported yamlObject = rights <$> fillConfigItemsFromObj supported yamlObject
data YamlAnalysisError
= YamlNotAnObject String
| IncompatibleValue T.Text (ConfigTypeT 'Supported) Value
deriving (Show)
newtype ValueNotFound = ValueNotFound { missingValueName :: T.Text } deriving (Show)
extractMap :: (MonadError e m, CoHas YamlAnalysisError e) => Value -> m Object
extractMap (Object fields) = pure fields
extractMap _ = throwError $ YamlNotAnObject "Top-level value is not an object"
braceWrappingKludge :: (MonadError e m, CoHas YamlAnalysisError e) => Object -> m (Either ValueNotFound Object)
braceWrappingKludge fields
| Nothing <- maybeBWVal = pure $ Left $ ValueNotFound bwField
| Just (Object obj) <- maybeBWVal = let bwSubfields = HM.fromList [ (bwField <> "." <> key, val)
| (key, val) <- HM.toList obj
]
in pure $ Right $ HM.delete bwField fields <> bwSubfields
| otherwise = throwError $ YamlNotAnObject "Brace wrapping value is not an object"
where
bwField = "BraceWrapping"
maybeBWVal = HM.lookup bwField fields
fillConfigItemsFromObj :: (MonadError e m, CoHas YamlAnalysisError e)
=> [ConfigItemT 'Supported] -> Object -> m [Either ValueNotFound (ConfigItemT 'Value)]
fillConfigItemsFromObj supported fields = mapM fillConfigItem supported
where
fillConfigItem ConfigItem { .. }
| Nothing <- maybeYamlVal = pure $ Left $ ValueNotFound nameConcatted
| Just yamlVal <- maybeYamlVal = do
value' <- case (value, yamlVal) of
(CTInt _, Number num)
| Just int <- toBoundedInteger num -> pure $ CTInt int
(CTUnsigned _, Number num)
| Just int <- toBoundedInteger num :: Maybe Int
, int >= 0 -> pure $ CTUnsigned $ fromIntegral int
(CTBool _, Bool b) -> pure $ CTBool b
(CTEnum vars _, String s)
| s `elem` vars -> pure $ CTEnum vars s
(CTEnum vars _, Bool b)
| boolAsEnumVar b `elem` vars -> pure $ CTEnum vars $ boolAsEnumVar b
_ -> throwError $ IncompatibleValue nameConcatted value yamlVal
pure $ Right $ ConfigItem { name = name, value = value' }
where
nameConcatted = T.intercalate "." name
maybeYamlVal = HM.lookup nameConcatted fields
formatClangFormat :: StyOpts -> BS.ByteString
formatClangFormat = encodePretty $ setConfCompare compare defConfig
boolAsEnumVar :: Bool -> T.Text
boolAsEnumVar True = "Yes"
boolAsEnumVar False = "No"