{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Graphics.Formats.STL.Parser where

import           Prelude                          hiding (takeWhile)

import           Data.Attoparsec.ByteString.Char8 (Parser, inClass, many',
                                                   rational, skipSpace, string,
                                                   takeWhile)
import qualified Data.Attoparsec.ByteString.Char8 as P
import qualified Data.ByteString                  as BS

import           Graphics.Formats.STL.Types       (STL (STL),
                                                   Triangle (Triangle), Vector,
                                                   triple)

loadSTL :: FilePath -> IO (Either String STL)
loadSTL :: FilePath -> IO (Either FilePath STL)
loadSTL FilePath
f = Parser STL -> ByteString -> Either FilePath STL
forall a. Parser a -> ByteString -> Either FilePath a
P.parseOnly Parser STL
stlParser (ByteString -> Either FilePath STL)
-> IO ByteString -> IO (Either FilePath STL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
f

mustLoadSTL :: FilePath -> IO STL
mustLoadSTL :: FilePath -> IO STL
mustLoadSTL FilePath
f = FilePath -> IO (Either FilePath STL)
loadSTL FilePath
f IO (Either FilePath STL)
-> (Either FilePath STL -> IO STL) -> IO STL
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left FilePath
err -> FilePath -> IO STL
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err
    Right STL
ok -> STL -> IO STL
forall (m :: * -> *) a. Monad m => a -> m a
return STL
ok

-- | A parser from 'Text' to the @STL@ type.  The parser should be
-- fairly permissive about whitespace, but has not been tested enough
-- against STL files in the wild.
stlParser :: Parser STL
stlParser :: Parser STL
stlParser = ByteString -> [Triangle] -> STL
STL (ByteString -> [Triangle] -> STL)
-> Parser ByteString ByteString
-> Parser ByteString ([Triangle] -> STL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
nameParser Parser ByteString ([Triangle] -> STL)
-> Parser ByteString [Triangle] -> Parser STL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Triangle -> Parser ByteString [Triangle]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString Triangle
triangle

nameParser :: Parser BS.ByteString
nameParser :: Parser ByteString ByteString
nameParser = ByteString -> Parser ByteString ByteString
text ByteString
"solid" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString ByteString
takeWhile (FilePath -> Char -> Bool
inClass FilePath
" -~") Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace

triangle :: Parser Triangle
triangle :: Parser ByteString Triangle
triangle = Maybe Vector -> (Vector, Vector, Vector) -> Triangle
Triangle (Maybe Vector -> (Vector, Vector, Vector) -> Triangle)
-> Parser ByteString (Maybe Vector)
-> Parser ByteString ((Vector, Vector, Vector) -> Triangle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Maybe Vector)
-> Parser ByteString (Maybe Vector)
forall a. Parser a -> Parser a
ss Parser ByteString (Maybe Vector)
normalParser Parser ByteString ((Vector, Vector, Vector) -> Triangle)
-> Parser ByteString (Vector, Vector, Vector)
-> Parser ByteString Triangle
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (Vector, Vector, Vector)
loop Parser ByteString Triangle
-> Parser ByteString ByteString -> Parser ByteString Triangle
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
text ByteString
"endfacet"

loop :: Parser (Vector, Vector, Vector)
loop :: Parser ByteString (Vector, Vector, Vector)
loop = Vector -> Vector -> Vector -> (Vector, Vector, Vector)
forall a. a -> a -> a -> (a, a, a)
triple (Vector -> Vector -> Vector -> (Vector, Vector, Vector))
-> Parser ByteString Vector
-> Parser ByteString (Vector -> Vector -> (Vector, Vector, Vector))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
text ByteString
"outer loop" Parser ByteString ByteString
-> Parser ByteString Vector -> Parser ByteString Vector
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Vector -> Parser ByteString Vector
forall a. Parser a -> Parser a
ss Parser ByteString Vector
vertex) Parser ByteString (Vector -> Vector -> (Vector, Vector, Vector))
-> Parser ByteString Vector
-> Parser ByteString (Vector -> (Vector, Vector, Vector))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Vector -> Parser ByteString Vector
forall a. Parser a -> Parser a
ss Parser ByteString Vector
vertex Parser ByteString (Vector -> (Vector, Vector, Vector))
-> Parser ByteString Vector
-> Parser ByteString (Vector, Vector, Vector)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Vector -> Parser ByteString Vector
forall a. Parser a -> Parser a
ss Parser ByteString Vector
vertex Parser ByteString (Vector, Vector, Vector)
-> Parser ByteString ByteString
-> Parser ByteString (Vector, Vector, Vector)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
text ByteString
"endloop"

normalParser :: Parser (Maybe Vector)
normalParser :: Parser ByteString (Maybe Vector)
normalParser = ByteString -> Parser ByteString ByteString
text ByteString
"facet" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Parser ByteString ByteString
text ByteString
"normal" Parser ByteString ByteString
-> Parser ByteString (Maybe Vector)
-> Parser ByteString (Maybe Vector)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
    Vector
n <- Parser ByteString Vector
v3
    Maybe Vector -> Parser ByteString (Maybe Vector)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Vector -> Parser ByteString (Maybe Vector))
-> Maybe Vector -> Parser ByteString (Maybe Vector)
forall a b. (a -> b) -> a -> b
$ case Vector
n of
        (Float
0, Float
0, Float
0) -> Maybe Vector
forall a. Maybe a
Nothing
        Vector
_         -> Vector -> Maybe Vector
forall a. a -> Maybe a
Just Vector
n

vertex :: Parser Vector
vertex :: Parser ByteString Vector
vertex = ByteString -> Parser ByteString ByteString
text ByteString
"vertex" Parser ByteString ByteString
-> Parser ByteString Vector -> Parser ByteString Vector
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Vector
v3

v3 :: Parser Vector
v3 :: Parser ByteString Vector
v3 = Float -> Float -> Float -> Vector
forall a. a -> a -> a -> (a, a, a)
triple (Float -> Float -> Float -> Vector)
-> Parser ByteString Float
-> Parser ByteString (Float -> Float -> Vector)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Float -> Parser ByteString Float
forall a. Parser a -> Parser a
ss Parser ByteString Float
float Parser ByteString (Float -> Float -> Vector)
-> Parser ByteString Float -> Parser ByteString (Float -> Vector)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Float -> Parser ByteString Float
forall a. Parser a -> Parser a
ss Parser ByteString Float
float Parser ByteString (Float -> Vector)
-> Parser ByteString Float -> Parser ByteString Vector
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString Float -> Parser ByteString Float
forall a. Parser a -> Parser a
ss Parser ByteString Float
float

ss :: Parser a -> Parser a
ss :: Parser a -> Parser a
ss Parser a
p = Parser a
p Parser a -> Parser ByteString () -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace

text :: BS.ByteString -> Parser BS.ByteString
text :: ByteString -> Parser ByteString ByteString
text ByteString
t = ByteString -> Parser ByteString ByteString
string ByteString
t Parser ByteString ByteString
-> Parser ByteString () -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace

float :: Parser Float
float :: Parser ByteString Float
float = Parser ByteString Float
forall a. Fractional a => Parser a
rational