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