-----------------------------------------------------------------------------
-- |
-- Copyright   : (C) 2015 Dimitri Sabadie
-- License     : BSD3
--
-- Maintainer  : Dimitri Sabadie <dimitri.sabadie@gmail.com>
-- Stability   : experimental
-- Portability : portable
--
-----------------------------------------------------------------------------

module Codec.Wavefront.Token where

import Codec.Wavefront.Face
import Codec.Wavefront.Line
import Codec.Wavefront.Location
import Codec.Wavefront.Normal
import Codec.Wavefront.Point
import Codec.Wavefront.TexCoord
import Control.Applicative ( Alternative(..) )
import Data.Attoparsec.Text as AP
import Data.Char ( isSpace )
import Data.Maybe ( catMaybes )
import Data.Text ( Text, unpack, strip )
import qualified Data.Text as T ( empty )
import Numeric.Natural ( Natural )
import Prelude hiding ( lines )

----------------------------------------------------------------------------------------------------
-- Token -------------------------------------------------------------------------------------------

data Token
  = TknV Location
  | TknVN Normal
  | TknVT TexCoord
  | TknP [Point]
  | TknL [Line]
  | TknF Face
  | TknG [Text]
  | TknO Text
  | TknMtlLib [Text]
  | TknUseMtl Text
  | TknS Natural
    deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)

-- |A stream of 'Token'.
type TokenStream = [Token]

tokenize :: Text -> Either String TokenStream
tokenize :: Text -> Either String [Token]
tokenize = ([Maybe Token] -> [Token])
-> Either String [Maybe Token] -> Either String [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Token] -> [Token]
cleanupTokens (Either String [Maybe Token] -> Either String [Token])
-> (Text -> Either String [Maybe Token])
-> Text
-> Either String [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Result [Maybe Token] -> Either String [Maybe Token]
analyseResult Bool
False (Result [Maybe Token] -> Either String [Maybe Token])
-> (Text -> Result [Maybe Token])
-> Text
-> Either String [Maybe Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser [Maybe Token] -> Text -> Result [Maybe Token]
forall a. Parser a -> Text -> Result a
parse (Parser (Maybe Token) -> Parser [Maybe Token]
forall a. Parser a -> Parser [a]
untilEnd Parser (Maybe Token)
tokenizer)
  where
    tokenizer :: Parser (Maybe Token)
tokenizer = [Parser (Maybe Token)] -> Parser (Maybe Token)
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
      [
        (Location -> Maybe Token)
-> Parser Text Location -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> (Location -> Token) -> Location -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Token
TknV) Parser Text Location
location
      , (Normal -> Maybe Token)
-> Parser Text Normal -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> (Normal -> Token) -> Normal -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Normal -> Token
TknVN) Parser Text Normal
normal
      , (TexCoord -> Maybe Token)
-> Parser Text TexCoord -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> (TexCoord -> Token) -> TexCoord -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TexCoord -> Token
TknVT) Parser Text TexCoord
texCoord
      , ([Point] -> Maybe Token)
-> Parser Text [Point] -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> ([Point] -> Token) -> [Point] -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Token
TknP) Parser Text [Point]
points
      , ([Line] -> Maybe Token)
-> Parser Text [Line] -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> ([Line] -> Token) -> [Line] -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> Token
TknL) Parser Text [Line]
lines
      , (Face -> Maybe Token) -> Parser Text Face -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> (Face -> Token) -> Face -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Face -> Token
TknF) Parser Text Face
face
      , ([Text] -> Maybe Token)
-> Parser Text [Text] -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> ([Text] -> Token) -> [Text] -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Token
TknG) Parser Text [Text]
groups
      , (Text -> Maybe Token) -> Parser Text Text -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> (Text -> Token) -> Text -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Token
TknO) Parser Text Text
object
      , ([Text] -> Maybe Token)
-> Parser Text [Text] -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> ([Text] -> Token) -> [Text] -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Token
TknMtlLib) Parser Text [Text]
mtllib
      , (Text -> Maybe Token) -> Parser Text Text -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> (Text -> Token) -> Text -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Token
TknUseMtl) Parser Text Text
usemtl
      , (Natural -> Maybe Token)
-> Parser Text Natural -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token)
-> (Natural -> Token) -> Natural -> Maybe Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Token
TknS) Parser Text Natural
smoothingGroup
      , Maybe Token
forall a. Maybe a
Nothing Maybe Token -> Parser Text () -> Parser (Maybe Token)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text ()
comment
      ]

analyseResult :: Bool -> Result [Maybe Token] -> Either String [Maybe Token]
analyseResult :: Bool -> Result [Maybe Token] -> Either String [Maybe Token]
analyseResult partial :: Bool
partial r :: Result [Maybe Token]
r = case Result [Maybe Token]
r of
  Done _ tkns :: [Maybe Token]
tkns -> [Maybe Token] -> Either String [Maybe Token]
forall a b. b -> Either a b
Right [Maybe Token]
tkns
  Fail i :: Text
i _ e :: String
e -> String -> Either String [Maybe Token]
forall a b. a -> Either a b
Left (String -> Either String [Maybe Token])
-> String -> Either String [Maybe Token]
forall a b. (a -> b) -> a -> b
$ "`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Int -> [a] -> [a]
Prelude.take 10 (Text -> String
unpack Text
i) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "` [...]: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
  Partial p :: Text -> Result [Maybe Token]
p -> if Bool
partial then String -> Either String [Maybe Token]
forall a b. a -> Either a b
Left "not completely tokenized" else Bool -> Result [Maybe Token] -> Either String [Maybe Token]
analyseResult Bool
True (Text -> Result [Maybe Token]
p Text
T.empty)

cleanupTokens :: [Maybe Token] -> TokenStream
cleanupTokens :: [Maybe Token] -> [Token]
cleanupTokens = [Maybe Token] -> [Token]
forall a. [Maybe a] -> [a]
catMaybes

----------------------------------------------------------------------------------------------------
-- Location ----------------------------------------------------------------------------------------

location :: Parser Location
location :: Parser Text Location
location = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "v " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text Location -> Parser Text Location
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Location
parseXYZW Parser Text Location -> Parser Text () -> Parser Text Location
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol
  where
    parseXYZW :: Parser Text Location
parseXYZW = do
      [Float]
xyz <- Parser Float
float Parser Float -> Parser Text () -> Parser Text [Float]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace
      case [Float]
xyz of
        [x :: Float
x,y :: Float
y,z :: Float
z] -> Location -> Parser Text Location
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Location
Location Float
x Float
y Float
z 1)
        [x :: Float
x,y :: Float
y,z :: Float
z,w :: Float
w] -> Location -> Parser Text Location
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Location
Location Float
x Float
y Float
z Float
w)
        _ -> String -> Parser Text Location
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "wrong number of x, y and z arguments for location"

----------------------------------------------------------------------------------------------------
-- Normal ------------------------------------------------------------------------------------------

normal :: Parser Normal
normal :: Parser Text Normal
normal = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "vn " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text Normal -> Parser Text Normal
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Normal
parseIJK Parser Text Normal -> Parser Text () -> Parser Text Normal
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol
  where
    parseIJK :: Parser Text Normal
parseIJK = do
      [Float]
ijk <- Parser Float
float Parser Float -> Parser Text () -> Parser Text [Float]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace
      case [Float]
ijk of
        [i :: Float
i,j :: Float
j,k :: Float
k] -> Normal -> Parser Text Normal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Normal
Normal Float
i Float
j Float
k)
        _ -> String -> Parser Text Normal
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "wrong number of i, j and k arguments for normal"

----------------------------------------------------------------------------------------------------
-- Texture coordinates -----------------------------------------------------------------------------

texCoord :: Parser TexCoord
texCoord :: Parser Text TexCoord
texCoord = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "vt " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text TexCoord -> Parser Text TexCoord
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text TexCoord
parseUVW Parser Text TexCoord -> Parser Text () -> Parser Text TexCoord
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol
  where
    parseUVW :: Parser Text TexCoord
parseUVW = do
      [Float]
uvw <- Parser Float
float Parser Float -> Parser Text () -> Parser Text [Float]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace
      case [Float]
uvw of
        [u :: Float
u,v :: Float
v] -> TexCoord -> Parser Text TexCoord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> TexCoord
TexCoord Float
u Float
v 0)
        [u :: Float
u,v :: Float
v,w :: Float
w] -> TexCoord -> Parser Text TexCoord
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> TexCoord
TexCoord Float
u Float
v Float
w)
        _ -> String -> Parser Text TexCoord
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "wrong number of u, v and w arguments for texture coordinates"

----------------------------------------------------------------------------------------------------
-- Points ------------------------------------------------------------------------------------------

points :: Parser [Point]
points :: Parser Text [Point]
points = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "p " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text [Point] -> Parser Text [Point]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> Point) -> Parser Text Int -> Parser Text Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Point
Point Parser Text Int
forall a. Integral a => Parser a
decimal Parser Text Point -> Parser Text () -> Parser Text [Point]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace Parser Text [Point] -> Parser Text () -> Parser Text [Point]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol

----------------------------------------------------------------------------------------------------
-- Lines -------------------------------------------------------------------------------------------
lines :: Parser [Line]
lines :: Parser Text [Line]
lines = do
    Parser Text ()
skipSpace
    Text
_ <- Text -> Parser Text Text
string "l "
    Parser Text ()
skipHSpace
    [LineIndex]
pointIndices <- Parser Text [LineIndex]
parsePointIndices
    [Line]
pts <- case [LineIndex]
pointIndices of
      _:_:_ -> [Line] -> Parser Text [Line]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Line] -> Parser Text [Line]) -> [Line] -> Parser Text [Line]
forall a b. (a -> b) -> a -> b
$ (LineIndex -> LineIndex -> Line)
-> [LineIndex] -> [LineIndex] -> [Line]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LineIndex -> LineIndex -> Line
Line [LineIndex]
pointIndices ([LineIndex] -> [LineIndex]
forall a. [a] -> [a]
tail [LineIndex]
pointIndices)
      _ -> String -> Parser Text [Line]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "line doesn't have at least two points"
    Parser Text ()
eol
    [Line] -> Parser Text [Line]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Line]
pts
  where
    parsePointIndices :: Parser Text [LineIndex]
parsePointIndices = ((Int, Maybe Int) -> LineIndex)
-> Parser Text (Int, Maybe Int) -> Parser Text LineIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(i :: Int
i,j :: Maybe Int
j) -> Int -> Maybe Int -> LineIndex
LineIndex Int
i Maybe Int
j) Parser Text (Int, Maybe Int)
parseLinePair Parser Text LineIndex -> Parser Text () -> Parser Text [LineIndex]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace
    parseLinePair :: Parser Text (Int, Maybe Int)
parseLinePair = do
      Int
v <- Parser Text Int
forall a. Integral a => Parser a
decimal
      Parser Text (Int, Maybe Int)
-> Parser Text (Int, Maybe Int) -> Parser Text (Int, Maybe Int)
forall a. Parser a -> Parser a -> Parser a
slashThenElse ((Int -> (Int, Maybe Int))
-> Parser Text Int -> Parser Text (Int, Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\vt :: Int
vt -> (Int
v, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
vt)) Parser Text Int
forall a. Integral a => Parser a
decimal) ((Int, Maybe Int) -> Parser Text (Int, Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
v,Maybe Int
forall a. Maybe a
Nothing))

----------------------------------------------------------------------------------------------------
-- Faces -------------------------------------------------------------------------------------------
face :: Parser Face
face :: Parser Text Face
face = do
    Parser Text ()
skipSpace
    Text
_ <- Text -> Parser Text Text
string "f "
    Parser Text ()
skipHSpace
    [FaceIndex]
faceIndices <- Parser Text [FaceIndex]
parseFaceIndices
    Face
f <- case [FaceIndex]
faceIndices of
      a :: FaceIndex
a:b :: FaceIndex
b:c :: FaceIndex
c:s :: [FaceIndex]
s -> Face -> Parser Text Face
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FaceIndex -> FaceIndex -> FaceIndex -> [FaceIndex] -> Face
Face FaceIndex
a FaceIndex
b FaceIndex
c [FaceIndex]
s)
      _ -> String -> Parser Text Face
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "face doesn't have at least three points"
    Parser Text ()
eol
    Face -> Parser Text Face
forall (f :: * -> *) a. Applicative f => a -> f a
pure Face
f
  where
    parseFaceIndices :: Parser Text [FaceIndex]
parseFaceIndices = ((Int, Maybe Int, Maybe Int) -> FaceIndex)
-> Parser Text (Int, Maybe Int, Maybe Int) -> Parser Text FaceIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(i :: Int
i,k :: Maybe Int
k,j :: Maybe Int
j) -> Int -> Maybe Int -> Maybe Int -> FaceIndex
FaceIndex Int
i Maybe Int
k Maybe Int
j) Parser Text (Int, Maybe Int, Maybe Int)
parseFaceTriple Parser Text FaceIndex -> Parser Text () -> Parser Text [FaceIndex]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace
    parseFaceTriple :: Parser Text (Int, Maybe Int, Maybe Int)
parseFaceTriple = do
      Int
v <- Parser Text Int
forall a. Integral a => Parser a
decimal
      Parser Text (Int, Maybe Int, Maybe Int)
-> Parser Text (Int, Maybe Int, Maybe Int)
-> Parser Text (Int, Maybe Int, Maybe Int)
forall a. Parser a -> Parser a -> Parser a
slashThenElse (Int -> Parser Text (Int, Maybe Int, Maybe Int)
forall a a a.
(Integral a, Integral a) =>
a -> Parser (a, Maybe a, Maybe a)
parseVT Int
v) ((Int, Maybe Int, Maybe Int)
-> Parser Text (Int, Maybe Int, Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
v,Maybe Int
forall a. Maybe a
Nothing,Maybe Int
forall a. Maybe a
Nothing))
    parseVT :: a -> Parser (a, Maybe a, Maybe a)
parseVT v :: a
v = Parser (a, Maybe a, Maybe a)
-> Parser (a, Maybe a, Maybe a) -> Parser (a, Maybe a, Maybe a)
forall a. Parser a -> Parser a -> Parser a
slashThenElse (a -> Maybe a -> Parser (a, Maybe a, Maybe a)
forall a a b. Integral a => a -> b -> Parser Text (a, b, Maybe a)
parseVN a
v Maybe a
forall a. Maybe a
Nothing) (Parser (a, Maybe a, Maybe a) -> Parser (a, Maybe a, Maybe a))
-> Parser (a, Maybe a, Maybe a) -> Parser (a, Maybe a, Maybe a)
forall a b. (a -> b) -> a -> b
$ do
      a
vt <- Parser a
forall a. Integral a => Parser a
decimal
      Parser (a, Maybe a, Maybe a)
-> Parser (a, Maybe a, Maybe a) -> Parser (a, Maybe a, Maybe a)
forall a. Parser a -> Parser a -> Parser a
slashThenElse (a -> Maybe a -> Parser (a, Maybe a, Maybe a)
forall a a b. Integral a => a -> b -> Parser Text (a, b, Maybe a)
parseVN a
v (Maybe a -> Parser (a, Maybe a, Maybe a))
-> Maybe a -> Parser (a, Maybe a, Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
vt) ((a, Maybe a, Maybe a) -> Parser (a, Maybe a, Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v,a -> Maybe a
forall a. a -> Maybe a
Just a
vt,Maybe a
forall a. Maybe a
Nothing))
    parseVN :: a -> b -> Parser Text (a, b, Maybe a)
parseVN v :: a
v vt :: b
vt = do
      a
vn <- Parser a
forall a. Integral a => Parser a
decimal
      (a, b, Maybe a) -> Parser Text (a, b, Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v,b
vt,a -> Maybe a
forall a. a -> Maybe a
Just a
vn)

----------------------------------------------------------------------------------------------------
-- Groups ------------------------------------------------------------------------------------------

groups :: Parser [Text]
groups :: Parser Text [Text]
groups = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "g " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text [Text] -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Text
name Parser Text Text -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser Text ()
skipHSpace Parser Text [Text] -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol

----------------------------------------------------------------------------------------------------
-- Objects -----------------------------------------------------------------------------------------

object :: Parser Text
object :: Parser Text Text
object = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "o " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Text
spacedName Parser Text Text -> Parser Text () -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol

----------------------------------------------------------------------------------------------------
-- Material libraries ------------------------------------------------------------------------------

mtllib :: Parser [Text]
mtllib :: Parser Text [Text]
mtllib = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "mtllib " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text [Text] -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Text
name Parser Text Text -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser Text ()
skipHSpace Parser Text [Text] -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol

----------------------------------------------------------------------------------------------------
-- Using materials ---------------------------------------------------------------------------------

usemtl :: Parser Text
usemtl :: Parser Text Text
usemtl = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "usemtl " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Text
spacedName Parser Text Text -> Parser Text () -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol

----------------------------------------------------------------------------------------------------
-- Smoothing groups --------------------------------------------------------------------------------
smoothingGroup :: Parser Natural
smoothingGroup :: Parser Text Natural
smoothingGroup = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "s " Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipHSpace Parser Text () -> Parser Text Natural -> Parser Text Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Natural
offOrIndex Parser Text Natural -> Parser Text () -> Parser Text Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
skipHSpace Parser Text Natural -> Parser Text () -> Parser Text Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
eol
  where
    offOrIndex :: Parser Text Natural
offOrIndex = Text -> Parser Text Text
string "off" Parser Text Text -> Parser Text Natural -> Parser Text Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Natural -> Parser Text Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0 Parser Text Natural -> Parser Text Natural -> Parser Text Natural
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Natural
forall a. Integral a => Parser a
decimal

----------------------------------------------------------------------------------------------------
-- Comments ----------------------------------------------------------------------------------------
comment :: Parser ()
comment :: Parser Text ()
comment = Parser Text ()
skipSpace Parser Text () -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
string "#" Parser Text Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (() () -> Parser Text String -> Parser Text ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser Text Char -> Parser Text () -> Parser Text String
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Text Char
anyChar Parser Text ()
eol)

----------------------------------------------------------------------------------------------------
-- Special parsers ---------------------------------------------------------------------------------

-- Read a slash ('/') and run the @thenP@ parser on success. Otherwise, call the @elseP@ parser.
slashThenElse :: Parser a -> Parser a -> Parser a
slashThenElse :: Parser a -> Parser a -> Parser a
slashThenElse thenP :: Parser a
thenP elseP :: Parser a
elseP = do
  Maybe Char
c <- Parser (Maybe Char)
peekChar
  case Maybe Char
c of
    Just '/' -> Int -> Parser Text Text
AP.take 1 Parser Text Text -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
thenP
    _ -> Parser a
elseP

-- End of line.
eol :: Parser ()
eol :: Parser Text ()
eol = Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany ((Char -> Bool) -> Parser Text Char
satisfy Char -> Bool
isHorizontalSpace) Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Text ()
endOfLine Parser Text () -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput)

-- Parse a name (any character but space).
name :: Parser Text
name :: Parser Text Text
name = (Char -> Bool) -> Parser Text Text
takeWhile1 ((Char -> Bool) -> Parser Text Text)
-> (Char -> Bool) -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace

spacedName :: Parser Text
spacedName :: Parser Text Text
spacedName = Text -> Text
strip (Text -> Text) -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
AP.takeWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem ("\n\r" :: String))

skipHSpace :: Parser ()
skipHSpace :: Parser Text ()
skipHSpace = () () -> Parser Text Text -> Parser Text ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Text Text
AP.takeWhile Char -> Bool
isHorizontalSpace

float :: Parser Float
float :: Parser Float
float = (Double -> Float) -> Parser Text Double -> Parser Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Parser Text Double
double

-- Loop a parser and collect its values until we hit the end of the stream. Fails on the first
-- failure.
untilEnd :: Parser a -> Parser [a]
untilEnd :: Parser a -> Parser [a]
untilEnd p :: Parser a
p = Parser [a]
go
  where
    go :: Parser [a]
go = do
      a
a <- Parser a
p
      Bool
end <- Parser Text Bool
forall t. Chunk t => Parser t Bool
atEnd
      if Bool
end then [a] -> Parser [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
a] else ([a] -> [a]) -> Parser [a] -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) Parser [a]
go