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

module Codec.Wavefront.Lexer where

import Codec.Wavefront.Element
import Codec.Wavefront.Face
import Codec.Wavefront.Line
import Codec.Wavefront.Location
import Codec.Wavefront.Normal
import Codec.Wavefront.Point
import Codec.Wavefront.Token
import Codec.Wavefront.TexCoord
import Data.DList ( DList, append, empty, fromList, snoc )
import Data.Text ( Text )
import Control.Monad.State ( State, execState, gets, modify )
import Data.Foldable ( traverse_ )
import Numeric.Natural ( Natural )

-- |The lexer context. The result of lexing a stream of tokens is this exact type.
data Ctxt = Ctxt {
    -- |Locations.
    Ctxt -> DList Location
ctxtLocations :: DList Location
    -- |Texture coordinates.
  , Ctxt -> DList TexCoord
ctxtTexCoords :: DList TexCoord
    -- |Normals.
  , Ctxt -> DList Normal
ctxtNormals :: DList Normal
    -- |Points.
  , Ctxt -> DList (Element Point)
ctxtPoints :: DList (Element Point)
    -- |Lines.
  , Ctxt -> DList (Element Line)
ctxtLines :: DList (Element Line)
    -- |Faces.
  , Ctxt -> DList (Element Face)
ctxtFaces :: DList (Element Face)
    -- |Current object.
  , Ctxt -> Maybe Text
ctxtCurrentObject :: Maybe Text
    -- |Current groups.
  , Ctxt -> [Text]
ctxtCurrentGroups :: [Text]
    -- |Current material.
  , Ctxt -> Maybe Text
ctxtCurrentMtl :: Maybe Text
    -- |Material libraries.
  , Ctxt -> DList Text
ctxtMtlLibs :: DList Text
    -- |Current smoothing group.
  , Ctxt -> Natural
ctxtCurrentSmoothingGroup :: Natural
  } deriving (Ctxt -> Ctxt -> Bool
(Ctxt -> Ctxt -> Bool) -> (Ctxt -> Ctxt -> Bool) -> Eq Ctxt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ctxt -> Ctxt -> Bool
$c/= :: Ctxt -> Ctxt -> Bool
== :: Ctxt -> Ctxt -> Bool
$c== :: Ctxt -> Ctxt -> Bool
Eq,Int -> Ctxt -> ShowS
[Ctxt] -> ShowS
Ctxt -> String
(Int -> Ctxt -> ShowS)
-> (Ctxt -> String) -> ([Ctxt] -> ShowS) -> Show Ctxt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ctxt] -> ShowS
$cshowList :: [Ctxt] -> ShowS
show :: Ctxt -> String
$cshow :: Ctxt -> String
showsPrec :: Int -> Ctxt -> ShowS
$cshowsPrec :: Int -> Ctxt -> ShowS
Show)

-- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered
-- as we consume tokens.
emptyCtxt :: Ctxt 
emptyCtxt :: Ctxt
emptyCtxt = Ctxt :: DList Location
-> DList TexCoord
-> DList Normal
-> DList (Element Point)
-> DList (Element Line)
-> DList (Element Face)
-> Maybe Text
-> [Text]
-> Maybe Text
-> DList Text
-> Natural
-> Ctxt
Ctxt {
    ctxtLocations :: DList Location
ctxtLocations = DList Location
forall a. DList a
empty
  , ctxtTexCoords :: DList TexCoord
ctxtTexCoords = DList TexCoord
forall a. DList a
empty
  , ctxtNormals :: DList Normal
ctxtNormals = DList Normal
forall a. DList a
empty
  , ctxtPoints :: DList (Element Point)
ctxtPoints = DList (Element Point)
forall a. DList a
empty
  , ctxtLines :: DList (Element Line)
ctxtLines = DList (Element Line)
forall a. DList a
empty
  , ctxtFaces :: DList (Element Face)
ctxtFaces = DList (Element Face)
forall a. DList a
empty
  , ctxtCurrentObject :: Maybe Text
ctxtCurrentObject = Maybe Text
forall a. Maybe a
Nothing
  , ctxtCurrentGroups :: [Text]
ctxtCurrentGroups = ["default"]
  , ctxtCurrentMtl :: Maybe Text
ctxtCurrentMtl = Maybe Text
forall a. Maybe a
Nothing
  , ctxtMtlLibs :: DList Text
ctxtMtlLibs = DList Text
forall a. DList a
empty
  , ctxtCurrentSmoothingGroup :: Natural
ctxtCurrentSmoothingGroup = 0
  }

-- |The lexer function, consuming tokens and yielding a 'Ctxt'.
lexer :: TokenStream -> Ctxt
lexer :: TokenStream -> Ctxt
lexer stream :: TokenStream
stream = State Ctxt () -> Ctxt -> Ctxt
forall s a. State s a -> s -> s
execState ((Token -> State Ctxt ()) -> TokenStream -> State Ctxt ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Token -> State Ctxt ()
consume TokenStream
stream) Ctxt
emptyCtxt
  where
    consume :: Token -> State Ctxt ()
consume tk :: Token
tk = case Token
tk of
      TknV v :: Location
v -> do
        DList Location
locations <- (Ctxt -> DList Location) -> StateT Ctxt Identity (DList Location)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Ctxt -> DList Location
ctxtLocations
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtLocations :: DList Location
ctxtLocations = DList Location
locations DList Location -> Location -> DList Location
forall a. DList a -> a -> DList a
`snoc` Location
v }
      TknVN vn :: Normal
vn -> do
        DList Normal
normals <- (Ctxt -> DList Normal) -> StateT Ctxt Identity (DList Normal)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Ctxt -> DList Normal
ctxtNormals
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtNormals :: DList Normal
ctxtNormals = DList Normal
normals DList Normal -> Normal -> DList Normal
forall a. DList a -> a -> DList a
`snoc` Normal
vn }
      TknVT vt :: TexCoord
vt -> do
        DList TexCoord
texCoords <- (Ctxt -> DList TexCoord) -> StateT Ctxt Identity (DList TexCoord)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Ctxt -> DList TexCoord
ctxtTexCoords
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtTexCoords :: DList TexCoord
ctxtTexCoords = DList TexCoord
texCoords DList TexCoord -> TexCoord -> DList TexCoord
forall a. DList a -> a -> DList a
`snoc` TexCoord
vt }
      TknP p :: [Point]
p -> do
        (pts :: DList (Element Point)
pts,element :: Point -> Element Point
element) <- (Ctxt -> DList (Element Point))
-> State Ctxt (DList (Element Point), Point -> Element Point)
forall a.
(Ctxt -> DList (Element a))
-> State Ctxt (DList (Element a), a -> Element a)
prepareElement Ctxt -> DList (Element Point)
ctxtPoints
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtPoints :: DList (Element Point)
ctxtPoints = DList (Element Point)
pts DList (Element Point)
-> DList (Element Point) -> DList (Element Point)
forall a. DList a -> DList a -> DList a
`append` (Point -> Element Point) -> DList Point -> DList (Element Point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Point -> Element Point
element ([Point] -> DList Point
forall a. [a] -> DList a
fromList [Point]
p) }
      TknL l :: [Line]
l -> do
        (lns :: DList (Element Line)
lns,element :: Line -> Element Line
element) <- (Ctxt -> DList (Element Line))
-> State Ctxt (DList (Element Line), Line -> Element Line)
forall a.
(Ctxt -> DList (Element a))
-> State Ctxt (DList (Element a), a -> Element a)
prepareElement Ctxt -> DList (Element Line)
ctxtLines
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtLines :: DList (Element Line)
ctxtLines = DList (Element Line)
lns DList (Element Line)
-> DList (Element Line) -> DList (Element Line)
forall a. DList a -> DList a -> DList a
`append` (Line -> Element Line) -> DList Line -> DList (Element Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Element Line
element ([Line] -> DList Line
forall a. [a] -> DList a
fromList [Line]
l) }
      TknF f :: Face
f -> do
        (fcs :: DList (Element Face)
fcs,element :: Face -> Element Face
element) <- (Ctxt -> DList (Element Face))
-> State Ctxt (DList (Element Face), Face -> Element Face)
forall a.
(Ctxt -> DList (Element a))
-> State Ctxt (DList (Element a), a -> Element a)
prepareElement Ctxt -> DList (Element Face)
ctxtFaces
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtFaces :: DList (Element Face)
ctxtFaces = DList (Element Face)
fcs DList (Element Face) -> Element Face -> DList (Element Face)
forall a. DList a -> a -> DList a
`snoc` Face -> Element Face
element Face
f }
      TknG g :: [Text]
g -> (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtCurrentGroups :: [Text]
ctxtCurrentGroups = [Text]
g }
      TknO o :: Text
o -> (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtCurrentObject :: Maybe Text
ctxtCurrentObject = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
o }
      TknMtlLib l :: [Text]
l -> do
        DList Text
libs <- (Ctxt -> DList Text) -> StateT Ctxt Identity (DList Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Ctxt -> DList Text
ctxtMtlLibs
        (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtMtlLibs :: DList Text
ctxtMtlLibs = DList Text
libs DList Text -> DList Text -> DList Text
forall a. DList a -> DList a -> DList a
`append` [Text] -> DList Text
forall a. [a] -> DList a
fromList [Text]
l }
      TknUseMtl mtl :: Text
mtl -> (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtCurrentMtl :: Maybe Text
ctxtCurrentMtl = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
mtl }
      TknS sg :: Natural
sg -> (Ctxt -> Ctxt) -> State Ctxt ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Ctxt -> Ctxt) -> State Ctxt ())
-> (Ctxt -> Ctxt) -> State Ctxt ()
forall a b. (a -> b) -> a -> b
$ \ctxt :: Ctxt
ctxt -> Ctxt
ctxt { ctxtCurrentSmoothingGroup :: Natural
ctxtCurrentSmoothingGroup = Natural
sg }

-- Prepare to create a new 'Element' by retrieving its associated list.
prepareElement :: (Ctxt -> DList (Element a)) -> State Ctxt (DList (Element a),a -> Element a)
prepareElement :: (Ctxt -> DList (Element a))
-> State Ctxt (DList (Element a), a -> Element a)
prepareElement field :: Ctxt -> DList (Element a)
field = do
  (aList :: DList (Element a)
aList,obj :: Maybe Text
obj,grp :: [Text]
grp,mtl :: Maybe Text
mtl,sg :: Natural
sg) <- (Ctxt
 -> (DList (Element a), Maybe Text, [Text], Maybe Text, Natural))
-> StateT
     Ctxt
     Identity
     (DList (Element a), Maybe Text, [Text], Maybe Text, Natural)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Ctxt
  -> (DList (Element a), Maybe Text, [Text], Maybe Text, Natural))
 -> StateT
      Ctxt
      Identity
      (DList (Element a), Maybe Text, [Text], Maybe Text, Natural))
-> (Ctxt
    -> (DList (Element a), Maybe Text, [Text], Maybe Text, Natural))
-> StateT
     Ctxt
     Identity
     (DList (Element a), Maybe Text, [Text], Maybe Text, Natural)
forall a b. (a -> b) -> a -> b
$ (\ctxt :: Ctxt
ctxt -> (Ctxt -> DList (Element a)
field Ctxt
ctxt,Ctxt -> Maybe Text
ctxtCurrentObject Ctxt
ctxt,Ctxt -> [Text]
ctxtCurrentGroups Ctxt
ctxt,Ctxt -> Maybe Text
ctxtCurrentMtl Ctxt
ctxt,Ctxt -> Natural
ctxtCurrentSmoothingGroup Ctxt
ctxt))
  (DList (Element a), a -> Element a)
-> State Ctxt (DList (Element a), a -> Element a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DList (Element a)
aList,Maybe Text -> [Text] -> Maybe Text -> Natural -> a -> Element a
forall a.
Maybe Text -> [Text] -> Maybe Text -> Natural -> a -> Element a
Element Maybe Text
obj [Text]
grp Maybe Text
mtl Natural
sg)