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

module Graphics.Formats.STL.Parser where

import           Prelude                    hiding (takeWhile)

import           Data.Attoparsec.Text       (Parser, double, inClass, many',
                                             skipSpace, string, takeWhile)
import qualified Data.Attoparsec.Text       as P
import           Data.Text                  (Text)
import qualified Data.Text.IO               as Text

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 -> Text -> Either FilePath STL
forall a. Parser a -> Text -> Either FilePath a
P.parseOnly Parser STL
stlParser (Text -> Either FilePath STL)
-> IO Text -> IO (Either FilePath STL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.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 = Text -> [Triangle] -> STL
STL (Text -> [Triangle] -> STL)
-> Parser Text Text -> Parser Text ([Triangle] -> STL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
nameParser Parser Text ([Triangle] -> STL)
-> Parser Text [Triangle] -> Parser STL
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Triangle -> Parser Text [Triangle]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Text Triangle
triangle

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

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

loop :: Parser (Vector, Vector, Vector)
loop :: Parser Text (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 Text Vector
-> Parser Text (Vector -> Vector -> (Vector, Vector, Vector))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text Text
text Text
"outer loop" Parser Text Text -> Parser Text Vector -> Parser Text Vector
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Vector -> Parser Text Vector
forall a. Parser a -> Parser a
ss Parser Text Vector
vertex) Parser Text (Vector -> Vector -> (Vector, Vector, Vector))
-> Parser Text Vector
-> Parser Text (Vector -> (Vector, Vector, Vector))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Vector -> Parser Text Vector
forall a. Parser a -> Parser a
ss Parser Text Vector
vertex Parser Text (Vector -> (Vector, Vector, Vector))
-> Parser Text Vector -> Parser Text (Vector, Vector, Vector)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text Vector -> Parser Text Vector
forall a. Parser a -> Parser a
ss Parser Text Vector
vertex Parser Text (Vector, Vector, Vector)
-> Parser Text Text -> Parser Text (Vector, Vector, Vector)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text Text
text Text
"endloop"

normalParser :: Parser (Maybe Vector)
normalParser :: Parser Text (Maybe Vector)
normalParser = Text -> Parser Text Text
text Text
"facet" Parser Text Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
text Text
"normal" Parser Text Text
-> Parser Text (Maybe Vector) -> Parser Text (Maybe Vector)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
    Vector
n <- Parser Text Vector
v3
    Maybe Vector -> Parser Text (Maybe Vector)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Vector -> Parser Text (Maybe Vector))
-> Maybe Vector -> Parser Text (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 Text Vector
vertex = Text -> Parser Text Text
text Text
"vertex" Parser Text Text -> Parser Text Vector -> Parser Text Vector
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Vector
v3

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

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

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

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