{-# LANGUAGE OverloadedStrings, BangPatterns #-} module PLY.Internal.Parsers where import Control.Applicative import Data.Attoparsec.ByteString.Char8 hiding (char) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC import PLY.Types -- |Skip white space, comments, and obj_info lines. skip :: Parser () skip = skipSpace *> ((ignore *> line *> skip) <|> pure ()) where ignore = string "comment " <|> string "obj_info " -- |Parse a PLY file format line format :: Parser Format format = "format" *> skipSpace *> (ascii <|> le <|> be) where ascii = "ascii 1.0" *> pure ASCII le = "binary_little_endian 1.0" *> pure Binary_LE be = "binary_big_endian 1.0" *> pure Binary_BE -- * Numeric type parsers char :: Parser Int8 char = signed decimal uchar :: Parser Word8 uchar = decimal int :: Parser Int int = signed decimal uint :: Parser Word32 uint = decimal int16 :: Parser Int16 int16 = signed decimal uint16 :: Parser Word16 uint16 = decimal float :: Parser Float float = realToFrac <$> double -- | Take everything up to the end of the line line :: Parser ByteString line = BC.pack <$> manyTill anyChar endOfLine scalarProperty :: Parser Property scalarProperty = ScalarProperty <$> ("property " *> scalarType) <*> line scalarType :: Parser ScalarT scalarType = choice $ [ ("char " <|> "int8 ") *> pure Tchar , ("uchar " <|> "uint8 ") *> pure Tuchar , ("short " <|> "int16 ") *> pure Tshort , ("ushort " <|> "uint16 ") *> pure Tushort , ("int " <|> "int32 ") *> pure Tint , ("uint " <|> "uint32 ") *> pure Tuint , ("float " <|> "float32 ") *> pure Tfloat , ("double " <|> "float64 ") *> pure Tdouble ] -- |Take the next white space-delimited word. word :: Parser ByteString word = skipSpace *> takeTill isSpace <* skipSpace listProperty :: Parser Property listProperty = ListProperty <$> ("property list " *> word *> scalarType) <*> line -- |Parse a monotyped list of values. All returned 'Scalar' values -- will be of the type corresponding to the specific 'ScalarT' given. parseList :: ScalarT -> Parser [Scalar] parseList t = int >>= flip count (parseScalar t) property :: Parser Property property = skip *> (scalarProperty <|> listProperty) element :: Parser Element element = Element <$> ("element " *> takeTill isSpace) <*> (skipSpace *> int <* skipSpace) <*> many1 property parseScalar :: ScalarT -> Parser Scalar parseScalar Tchar = Schar <$> char parseScalar Tuchar = Suchar <$> uchar parseScalar Tshort = Sshort <$> int16 parseScalar Tushort = Sushort <$> uint16 parseScalar Tint = Sint <$> int parseScalar Tuint = Suint <$> uint parseScalar Tfloat = Sfloat <$> float parseScalar Tdouble = Sdouble <$> double -- |Parse a flat property list multiProps :: [Property] -> Parser [Scalar] multiProps = go [] where go acc [] = pure (reverse acc) go acc (ScalarProperty t _:ps) = do !x <- parseScalar t skipSpace go (x:acc) ps go _ (ListProperty t _:_) = int <* skipSpace >>= flip count (parseScalar t <* skipSpace) -- FIXME: Support for list properties assumes that an element will not -- have any other properties if it has a list property! -- |Parse a PLY header. header :: Parser (Format, [Element]) header = (,) <$> preamble <*> elements <* "end_header" <* endOfLine where preamble = "ply" *> skip *> format elements = many1 (skip *> element <* skipSpace) -- |Advance a 'ByteString' to where a given 'Parser' finishes. An -- 'error' is raised if the parser fails to complete. parseSkip :: Parser a -> ByteString -> ByteString parseSkip = (aux .) . parse where aux (Fail _ _ msg) = error $ "parseSkip failed: "++msg aux (Partial _) = error $ "Incomplete data" aux (Done t _) = t