packages feed

hydrogen-parsing (empty) → 0.10

raw patch · 7 files changed

+378/−0 lines, 7 filesdep +basedep +containersdep +hydrogen-preludesetup-changed

Dependencies added: base, containers, hydrogen-prelude, parsec

Files

+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 Julian Fleischer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hydrogen-parsing.cabal view
@@ -0,0 +1,39 @@+name:                 hydrogen-parsing+version:              0.10+homepage:             https://scravy.de/hydrogen-parsing/+synopsis:             Hydrogen Parsing Utilities+license:              MIT+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-parsing++library+  exposed-modules:    Hydrogen.Parsing+                      , Hydrogen.Parsing.Char+  build-depends:      base ==4.7.*+                      , containers ==0.5.*+                      , hydrogen-prelude ==0.10+                      , parsec ==3.1.*+  hs-source-dirs:     src+  ghc-options:        -Wall+  default-language:   Haskell2010+  default-extensions:  CPP+                       , DeriveDataTypeable+                       , DeriveGeneric+                       , EmptyCase+                       , FlexibleContexts+                       , GADTs+                       , LambdaCase+                       , MultiWayIf+                       , NoImplicitPrelude+                       , RecordWildCards+                       , ScopedTypeVariables+                       , StandaloneDeriving
+ src/Hydrogen/Parsing.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}++module Hydrogen.Parsing (+    module Text.Parsec.Combinator+  , module Text.Parsec.Prim+  , module Text.Parsec.Pos+  , Parser+  , ParseError+  , SomethingBad+  , Tokens+  , runTokenParser+  , mkError+  , sourceToken+  , manyBetween+  , (>+>)+  , (<+<)+  , sya+  , ignoreUnderscores+  , tryRead+  , tryReads+  , tryReadDecimal+  , tryReadRational+  , tryReadHex+  , tryReadUUID+  , tryReadVersion+  , tryReadDateTime+  , tryReadDate+  , tryReadTime+  , tryReadBool+  ) where++import Hydrogen.Prelude++import Text.Parsec.Combinator+import Text.Parsec.Error+import Text.Parsec.Pos+import Text.Parsec.Prim+++-- | Infix to postfix notation (an implementation of the Shunting-Yard-Algorithm)+sya :: (Ord p, Eq o)+    => (a -> Maybe o)   -- ^ Determine operator+    -> (o -> Bool)      -- ^ Is left precedence?+    -> (o -> p)         -- ^ Precedence of given operator+    -> [a]              -- ^ The input stream (infix notation)+    -> [a]              -- ^ The output stream (postfix notation)+sya mkOp isL p = sy []+  where+    sy (t : ts) (x : xs)+        | isOp x && isOp t && cmp t x = t : sy ts (x : xs)++    sy ts (x : xs)+        | isOp x    = sy (x : ts) xs+        | otherwise = x : sy ts xs++    sy ts [] = ts++    isOp = isJust . mkOp++    cmp o1 o2 = isL o1' && p o1' == p o2' || p o1' > p o2'+      where+        Just o1' = mkOp o1+        Just o2' = mkOp o2++++tryRead :: (Monad m) => ReadS a -> String -> m a+tryRead p s = case p s of+    [(val, "")] -> return val+    [] -> fail "no parse"+    _ -> fail "ambiguous parse"++tryReads :: (Monad m, Read a) => String -> m a+tryReads = tryRead reads+++ignoreUnderscores :: String -> String+ignoreUnderscores = \case+    x : xs -> x : ignore xs+    xs -> xs+  where+    ignore = \case+        xs@(x : '_' : _) | not (isAlphaNum x) -> xs+        '_' : x : xs | isAlphaNum x -> x : ignore xs+        x : xs -> x : ignore xs+        xs -> xs++tryReadDecimal :: String -> Maybe Rational+tryReadDecimal = \case+    ('-' : xs) -> negate <$> readRational xs+    ('+' : xs) -> readRational xs+    ('.' : xs) -> readRational ("0." ++ xs)+    xs -> readRational xs+  where+    readRational = tryRead readFloat . ignoreUnderscores++tryReadRational :: String -> Maybe Rational+tryReadRational xs = case right of+    (_ : right') -> liftM2 (%) numer denom+      where+        numer = tryRead reads left+        denom = tryRead reads right'++    _ -> Nothing+  where+    (left, right) = span (/= '/') (ignoreUnderscores xs)++tryReadHex :: String -> Maybe Rational+tryReadHex = tryRead readHex . ignoreUnderscores . hex+  where+    hex = \case+      '0' : 'x' : xs -> xs+      _ -> ""++tryReadUUID :: String -> Maybe UUID+tryReadUUID = tryRead reads++tryReadVersion :: String -> Maybe Version+tryReadVersion = \case+    ('v' : xs) -> tryRead reads xs+    _ -> fail "no version"++tryReadDateTime :: String -> Maybe (Maybe ZonedTime)+tryReadDateTime xs = case xs =~ dateTime of++    [[_, y, m, d, h, min, _, s, s', z, zm, _, zs]]+        -> Just (liftM2 ZonedTime (liftM2 LocalTime date time) zone)+      where+        (year, month, day, hour, minute) = (read y, read m, read d, read h, read min)+        sec = read ((if null s then "0" else s) ++ (if null s' then ".0" else s'))++        time = makeTimeOfDayValid hour minute sec+        date = fromGregorianValid year month day++        zone = Just $ case z of+            "Z" -> utc+            ('-' : _) -> minutesToTimeZone (negate zn)+            _ -> minutesToTimeZone zn+          where+            zn = read zm * 60 + (if zs == "" then 0 else read zs)++    _ -> Nothing++  where+    date = "([0-9]{4})-?([0-9]{2})-?([0-9]{2})"+    time = "([0-9]{2}):?([0-9]{2})(:?([0-9]{2})(\\.[0-9]{1,12})?)?"+    timeZone = "(Z|[+-]([0-9]{1,2})(:?([0-9]{2}))?)"+    dateTime = concat ["^", date, "T?", time, timeZone, "$"]++tryReadDate :: String -> Maybe (Maybe Day)+tryReadDate xs = case xs =~ date of+    [[_, y, _, m, d, ""]] -> Just (fromGregorianValid year month day)+      where+        (year, month, day) = (read y, read m, read d)++    [[_, y, _, _, _, d]] -> Just (fromOrdinalDateValid year day)+      where+        (year, day) = (read y, read d)++    _ -> Nothing+  where+    date = "^([0-9]{4})-(([0-9]{2})-([0-9]{2})|([0-9]{3}))$"++tryReadTime :: String -> Maybe (Maybe TimeOfDay)+tryReadTime xs = case xs =~ time of+    [[_, h, m, _, s]] -> Just (makeTimeOfDayValid hour min sec)+      where+        (hour, min, sec) = (read h, read m, if null s then 0 else read s)++    _ -> Nothing+  where+    time = "^([0-9]{2}):([0-9]{2})(:([0-9]{2}))?$"++tryReadBool :: String -> Maybe Bool+tryReadBool = \case+    "true" -> return True+    "TRUE" -> return True+    "True" -> return True+    "false" -> return False+    "False" -> return False+    "FALSE" -> return False+    _ -> Nothing+++instance Serialize SourcePos where++    put pos = do+        let line = sourceLine pos+            col  = sourceColumn pos+            name = sourceName pos+        putWord32be (fromIntegral line)+        putWord32be (fromIntegral col)+        put name++    get = do+        line <- fromIntegral <$> getWord32be+        col  <- fromIntegral <$> getWord32be+        name <- get+        return (newPos name line col)++type SomethingBad = (SourcePos, [String])+type Parser source result = source -> Either SomethingBad result+type Tokens t = [(SourcePos, t)]++mkError :: ParseError -> Either SomethingBad b+mkError e = Left (errorPos e, map messageString (errorMessages e))++runTokenParser :: (Stream a Identity t) => ParsecT a () Identity b -> Parser a b+runTokenParser p = either mkError Right . runIdentity . runParserT p () ""++sourceToken :: (Show t, Stream (Tokens t) m (SourcePos, t))+    => (t -> Maybe a)+    -> ParsecT [(SourcePos, t)] u m a+sourceToken f = tokenPrim (show . snd) nextPos (f . snd)+  where+    nextPos p _ = \case+        ((p', _) : _) -> p'+        _ -> p++manyBetween :: (Monad m, Stream s m t)+    => ParsecT s u m open -> ParsecT s u m close -> ParsecT s u m p -> ParsecT s u m [p]+manyBetween o c p = o *> manyTill p c++(>+>) :: Parser a b -> Parser b c -> Parser a c+p1 >+> p2 = join <$> fmap p2 <$> p1++(<+<) :: Parser b c -> Parser a b -> Parser a c+(<+<) = flip (>+>)++
+ src/Hydrogen/Parsing/Char.hs view
@@ -0,0 +1,88 @@+module Hydrogen.Parsing.Char (+    module Hydrogen.Parsing+  , oneOf+  , noneOf+  , spaces+  , space+  , newline+  , tab+  , upper+  , lower+  , alphaNum+  , letter+  , digit+  , hexDigit+  , char+  , anyChar+  , satisfy+  , string+  , number+  , positiveNumber+  , negativeNumber+  , decimal+  , name+  , name_+  , keyword+  , keyword_+  , between'+  ) where++import Hydrogen.Prelude hiding ((<|>), many, optional)+import Hydrogen.Parsing++import Text.Parsec.Char hiding (newline)++-- | @[a-z][a-z0-9]*@+name :: (Monad m, Stream s m Char) => ParsecT s u m String+name = liftA2 (:) letter (many alphaNum)++-- | @[a-z_][a-z0-9_]*@+name_ :: (Monad m, Stream s m Char) => ParsecT s u m String+name_ = liftA2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))++-- | @keyword w@ parses the string @w@ which must not be followed by any alpha numeric character,+-- i.e. @keyword "as"@ parses "as" but not "ass".+keyword :: (Monad m, Stream s m Char) => String -> ParsecT s u m String+keyword w = string w <* notFollowedBy alphaNum++keyword_ :: (Monad m, Stream s m Char) => String -> ParsecT s u m ()+keyword_ w = const () <$> (string w <* notFollowedBy alphaNum)++between' :: (Monad m, Stream s m Char) => Char -> Char -> ParsecT s u m t -> ParsecT s u m t+between' a b = between (char a) (char b)++number, positiveNumber, negativeNumber+    :: (Monad m, Stream s m Char, Read a, Num a, Integral a) => ParsecT s u m a++-- | Parses a negative or a positive number (indicated by an unary minus operator, does not accept an unary plus).+number = negativeNumber <|> positiveNumber++-- | Parses a positive integral number.+positiveNumber = (read <$> many1 digit)++-- | Parses a negative integral number (indicated by an unary minus operator).+negativeNumber = negate . read <$> (char '-' >> many1 digit)++decimal, positiveDecimal, negativeDecimal+    :: (Monad m, Stream s m Char, Read a, Num a, RealFrac a) => ParsecT s u m a++-- | Parses a decimal number+decimal = negativeDecimal <|> positiveDecimal++-- | Parses a positive decimal number+positiveDecimal = fst . head . readFloat <$> liftM2 (++) (many1 digit) (option "" (exp_ <|> digits))+  where+    digits = liftA2 (:) (char '.') (many1 digit)+    exp_ = concat <$> sequence [return <$> char 'e', option "" (string "-"), many1 digit]++-- | Parses a negative decimal number+negativeDecimal = negate <$> (char '-' >> positiveDecimal)++-- | Parses end of line, which maybe ('\n' or '\r' or "\r\n").+--+-- Returns the newline character, '\r' in case of "\r\n".+newline :: (Monad m, Stream s m Char) => ParsecT s u m Char+newline = char '\n' <|> (char '\r' <* optional (char '\n'))+++