{-|
Description : Parsing nested maps according to a format
-}
module Language.Haskell.Formatter.Internal.TreeFormat
       (TreeFormat, Leaf(..), parseYamlFile) where
import qualified Control.Arrow as Arrow
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import qualified Data.Monoid as Monoid
import qualified Data.Scientific as Scientific
import qualified Data.Text as Text
import qualified Data.Yaml as Yaml
import qualified Language.Haskell.Formatter.Internal.MapTree as MapTree
import qualified Language.Haskell.Formatter.Internal.Newline as Newline

type TreeFormat a = MapTree.MapForest String (Leaf a)

data Leaf a = Boolean (RawLeaf Bool a)
            | LimitedInteger (RawLeaf Int a)
            | SingleFloating (RawLeaf Float a)

type RawLeaf a b = a -> b -> b

parseYamlFile :: TreeFormat a -> a -> FilePath -> IO (Either String a)
parseYamlFile :: TreeFormat a -> a -> FilePath -> IO (Either FilePath a)
parseYamlFile TreeFormat a
format a
ball FilePath
file
  = do Either ParseException Value
maybeValue <- FilePath -> IO (Either ParseException Value)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither FilePath
file
       let interpretation :: Either FilePath a
interpretation
             = case Either ParseException Value
maybeValue of
                   Left ParseException
exception -> FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ ParseException -> FilePath
forall a. Show a => a -> FilePath
show ParseException
exception
                   Right Value
value -> TreeFormat a -> Value -> a -> Either FilePath a
forall a. TreeFormat a -> Value -> a -> Either FilePath a
defaultInterpret TreeFormat a
format Value
value a
ball
       Either FilePath a -> IO (Either FilePath a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FilePath a -> IO (Either FilePath a))
-> Either FilePath a -> IO (Either FilePath a)
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> Either FilePath a -> Either FilePath a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
Arrow.left FilePath -> FilePath
fileError Either FilePath a
interpretation
  where fileError :: FilePath -> FilePath
fileError FilePath
message = [FilePath] -> FilePath
Newline.joinSeparatedLines [FilePath
introduction, FilePath
message]
        introduction :: FilePath
introduction = FilePath -> FilePath -> FilePath
forall a. Monoid a => a -> a -> a
Monoid.mappend FilePath
file FilePath
":"

defaultInterpret :: TreeFormat a -> Yaml.Value -> a -> Either String a
defaultInterpret :: TreeFormat a -> Value -> a -> Either FilePath a
defaultInterpret TreeFormat a
format Value
value a
ball
  = if MapTree FilePath FilePath -> Bool
forall k a. MapTree k a -> Bool
MapTree.isEmpty MapTree FilePath FilePath
errors then a -> Either FilePath a
forall a b. b -> Either a b
Right a
interpretation else
      FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ MapTree FilePath FilePath -> FilePath
MapTree.indentTree MapTree FilePath FilePath
errors
  where (MapTree FilePath FilePath
errors, a
interpretation) = TreeFormat a -> Value -> a -> (MapTree FilePath FilePath, a)
forall a.
TreeFormat a -> Value -> a -> (MapTree FilePath FilePath, a)
interpret TreeFormat a
format Value
value a
ball

interpret ::
          TreeFormat a -> Yaml.Value -> a -> (MapTree.MapTree String String, a)
interpret :: TreeFormat a -> Value -> a -> (MapTree FilePath FilePath, a)
interpret TreeFormat a
formatMap (Yaml.Object Object
rawValueMap) a
ball = (MapTree FilePath FilePath
errorNode, a
ball')
  where errorNode :: MapTree FilePath FilePath
errorNode = MapForest FilePath FilePath -> MapTree FilePath FilePath
forall k a. MapForest k a -> MapTree k a
MapTree.Node (MapForest FilePath FilePath -> MapTree FilePath FilePath)
-> MapForest FilePath FilePath -> MapTree FilePath FilePath
forall a b. (a -> b) -> a -> b
$ (Maybe (MapTree FilePath FilePath)
 -> Maybe (MapTree FilePath FilePath))
-> Map FilePath (Maybe (MapTree FilePath FilePath))
-> MapForest FilePath FilePath
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Maybe (MapTree FilePath FilePath)
-> Maybe (MapTree FilePath FilePath)
forall a. a -> a
id Map FilePath (Maybe (MapTree FilePath FilePath))
errorTree
        (a
ball', Map FilePath (Maybe (MapTree FilePath FilePath))
errorTree) = (a -> FilePath -> Value -> (a, Maybe (MapTree FilePath FilePath)))
-> a
-> Map FilePath Value
-> (a, Map FilePath (Maybe (MapTree FilePath FilePath)))
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumWithKey a -> FilePath -> Value -> (a, Maybe (MapTree FilePath FilePath))
move a
ball Map FilePath Value
valueMap
        move :: a -> FilePath -> Value -> (a, Maybe (MapTree FilePath FilePath))
move a
ballPart FilePath
key Value
value = (a
ballPart', Maybe (MapTree FilePath FilePath)
maybeErrors)
          where (Maybe (MapTree FilePath FilePath)
maybeErrors, a
ballPart') = Maybe (MapTree FilePath (Leaf a))
-> Value -> a -> (Maybe (MapTree FilePath FilePath), a)
forall a.
Maybe (MapTree FilePath (Leaf a))
-> Value -> a -> (Maybe (MapTree FilePath FilePath), a)
matchTree Maybe (MapTree FilePath (Leaf a))
maybeFormat Value
value a
ballPart
                maybeFormat :: Maybe (MapTree FilePath (Leaf a))
maybeFormat = FilePath -> TreeFormat a -> Maybe (MapTree FilePath (Leaf a))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
key TreeFormat a
formatMap
        valueMap :: Map FilePath Value
valueMap = (Text -> FilePath) -> Map Text Value -> Map FilePath Value
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys Text -> FilePath
Text.unpack (Map Text Value -> Map FilePath Value)
-> Map Text Value -> Map FilePath Value
forall a b. (a -> b) -> a -> b
$ Object -> Map Text Value
forall a. HashMap Text a -> Map Text a
orderedMap Object
rawValueMap
        orderedMap :: HashMap Text a -> Map Text a
orderedMap = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a)
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
interpret TreeFormat a
_ Value
value a
ball = (MapTree FilePath FilePath
forall k. MapTree k FilePath
errorLeaf, a
ball)
  where errorLeaf :: MapTree k FilePath
errorLeaf = FilePath -> MapTree k FilePath
forall k a. a -> MapTree k a
MapTree.Leaf (FilePath -> MapTree k FilePath) -> FilePath -> MapTree k FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Value -> FilePath
unexpectedMessage FilePath
"a map" Value
value

matchTree ::
          Maybe (MapTree.MapTree String (Leaf a)) ->
            Yaml.Value -> a -> (Maybe (MapTree.MapTree String String), a)
matchTree :: Maybe (MapTree FilePath (Leaf a))
-> Value -> a -> (Maybe (MapTree FilePath FilePath), a)
matchTree Maybe (MapTree FilePath (Leaf a))
Nothing Value
_ a
ball = (MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath)
forall a. a -> Maybe a
Just (MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath))
-> MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> MapTree FilePath FilePath
forall k a. a -> MapTree k a
MapTree.Leaf FilePath
message, a
ball)
  where message :: FilePath
message = FilePath
"Unexpected key."
matchTree (Just (MapTree.Leaf Leaf a
leaf)) Value
value a
ball
  = case Leaf a -> Value -> a -> Either FilePath a
forall a. Leaf a -> Value -> a -> Either FilePath a
matchLeaf Leaf a
leaf Value
value a
ball of
        Left FilePath
message -> (MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath)
forall a. a -> Maybe a
Just (MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath))
-> MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> MapTree FilePath FilePath
forall k a. a -> MapTree k a
MapTree.Leaf FilePath
message, a
ball)
        Right a
ball' -> (Maybe (MapTree FilePath FilePath)
forall a. Maybe a
Nothing, a
ball')
matchTree (Just (MapTree.Node MapForest FilePath (Leaf a)
node)) Value
value a
ball = (Maybe (MapTree FilePath FilePath)
maybeErrors, a
ball')
  where maybeErrors :: Maybe (MapTree FilePath FilePath)
maybeErrors = if MapTree FilePath FilePath -> Bool
forall k a. MapTree k a -> Bool
MapTree.isEmpty MapTree FilePath FilePath
errors then Maybe (MapTree FilePath FilePath)
forall a. Maybe a
Nothing else MapTree FilePath FilePath -> Maybe (MapTree FilePath FilePath)
forall a. a -> Maybe a
Just MapTree FilePath FilePath
errors
        (MapTree FilePath FilePath
errors, a
ball') = MapForest FilePath (Leaf a)
-> Value -> a -> (MapTree FilePath FilePath, a)
forall a.
TreeFormat a -> Value -> a -> (MapTree FilePath FilePath, a)
interpret MapForest FilePath (Leaf a)
node Value
value a
ball

matchLeaf :: Leaf a -> Yaml.Value -> a -> Either String a
matchLeaf :: Leaf a -> Value -> a -> Either FilePath a
matchLeaf (Boolean RawLeaf Bool a
go) (Yaml.Bool Bool
boolean) a
ball = a -> Either FilePath a
forall a b. b -> Either a b
Right (a -> Either FilePath a) -> a -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ RawLeaf Bool a
go Bool
boolean a
ball
matchLeaf (LimitedInteger RawLeaf Int a
go) value :: Value
value@(Yaml.Number Scientific
number) a
ball
  = case Scientific -> Maybe Int
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger Scientific
number of
        Maybe Int
Nothing -> FilePath -> Either FilePath a
forall a b. a -> Either a b
Left FilePath
message
          where message :: FilePath
message = FilePath -> Value -> FilePath
unexpectedMessage FilePath
"a limited integer" Value
value
        Just Int
integer -> a -> Either FilePath a
forall a b. b -> Either a b
Right (a -> Either FilePath a) -> a -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ RawLeaf Int a
go Int
integer a
ball
matchLeaf (SingleFloating RawLeaf Float a
go) (Yaml.Number Scientific
number) a
ball
  = a -> Either FilePath a
forall a b. b -> Either a b
Right (a -> Either FilePath a) -> a -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ RawLeaf Float a
go Float
floating a
ball
  where floating :: Float
floating = Scientific -> Float
forall a. RealFloat a => Scientific -> a
Scientific.toRealFloat Scientific
number
matchLeaf Leaf a
format Value
value a
_ = FilePath -> Either FilePath a
forall a b. a -> Either a b
Left (FilePath -> Either FilePath a) -> FilePath -> Either FilePath a
forall a b. (a -> b) -> a -> b
$ FilePath -> Value -> FilePath
unexpectedMessage FilePath
expected Value
value
  where expected :: FilePath
expected
          = case Leaf a
format of
                Boolean RawLeaf Bool a
_ -> FilePath
"a Boolean"
                LimitedInteger RawLeaf Int a
_ -> FilePath
"a limited integer"
                SingleFloating RawLeaf Float a
_ -> FilePath
"a single-precision floating-point number"

unexpectedMessage :: String -> Yaml.Value -> String
unexpectedMessage :: FilePath -> Value -> FilePath
unexpectedMessage FilePath
expected Value
actualValue
  = [FilePath] -> FilePath
Newline.joinSeparatedLines [FilePath
introduction, FilePath
actual]
  where introduction :: FilePath
introduction = [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FilePath
"Expected ", FilePath
expected, FilePath
", but got:"]
        actual :: FilePath
actual = ByteString -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode Value
actualValue