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 format ball file
= do maybeValue <- Yaml.decodeFileEither file
let interpretation
= case maybeValue of
Left exception -> Left $ show exception
Right value -> defaultInterpret format value ball
return $ Arrow.left fileError interpretation
where fileError message = Newline.joinSeparatedLines [introduction, message]
introduction = Monoid.mappend file ":"
defaultInterpret :: TreeFormat a -> Yaml.Value -> a -> Either String a
defaultInterpret format value ball
= if MapTree.isEmpty errors then Right interpretation else
Left $ MapTree.indentTree errors
where (errors, interpretation) = interpret format value ball
interpret ::
TreeFormat a -> Yaml.Value -> a -> (MapTree.MapTree String String, a)
interpret formatMap (Yaml.Object rawValueMap) ball = (errorNode, ball')
where errorNode = MapTree.Node $ Map.mapMaybe id errorTree
(ball', errorTree) = Map.mapAccumWithKey move ball valueMap
move ballPart key value = (ballPart', maybeErrors)
where (maybeErrors, ballPart') = matchTree maybeFormat value ballPart
maybeFormat = Map.lookup key formatMap
valueMap = Map.mapKeys Text.unpack $ orderedMap rawValueMap
orderedMap = Map.fromList . HashMap.toList
interpret _ value ball = (errorLeaf, ball)
where errorLeaf = MapTree.Leaf $ unexpectedMessage "a map" value
matchTree ::
Maybe (MapTree.MapTree String (Leaf a)) ->
Yaml.Value -> a -> (Maybe (MapTree.MapTree String String), a)
matchTree Nothing _ ball = (Just $ MapTree.Leaf message, ball)
where message = "Unexpected key."
matchTree (Just (MapTree.Leaf leaf)) value ball
= case matchLeaf leaf value ball of
Left message -> (Just $ MapTree.Leaf message, ball)
Right ball' -> (Nothing, ball')
matchTree (Just (MapTree.Node node)) value ball = (maybeErrors, ball')
where maybeErrors = if MapTree.isEmpty errors then Nothing else Just errors
(errors, ball') = interpret node value ball
matchLeaf :: Leaf a -> Yaml.Value -> a -> Either String a
matchLeaf (Boolean go) (Yaml.Bool boolean) ball = Right $ go boolean ball
matchLeaf (LimitedInteger go) value@(Yaml.Number number) ball
= case Scientific.toBoundedInteger number of
Nothing -> Left message
where message = unexpectedMessage "a limited integer" value
Just integer -> Right $ go integer ball
matchLeaf (SingleFloating go) (Yaml.Number number) ball
= Right $ go floating ball
where floating = Scientific.toRealFloat number
matchLeaf format value _ = Left $ unexpectedMessage expected value
where expected
= case format of
Boolean _ -> "a Boolean"
LimitedInteger _ -> "a limited integer"
SingleFloating _ -> "a single-precision floating-point number"
unexpectedMessage :: String -> Yaml.Value -> String
unexpectedMessage expected actualValue
= Newline.joinSeparatedLines [introduction, actual]
where introduction = concat ["Expected ", expected, ", but got:"]
actual = show $ Yaml.encode actualValue