diff --git a/bookhound.cabal b/bookhound.cabal --- a/bookhound.cabal +++ b/bookhound.cabal @@ -5,8 +5,8 @@ -- see: https://github.com/sol/hpack name: bookhound -version: 0.1.10.0 -synopsis: Simple Parser Combinators & Parsers +version: 0.1.11.0 +synopsis: Simple Parser Combinators description: Please see the README on GitHub at category: Parsers homepage: https://github.com/albertprz/bookhound#readme @@ -31,25 +31,13 @@ Bookhound.Internal.Foldable Bookhound.Internal.Map Bookhound.Internal.String - Bookhound.Operations.Finder - Bookhound.Operations.ToJson - Bookhound.Operations.ToXml - Bookhound.Operations.ToYaml Bookhound.Parser Bookhound.ParserCombinators Bookhound.Parsers.Char Bookhound.Parsers.Collections Bookhound.Parsers.DateTime - Bookhound.Parsers.Json Bookhound.Parsers.Number Bookhound.Parsers.String - Bookhound.Parsers.Toml - Bookhound.Parsers.Xml - Bookhound.Parsers.Yaml - Bookhound.SyntaxTrees.Json - Bookhound.SyntaxTrees.Toml - Bookhound.SyntaxTrees.Xml - Bookhound.SyntaxTrees.Yaml other-modules: Paths_bookhound hs-source-dirs: diff --git a/src/Bookhound/Operations/Finder.hs b/src/Bookhound/Operations/Finder.hs deleted file mode 100644 --- a/src/Bookhound/Operations/Finder.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Bookhound.Operations.Finder (Finder(..)) where - - -import Bookhound.Parser (runParser) -import Bookhound.ParserCombinators (IsMatch (..), (<|>), (|*)) -import Bookhound.Parsers.Char (dot) -import Bookhound.Parsers.Number (unsignedInt) -import Bookhound.Parsers.String (withinSquareBrackets) -import Bookhound.SyntaxTrees.Json (JsExpression (..)) -import Bookhound.SyntaxTrees.Toml (TomlExpression (..)) -import Bookhound.SyntaxTrees.Yaml (YamlExpression (..)) - - -import Data.Either (fromRight) -import Data.Maybe (listToMaybe) - -import qualified Data.Map as Map -import Data.Text (pack) - - - -class Finder a where - - toList :: a -> [(String, a)] - findAll :: ((String, a) -> Bool) -> a -> [a] - find :: ((String, a) -> Bool) -> a -> Maybe a - findByKeys :: [String] -> a -> Maybe a - findByPath :: String -> a -> Maybe a - - - findAll f = fmap snd . filter f . toList - find f = listToMaybe . findAll f - - findByKeys [] expr = Just expr - findByKeys (x : xs) expr = findByKey x expr >>= findByKeys xs where - - findByKey key = find (\(str, _) -> str == key) - - findByPath path = findByKeys pathSeq where - - pathSeq = fromRight [] $ runParser parsePath $ pack path - parsePath = is '$' *> ((index <|> key) |*) - - index = show <$> withinSquareBrackets unsignedInt - key = dot *> word - word = (noneOf ['.', '['] |*) - - - -instance Finder JsExpression where - toList = \case - nil@JsNull -> [("", nil)] - n@(JsNumber _) -> [("", n)] - bool@(JsBool _) -> [("", bool)] - str@(JsString _) -> [("", str)] - JsArray arr -> zip (show <$> [0 .. length arr - 1]) arr - JsObject obj -> Map.toList obj - - -instance Finder YamlExpression where - toList = \case - nil@YamlNull -> [("", nil)] - n@(YamlInteger _) -> [("", n)] - n@(YamlFloat _) -> [("", n)] - bool@(YamlBool _) -> [("", bool)] - str@(YamlString _) -> [("", str)] - date@(YamlDate _) -> [("", date)] - time@(YamlTime _) -> [("", time)] - dateTime@(YamlDateTime _) -> [("", dateTime)] - YamlList _ arr -> zip (show <$> [0 .. length arr - 1]) arr - YamlMap _ obj -> Map.toList obj - - -instance Finder TomlExpression where - toList = \case - nil@TomlNull -> [("", nil)] - n@(TomlInteger _) -> [("", n)] - n@(TomlFloat _) -> [("", n)] - bool@(TomlBool _) -> [("", bool)] - str@(TomlString _) -> [("", str)] - date@(TomlDate _) -> [("", date)] - time@(TomlTime _) -> [("", time)] - dateTime@(TomlDateTime _) -> [("", dateTime)] - TomlArray arr -> zip (show <$> [0 .. length arr - 1]) arr - TomlTable _ obj -> Map.toList obj diff --git a/src/Bookhound/Operations/ToJson.hs b/src/Bookhound/Operations/ToJson.hs deleted file mode 100644 --- a/src/Bookhound/Operations/ToJson.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Bookhound.Operations.ToJson (ToJson(..)) where - -import Bookhound.Parser (runParser) -import Bookhound.ParserCombinators (IsMatch (..), maybeWithin, (<|>), (|*)) -import Bookhound.Parsers.Json (json) -import Bookhound.Parsers.String (spacing) -import Bookhound.SyntaxTrees.Json (JsExpression (..)) -import Bookhound.SyntaxTrees.Toml (TomlExpression (..)) -import Bookhound.SyntaxTrees.Xml (XmlExpression (..)) -import Bookhound.SyntaxTrees.Yaml (YamlExpression (..)) - -import Data.Either (fromRight) -import Data.Text (pack) - -import Data.Map (Map, elems) -import qualified Data.Map as Map - - -class ToJson a where - toJson :: a -> JsExpression - - -instance {-# OVERLAPPABLE #-} ToJson JsExpression where - toJson = id - -instance ToJson XmlExpression where - - toJson XmlExpression { tagName = tag, expressions = exprs, .. } - | tag == "literal" = fromRight JsNull . runParser literalParser . - pack . head . elems $ fields - | tag == "array" = JsArray $ childExprToJson <$> exprs - | tag == "object" = JsObject . Map.fromList $ (\x -> (tagName x, childExprToJson x)) <$> - exprs - | otherwise = JsNull where - - literalParser = json <|> (JsString <$> maybeWithin spacing (isNot '<' |*)) - - childExprToJson = toJson . head . (expressions) - - -instance ToJson YamlExpression where - - toJson = \case - YamlNull -> JsNull - YamlInteger n -> JsNumber $ fromIntegral n - YamlFloat n -> JsNumber n - YamlBool bool -> JsBool bool - YamlString str -> JsString str - YamlDate date -> JsString $ show date - YamlTime time -> JsString $ show time - YamlDateTime dateTime -> JsString $ show dateTime - YamlList _ list -> JsArray $ toJson <$> list - YamlMap _ mapping -> JsObject $ toJson <$> mapping - - -instance ToJson TomlExpression where - - toJson = \case - TomlNull -> JsNull - TomlInteger n -> JsNumber $ fromIntegral n - TomlFloat n -> JsNumber n - TomlBool bool -> JsBool bool - TomlString str -> JsString str - TomlDate date -> JsString $ show date - TomlTime time -> JsString $ show time - TomlDateTime dateTime -> JsString $ show dateTime - TomlArray list -> JsArray $ toJson <$> list - TomlTable _ mapping -> JsObject $ toJson <$> mapping - - - -instance ToJson String where - toJson = JsString - -instance ToJson Char where - toJson = JsString . pure - -instance ToJson Int where - toJson = JsNumber . fromIntegral - -instance ToJson Integer where - toJson = JsNumber . fromIntegral - -instance ToJson Double where - toJson = JsNumber - -instance ToJson Bool where - toJson = JsBool - -instance ToJson a => ToJson [a] where - toJson = JsArray . fmap toJson - -instance ToJson a => ToJson (Map String a) where - toJson = JsObject . fmap toJson - -instance ToJson a => ToJson (Maybe a) where - toJson = maybe JsNull toJson diff --git a/src/Bookhound/Operations/ToXml.hs b/src/Bookhound/Operations/ToXml.hs deleted file mode 100644 --- a/src/Bookhound/Operations/ToXml.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Bookhound.Operations.ToXml (ToXml(..)) where - -import Bookhound.Operations.ToJson (ToJson (..)) -import Bookhound.SyntaxTrees.Json (JsExpression (..)) -import Bookhound.SyntaxTrees.Xml (XmlExpression (..), literalExpression) - -import Data.Char (toLower) -import qualified Data.Map as Map - - -class ToXml a where - toXml :: a -> XmlExpression - - -instance {-# OVERLAPPABLE #-} ToJson a => ToXml a where - toXml = toXml . toJson - -instance ToXml XmlExpression where - toXml = id - - -instance ToXml JsExpression where - - toXml = \case - JsNull -> literalExpression "null" - JsNumber n -> literalExpression $ show n - JsBool bool -> literalExpression $ toLower <$> show bool - JsString str -> literalExpression str - - JsArray arr -> XmlExpression "array" Map.empty (elemExpr <$> arr) where - - elemExpr element = XmlExpression { tagName = "elem", - fields = Map.empty, - expressions = [toXml element] } - - JsObject obj -> XmlExpression "object" Map.empty (keyValueExpr <$> Map.toList obj) where - - keyValueExpr (key, value) = XmlExpression { tagName = key, - fields = Map.empty, - expressions = [toXml value] } diff --git a/src/Bookhound/Operations/ToYaml.hs b/src/Bookhound/Operations/ToYaml.hs deleted file mode 100644 --- a/src/Bookhound/Operations/ToYaml.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -module Bookhound.Operations.ToYaml (ToYaml(..)) where - -import Bookhound.Operations.ToJson (ToJson (..)) -import Bookhound.Parser (runParser) -import Bookhound.Parsers.Number (intLike) -import Bookhound.SyntaxTrees.Json (JsExpression (..)) -import Bookhound.SyntaxTrees.Yaml (CollectionType (..), YamlExpression (..)) -import Data.Text (pack) - - - -class ToYaml a where - toYaml :: a -> YamlExpression - -instance {-# OVERLAPPABLE #-} ToJson a => ToYaml a where - toYaml = toYaml . toJson - -instance ToYaml YamlExpression where - toYaml = id - -instance ToYaml JsExpression where - - toYaml = \case - JsNull -> YamlNull - JsNumber n -> either (const (YamlFloat n)) YamlInteger $ - runParser intLike $ pack $ show n - JsBool bool -> YamlBool bool - JsString str -> YamlString str - JsArray arr -> YamlList Standard $ toYaml <$> arr - JsObject obj -> YamlMap Standard $ toYaml <$> obj diff --git a/src/Bookhound/Parsers/Json.hs b/src/Bookhound/Parsers/Json.hs deleted file mode 100644 --- a/src/Bookhound/Parsers/Json.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Bookhound.Parsers.Json (json, nil, number, bool, string, array, object) where - -import Bookhound.Parser (Parser, withError) -import Bookhound.ParserCombinators (IsMatch (..), maybeWithin, (<|>), (|*)) -import Bookhound.Parsers.Char (colon, doubleQuote) -import Bookhound.Parsers.Collections (listOf, mapOf) -import Bookhound.Parsers.Number (double) -import Bookhound.Parsers.String (spacing, withinDoubleQuotes) -import Bookhound.SyntaxTrees.Json (JsExpression (..)) - - -json :: Parser JsExpression -json = maybeWithin spacing jsValue - where - jsValue = element <|> container - - -nil :: Parser JsExpression -nil = withError "Json Null" - $ JsNull <$ is "null" - -number :: Parser JsExpression -number = withError "Json Number" - $ JsNumber <$> double - - -bool :: Parser JsExpression -bool = withError "Json Bool" - $ JsBool <$> (True <$ is "true" <|> - False <$ is "false") - - -string :: Parser JsExpression -string = withError "Json String" - $ JsString <$> text - - -array :: Parser JsExpression -array = withError "Json Array" - $ JsArray <$> listOf json - - -object :: Parser JsExpression -object = withError "Json Object" - $ JsObject <$> mapOf colon text json - - - -element :: Parser JsExpression -element = number <|> bool <|> nil <|> string - -container :: Parser JsExpression -container = array <|> object - - - -text :: Parser String -text = withinDoubleQuotes (inverse doubleQuote |*) diff --git a/src/Bookhound/Parsers/Toml.hs b/src/Bookhound/Parsers/Toml.hs deleted file mode 100644 --- a/src/Bookhound/Parsers/Toml.hs +++ /dev/null @@ -1,138 +0,0 @@ -module Bookhound.Parsers.Toml (toml, nil, integer, float, bool, string, - array, inlineTable) where - -import Bookhound.Parser (Parser, withError) -import Bookhound.ParserCombinators (IsMatch (..), maybeWithin, within, (<#>), - (<|>), (>>>), (|*), (|+), (|?)) -import Bookhound.Parsers.Char (dash, digit, dot, doubleQuote, equal, - hashTag, letter, newLine, quote, - spaceOrTab, underscore, whiteSpace) -import Bookhound.Parsers.Collections (listOf, mapOf) -import Bookhound.Parsers.Number (double, hexInt, int, octInt) -import Bookhound.Parsers.String (blankLine, blankLines, spacesOrTabs, - spacing, withinDoubleQuotes, withinQuotes, - withinSquareBrackets) -import Bookhound.SyntaxTrees.Toml (TableType (..), TomlExpression (..)) - -import qualified Bookhound.Parsers.DateTime as Dt - -import qualified Data.Map as Map -import Data.Maybe (maybeToList) - - - -toml :: Parser TomlExpression -toml = maybeWithin (((pure <$> whiteSpace) <|> comment) |+) topLevelTable - - - --- TODO: Add support for table arrays - -nil :: Parser TomlExpression -nil = withError "Toml Null" - $ TomlNull <$ is "null" - -integer :: Parser TomlExpression -integer = withError "Toml Integer" - $ TomlInteger <$> (hexInt <|> octInt <|> int) - -float :: Parser TomlExpression -float = withError "Toml Float" - $ TomlFloat <$> double - -bool :: Parser TomlExpression -bool = withError "Toml Bool" - $ TomlBool <$> (True <$ is "true" <|> - False <$ is "false") - - -dateTime :: Parser TomlExpression -dateTime = withError "Toml DateTime" - $ TomlDateTime <$> Dt.dateTime - -date :: Parser TomlExpression -date = withError "Toml Date" - $ TomlDate <$> Dt.date - -time :: Parser TomlExpression -time = withError "Toml Time" - $ TomlTime <$> Dt.time - - -string :: Parser TomlExpression -string = withError "Toml String" - $ TomlString <$> text - where - text = within (doubleQuote <#> 3) (multiline (inverse doubleQuote |*)) <|> - within (quote <#> 3) (multiline (inverse quote |*)) <|> - withinDoubleQuotes (inverse doubleQuote |*) <|> - withinQuotes (inverse quote |*) - - multiline parser = mconcat <$> (((blankLine |?) *> line parser) |*) - - line parser = is "\\" *> (whiteSpace |*) *> parser - - -array :: Parser TomlExpression -array = withError "Toml Array" - $ TomlArray <$> listOf (maybeWithin spacing tomlExpr) - - -key :: Parser String -key = keyParser >>> ((dot >>> keyParser) |*) - where - keyParser = maybeWithin spacesOrTabs $ freeText <|> - withinDoubleQuotes (inverse doubleQuote |*) <|> - withinQuotes (inverse quote |*) - - freeText = ((letter <|> digit <|> underscore <|> dash) |+) - - -inlineTable :: Parser TomlExpression -inlineTable = withError "Toml Table" - $ TomlTable Inline <$> mapOf equal key tomlExpr - - -topLevelTable :: Parser TomlExpression -topLevelTable = withError "Toml Table" - $ TomlTable TopLevel . Map.fromList <$> maybeWithin spacing tables - where - tables = do xs <- keyValueSeqParser - ys <- (tableParser |*) - pure (ys <> [("", TomlTable Standard . Map.fromList $ xs)]) - - tableParser = do k <- withinSquareBrackets key - v <- maybeWithin spacing standardTable - pure (k, v) - - standardTable = TomlTable Standard . Map.fromList <$> keyValueSeqParser - - - keyValueSeqParser = do xs <- ((keyValueParser <* (blankLine *> (blankLines |?))) |*) - x <- (keyValueParser |?) - pure (xs <> maybeToList x) - - keyValueParser = do k <- key - maybeWithin spacesOrTabs equal - v <- tomlExpr - pure (k, v) - - - -element :: Parser TomlExpression -element = dateTime <|> date <|> time <|> float <|> - integer <|> bool <|> nil <|> string - - -container :: Parser TomlExpression -container = array <|> inlineTable - - -comment :: Parser String -comment = hashTag *> (inverse newLine |+) <* newLine - - -tomlExpr :: Parser TomlExpression -tomlExpr = maybeWithin (((pure <$> spaceOrTab) <|> comment) |+) tomlValue - where - tomlValue = element <|> container diff --git a/src/Bookhound/Parsers/Xml.hs b/src/Bookhound/Parsers/Xml.hs deleted file mode 100644 --- a/src/Bookhound/Parsers/Xml.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Bookhound.Parsers.Xml (xml, branchExpr, leafExpr, literal) where - -import Bookhound.Parser (Parser, withError) -import Bookhound.ParserCombinators (IsMatch (..), maybeWithin, (<|>), (|*), - (|+)) -import Bookhound.Parsers.Char (doubleQuote) -import Bookhound.Parsers.String (spacing, withinAngleBrackets, - withinDoubleQuotes) -import Bookhound.SyntaxTrees.Xml (XmlExpression (..), literalExpression) - -import Data.Map (Map) -import qualified Data.Map as Map - - -xml :: Parser XmlExpression -xml = maybeWithin ((header <|> comment) |+) - $ maybeWithin spacing $ branchExpr <|> leafExpr - - - -field :: Parser (String, String) -field = withError "Xml Field" $ - (,) <$> text <* is '=' <*> quotedText - where - quotedText = withinDoubleQuotes (inverse doubleQuote |*) - - -fullTag :: Parser (String, Map String String) -fullTag = withError "Xml Tag" $ - do tag <- text - flds <- Map.fromList <$> ((spacing *> field) |*) - pure (tag, flds) - - -branchExpr :: Parser XmlExpression -branchExpr = withError "Xml Branch Expression" $ - do (tag, flds) <- withinAngleBrackets fullTag - exprs <- (xml |+) <|> literal - maybeWithin spacing (is (" tag <> ">")) - pure $ XmlExpression { tagName = tag, fields = flds, expressions = exprs } - - -literal :: Parser [XmlExpression] -literal = withError "Xml Literal" $ - pure . literalExpression <$> maybeWithin spacing (isNot '<' |*) - - -leafExpr :: Parser XmlExpression -leafExpr = withError "Xml Leaf Expression" $ - do (tag, flds) <- withinAngleBrackets (fullTag <* is '/') - pure $ XmlExpression { tagName = tag, fields = flds, expressions = [] } - - -header :: Parser String -header = maybeWithin spacing $ - is " (isNot '?' |*) <* is "?>" - - -comment :: Parser String -comment = maybeWithin spacing $ - is "" - - - -text :: Parser String -text = (noneOf ['/', '>', ' ', '='] |+) diff --git a/src/Bookhound/Parsers/Yaml.hs b/src/Bookhound/Parsers/Yaml.hs deleted file mode 100644 --- a/src/Bookhound/Parsers/Yaml.hs +++ /dev/null @@ -1,213 +0,0 @@ -module Bookhound.Parsers.Yaml (yaml, nil, integer, float, bool, string, - list, mapping) where - - -import Bookhound.Parser (Parser, andThen, check, exactly, - withError) -import Bookhound.ParserCombinators (IsMatch (..), maybeWithin, (<#>), (<|>), - (>>>), (|*), (|+), (|++), (|?)) -import Bookhound.Parsers.Char (char, colon, dash, dot, doubleQuote, - hashTag, newLine, question, quote, space, - whiteSpace) -import Bookhound.Parsers.Collections (listOf, mapOf) -import Bookhound.Parsers.Number (double, hexInt, int, octInt) -import Bookhound.Parsers.String (blankLine, blankLines, spaces, - spacesOrTabs, tabs, withinDoubleQuotes, - withinQuotes) -import Bookhound.SyntaxTrees.Yaml (CollectionType (..), YamlExpression (..)) - -import qualified Bookhound.Parsers.DateTime as Dt - -import Data.List (nub) -import qualified Data.Map as Map - - - -yaml :: Parser YamlExpression -yaml = normalize `andThen` yamlWithIndent (-1) - - - - --- TODO: Add support for anchors and aliases - -nil :: Parser YamlExpression -nil = withError "Yaml Null" - $ YamlNull <$ oneOf ["null", "Null", "NULL"] - -integer :: Parser YamlExpression -integer = withError "Yaml Integer" - $ YamlInteger <$> (hexInt <|> octInt <|> int) - -float :: Parser YamlExpression -float = withError "Yaml Float" - $ YamlFloat <$> double - -bool :: Parser YamlExpression -bool = withError "Yaml Bool" - $ YamlBool <$> (True <$ oneOf ["true", "True", "TRUE"] <|> - False <$ oneOf ["false", "False", "FALSE"]) - - -dateTime :: Parser YamlExpression -dateTime = withError "Yaml DateTime" - $ YamlDateTime <$> Dt.dateTime - -date :: Parser YamlExpression -date = withError "Yaml Date" - $ YamlDate <$> Dt.date - -time :: Parser YamlExpression -time = withError "Yaml Time" - $ YamlTime <$> Dt.time - - -string :: Int -> Parser YamlExpression -string indent = withError "Yaml String" - $ YamlString <$> text indent - - -sequential :: Parser a -> Int -> Parser [YamlExpression] -sequential sep indent = listParser - where - - listParser = indentationCheck elemParser indent - - elemParser = do n <- length <$> (space |*) - sep *> whiteSpace - elm <- yamlWithIndent n - pure (n, elm) - - -list :: Int -> Parser YamlExpression -list indent = withError "Json List" - $ (YamlList Inline <$> jsonList) - <|> (YamlList Standard <$> yamlList) - where - yamlList = sequential dash indent - jsonList = maybeWithin spacesOrTabs $ listOf $ yamlWithIndent (-1) - - -set :: Int -> Parser YamlExpression -set indent = withError "Yaml Set" - $ YamlList Standard . nub <$> sequential question indent - - -mapping :: Int -> Parser YamlExpression -mapping indent = withError "Yaml Mapping" - $ (YamlMap Inline <$> jsonMap) - <|> (YamlMap Standard <$> yamlMap) - where - yamlMap = Map.fromList <$> mapParser - jsonMap = maybeWithin spacesOrTabs $ mapOf colon (text 100) $ yamlWithIndent (-1) - - mapParser = indentationCheck keyValueParser indent - - keyValueParser = do n <- length <$> (space |*) - key <- show <$> element indent - (spacesOrTabs |?) - colon *> whiteSpace - value <- yamlWithIndent n - pure (n, (key, value)) - - - -element :: Int -> Parser YamlExpression -element indent = exactly (dateTime <|> date <|> time <|> float <|> - integer <|> bool <|> nil) <|> - string indent - -container :: Int -> Parser YamlExpression -container indent = list indent <|> mapping indent <|> set indent - - - -yamlWithIndent :: Int -> Parser YamlExpression -yamlWithIndent indent = maybeWithin ((blankLine <|> comment <|> directive <|> - docStart <|> docEnd) |+) - yamlValue - where - yamlValue = container indent <|> maybeWithin spacesOrTabs (element indent) - comment = hashTag *> (inverse newLine |+) <* newLine - directive = is "%" *> (inverse space *> (inverse newLine |+)) <* newLine - docStart = dash <#> 3 - docEnd = dot <#> 3 - - - -text :: Int -> Parser String -text indent = withinDoubleQuotes (quotedParser (inverse doubleQuote |*)) <|> - withinQuotes (quotedParser (inverse quote |*)) <|> - (is "|" *> blankLine *> plainTextParser literalLineParser) <|> - (is ">" *> blankLine *> (spacesOrTabs |?) *> plainTextParser foldingLineParser) <|> - plainTextParser foldingLineParser - where - - quotedParser parser = mconcat <$> ((snd <$> foldingLineParser parser) |*) - - plainTextParser styleParser = allowedStart >>> allowedString >>> - (indentationCheck (styleParser allowedString) indent |*) - - foldingLineParser parser = do sep <- ("\n" <$ newLine <* blankLines) <|> (" " <$ newLine) - n <- maybeWithin tabs $ length <$> (space |*) - str <- parser - pure (n, sep <> str) - - literalLineParser parser = do sep <- pure <$> newLine - n <- length <$> (space |*) - str <- parser - pure (n, sep <> replicate (n - indent) ' ' <> str) - - allowedStart = noneOf $ forbiddenChar <> ['>', '|', ':', '!'] - - allowedString = (noneOf forbiddenChar |*) - - forbiddenChar = ['\n', '#', '&', '*', ',', '?', '-', ':', '[', ']', '{', '}'] - - - -indentationCheck :: Parser (Int, a) -> Int -> Parser [a] -indentationCheck parser indent = ((snd <$> check "indentation" - (\(n, _) -> n > indent) parser) |+) - - -normalize :: Parser String -normalize = withError "Normalize Yaml" - $ (parserActions >>> normalize) <|> (char |*) - where - - parserActions = spreadDashes <|> - spreadDashKey <|> - spreadKeyDash <|> - next - - next = pure <$> char - - spreadDashes = ((<>) "- ") . genDashes <$> dashesParser - - genDashes (offset, n) = concatMap (\x -> "- " <> replicate (offset + 2 * x) ' ') - [1 .. n - 1] - - dashesParser = do offset <- length <$> (spaces |?) - n <- length <$> ((dash <* spacesOrTabs) |++) - pure (offset, n) - - - spreadDashKey = (\(offset, key) -> replicate offset ' ' <> "- " <> - replicate (offset + 2) ' ' <> key <> ": ") - <$> dashKeyParser - - dashKeyParser = do offset <- length <$> (spaces |?) - dash <* spacesOrTabs - key <- text 100 <* maybeWithin spacesOrTabs colon - pure (offset, key) - - - spreadKeyDash = (\(offset, key) -> replicate offset ' ' <> key <> ": " <> - replicate (offset + 2) ' ' <> "- ") - <$> keyDashParser - - keyDashParser = do offset <- length <$> (spaces |?) - key <- text 100 <* maybeWithin spacesOrTabs colon - dash <* spacesOrTabs - pure (offset, key) diff --git a/src/Bookhound/SyntaxTrees/Json.hs b/src/Bookhound/SyntaxTrees/Json.hs deleted file mode 100644 --- a/src/Bookhound/SyntaxTrees/Json.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Bookhound.SyntaxTrees.Json (JsExpression(..)) where - -import Bookhound.Internal.Foldable (stringify) -import Bookhound.Internal.Map (showMap) - -import Data.Char (toLower) -import Data.Map (Map) - - - -data JsExpression - = JsNumber Double - | JsBool Bool - | JsString String - | JsArray [JsExpression] - | JsObject (Map String JsExpression) - | JsNull - deriving (Eq, Ord) - - -instance Show JsExpression where - show = \case - JsNull -> "null" - JsNumber n -> show n - JsBool bool -> toLower <$> show bool - JsString str -> show str - JsArray arr -> stringify ",\n" "[\n" "\n]" 2 $ show <$> arr - JsObject obj -> stringify ",\n" "{\n" "\n}" 2 $ showMap ": " id show obj diff --git a/src/Bookhound/SyntaxTrees/Toml.hs b/src/Bookhound/SyntaxTrees/Toml.hs deleted file mode 100644 --- a/src/Bookhound/SyntaxTrees/Toml.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Bookhound.SyntaxTrees.Toml (TomlExpression(..), TableType(..)) where - -import Bookhound.Internal.DateTime (showDateTime) -import Bookhound.Internal.Foldable (stringify) -import Bookhound.Internal.Map (showMap) - -import Data.Char (toLower) -import Data.Time (Day, TimeOfDay, ZonedTime (..)) - -import Data.Map (Map) -import qualified Data.Map as Map - - - -data TomlExpression - = TomlInteger Integer - | TomlFloat Double - | TomlBool Bool - | TomlString String - | TomlDate Day - | TomlTime TimeOfDay - | TomlDateTime ZonedTime - | TomlArray [TomlExpression] - | TomlTable TableType (Map String TomlExpression) - | TomlNull - deriving (Eq, Ord) - - -data TableType - = TopLevel - | Standard - | Inline - deriving (Eq, Ord) - - -instance Show TomlExpression where - show = \case - TomlNull -> "null" - TomlInteger n -> show n - TomlFloat n -> show n - TomlBool bool -> toLower <$> show bool - TomlDate date -> show date - TomlTime time -> show time - TomlDateTime dateTime -> showDateTime dateTime - TomlString str -> show str - - TomlTable Standard table -> stringify "\n" "" "" 0 $ showMap " = " id show table - - TomlTable TopLevel table -> stringify "\n\n" "\n" "\n" 0 $ showMap "" showTableHeader show table where - showTableHeader header = if header /= "" then "[" <> header <> "]" <> "\n" else "" - - TomlTable Inline table -> stringify (", " <> sep) ("{ " <> sep) (" }" <> sep) n $ - showMap " = " id show table where - (sep, n) = if (length . mconcat) (show <$> Map.toList table) >= 80 then ("\n", 2) else ("", 0) - - TomlArray arr -> stringify (", " <> sep) ("[ " <> sep) (" ]" <> sep) n $ show <$> arr where - (sep, n) = if (length . mconcat) (show <$> arr) >= 80 then ("\n", 2) else ("", 0) diff --git a/src/Bookhound/SyntaxTrees/Xml.hs b/src/Bookhound/SyntaxTrees/Xml.hs deleted file mode 100644 --- a/src/Bookhound/SyntaxTrees/Xml.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Bookhound.SyntaxTrees.Xml (XmlExpression(..), literalExpression, flatten, findAll, find) where - -import Bookhound.Internal.Foldable (stringify) - -import Data.Maybe (listToMaybe) - -import Data.Map (Map, elems, keys) -import qualified Data.Map as Map - - -data XmlExpression - = XmlExpression - { tagName :: String - , fields :: Map String String - , expressions :: [XmlExpression] - } - deriving (Eq, Ord) - - -instance Show XmlExpression where - - show XmlExpression { tagName = tag, .. } - | tag == "literal" = head . elems $ fields - | otherwise = "<" <> tag <> flds <> innerExprs where - - innerExprs = if | null expressions -> "/>" - | otherwise -> ">" <> ending - - (sep, n) = if | ((tagName) . head) expressions == "literal" -> ("", 0) - | otherwise -> ("\n", 2) - - ending = stringify sep sep sep n (show <$> expressions) <> " tag <> ">" - - flds | null fields = "" - | otherwise = " " <> fieldsString where - - fieldsString = stringify " " "" "" 0 $ showFn <$> tuples - showFn (x, y) = x <> "=" <> show y - tuples = zip (keys fields) (elems fields) - - - -literalExpression :: String -> XmlExpression -literalExpression val = XmlExpression { tagName = "literal", - fields = Map.fromList [("value", val)], - expressions = [] } - - -flatten :: XmlExpression -> [XmlExpression] -flatten expr = expr : expressions expr >>= flatten - - -findAll :: (XmlExpression -> Bool) -> XmlExpression -> [XmlExpression] -findAll f = filter f . flatten - - -find :: (XmlExpression -> Bool) -> XmlExpression -> Maybe XmlExpression -find f = listToMaybe . findAll f diff --git a/src/Bookhound/SyntaxTrees/Yaml.hs b/src/Bookhound/SyntaxTrees/Yaml.hs deleted file mode 100644 --- a/src/Bookhound/SyntaxTrees/Yaml.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Bookhound.SyntaxTrees.Yaml (YamlExpression(..), CollectionType(..)) where - -import Bookhound.Internal.DateTime () -import Bookhound.Internal.Foldable (stringify) -import Bookhound.Internal.Map (showMap) - -import Data.Char (toLower) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Time (Day, TimeOfDay, ZonedTime (..)) - - - -data YamlExpression - = YamlInteger Integer - | YamlFloat Double - | YamlBool Bool - | YamlString String - | YamlDate Day - | YamlTime TimeOfDay - | YamlDateTime ZonedTime - | YamlList CollectionType [YamlExpression] - | YamlMap CollectionType (Map String YamlExpression) - | YamlNull - deriving (Eq, Ord) - -data CollectionType - = Standard - | Inline - deriving (Eq, Ord) - - -instance Show YamlExpression where - show = \case - YamlNull -> "null" - YamlInteger n -> show n - YamlFloat n -> show n - YamlBool bool -> toLower <$> show bool - YamlDate date -> show date - YamlTime time -> show time - YamlDateTime dateTime -> show dateTime - YamlString str -> showStr str - YamlList Standard list -> stringify "\n" "\n" "" 2 $ ("- " <>) . show <$> list - YamlMap Standard mapping -> stringify "\n" "\n" "" 2 $ showMap ": " id show mapping - - YamlList Inline list -> stringify (", " <> sep) ("[ " <> sep) (" ]" <> sep) n $ show <$> list where - (sep, n) = if (length . mconcat) (show <$> list) >= 80 then ("\n", 2) else ("", 0) - - YamlMap Inline mapping -> stringify (", " <> sep) ("{ " <> sep) (" }" <> sep) n $ - showMap ": " id show mapping where - (sep, n) = if (length . mconcat) (show <$> Map.toList mapping) >= 80 then ("\n", 2) else ("", 0) - - - -showStr :: String -> String -showStr str = (if (length (lines str) > 1) && not (any (`elem` str) forbiddenChar) - then "| \n" - else if length (lines str) > 1 then "\n" - else "") <> - - (if not $ any (`elem` str) forbiddenChar then str - else if '"' `elem` str then "'" <> indented 3 <> "'" - else "\"" <> indented 3) <> "\"" where - - indented n = head (lines str) <> - mconcat ((("\n" <> replicate n ' ') <>) <$> tail (lines str)) - - forbiddenChar = ['#', '&', '*', ',', '?', '-', ':', '[', ']', '{', '}'] <> - ['>', '|', ':', '!']