-----------------------------------------------------------------------------
-- |
-- 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
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
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 {
    ctxtLocations :: DList Location
ctxtLocations = forall a. DList a
empty
  , ctxtTexCoords :: DList TexCoord
ctxtTexCoords = forall a. DList a
empty
  , ctxtNormals :: DList Normal
ctxtNormals = forall a. DList a
empty
  , ctxtPoints :: DList (Element Point)
ctxtPoints = forall a. DList a
empty
  , ctxtLines :: DList (Element Line)
ctxtLines = forall a. DList a
empty
  , ctxtFaces :: DList (Element Face)
ctxtFaces = forall a. DList a
empty
  , ctxtCurrentObject :: Maybe Text
ctxtCurrentObject = forall a. Maybe a
Nothing
  , ctxtCurrentGroups :: [Text]
ctxtCurrentGroups = [Text
"default"]
  , ctxtCurrentMtl :: Maybe Text
ctxtCurrentMtl = forall a. Maybe a
Nothing
  , ctxtMtlLibs :: DList Text
ctxtMtlLibs = forall a. DList a
empty
  , ctxtCurrentSmoothingGroup :: Natural
ctxtCurrentSmoothingGroup = Natural
0
  }

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