module Text.Namelist.Parser (namelist) where
import Text.Parsec hiding (letter)
import Data.Complex(Complex((:+)))
import Data.Char (toUpper, toLower, isDigit)
import Data.CaseInsensitive (CI, mk)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$), (<*>), (<*), (*>), pure)
#endif
import Text.Namelist.Types
isLetter :: Char -> Bool
isLetter i
| '\97' <= i && i <= '\122' = True
| '\65' <= i && i <= '\90' = True
| otherwise = False
letter :: Stream s m Char => ParsecT s u m Char
letter = satisfy isLetter <?> "letter"
isAlphaNumeric :: Char -> Bool
isAlphaNumeric a = isLetter a || isDigit a || a == '_'
alphanumericCharacter :: Stream s m Char => ParsecT s u m Char
alphanumericCharacter = satisfy isAlphaNumeric <?> "alphanumeric-character"
name :: Stream s m Char => ParsecT s u m (CI String)
name = do
n <- (:) <$> letter <*> many alphanumericCharacter <?> "name"
if length n > 31
then fail "name too long"
else return $ mk n
sign :: (Stream s m Char, Num a) => ParsecT s u m (a -> a)
sign = (id <$ char '+') <|> (negate <$ char '-') <?> "sign"
fDigit :: Stream s m Char => ParsecT s u m Int
fDigit = () <$> (fromEnum <$> digit) <*> pure 48 <?> "digit"
unsignedInteger :: Stream s m Char => ParsecT s u m Int
unsignedInteger = chainl1 fDigit (pure $ \s d -> 10 * s + d)
integerLiteral :: Stream s m Char => ParsecT s u m Int
integerLiteral = ($) <$> option id sign <*> unsignedInteger <?> "integer"
exponentialPart :: Stream s m Char => ParsecT s u m Int
exponentialPart = oneOf "eEdDqQ" *> integerLiteral
realExpLiteral :: Stream s m Char => ParsecT s u m Double
realExpLiteral = do
s <- option id sign
i <- fromIntegral <$> unsignedInteger
e <- fromIntegral <$> exponentialPart
return $ s (i * 10 ** e)
realDotLiteral :: Stream s m Char => ParsecT s u m Double
realDotLiteral = do
sgn <- option id sign
mbi <- optionMaybe unsignedInteger
_ <- char '.'
(f, e) <- chainl ((,) <$> (fromIntegral <$> fDigit) <*> pure 1)
(pure $ \(s, n) (d, _) -> (10 * s + d, n + 1)) (0 :: Integer,0)
e2 <- option 0 exponentialPart
i <- case mbi of
Nothing | e == 0 -> fail "either decimal and floating part are missing"
| otherwise -> return 0
Just i -> return i
return $ sgn $ fromIntegral (fromIntegral i * 10 ^ e + f) / 10 ** (fromIntegral $ e e2)
realLiteral :: Stream s m Char => ParsecT s u m Double
realLiteral = try realExpLiteral <|> realDotLiteral
tokenize :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
tokenize p = spaces *> p <* spaces
complexLiteral :: Stream s m Char => ParsecT s u m (Complex Double)
complexLiteral = (:+)
<$> (char '(' *> tokenize realLiteral)
<*> (char ',' *> tokenize realLiteral <* char ')')
ciString :: Stream s m Char => String -> ParsecT s u m String
ciString [] = return []
ciString (a:as) = (:) <$> oneOf [toUpper a, toLower a] <*> ciString as
shortLogicalLiteral :: Stream s m Char => ParsecT s u m Bool
shortLogicalLiteral = choice
[ True <$ (char 'T' <|> char 't')
, False <$ (char 'F' <|> char 'f')
] <* lookAhead (satisfy $ not . isAlphaNumeric)
longLogicalLiteral :: Stream s m Char => ParsecT s u m Bool
longLogicalLiteral = char '.' *> choice
[ True <$ ciString "true."
, False <$ ciString "false."
]
logicalLiteral :: Stream s m Char => ParsecT s u m Bool
logicalLiteral = shortLogicalLiteral <|> longLogicalLiteral
stringLiteral :: Stream s m Char => ParsecT s u m String
stringLiteral = sl '\'' <|> sl '"'
where
sl s = char s *> many (body s) <* char s
body s = try (s <$ char s *> char s) <|> noneOf [s]
literal :: Stream s m Char => ParsecT s u m Value
literal = choice
[ try mulValue
, try mulNull
, try $ Real <$> realLiteral
, Integer <$> integerLiteral
, Complex <$> complexLiteral
, try $ Logical <$> logicalLiteral
, String <$> stringLiteral
]
mulNull :: Stream s m Char => ParsecT s u m Value
mulNull = (:* Null) <$> unsignedInteger <* char '*'
mulValue :: Stream s m Char => ParsecT s u m Value
mulValue = (:*) <$> unsignedInteger <*> (char '*' *> literal)
index :: Stream s m Char => ParsecT s u m Index
index = choice
[ try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> s (optionMaybe i)
, try $ Range <$> optionMaybe u <*> s (optionMaybe u) <*> pure Nothing
, try $ Index <$> u
] <?> "index"
where
u = tokenize unsignedInteger
i = tokenize integerLiteral
s = (char ':' *>)
key :: Stream s m Char => ParsecT s u m Key
key = choice
[ try $ Indexed <$> name <*> (char '(' *> sepBy1 index (char ',') <* char ')')
, try $ Sub <$> name <*> (char '%' *> key)
, try $ Key <$> name
] <?> "key"
keyVal :: Stream s m Char => ParsecT s u m Pair
keyVal = do
k <- key
_ <- tokenize $ char '='
v <- tokenize (literal <|> pure Null) `sepEndBy` tokenize (char ',')
return $ k := case reverse v of
[a] -> a
[Null,a] -> a
Null:Null:as -> Array (reverse $ Null:as)
Null:as -> Array (reverse as)
as -> Array (reverse as)
group :: Stream s m Char => ParsecT s u m Group
group = Group <$> tokenize (char '&' *> name) <*> many keyVal <* tokenize (char '/')
namelist :: Stream s m Char => ParsecT s u m [Group]
namelist = many group