packages feed

hydrogen-syntax 0.11 → 0.12

raw patch · 5 files changed

+272/−188 lines, 5 filesdep ~hydrogen-parsingdep ~hydrogen-prelude

Dependency ranges changed: hydrogen-parsing, hydrogen-prelude

Files

hydrogen-syntax.cabal view
@@ -1,41 +1,44 @@-name:                 hydrogen-syntax-version:              0.11-homepage:             https://scravy.de/hydrogen-syntax/-synopsis:             Hydrogen Syntax-license:              BSD3-license-file:         LICENSE-extra-source-files:   CHANGELOG.md, README.md-author:               Julian Fleischer-maintainer:           julian@scravy.de-category:             Language-build-type:           Simple-cabal-version:        >=1.14+name:                   hydrogen-syntax+version:                0.12+homepage:               https://scravy.de/hydrogen-syntax/+synopsis:               Hydrogen Syntax+license:                BSD3+license-file:           LICENSE+extra-source-files:     CHANGELOG.md, README.md+author:                 Julian Fleischer+maintainer:             julian@scravy.de+category:               Language+build-type:             Simple+cabal-version:          >=1.14  source-repository head-    type:             git-    location:         https://github.com/scravy/hydrogen-syntax+    type:               git+    location:           https://github.com/scravy/hydrogen-syntax  library-  exposed-modules:    Hydrogen.Syntax.Parser-                      , Hydrogen.Syntax.Types-  build-depends:      base ==4.7.*-                      , containers ==0.5.* -                      , hydrogen-prelude ==0.11-                      , hydrogen-parsing ==0.11-                      , nicify ==1.1.*-                      , parsec ==3.1.*-                      , uuid ==1.3.*-  hs-source-dirs:     src-  ghc-options:        -Wall-  default-language:   Haskell2010-  default-extensions:  CPP-                       , DeriveDataTypeable-                       , DeriveGeneric-                       , EmptyCase-                       , FlexibleContexts-                       , GADTs-                       , LambdaCase-                       , MultiWayIf-                       , NoImplicitPrelude-                       , RecordWildCards-                       , TupleSections+  exposed-modules:      Hydrogen.Syntax.Parser+                        , Hydrogen.Syntax.Parser.TokenParser+                        , Hydrogen.Syntax.Parser.LayoutParser+                        , Hydrogen.Syntax.Types+  build-depends:        base ==4.7.*+                        , containers ==0.5.*+                        , hydrogen-parsing ==0.12+                        , hydrogen-prelude ==0.12+                        , nicify ==1.1.*+                        , parsec ==3.1.*+                        , uuid ==1.3.*+  hs-source-dirs:       src+  ghc-options:          -Wall+  default-language:     Haskell2010+  default-extensions:   CPP+                        , DeriveDataTypeable+                        , DeriveGeneric+                        , EmptyCase+                        , FlexibleContexts+                        , GADTs+                        , LambdaCase+                        , MultiWayIf+                        , NoImplicitPrelude+                        , RecordWildCards+                        , ScopedTypeVariables+                        , TupleSections
src/Hydrogen/Syntax/Parser.hs view
@@ -1,148 +1,20 @@-module Hydrogen.Syntax.Parser where--import Hydrogen.Prelude hiding ((<|>), many)-import Hydrogen.Syntax.Types--import Hydrogen.Parsing.Char hiding (token, tokens, space)---tokenize :: String -> Parser String (Tokens Token)-tokenize srcName = either mkError sanitize . runIdentity . runParserT tokens () srcName-  where-    tokens = many (liftA2 (,) getPosition token) <* eof--    token = choice [-        TIndent <$> indent-      , something >>= \x -> choice [-          TString x '\'' <$> chars3 "'''"-        , TString x '\"' <$> chars3 "\"\"\""-        , TString x '`' <$> chars3 "```"-        , TString x '\'' <$> chars' '\''-        , TString x '\"' <$> chars' '\"'-        , TString x '`' <$> chars' '`'-        , TSomething <$> return x-        ]-      , TString "" '\'' <$> chars3 "'''"-      , TString "" '\"' <$> chars3 "\"\"\""-      , TString "" '`' <$> chars3 "```"-      , TString "" '\'' <$> chars '\''-      , TString "" '\"' <$> chars '\"'-      , TString "" '`' <$> chars' '`'-      , const TSpaces <$> many1 (char ' ')-      , const TComma <$> char ','-      , const TSemicolon <$> char ';'-      , TBraceOpen "" <$> oneOf "([{"-      , TBraceClose <$> oneOf ")]}"-      ]--    something = many1 (noneOf ("([{)]}\'\"`;, " ++ ['\0' .. '\x1F']))--    indent = many1 (try (many space >> (nl <|> comment))) *> (length <$> many space)-      where-        space = char ' '-        nl = string "\n"-        comment = string ";;" >> many (noneOf "\n") <* char '\n'--    chars' d = inBetween (char d) (many (try (char '\\' >> char d) <|> noneOf (d : "\n")))--    chars d = inBetween (char d) (many (noneOf (d : "\\\n") <|> escape))--    chars3 d = manyBetween (try (string d)) (try (string d)) (noneOf "\\" <|> escape)--    inBetween d p = d *> p <* d--    escape = char '\\' >> choice [-          oneOf "\\\'\"?`"-        , special <$> oneOf (map fst escapes)-        , char 'x' >> (convert <$> count 2 hexDigit)-        , char 'u' >> (convert <$> count 4 hexDigit)-        , char 'U' >> (convert <$> count 8 hexDigit) -- like Python-        ]-      where-        special = fromJust . flip lookup escapes-        escapes = [-            ('0', '\0'),-            ('a', '\a'),-            ('b', '\b'),-            ('f', '\f'),-            ('n', '\n'),-            ('r', '\r'),-            ('t', '\t'),-            ('v', '\v') ]-        convert str = let [(hex, _)] = readHex str in toEnum hex--    sanitize :: [(SourcePos, Token)] -> Either SomethingBad (Tokens Token)--    sanitize (t1@(p1, v1) : ts@(_t2@(p2, v2) : tss)) = case (v1, v2) of--        (TSomething k, TBraceOpen _ t) -> sanitize ((p1, TBraceOpen k t) : tss)--        (TString _ _ _, TSomething _) -> Left [(p2, "")]-        (TString _ _ _, TBraceOpen _ _) -> Left [(p2, "")]--        (TBraceClose _, TSomething _) -> Left [(p2, "")]-        (TBraceClose _, TString _ _ _) -> Left [(p2, "")]-        (TBraceClose _, TBraceOpen _ _) -> Left [(p2, "")]-        -        (TBraceOpen _ _, TIndent _) -> sanitize (t1 : tss)-        (TBraceOpen _ _, TSpaces) -> sanitize (t1 : tss)-        (TBraceOpen _ _, _) ->-            fmap ([t1, (p2, TIndent (sourceColumn p2 - 1))] ++) (sanitize ts)--        (TSpaces, _) -> sanitize ts--        (TIndent _, TBraceOpen _ '{') -> sanitize ts-        (TIndent _, TBraceClose _) -> sanitize ts-        (TIndent _, TSemicolon) -> sanitize ts--        (TSemicolon, TIndent _) -> sanitize (t1 : tss)--        _ -> fmap (t1 :) (sanitize ts)--    sanitize [t@(_, v)] = Right $ case v of-        TSpaces -> []-        TIndent _ -> []-        TSemicolon -> [t]-        _ -> [t]--    sanitize [] = Right []--layout :: Parser (Tokens Token) POPs-layout = runTokenParser (many (liftA2 (,) getPosition (someToken 0)) <* eof)-  where-    someToken :: Monad m => Int -> ParsecT [(SourcePos, Token)] u m POP-    someToken i = choice [-        sourceToken $ \case--            TIndent i' | i' <= i -> Just (Token SomethingT "" ";;")--            TString k '\'' v -> Just (Token AposString k v)-            TString k '"'  v -> Just (Token QuotString k v)-            TString k '`'  v -> Just (Token TickString k v)--            TComma -> Just (Token SomethingT "" ",")-            TSemicolon -> Just (Token SomethingT "" ";")-            TSomething v -> Just (Token SomethingT "" v)+module Hydrogen.Syntax.Parser (+    module Hydrogen.Syntax.Parser.TokenParser+  , module Hydrogen.Syntax.Parser.LayoutParser+  , parse+  , parse'+) where -            _ -> Nothing+import Hydrogen.Prelude+import Hydrogen.Parsing hiding (parse) -      , do-            (k, c) <- sourceToken $ \case-                TBraceOpen k c -> curry Just k c-                _ -> Nothing-            i' <- sourceToken $ \(TIndent indent) -> Just indent-            ts <- many (liftA2 (,) getPosition (someToken i'))-            bt <- case c of-                '(' -> sourceToken $ \case TBraceClose ')' -> Just Grouping ; _ -> Nothing-                '[' -> sourceToken $ \case TBraceClose ']' -> Just Brackets ; _ -> Nothing-                '{' -> sourceToken $ \case TBraceClose '}' -> Just Mustache ; _ -> Nothing-                _ -> error "Popsicle!"-            return (Block bt k ts)+import Hydrogen.Syntax.Types+import Hydrogen.Syntax.Parser.TokenParser+import Hydrogen.Syntax.Parser.LayoutParser -      ] <* skipMany (sourceToken lineContinuation)-      where-        lineContinuation = \case TIndent i' | i' > i -> Just () ; _ -> Nothing+parse :: String -> Parser String (POPs a)+parse srcName = parseTokens default_ srcName >+> parseLayout default_ -parse :: String -> Parser String POPs-parse srcName = tokenize srcName >+> layout+parse' :: TokenizerConfig -> LayoutConfig a -> String -> Parser String (POPs a)+parse' tc lc srcName = parseTokens tc srcName >+> parseLayout lc
+ src/Hydrogen/Syntax/Parser/LayoutParser.hs view
@@ -0,0 +1,61 @@+module Hydrogen.Syntax.Parser.LayoutParser where++import Hydrogen.Prelude hiding ((<|>), many)+import Hydrogen.Syntax.Types++import Hydrogen.Parsing.Char hiding (token, tokens, space)+++data LayoutConfig a = LayoutConfig {+    cfgValueTokens :: String -> Maybe a+  , cfgBlockTransformer :: POP a -> POP a+  , cfgIndentToken :: String+}++instance Default (LayoutConfig a) where+    default_ = LayoutConfig {+        cfgValueTokens = const Nothing+      , cfgBlockTransformer = id+      , cfgIndentToken = ";;"+    }++parseLayout :: forall a. LayoutConfig a -> Parser (Tokens Token) (POPs a)+parseLayout cfg = runTokenParser (many (liftA2 (,) getPosition (someToken 0)) <* eof)+  where+    LayoutConfig { .. } = cfg++    someToken :: Monad m => Int -> ParsecT [(SourcePos, Token)] u m (POP a)+    someToken i = choice [+        sourceToken $ \case++            TIndent i' | i' <= i -> Just (Token SomethingT "" cfgIndentToken)++            TString k '\'' v -> Just (Token AposString k v)+            TString k '"'  v -> Just (Token QuotString k v)+            TString k '`'  v -> Just (Token TickString k v)++            TSpecial v -> Just (Token SomethingT "" [v])+            TSomething v+                | isJust val -> Just (Value (fromJust val) v)+                | otherwise  -> Just (Token SomethingT "" v)+              where+                val = cfgValueTokens v++            _ -> Nothing++      , do+            (k, c) <- sourceToken $ \case+                TBraceOpen k c -> curry Just k c+                _ -> Nothing+            i' <- sourceToken $ \(TIndent indent) -> Just indent+            ts <- many (liftA2 (,) getPosition (someToken i'))+            bt <- case c of+                '(' -> sourceToken $ \case TBraceClose ')' -> Just Grouping ; _ -> Nothing+                '[' -> sourceToken $ \case TBraceClose ']' -> Just Brackets ; _ -> Nothing+                '{' -> sourceToken $ \case TBraceClose '}' -> Just Mustache ; _ -> Nothing+                _ -> error "Popsicle!"+            return (cfgBlockTransformer $ Block bt k ts)++      ] <* skipMany (sourceToken lineContinuation)+      where+        lineContinuation = \case TIndent i' | i' > i -> Just () ; _ -> Nothing
+ src/Hydrogen/Syntax/Parser/TokenParser.hs view
@@ -0,0 +1,148 @@+module Hydrogen.Syntax.Parser.TokenParser where++import Hydrogen.Prelude hiding ((<|>), many)+import Hydrogen.Syntax.Types++import Hydrogen.Parsing.Char hiding (token, tokens, space)+++data TokenizerConfig = TokenizerConfig {+    cfgSpaces :: [Char]+  , cfgEscapes :: [(Char, Char)]+  , cfgComments :: String+  , cfgOpeningBraces :: [Char]+  , cfgClosingBraces :: [Char]+  , cfgControlCharacters :: [Char]+  , cfgSpecialCharacters :: [Char]+  , cfgSpecialSemantics :: [Char]+  , cfgFoldSpecials :: [Char]+} deriving (Eq, Show)++instance Default TokenizerConfig where+    default_ = TokenizerConfig {+        cfgSpaces = " "+      , cfgEscapes = [+            ('\\', '\\'),+            ('\'', '\''),+            ('"', '"'),+            ('`', '`'),+            ('0', '\0'),+            ('a', '\a'),+            ('b', '\b'),+            ('f', '\f'),+            ('n', '\n'),+            ('r', '\r'),+            ('t', '\t'),+            ('v', '\v') ]+      , cfgComments = ";;"+      , cfgOpeningBraces = "([{"+      , cfgClosingBraces = ")]}"+      , cfgControlCharacters = ['\0' .. '\x1F']+      , cfgSpecialCharacters = ",;"+      , cfgSpecialSemantics = "{;"+      , cfgFoldSpecials = ";"+    }++parseTokens :: TokenizerConfig -> String -> Parser String (Tokens Token)+parseTokens cfg src = either mkError sanitize . runIdentity . runParserT tokens () src+  where+    TokenizerConfig { .. } = cfg++    tokens = many (liftA2 (,) getPosition token) <* eof++    token = choice [+        TIndent <$> indent+      , something >>= \x -> choice [+          TString x '\'' <$> chars3 "'''"+        , TString x '\"' <$> chars3 "\"\"\""+        , TString x '`' <$> chars3 "```"+        , TString x '\'' <$> chars' '\''+        , TString x '\"' <$> chars' '\"'+        , TString x '`' <$> chars' '`'+        , TSomething <$> return x+        ]+      , TString "" '\'' <$> chars3 "'''"+      , TString "" '\"' <$> chars3 "\"\"\""+      , TString "" '`' <$> chars3 "```"+      , TString "" '\'' <$> chars '\''+      , TString "" '\"' <$> chars '\"'+      , TString "" '`' <$> chars' '`'+      , const TSpaces <$> many1 space+      , TSpecial <$> oneOf cfgSpecialCharacters+      , TBraceOpen "" <$> oneOf cfgOpeningBraces+      , TBraceClose <$> oneOf cfgClosingBraces+      ]++    space = oneOf cfgSpaces++    forbidden = join [+        cfgOpeningBraces+      , cfgClosingBraces+      , "\'\"`"+      , cfgSpecialCharacters+      , cfgSpaces+      , cfgControlCharacters+      ]++    something = many1 (noneOf forbidden)++    indent = many1 (try (many space >> (nl <|> comment))) *> (length <$> many space)+      where+        nl = string "\n"+        comment = try (string cfgComments >> many (noneOf "\n") <* char '\n')++    chars' d = inBetween (char d) (many (try (char '\\' >> char d) <|> noneOf (d : "\n")))++    chars d = inBetween (char d) (many (noneOf (d : "\\\n") <|> escape))++    chars3 d = manyBetween (try (string d)) (try (string d)) (noneOf "\\" <|> escape)++    inBetween d p = d *> p <* d++    escape = char '\\' >> choice [+          special <$> oneOf (map fst cfgEscapes)+        , char 'x' >> (convert <$> count 2 hexDigit)+        , char 'u' >> (convert <$> count 4 hexDigit)+        , char 'U' >> (convert <$> count 8 hexDigit)+        ]+      where+        special = fromJust . flip lookup cfgEscapes+        convert str = let [(hex, _)] = readHex str in toEnum hex++    sanitize :: [(SourcePos, Token)] -> Either SomethingBad (Tokens Token)++    sanitize (t1@(p1, v1) : ts@(_t2@(p2, v2) : tss)) = case (v1, v2) of++        (TSomething k, TBraceOpen _ t) -> sanitize ((p1, TBraceOpen k t) : tss)++        (TString _ _ _, TSomething _) -> Left [(p2, "")]+        (TString _ _ _, TBraceOpen _ _) -> Left [(p2, "")]++        (TBraceClose _, TSomething _) -> Left [(p2, "")]+        (TBraceClose _, TString _ _ _) -> Left [(p2, "")]+        (TBraceClose _, TBraceOpen _ _) -> Left [(p2, "")]+        +        (TBraceOpen _ _, TIndent _) -> sanitize (t1 : tss)+        (TBraceOpen _ _, TSpaces) -> sanitize (t1 : tss)+        (TBraceOpen _ _, _) ->+            fmap ([t1, (p2, TIndent (sourceColumn p2 - 1))] ++) (sanitize ts)++        (TSpaces, _) -> sanitize ts+        (TSpecial _, TSpaces) -> sanitize (t1 : tss) +        (TSpecial x1, TSpecial x2) | x1 == x2 && x1 `elem` cfgFoldSpecials -> sanitize ts++        (TIndent _, TBraceOpen _ b) | b `elem` cfgSpecialSemantics -> sanitize ts+        (TIndent _, TBraceClose _) -> sanitize ts+        (TIndent _, TSpecial x) | x `elem` cfgSpecialSemantics -> sanitize ts++        (TSpecial x, TIndent _) | x `elem` cfgSpecialSemantics -> sanitize (t1 : tss)++        _ -> fmap (t1 :) (sanitize ts)++    sanitize [t@(_, v)] = Right $ case v of+        TSpaces -> []+        TIndent _ -> []+        TSpecial x | x `elem` cfgSpecialSemantics -> []+        _ -> [t]++    sanitize [] = Right []
src/Hydrogen/Syntax/Types.hs view
@@ -3,14 +3,15 @@ import Hydrogen.Prelude import Hydrogen.Parsing -type POPs = [(SourcePos, POP)]+type POPs a = [(SourcePos, POP a)] -data POP where-    Token :: TokenType -> [Char] -> [Char] -> POP-    Block :: BlockType -> [Char] -> POPs -> POP-  deriving (Eq, Ord, Show, Typeable, Generic)+data POP a where+    Token :: TokenType -> [Char] -> [Char] -> POP a+    Block :: BlockType -> [Char] -> POPs a -> POP a+    Value :: a -> String -> POP a+  deriving (Eq, Show, Typeable, Generic) -instance Serialize POP+instance Serialize a => Serialize (POP a)  data TokenType where     AposString :: TokenType@@ -30,8 +31,7 @@ instance Serialize BlockType  data Token where-    TComma :: Token-    TSemicolon :: Token+    TSpecial :: Char -> Token     TBraceOpen :: [Char] -> Char -> Token     TBraceClose :: Char -> Token     TSomething :: [Char] -> Token