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 )
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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> [Char]
$cshow :: Token -> [Char]
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)
type TokenStream = [Token]
tokenize :: Text -> Either String TokenStream
tokenize :: Text -> Either [Char] [Token]
tokenize = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe Token] -> [Token]
cleanupTokens forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Result [Maybe Token] -> Either [Char] [Maybe Token]
analyseResult Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Result a
parse (forall a. Parser a -> Parser [a]
untilEnd Parser Text (Maybe Token)
tokenizer)
where
tokenizer :: Parser Text (Maybe Token)
tokenizer = forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
[
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Token
TknV) Parser Location
location
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Normal -> Token
TknVN) Parser Normal
normal
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. TexCoord -> Token
TknVT) Parser TexCoord
texCoord
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Token
TknP) Parser [Point]
points
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Line] -> Token
TknL) Parser [Line]
lines
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Face -> Token
TknF) Parser Face
face
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Token
TknG) Parser [Text]
groups
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Token
TknO) Parser Text
object
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Token
TknMtlLib) Parser [Text]
mtllib
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Token
TknUseMtl) Parser Text
usemtl
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Token
TknS) Parser Natural
smoothingGroup
, forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
comment
]
analyseResult :: Bool -> Result [Maybe Token] -> Either String [Maybe Token]
analyseResult :: Bool -> Result [Maybe Token] -> Either [Char] [Maybe Token]
analyseResult Bool
partial Result [Maybe Token]
r = case Result [Maybe Token]
r of
Done Text
_ [Maybe Token]
tkns -> forall a b. b -> Either a b
Right [Maybe Token]
tkns
Fail Text
i [[Char]]
_ [Char]
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"`" forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
Prelude.take Int
10 (Text -> [Char]
unpack Text
i) forall a. [a] -> [a] -> [a]
++ [Char]
"` [...]: " forall a. [a] -> [a] -> [a]
++ [Char]
e
Partial Text -> Result [Maybe Token]
p -> if Bool
partial then forall a b. a -> Either a b
Left [Char]
"not completely tokenized" else Bool -> Result [Maybe Token] -> Either [Char] [Maybe Token]
analyseResult Bool
True (Text -> Result [Maybe Token]
p Text
T.empty)
cleanupTokens :: [Maybe Token] -> TokenStream
cleanupTokens :: [Maybe Token] -> [Token]
cleanupTokens = forall a. [Maybe a] -> [a]
catMaybes
location :: Parser Location
location :: Parser Location
location = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"v " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Location
parseXYZW forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
where
parseXYZW :: Parser Location
parseXYZW = do
[Float]
xyz <- Parser Float
float forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace
case [Float]
xyz of
[Float
x,Float
y,Float
z] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Location
Location Float
x Float
y Float
z Float
1)
[Float
x,Float
y,Float
z,Float
w] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Float -> Location
Location Float
x Float
y Float
z Float
w)
[Float]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"wrong number of x, y and z arguments for location"
normal :: Parser Normal
normal :: Parser Normal
normal = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"vn " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Normal
parseIJK forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
where
parseIJK :: Parser Normal
parseIJK = do
[Float]
ijk <- Parser Float
float forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace
case [Float]
ijk of
[Float
i,Float
j,Float
k] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> Normal
Normal Float
i Float
j Float
k)
[Float]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"wrong number of i, j and k arguments for normal"
texCoord :: Parser TexCoord
texCoord :: Parser TexCoord
texCoord = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"vt " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser TexCoord
parseUVW forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
where
parseUVW :: Parser TexCoord
parseUVW = do
[Float]
uvw <- Parser Float
float forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace
case [Float]
uvw of
[Float
u,Float
v] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> TexCoord
TexCoord Float
u Float
v Float
0)
[Float
u,Float
v,Float
w] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> Float -> TexCoord
TexCoord Float
u Float
v Float
w)
[Float]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"wrong number of u, v and w arguments for texture coordinates"
points :: Parser [Point]
points :: Parser [Point]
points = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"p " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Point
Point forall a. Integral a => Parser a
decimal forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
lines :: Parser [Line]
lines :: Parser [Line]
lines = do
Parser ()
skipSpace
Text
_ <- Text -> Parser Text
string Text
"l "
Parser ()
skipHSpace
[LineIndex]
pointIndices <- Parser Text [LineIndex]
parsePointIndices
[Line]
pts <- case [LineIndex]
pointIndices of
LineIndex
_:LineIndex
_:[LineIndex]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LineIndex -> LineIndex -> Line
Line [LineIndex]
pointIndices (forall a. [a] -> [a]
tail [LineIndex]
pointIndices)
[LineIndex]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"line doesn't have at least two points"
Parser ()
eol
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Line]
pts
where
parsePointIndices :: Parser Text [LineIndex]
parsePointIndices = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
i,Maybe Int
j) -> Int -> Maybe Int -> LineIndex
LineIndex Int
i Maybe Int
j) Parser Text (Int, Maybe Int)
parseLinePair forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace
parseLinePair :: Parser Text (Int, Maybe Int)
parseLinePair = do
Int
v <- forall a. Integral a => Parser a
decimal
forall a. Parser a -> Parser a -> Parser a
slashThenElse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
vt -> (Int
v, forall a. a -> Maybe a
Just Int
vt)) forall a. Integral a => Parser a
decimal) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
v,forall a. Maybe a
Nothing))
face :: Parser Face
face :: Parser Face
face = do
Parser ()
skipSpace
Text
_ <- Text -> Parser Text
string Text
"f "
Parser ()
skipHSpace
[FaceIndex]
faceIndices <- Parser Text [FaceIndex]
parseFaceIndices
Face
f <- case [FaceIndex]
faceIndices of
FaceIndex
a:FaceIndex
b:FaceIndex
c:[FaceIndex]
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FaceIndex -> FaceIndex -> FaceIndex -> [FaceIndex] -> Face
Face FaceIndex
a FaceIndex
b FaceIndex
c [FaceIndex]
s)
[FaceIndex]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"face doesn't have at least three points"
Parser ()
eol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Face
f
where
parseFaceIndices :: Parser Text [FaceIndex]
parseFaceIndices = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
i,Maybe Int
k,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 forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace
parseFaceTriple :: Parser Text (Int, Maybe Int, Maybe Int)
parseFaceTriple = do
Int
v <- forall a. Integral a => Parser a
decimal
forall a. Parser a -> Parser a -> Parser a
slashThenElse (forall {a} {a} {a}.
(Integral a, Integral a) =>
a -> Parser (a, Maybe a, Maybe a)
parseVT Int
v) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
v,forall a. Maybe a
Nothing,forall a. Maybe a
Nothing))
parseVT :: a -> Parser (a, Maybe a, Maybe a)
parseVT a
v = forall a. Parser a -> Parser a -> Parser a
slashThenElse (forall {a} {a} {b}.
Integral a =>
a -> b -> Parser Text (a, b, Maybe a)
parseVN a
v forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ do
a
vt <- forall a. Integral a => Parser a
decimal
forall a. Parser a -> Parser a -> Parser a
slashThenElse (forall {a} {a} {b}.
Integral a =>
a -> b -> Parser Text (a, b, Maybe a)
parseVN a
v forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
vt) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v,forall a. a -> Maybe a
Just a
vt,forall a. Maybe a
Nothing))
parseVN :: a -> b -> Parser Text (a, b, Maybe a)
parseVN a
v b
vt = do
a
vn <- forall a. Integral a => Parser a
decimal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v,b
vt,forall a. a -> Maybe a
Just a
vn)
groups :: Parser [Text]
groups :: Parser [Text]
groups = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"g " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
object :: Parser Text
object :: Parser Text
object = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"o " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
spacedName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
mtllib :: Parser [Text]
mtllib :: Parser [Text]
mtllib = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"mtllib " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
name forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
usemtl :: Parser Text
usemtl :: Parser Text
usemtl = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"usemtl " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
spacedName forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
smoothingGroup :: Parser Natural
smoothingGroup :: Parser Natural
smoothingGroup = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"s " forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Natural
offOrIndex forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipHSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
eol
where
offOrIndex :: Parser Natural
offOrIndex = Text -> Parser Text
string Text
"off" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
0 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Integral a => Parser a
decimal
comment :: Parser ()
= Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"#" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Char
anyChar Parser ()
eol)
slashThenElse :: Parser a -> Parser a -> Parser a
slashThenElse :: forall a. Parser a -> Parser a -> Parser a
slashThenElse Parser a
thenP Parser a
elseP = do
Maybe Char
c <- Parser (Maybe Char)
peekChar
case Maybe Char
c of
Just Char
'/' -> Int -> Parser Text
AP.take Int
1 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
thenP
Maybe Char
_ -> Parser a
elseP
eol :: Parser ()
eol :: Parser ()
eol = forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isHorizontalSpace) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser ()
endOfLine forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall t. Chunk t => Parser t ()
endOfInput)
name :: Parser Text
name :: Parser Text
name = (Char -> Bool) -> Parser Text
takeWhile1 forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace
spacedName :: Parser Text
spacedName :: Parser Text
spacedName = Text -> Text
strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
AP.takeWhile (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem ([Char]
"\n\r" :: String))
skipHSpace :: Parser ()
skipHSpace :: Parser ()
skipHSpace = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Bool) -> Parser Text
AP.takeWhile Char -> Bool
isHorizontalSpace
float :: Parser Float
float :: Parser Float
float = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac Parser Double
double
untilEnd :: Parser a -> Parser [a]
untilEnd :: forall a. Parser a -> Parser [a]
untilEnd Parser a
p = Parser Text [a]
go
where
go :: Parser Text [a]
go = do
a
a <- Parser a
p
Bool
end <- forall t. Chunk t => Parser t Bool
atEnd
if Bool
end then forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
a] else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
aforall a. a -> [a] -> [a]
:) Parser Text [a]
go