Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

337 lines (287 sloc) 12.447 kb
module YAML ( Node(..), YAML(..),
-- buildTree, unEscape, tokenize, tokenizeBytes,
singleT,
getScalar, getMapping, getSequence,
getMappingValues, getMappingList, makeTree, makeTokens,
showYaml, readYaml, parseYaml, parseYamlList ) where
import YAML.Reference ( Code(..), tokenize ) -- , tokenizeBytes )
import Data.Maybe ( catMaybes )
import Data.Char ( isHexDigit, isSpace, isAlphaNum )
import Data.List ( groupBy )
import Data.Function ( on )
data Node = Leaf String
| List [Node]
| Map [(Node,Node)]
| Null
deriving ( Eq, Show )
singleT :: (YAML k,YAML v) => k -> v -> [(Node,Node)]
singleT k v = [(toNode k,toNode v)]
class YAML a where
toNode :: a -> Node
fromNode :: Node -> Maybe a
toString :: [a] -> Maybe String
toString _ = Nothing
fromString :: String -> [a]
fromString _ = []
instance YAML Node where
toNode x = x
fromNode x = Just x
instance YAML Char where
toNode c = Leaf [c]
fromNode (Leaf [c]) = Just c
fromNode _ = Nothing
toString = Just
fromString s = s
instance YAML Int where
toNode = Leaf . show
fromNode (Leaf s) = case readsPrec 0 s of
[(x,"")] -> Just x
_ -> Nothing
fromNode _ = Nothing
instance YAML a => YAML [a] where
toNode ns = maybe (List $ map toNode ns) Leaf $ toString ns
fromNode (List ns) = Just $ catMaybes $ map fromNode ns
fromNode (Leaf x) = Just $ fromString x
fromNode _ = Just []
newtype Assoc a b = Assoc { unAssoc :: [(a,b)] }
instance (YAML a, YAML b) => YAML (Assoc a b) where
toNode (Assoc ns) = Map $ map (\(a,b) -> (toNode a,toNode b)) ns
fromNode (Map t) = Just $ Assoc $ catMaybes $ map cm $
map (\(a,b) -> (fromNode a,fromNode b)) t
where cm (Just a,Just b) = Just (a,b)
cm _ = Nothing
fromNode _ = Just $ Assoc []
instance YAML a => YAML (Maybe a) where
toNode Nothing = Null
toNode (Just x) = toNode x
fromNode Null = Just Nothing
fromNode n = case fromNode n of
Just x -> Just (Just x)
Nothing -> Nothing
instance (YAML a, YAML b) => YAML (Either a b) where
toNode (Left x) = Map $ singleT "Left" $ toNode x
toNode (Right x) = Map $ singleT "Right" $ toNode x
fromNode (Map t) = case t of
[(Leaf "Left",n)] -> Left `fmap` fromNode n
[(Leaf "Right",n)] -> Right `fmap` fromNode n
_ -> Nothing
fromNode _ = Nothing
instance (YAML a, YAML b) => YAML (a,b) where
toNode (a,b) = List [toNode a, toNode b]
fromNode n = do [a,b] <- fromNode n
aa <- fromNode a
bb <- fromNode b
Just (aa,bb)
instance YAML Bool where
toNode True = Leaf "true"
toNode False = Leaf "false"
fromNode (Leaf "true") = Just True
fromNode (Leaf "false") = Just False
fromNode _ = Nothing
instance YAML () where
toNode () = Null
fromNode Null = Just ()
fromNode _ = Nothing
-- Use the reference implementation to parse the stupid thing
type Aliases = [(String,Node)]
type Tokens = [(Code,String)]
data TokenTree = TextT String
| MetaT String
| LineFoldT -- BreakT, IndT String, WhiteT String
| LineFeedT
| EscapeT [TokenTree]
| CommentT [TokenTree]
| DirectiveT [TokenTree]
| TagT [TokenTree]
| HandleT [TokenTree]
| AnchorT [TokenTree]
| PropertiesT [TokenTree]
| AliasT [TokenTree]
| ScalarT [TokenTree]
| SequenceT [TokenTree]
| MappingT [TokenTree]
| NodeT [TokenTree]
| PairT [TokenTree]
| DocumentT [TokenTree]
deriving ( Show )
buildTree :: Tokens -> [TokenTree]
buildTree = fst . btu Nothing
where btu :: Maybe Code -> Tokens -> ([TokenTree],Tokens)
btu _ [] = ([],[])
btu e ((c,s):xs) =
case c of
e' | e == Just e' -> ([],xs)
Text -> prepend $ TextT s
Meta -> prepend $ MetaT s
LineFold -> prepend LineFoldT
LineFeed -> prepend LineFeedT
BeginEscape -> branch EscapeT EndEscape
BeginComment -> branch CommentT EndComment
BeginDirective -> branch DirectiveT EndDirective
BeginTag -> branch TagT EndTag
BeginHandle -> branch HandleT EndHandle
BeginAnchor -> branch AnchorT EndAnchor
BeginProperties -> branch PropertiesT EndProperties
BeginAlias -> branch AliasT EndAlias
BeginScalar -> branch ScalarT EndScalar
BeginSequence -> branch SequenceT EndSequence
BeginMapping -> branch MappingT EndMapping
BeginNode -> branch NodeT EndNode
BeginPair -> branch PairT EndPair
BeginDocument -> branch DocumentT EndDocument
_ -> btu e xs
where prepend :: TokenTree -> ([TokenTree],Tokens)
prepend t = let (ts,xs') = btu e xs
in (t:ts,xs')
branch :: ([TokenTree] -> TokenTree) -> Code
-> ([TokenTree],Tokens)
branch f e' = let (ts,xs') = btu (Just e') xs
(ts',xs'') = btu e xs'
in (f ts:ts',xs'')
-- parse :: Tokens -> [Node]
-- parse = stre
-- where stre [] = []
-- stre ((BeginDocument,_):xs) = docu (\n ts -> n:stre ts) xs
-- stre (_:xs) = stre xs
-- stre [] = []
-- docu :: (Node -> Tokens -> [Node]) -> Tokens -> [Node]
-- docu f ((BeginNode,_):xs) = node f xs
-- docu f ((EndDocument,_):xs) = f xs
-- docu f (_:xs) = docu f xs
-- docu _ [] = [] -- impossible
-- node f ((BeginScalar,_):xs) = text "" (\n ts -> n:f ts) xs
-- node f ((BeginSequence,_):xs) = seq f xs
-- -- scalars - read text
-- text ss f ((Text,s):xs) = text (ss++s) f xs
-- text ss f ((BeginEscape,_):xs) = escText ss f xs
-- text ss f ((EndScalar,_):xs) = f (Leaf ss) xs
-- text ss f (_:xs) = text ss f xs -- impossible
-- text ss _ [] = [Scalar ss] -- impossible
-- escText ss f ((Meta,s):xs) = escText (ss++unEscape s) f xs
-- escText ss f ((EndEscape,_):xs) = text ss f xs
-- escText ss f (_:xs) = escText ss f xs -- impossible
-- escText ss _ [] = [Leaf ss] -- impossible
-- -- sequences
-- seq ys f ((BeginNode,_):xs) = node (\n ts -> seq (n:ys) f ts) xs
-- seq ys f ((EndSequence,_):xs) = f (List ys) xs
-- seq ys f (_:xs) = seq ys f xs
-- -- It looks like this might work, but it definitely waits until EndSequence
-- -- before it even makes a List... Can we do better? Probably not.
parseStream :: [TokenTree] -> [Node]
parseStream (DocumentT n:xs) = snd (parseNodes [] n) ++ parseStream xs
parseStream (_:xs) = parseStream xs
parseStream [] = []
parseNodes :: Aliases -> [TokenTree] -> (Aliases,[Node])
parseNodes as (NodeT n:xs) = let (as',n') = parseNode as n
(as'',ns) = parseNodes as' xs
in (as'',n':ns)
parseNodes as (_:xs) = parseNodes as xs
parseNodes as [] = (as,[])
parseNode :: Aliases -> [TokenTree] -> (Aliases,Node)
parseNode as (PropertiesT ps:xs) = applyProp ps $ parseNode as xs
parseNode as (AliasT a:_) = (as,maybe Null id $ lookup (getMeta a) as)
parseNode as (ScalarT s:_) = (as,Leaf $ getText s)
parseNode as (SequenceT s:_) = let (as',ns) = parseNodes as s in (as',List ns)
parseNode as (MappingT m:_) = let (as',ps) = parsePairs as m in (as',Map ps)
parseNode as (_:xs) = parseNode as xs
parseNode as [] = (as,Null)
applyProp :: [TokenTree] -> (Aliases,Node) -> (Aliases,Node)
applyProp ((AnchorT a):xs) = addAlias (getMeta a) . applyProp xs
where addAlias :: String -> (Aliases,Node) -> (Aliases,Node)
addAlias k (as,n) = ((k,n):as,n)
applyProp (_:xs) = applyProp xs
applyProp [] = id
parsePairs :: Aliases -> [TokenTree] -> (Aliases,[(Node,Node)])
parsePairs as (PairT p:xs) = case parseNodes as p of
(as',[k,v]) -> let (as'',ps) = parsePairs as' xs
in (as'',(k,v):ps)
(as',_) -> parsePairs as' xs
parsePairs as (_:xs) = parsePairs as xs
parsePairs as [] = (as,[])
getText :: [TokenTree] -> String
getText (TextT s:xs) = s++getText xs
getText (EscapeT s:xs) = unEscape (getMeta s)++getText xs
getText (_:xs) = getText xs
getText [] = ""
unEscape :: String -> String
unEscape d | length d `elem` [2,4] && all isHexDigit d
= [toEnum $ read $ "0x"++d]
| length d == 8 && all isHexDigit d
= [toEnum $ read $ "0x"++take 4 d,toEnum $ read $ "0x"++drop 4 d]
unEscape [c] = search "\0\0a\ab\bt\tn\nv\vf\fr\re\x1bN\x85_\xa0L\x2028P\x2029"
where search (a:b:xs) | a==c = [b]
| otherwise = search xs
search _ = [c] -- space, ", /, \ (and anything else)
unEscape x = ""
getMeta :: [TokenTree] -> String
getMeta (MetaT s:xs) = s++getMeta xs
getMeta (_:xs) = getMeta xs
getMeta [] = ""
tokenizeLazy :: String -> String -> [(Code,String)]
tokenizeLazy name = concat . map (tokenize name . unlines)
. groupBetween "..." . lines
where groupBetween :: Eq a => a -> [a] -> [[a]]
groupBetween s = uncurry (:) . gb
where -- gb :: [a] -> ([a],[[a]])
gb [] = ([],[])
gb (x:xs) | x == s = let (y,ys) = gb xs in ([],y:ys)
| otherwise = let (y,ys) = gb xs in (x:y,ys)
parseYaml :: String -> [Node]
parseYaml = parseStream . buildTree . tokenizeLazy "-"
makeTokens = tokenizeLazy "-"
makeTree = buildTree . tokenizeLazy "-"
parseYamlList :: String -> [Node]
parseYamlList x = case parseYaml x of
[List ns] -> ns
_ -> error "bad input in parseYamlList"
readYaml :: YAML a => String -> Maybe a
readYaml s = case parseYaml s of
[] -> Nothing
(n:_) -> fromNode n
dumpNode :: Node -> String
dumpNode node0 = f False 0 node0 "\n" where
f nn _ Null = foo nn . showString "null"
f nn _ (Leaf x) = foo nn . showString' x
f nn i (List ns) =
nl nn [ g i . showString "-" . f True (i + 1) n | n <- ns ]
f nn i (Map ns) =
nl nn [ g i . showString x . showString ":" . f True (i + 1) y
| (Leaf x,y) <- ns ] -- need to use ? if needed...
g i = showString $ replicate i ' '
nl _ [] = id
nl nn xs = (if nn then ('\n':) else id) .
foldr1 (\x y -> x . showChar '\n' . y ) xs
foo True = showChar ' '
foo False = id
showYaml :: YAML a => a -> String
showYaml n = dumpNode (toNode n)
showString' :: String -> String -> String
showString' a b = if all isGood a then a ++ b else '"':f a b where
f [] y = '"':y
f (x:xs) ys | x == '\n' = '\\':'n':f xs ys
| isQuoteGood x = x:f xs ys
| otherwise = '\\':x:f xs ys
isQuoteGood x = isGood x || isSpace x || x `elem` "!@#$%^&*(){}/"
isGood :: Char -> Bool
isGood x = isAlphaNum x || x `elem` "_-.@/"
getScalar :: Node -> Maybe String
getScalar (Leaf s) = Just s
getScalar (Map t) = lookup (Leaf "=") t >>= getScalar
getScalar _ = Nothing
-- | find an element from a mapping.
getMapping :: String -> Node -> Maybe Node
getMapping k (Map t) = lookup (Leaf k) t
getMapping "=" (Leaf x) = Just $ Leaf x
getMapping _ _ = Nothing
-- | read a mapping into a 'Trie'.
getMappingList :: Node -> [(Node,Node)]
getMappingList (Map t) = t
getMappingList l = singleT "=" l
-- | read a mapping into a list.
getMappingValues :: Node -> Maybe [Node]
getMappingValues (Map t) = Just $ map snd t
getMappingValues _ = Nothing
-- | read a sequence.
getSequence :: Node -> Maybe [Node]
getSequence (List ns) = Just ns
getSequence _ = Nothing
Jump to Line
Something went wrong with that request. Please try again.