{-# 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
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