Started nice generic module (with temporary name)
Getty Ritter
10 years ago
| 1 | {-# LANGUAGE OverloadedStrings #-} | |
| 2 | ||
| 3 | module Data.SCargot.Foo where | |
| 4 | ||
| 5 | import Control.Applicative hiding ((<|>), many) | |
| 6 | import Data.Char | |
| 7 | import Data.Monoid ((<>)) | |
| 8 | import Data.Text (Text, concatMap, pack, singleton) | |
| 9 | import Numeric (readDec, readFloat, readHex, readSigned) | |
| 10 | import Text.Parsec | |
| 11 | import Text.Parsec.Text | |
| 12 | import Text.Parsec.Token (float, integer, stringLiteral) | |
| 13 | import Text.Parsec.Language (haskell) | |
| 14 | ||
| 15 | import Prelude hiding (concatMap) | |
| 16 | ||
| 17 | import Data.SCargot.Repr.Basic (SExpr) | |
| 18 | import Data.SCargot.General | |
| 19 | ||
| 20 | ||
| 21 | ||
| 22 | data Atom | |
| 23 | = AToken Text | |
| 24 | | AString Text | |
| 25 | | AInt Integer | |
| 26 | | AFloat Double | |
| 27 | deriving (Eq, Show) | |
| 28 | ||
| 29 | atomChar :: Parser Char | |
| 30 | atomChar = satisfy go | |
| 31 | where go c = isAlphaNum c | |
| 32 | || c == '-' || c == '*' || c == '/' | |
| 33 | || c == '+' || c == '<' || c == '>' | |
| 34 | || c == '=' || c == '!' || c == '?' | |
| 35 | ||
| 36 | pToken :: Parser Text | |
| 37 | pToken = pack <$> ((:) <$> letter <*> many atomChar) | |
| 38 | ||
| 39 | pString :: Parser Text | |
| 40 | pString = pack <$> between (char '"') (char '"') (many (val <|> esc)) | |
| 41 | where val = Just <$> satisfy (\ c -> c /= '"' && c /= '\\' && c > '\026') | |
| 42 | esc = do char '\\' | |
| 43 | Nothing <$ (gap <|> char '&') <|> | |
| 44 | Just <$> cod | |
| 45 | gap = many1 space >> char '\\' | |
| 46 | cod = undefined | |
| 47 | ||
| 48 | pFloat :: Parser Double | |
| 49 | pFloat = undefined | |
| 50 | ||
| 51 | pInt :: Parser Integer | |
| 52 | pInt = do | |
| 53 | s <- (negate <$ char '-' <|> id <$ char '+' <|> pure id) | |
| 54 | n <- read <$> many1 digit | |
| 55 | return (s n) | |
| 56 | ||
| 57 | pAtom :: Parser Atom | |
| 58 | pAtom = AInt <$> pInt | |
| 59 | <|> AFloat <$> pFloat | |
| 60 | <|> AToken <$> pToken | |
| 61 | <|> AString <$> pString | |
| 62 | ||
| 63 | escape :: Char -> Text | |
| 64 | escape '\n' = "\\n" | |
| 65 | escape '\t' = "\\t" | |
| 66 | escape '\r' = "\\r" | |
| 67 | escape '\b' = "\\b" | |
| 68 | escape '\f' = "\\f" | |
| 69 | escape '\\' = "\\\\" | |
| 70 | escape '"' = "\\\"" | |
| 71 | escape c = singleton c | |
| 72 | ||
| 73 | sAtom :: Atom -> Text | |
| 74 | sAtom (AToken t) = t | |
| 75 | sAtom (AString s) = "\"" <> concatMap escape s <> "\"" | |
| 76 | sAtom (AInt i) = pack (show i) | |
| 77 | sAtom (AFloat f) = pack (show f) | |
| 78 | ||
| 79 | fooSpec :: SExprSpec Atom (SExpr Atom) | |
| 80 | fooSpec = mkSpec pAtom sAtom |