path: root/src/Wavefront/Lex.hs

{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings        #-}
module Wavefront.Lex where

import Data.Bool
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Internal as BS
import Data.ByteString.Lex.Fractional as F
import Data.ByteString.Lex.Integral as I
import Data.Char
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.List
import Data.Maybe
import qualified Rank2
import Control.Monad.Writer.Lazy

import Text.UTF8

data ObjBuilder m = ObjBuilder
    { vertex           :: [Double] -> m ()
    , vertexT          :: [Double] -> m ()
    , vertexN          :: [Double] -> m ()
    , vertexP          :: [Double] -> m ()
    , face             :: [RefTriple] -> m ()
    , line             :: [RefTriple] -> m ()
    , cstype           :: Bool -> CSType -> m ()
    , curv2            :: [Int] -> m ()
    , curv             :: Double -> Double -> [Int] -> m ()
    , parm             :: ParamSpec -> [Double] -> m ()
    , specialPoints    :: [Int] -> m ()
    , endFreeForm      :: m ()
    , ctech            :: CurveSamplingSpec -> m ()
    , stech            :: SurfaceSamplingSpec -> m ()
    , deg              :: [Int] -> m ()
    , surf             :: Double -> Double -> Double -> Double -> [RefTriple] -> m ()
    , trim             :: [CurveSpec] -> m ()
    , hole             :: [CurveSpec] -> m ()
    , specialCurves    :: [CurveSpec] -> m ()
    , equivalentCurves :: [EmbeddedCurve] -> m ()
    , groups           :: [S.ByteString] -> m ()
    , smoothingGroup   :: Int -> m ()
    , mergingGroup     :: Int -> Double -> m ()
    , usemtl           :: S.ByteString -> m ()
    , deprecated_cdc   :: [Int] -> m ()
    , deprecated_cdp   :: [Int] -> m ()
    , deprecated_bzp   :: [Int] -> m ()
    , deprecated_bsp   :: [Int] -> m ()
    , mtllib           :: [S.ByteString] -> m ()
    , objectName       :: S.ByteString -> m ()
    , bmat             :: ParamSpec -> [Double] -> m ()
    , step             :: [Int] -> m ()
    , points           :: [Int] -> m ()
    , usemap           :: Maybe S.ByteString -> m ()
    , maplib           :: [S.ByteString] -> m ()
    , c_interp         :: Bool -> m ()
    , d_interp         :: Bool -> m ()
    , trace_obj        :: S.ByteString -> m ()
    , shadow_obj       :: S.ByteString -> m ()
    , deprecated_res   :: [Int] -> m ()
    , bevel            :: Bool -> m ()
    , lod              :: Int -> m ()
    , call             :: S.ByteString -> [S.ByteString] -> m ()
    , command          :: Bool -> L.ByteString -> m L.ByteString
    , badToken         :: L.ByteString -> m ()
    }

instance Rank2.Functor ObjBuilder where
    f <$> b = b
        { vertex           = \vs             -> f $ vertex b vs
        , vertexT          = \vs             -> f $ vertexT b vs
        , vertexN          = \vs             -> f $ vertexN b vs
        , vertexP          = \vs             -> f $ vertexP b vs
        , face             = \is             -> f $ face b is
        , line             = \is             -> f $ line b is
        , cstype           = \isRat typ      -> f $ cstype b isRat typ
        , curv2            = \is             -> f $ curv2 b is
        , curv             = \u0 v0 is       -> f $ curv b u0 v0 is
        , parm             = \uv is          -> f $ parm b uv is
        , specialPoints    = \is             -> f $ specialPoints b is
        , endFreeForm      =                    f $ endFreeForm b
        , ctech            = \approx         -> f $ ctech b approx
        , stech            = \approx         -> f $ stech b approx
        , deg              = \is             -> f $ deg b is
        , surf             = \u0 u1 v0 v1 ts -> f $ surf b u0 u1 v0 v1 ts
        , trim             = \ss             -> f $ trim b ss
        , hole             = \ss             -> f $ hole b ss
        , specialCurves    = \ss             -> f $ specialCurves b ss
        , equivalentCurves = \ccs            -> f $ equivalentCurves b ccs
        , groups           = \gs             -> f $ groups b gs
        , smoothingGroup   = \sg             -> f $ smoothingGroup b sg
        , mergingGroup     = \mg δ           -> f $ mergingGroup b mg δ
        , usemtl           = \mtl            -> f $ usemtl b mtl
        , deprecated_cdc   = \is             -> f $ deprecated_cdc b is
        , deprecated_cdp   = \is             -> f $ deprecated_cdp b is
        , deprecated_bzp   = \is             -> f $ deprecated_bzp b is
        , deprecated_bsp   = \is             -> f $ deprecated_bsp b is
        , mtllib           = \fns            -> f $ mtllib b fns
        , objectName       = \obn            -> f $ objectName b obn
        , bmat             = \uv fs          -> f $ bmat b uv fs
        , step             = \is             -> f $ step b is
        , points           = \is             -> f $ points b is
        , usemap           = \map            -> f $ usemap b map
        , maplib           = \fns            -> f $ maplib b fns
        , c_interp         = \x              -> f $ c_interp b x
        , d_interp         = \x              -> f $ d_interp b x
        , trace_obj        = \obj            -> f $ trace_obj b obj
        , shadow_obj       = \obj            -> f $ shadow_obj b obj
        , deprecated_res   = \is             -> f $ deprecated_res b is
        , bevel            = \x              -> f $ bevel b x
        , lod              = \lvl            -> f $ lod b lvl
        , call             = \obj args       -> f $ call b obj args
        , command          = \x cmd          -> f $ command b x cmd
        , badToken         = \bs             -> f $ badToken b bs
        }


nullBuilder :: Applicative m => ObjBuilder m
nullBuilder = ObjBuilder
    { vertex           = \vs             -> pure ()
    , vertexT          = \vs             -> pure ()
    , vertexN          = \vs             -> pure ()
    , vertexP          = \vs             -> pure ()
    , face             = \is             -> pure ()
    , line             = \is             -> pure ()
    , cstype           = \isRat typ      -> pure ()
    , curv2            = \is             -> pure ()
    , curv             = \u0 v0 is       -> pure ()
    , parm             = \uv is          -> pure ()
    , specialPoints    = \is             -> pure ()
    , endFreeForm      =                    pure ()
    , ctech            = \approx         -> pure ()
    , stech            = \approx         -> pure ()
    , deg              = \is             -> pure ()
    , surf             = \u0 u1 v0 v1 ts -> pure ()
    , trim             = \ss             -> pure ()
    , hole             = \ss             -> pure ()
    , specialCurves    = \ss             -> pure ()
    , equivalentCurves = \ccs            -> pure ()
    , groups           = \gs             -> pure ()
    , smoothingGroup   = \sg             -> pure ()
    , mergingGroup     = \mg δ           -> pure ()
    , usemtl           = \mtl            -> pure ()
    , deprecated_cdc   = \is             -> pure ()
    , deprecated_cdp   = \is             -> pure ()
    , deprecated_bzp   = \is             -> pure ()
    , deprecated_bsp   = \is             -> pure ()
    , mtllib           = \fns            -> pure ()
    , objectName       = \obn            -> pure ()
    , bmat             = \uv fs          -> pure ()
    , step             = \is             -> pure ()
    , points           = \is             -> pure ()
    , usemap           = \map            -> pure ()
    , maplib           = \fns            -> pure ()
    , c_interp         = \b              -> pure ()
    , d_interp         = \b              -> pure ()
    , trace_obj        = \obj            -> pure ()
    , shadow_obj       = \obj            -> pure ()
    , deprecated_res   = \is             -> pure ()
    , bevel            = \b              -> pure ()
    , lod              = \lvl            -> pure ()
    , call             = \obj args       -> pure ()
    , command          = \b cmd          -> pure L.empty
    , badToken         = \bs             -> pure ()
    }

echoBuilder :: (MonadWriter (f String) m, Applicative f) => ObjBuilder m
echoBuilder = ObjBuilder
    { vertex           = \vs -> echo $ unwords ("v": map show vs)
    , vertexT          = \vs -> echo $ unwords ("vt": map show vs)
    , vertexN          = \vs -> echo $ unwords ("vn": map show vs)
    , vertexP          = \vs -> echo $ unwords ("vp": map show vs)
    , face             = \ts -> echo $ unwords ("f":map showRefTriple ts)
    , line             = \ts -> echo $ unwords ("l":map showRefTriple ts)
    , cstype           = \isRat typ -> echo $ unwords [ if isRat then  "cstype rat" else "cstype"
                                                      , map toLower (show typ) ]
    , curv2            = \is -> echo $ unwords ("curv2":map show is)
    , curv             = \u0 v0 is -> echo $ unwords ("curv":show u0:show v0:map show is)
    , parm             = \isU ds -> echo $ unwords ("parm":showParamSpec isU:map show ds)
    , specialPoints    = \is -> echo $ unwords ("sp":map show is)
    , endFreeForm      = echo "end"
    , ctech            = \approx -> echo $ "ctech " ++ showCurveSamplingSpec approx
    , stech            = \approx -> echo $ "stech " ++ showSurfaceSamplingSpec approx
    , deg              = \is -> echo $ unwords ("deg":map show is)
    , surf             = \u0 u1 v0 v1 ts -> echo $ unwords $ "surf " : map show [u0,u1,v0,v1]
                                                                ++ map showRefTriple ts
    , trim             = \ss -> echo $ unwords ("trim":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
    , hole             = \ss -> echo $ unwords ("hole":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
    , specialCurves    = \ss -> echo $ unwords ("scrv":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
    , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurve ccs)
    , groups           = \gs -> echo $ unwords $ "g":map unpackUtf8 gs
    , smoothingGroup   = \sg -> echo ("s " ++ show sg)
    , mergingGroup     = \mg δ -> echo $ unwords ["mg",show mg,show δ]
    , usemtl           = \mtl -> echo ("usemtl " ++ unpackUtf8 mtl)
    , deprecated_cdc   = \is -> echo $ unwords ("cdc":map show is)
    , deprecated_bzp   = \is -> echo $ unwords ("bzp":map show is)
    , mtllib           = \fns -> echo $ unwords $ "mtllib " : map unpackUtf8 fns
    , objectName       = \obn -> echo ("o " ++ unpackUtf8 obn)
    , bmat             = \isU is -> echo $ unwords ("bmat":showParamSpec isU:map show is)
    , step             = \is -> echo $ unwords ("step":map show is)
    , points           = \is -> echo $ unwords ("p":map show is)
    , usemap           = \mp -> echo $ "usemap " ++ maybe "off" unpackUtf8 mp
    , maplib           = \fns -> echo ("maplib " ++ show fns)
    , c_interp         = \flag -> echo $ "c_interp " ++ bool "off" "on" flag
    , d_interp         = \flag -> echo $ "d_interp " ++ bool "off" "on" flag
    , deprecated_cdp   = \x -> echo $ "cdp " ++ show x
    , deprecated_bsp   = \x -> echo $ "bsp " ++ show x
    , trace_obj        = \x -> echo $ "trace_obj " ++ unpackUtf8 x
    , shadow_obj       = \x -> echo $ "shadow_obj " ++ unpackUtf8 x
    , deprecated_res   = \x -> echo $ "res " ++ show x
    , bevel            = \x -> echo $ "bevel " ++ show x
    , lod              = \x -> echo $ "lod " ++ show x
    , call             = \fn as -> echo $ unwords ("call":map unpackUtf8 (fn:as))
    , command          = \e cmd -> do echo $ "csh " ++ (bool ('-':) id e $ unpackUtf8 $ L.toStrict cmd)
                                      return L.empty
    , badToken         = \bs -> echo $ "bad token: " ++ show (L.take 20 bs)
    }
 where
    echo = tell . pure

data CurveSamplingSpec
    -- ctech cparm
    = UniformSubdivision
        { divisionsPerCurveDegree :: Double -- ^ This really ought to be an integer but
                                            -- but examples show floats.  The only way
                                            -- it makes sense as a float is if we are to
                                            -- convert to an integer *after* multiplying
                                            -- by the curve degree.
        }
    -- ctech cspace
    | MaxLengthPolygonal { maxPolygonEdgeLength :: Double }
    -- ctech curv
    | CurvatureBasedPolygon { maxDistanceToCurve :: Double, maximumDegreesPerSample :: Double }
 deriving (Eq,Show)

showCurveSamplingSpec :: CurveSamplingSpec -> String
showCurveSamplingSpec (UniformSubdivision d)      = "cparm " ++ show d
showCurveSamplingSpec (MaxLengthPolygonal d)      = "cspace " ++ show d
showCurveSamplingSpec (CurvatureBasedPolygon d a) = unwords ["curv",show d,show a]

data SurfaceSamplingSpec
    -- stech cparma ures vres
    = UniformIsoparametric { uDivisionsPerDegree :: Double, vDivisionsPerDegree :: Double }
    -- stech cparmb uvres
    | UniformAfterTrimming { uvDivisionsPerDegree :: Double }
    -- stech cspace maxlength
    | MaxLengthPolytopal { maxPolytopEdgeLength :: Double }
    -- stech curv maxdist maxangle
    | CurvatureBasedPolytope { maxDistanceToSurface :: Double, maxDegreesPerCorner :: Double }
 deriving (Eq,Show)

showSurfaceSamplingSpec :: SurfaceSamplingSpec -> String
showSurfaceSamplingSpec (UniformIsoparametric ures vres)   = unwords ["cparma",show ures,show vres]
showSurfaceSamplingSpec (UniformAfterTrimming uvres)       = "cparmb " ++ show uvres
showSurfaceSamplingSpec (MaxLengthPolytopal maxlength)     = "cspace " ++ show maxlength
showSurfaceSamplingSpec (CurvatureBasedPolytope maxd maxa) = unwords ["curv",show maxd,show maxa]

data ObjState = ObjState
    {
    }

newtype ObjConfig = ObjConfig
    { cfgSubst :: IntMap L.ByteString
    }

-- consChunk :: S.ByteString -> L.ByteString -> L.ByteString
-- consChunk c bs = L.fromChunks (c : L.toChunks bs)

reappend :: ByteString -> ByteString -> Maybe ByteString
reappend a b =
    let (ap,ao,al) = BS.toForeignPtr a
        (bp,bo,bl) = BS.toForeignPtr b
    in if ap == bp && ao+al == bo
        then Just $ BS.PS ap ao (al+bl)
        else Nothing

reconsChunk :: S.ByteString -> L.ByteString -> L.ByteString
reconsChunk b bs = case L.toChunks bs of
    (c:cs) -> case reappend b c of
        Just x  -> L.fromChunks (x:cs)
        Nothing -> L.fromChunks (b:c:cs)
    _      -> L.fromChunks [b]

findToken :: ObjConfig -> L.ByteString -> L.ByteString
findToken (ObjConfig args) bs = case L.dropWhile (\c -> isSpace c || c=='\\') bs of
  cs -> case L.uncons cs of
    Just ('#',comment) -> findToken (ObjConfig args) $ L.drop 1 $ L.dropWhile (/='\n') comment
    Just ('$',ref)     -> case L.splitAt 5 ref of
                            (refp,ds) -> case I.readDecimal (L.toStrict refp) of
                                Just (i,es) -> case IntMap.lookup i args of
                                    Just val -> val <> reconsChunk es ds
                                    _        -> reconsChunk es ds
                                _ -> cs
    Just _             -> cs
    Nothing            -> L.empty

findNewLine :: [L.ByteString] -> ObjConfig -> L.ByteString -> (L.ByteString,L.ByteString)
findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || c=='#' || c=='\\') bs of
  (ts,cs) -> case L.uncons cs of
    Just ('\n',ds)     -> (L.concat $ reverse $ ts : ps,ds)
    Just ('#',comment) -> findNewLine (ts:ps) o $ L.dropWhile (/='\n') comment
    Just ('$',ref)     -> case L.splitAt 5 ref of
                            (refp,ds) -> case I.readDecimal (L.toStrict refp) of
                                Just (i,es) -> case IntMap.lookup i args of
                                    Just val -> findNewLine (val:ts:ps) o $ reconsChunk es ds
                                    _        -> findNewLine (ts:ps) o $ reconsChunk es ds
                                _ -> findNewLine ("$":ts:ps) o ref
    Just ('\\',ds)     -> findNewLine (ts:ps) o $ if L.take 1 ds == "\n" then L.drop 1 ds
                                                                         else ds
    Nothing            -> (L.concat $ reverse $ ts : ps,L.empty)

-- The 44 keywords of the OBJ file format:
--
--      1      bevel
--      2      bmat
--      3      bsp
--      4      bzp
--      5      call
--      6      cdc
--      7      cdp
--      8      c_interp
--      9      con
--     10      csh
--     11      cstype
--     12      ctech
--     13      curv2
--     14      curv
--     15      deg
--     16      d_interp
--     17      end
--     18      f
--     19      g
--     20      hole
--     21      l
--     22      lod
--     23      maplib
--     24      mg
--     25      mtllib
--     26      o
--     27      p
--     28      parm
--     29      res
--     30      s
--     31      scrv
--     32      shadow_obj
--     33      sp
--     34      stech
--     35      step
--     36      surf
--     37      trace_obj
--     38      trim
--     39      usemap
--     40      usemtl
--     41      v
--     42      vn
--     43      vp
--     44      vt

nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString
nextToken tok bs = tok $ L.dropWhile (not . isSpace) bs

parseFloats tok bs cont = case L.splitAt 22 (tok bs) of
    (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of
        Just (x,b) -> parseFloats tok (reconsChunk b bs') (cont . (x :))
        Nothing    -> cont [] bs

parseFloatsN 0 _   bs cont = cont [] bs
parseFloatsN n tok bs cont = case L.splitAt 22 (tok bs) of
    (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of
        Just (x,b) -> parseFloatsN (n-1) tok (reconsChunk b bs') (cont . (x :))
        Nothing    -> cont [] bs

parseInts tok bs cont = case L.splitAt 5 (tok bs) of
    (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
        Just (x,b) -> parseInts tok (reconsChunk b bs') (cont . (x :))
        Nothing    -> cont [] bs

parseIntsN 0 tok bs cont = cont [] bs
parseIntsN n tok bs cont = case L.splitAt 5 (tok bs) of
    (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of
        Just (x,b) -> parseIntsN (n-1) tok (reconsChunk b bs') (cont . (x :))
        Nothing    -> cont [] bs

-- Optimize me
parseTriples :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([RefTriple] -> L.ByteString -> b) -> b
parseTriples tok bs cont = case L.splitAt 17 (tok bs) of
    (ds,bs') -> case I.readSigned I.readDecimal (L.toStrict ds) of

        Just (v,b) -> case S.splitAt 1 b of

            ("/",ds') -> case I.readSigned I.readDecimal ds' of

                Just (vt,c) -> case S.splitAt 1 c of
                    ("/",ds'') -> case I.readSigned I.readDecimal ds'' of
                        Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v (Just vt) (Just vn) :)
                        Nothing     -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v (Just vt) Nothing :)

                    _          -> parseTriples tok (reconsChunk c bs') $ cont . (RefTriple v (Just vt) Nothing :)

                Nothing -> case S.splitAt 1 ds' of
                    ("/",ds'') -> case I.readSigned I.readDecimal ds'' of
                        Just (vn,d) -> parseTriples tok (reconsChunk d bs') $ cont . (RefTriple v Nothing (Just vn) :)
                        Nothing     -> parseTriples tok (reconsChunk ds'' bs') $ cont . (RefTriple v Nothing Nothing :)

                    _          -> parseTriples tok (reconsChunk ds' bs') $ cont . (RefTriple v Nothing Nothing :)


            _         -> parseTriples tok (reconsChunk b bs') $ cont . (RefTriple v Nothing Nothing :)

        Nothing -> cont [] bs

parseCurveSpecs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b
parseCurveSpecs tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of
    (u0:u1:_) -> do
        parseIntsN 1 tok bs' $ \is bs'' -> case is of
            (i:_) -> parseCurveSpecs tok bs'' $ cont . (CurveSpec u0 u1 i :)
            _     -> cont [] bs''

    _ -> cont [] bs'


parseCurveSpecsN :: Int -> (L.ByteString -> L.ByteString) -> L.ByteString -> ([CurveSpec] -> L.ByteString -> b) -> b
parseCurveSpecsN 0 tok bs cont = cont [] bs
parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of
    (u0:u1:_) -> do
        parseIntsN 1 tok bs' $ \is bs'' -> case is of
            (i:_) -> parseCurveSpecsN (n-1) tok bs'' $ cont . (CurveSpec u0 u1 i :)
            _     -> cont [] bs''

    _ -> cont [] bs'

parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b
parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of
    (sref:_) -> do
        parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of
            (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :)
            _     -> cont [] bs''

    _ -> cont [] bs'

data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor
 deriving (Eq,Ord,Show,Enum)

data ParamSpec = ParamU | ParamV
 deriving (Eq,Ord,Show,Enum)

showParamSpec :: ParamSpec -> String
showParamSpec ParamU = "u"
showParamSpec ParamV = "v"

data RefTriple = RefTriple
        { refV :: {-# UNPACK #-} !Int
        , refT :: !(Maybe Int)
        , refN :: !(Maybe Int)
        }
-- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int)
 deriving (Eq,Ord,Show)

showRefTriple :: RefTriple -> String
showRefTriple (RefTriple v Nothing (Just n)) = show v ++ "//" ++ show n
showRefTriple (RefTriple v mt mn) = intercalate "/" $ map show
                                                    $ mappend [v]
                                                    $ maybe id (mappend . pure) mt
                                                    $ maybe id (mappend . pure) mn
                                                    $ []

data CurveSpec = CurveSpec
    { curveStart :: Double
    , curveEnd   :: Double
    , curveRef   :: Int
    }
 deriving (Eq,Ord,Show)

data EmbeddedCurve = EmbeddedCurve
    { curveSurfaceRef :: Int
    , embeddedCurve :: CurveSpec
    }
 deriving (Eq,Ord,Show)

showEmbeddedCurve :: EmbeddedCurve -> String
showEmbeddedCurve (EmbeddedCurve s c) = unwords
    [ show s
    , show (curveStart c)
    , show (curveEnd c)
    , show (curveRef c)
    ]

lengthLessThan :: Int -> L.ByteString -> Bool
lengthLessThan n bs =
    foldr (\c ret ac -> let m = S.length c in if ac <= m then False else ret $! ac - m)
          (const True)
          (L.toChunks bs)
          n

substVar :: ObjConfig -> L.ByteString -> L.ByteString
substVar _ mtl | L.take 1 mtl/="$" = mtl
substVar (ObjConfig args) mtl = case I.readDecimal (L.toStrict $ L.drop 1 mtl) of
    Just (i,_) -> case IntMap.lookup i args of
        Just val -> val
        Nothing  -> mtl
    Nothing -> mtl


parseOBJ :: Monad m => ObjBuilder m -> ObjConfig -> L.ByteString -> m ()
parseOBJ builder args bs0
    | lengthLessThan 2 bs = return ()
    | isSpace (L.index bs 1)  = case L.head bs of
        'f' -> parseT face 2
        'g' -> case findNewLine [] args $ L.drop 1 bs of -- Newline required to terminate group name list.
                (gn,bs') -> do
                    groups builder (map L.toStrict $ L.words gn)
                    parseOBJ builder args bs'
        'l' -> parseT line 2
        's' -> case next 1 bs of
                tok -> parseOffOrNumber tok $ \sg bs' -> do
                            smoothingGroup builder sg
                            parseOBJ builder args bs'
        'v' -> parseV vertex 2
        'o' -> -- o object-name
               case findNewLine [] args $ L.drop 1 bs of
                (objn,bs') -> do
                    objectName builder (L.toStrict objn)
                    parseOBJ builder args bs'
        'p' -> parseI points 2
        _   -> bad bs
    | otherwise = case L.take 2 bs of
        "vt" -> parseV vertexT 3
        "vn" -> parseV vertexN 3
        "vp" -> parseV vertexP 3
        "be" -> parseOF bevel 2 -- bevel
        "bm" -> parseUV (next 2 bs) $ \uv bs' -> do -- bmat
                    parseFloats (findToken args) bs' $ \vs bs'' -> do
                        bmat builder uv vs
                        parseOBJ builder args bs''

        "bs" -> parseI deprecated_bsp 4 -- bsp
        "bz" -> parseI deprecated_bzp 4 -- bzp
        "ca" -> -- call
                case findNewLine [] args $ next 2 bs of
                    (fnn,bs') -> do
                        let slurp fnn = case L.break (=='.') fnn of
                                (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
                                                                                 else [fn]
                                         | ".obj" <- L.take 4 ext ->
                                                if L.all isSpace (L.take 1 $ L.drop 4 ext)
                                                    then (fn <> ".obj") : slurpArgs (findToken args $ L.drop 4 ext)
                                                    else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
                                         | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
                                                        in (fn <> L.take 1 ext <> f) : fs
                            slurpArgs fnn | L.null fnn = []
                            slurpArgs fnn = case L.break isSpace fnn of
                                (a,as) -> findToken args a : slurpArgs as
                        case map L.toStrict $ slurpArgs fnn of
                            []    -> return ()
                            fn:as -> call builder fn as
                        parseOBJ builder args bs'

        "cd" -> if lengthLessThan 3 bs || L.index bs 2 /= 'p'
                    then parseI deprecated_cdc 4 -- cdc
                    else parseI deprecated_cdp 4 -- cdp
        "co" -> -- con
                parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do
                    equivalentCurves builder ss
                    parseOBJ builder args bs'
        "cs" -> if lengthLessThan 3 bs
                    then bad bs
                    else case L.index bs 2 of
                        'h' -> -- csh
                               let (dash,tok) = L.splitAt 1 $ next 3 bs
                                   wantsErrorCheck = dash /= "-"
                               in case findNewLine [] args tok of
                                (cmd,bs') -> do result <- command builder wantsErrorCheck cmd
                                                parseOBJ builder args $ result <> bs'
                        _ -> -- cstype
                             let parseRat = parseChar 'r'
                                 parseTyp tok cont | lengthLessThan 3 tok = bad tok
                                                   | otherwise = case L.index tok 2 of
                                    'a' -> cont Bmatrix  $ next 3 tok
                                    'z' -> cont Bezier   $ next 3 tok
                                    'p' -> cont Bspline  $ next 3 tok
                                    'r' -> cont Cardinal $ next 3 tok
                                    'y' -> cont Taylor   $ next 3 tok
                                    _   -> bad tok
                             in parseRat (next 2 bs) $ \isRat bs' -> do
                                    parseTyp bs' $ \typ bs'' -> do
                                        cstype builder isRat typ
                                        parseOBJ builder args bs''
        "ct" -> -- ctech
                let tok = next 2 bs
                in if lengthLessThan 2 tok
                    then bad tok
                    else case L.index tok 1 of
                        'p' -> -- cparm
                               parseFloats (findToken args) (next 2 tok) $ \is bs' -> do
                                    let x:_ = is ++ [0]
                                    ctech builder (UniformSubdivision x)
                                    parseOBJ builder args bs'
                        's' -> -- cspace
                               parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
                                    let x:_ = fs ++ [1.0]
                                    ctech builder (MaxLengthPolygonal x)
                                    parseOBJ builder args bs'
                        'u' -> -- curv
                               parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
                                    let δ:θ:_ = fs ++ repeat 1.0
                                    ctech builder (CurvatureBasedPolygon δ θ)
                                    parseOBJ builder args bs'
                        _   -> bad tok
        "cu" -> if lengthLessThan 5 bs
                    then bad bs
                    else if L.index bs 4 == '2'
                            then parseI curv2 5 -- curv2
                            else do -- curv
                                parseFloatsN 2 (findToken args) (L.drop 4 bs) $ \vs bs' ->
                                    parseInts (findToken args) bs' $ \is bs'' -> do
                                        let u0:v0:_ = vs ++ repeat 0.0
                                        curv builder u0 v0 is
                                        parseOBJ builder args bs''
        "c_" -> -- c_interp
                parseOF c_interp 2
        "de" -> parseI deg 3
        "d_" -> -- d_interp
                parseOF d_interp 2
        "en" -> do endFreeForm builder
                   parseOBJ builder args (next 2 bs)
        "lo" -> -- lod
                parseInts (findToken args) (next 2 bs) $ \is bs' -> do
                    let level:_ = is ++ [0]
                    lod builder level
                    parseOBJ builder args bs'
        "ho" -> -- hole
                parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
                    hole builder ss
                    parseOBJ builder args bs'
        "mg" -> case next 2 bs of
                tok -> parseOffOrNumber tok $ \mg bs' -> do
                            parseFloatsN 1 (findToken args) bs' $ \fs bs'' -> do
                                mergingGroup builder mg (head $ fs ++ [0])
                                parseOBJ builder args bs''
        "pa" -> parseUV (next 2 bs) $ \uv bs' -> do
                    parseFloats (findToken args) bs' $ \vs bs'' -> do
                       parm builder uv vs
                       parseOBJ builder args bs''
        "re" -> -- res (deprecated)
                parseI deprecated_res 3
        "sc" -> -- scrv
                parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
                    specialCurves builder ss
                    parseOBJ builder args bs'
        "sh" -> -- shadow_obj
                parseO shadow_obj 10
        "sp" -> parseI specialPoints 3
        "st" -> -- stech or step
                if lengthLessThan 4 bs then bad bs
                else case L.index bs 3 of
                  'c' ->
                    -- stech
                    let tok = next 2 bs
                    in if lengthLessThan 2 tok
                        then bad tok
                        else case L.index tok 1 of
                            'p' -> -- cparma/cparmb
                                   if lengthLessThan 6 tok
                                    then bad tok
                                    else if L.index tok 5 == 'b'
                                            then -- cparmb
                                               parseFloats (findToken args) (next 5 tok) $ \is bs' -> do
                                                    let x:_ = is ++ [0]
                                                    stech builder (UniformAfterTrimming x)
                                                    parseOBJ builder args bs'
                                            else -- cparma
                                               parseFloats (findToken args) (next 5 tok) $ \is bs' -> do
                                                    let x:y:_ = is ++ [0]
                                                    stech builder (UniformIsoparametric x y)
                                                    parseOBJ builder args bs'
                            's' -> -- cspace
                                   parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
                                        let x:_ = fs ++ [1.0]
                                        stech builder (MaxLengthPolytopal x)
                                        parseOBJ builder args bs'
                            'u' -> -- curv
                                   parseFloats (findToken args) (next 2 tok) $ \fs bs' -> do
                                        let δ:θ:_ = fs ++ repeat 1.0
                                        stech builder (CurvatureBasedPolytope δ θ)
                                        parseOBJ builder args bs'
                            _   -> bad tok

                  _   -> -- step
                         parseI step 4

        "su" -> -- surf
                parseFloatsN 4 (findToken args) (next 2 bs) $ \fs bs' -> do
                    parseTriples (findToken args) bs' $ \ts bs'' -> do
                        let u0:u1:v0:v1:_ = fs ++ repeat 0
                        surf builder u0 u1 v0 v1 ts
                        parseOBJ builder args bs''
        "tr" -> -- trip or trace_obj
                if lengthLessThan 3 bs
                    then bad bs
                    else case L.index bs 2 of
                    'a' -> -- trace_obj
                           parseO trace_obj 9
                    _   -> -- trim
                           parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
                                trim builder ss
                                parseOBJ builder args bs'
        "us" -> -- usemtl or usemap
                if lengthLessThan 5 bs
                    then bad bs
                    else case L.break isSpace $ next 2 bs of
                        (mtl0,bs') -> do
                            let mtl = substVar args mtl0
                            case L.index bs 4 of
                                'a' -> usemap builder $ if mtl == "off" then Nothing
                                                                        else Just (L.toStrict mtl)
                                _   -> usemtl builder (L.toStrict mtl)
                            parseOBJ builder args bs'
        "ma" -> -- maplib
                case findNewLine [] args $ next 2 bs of
                    (fnn,bs') -> do
                        let slurp fnn = case L.break (=='.') fnn of
                                (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
                                                                                 else [fn]
                                         | ext <- L.take 4 ext
                                           -- XXX What is the map library extension?
                                         , ext `elem` [".map",".mtl",".obj"] ->
                                                if L.all isSpace (L.take 1 $ L.drop 4 ext)
                                                    then (fn <> ext) : slurp (findToken args $ L.drop 4 ext)
                                                    else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
                                         | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
                                                        in (fn <> L.take 1 ext <> f) : fs
                        maplib builder (map L.toStrict $ slurp fnn)
                        parseOBJ builder args bs'
        "mt" -> -- mtllib
                case findNewLine [] args $ next 2 bs of
                    (fnn,bs') -> do
                        let slurp fnn = case L.break (=='.') fnn of
                                (fn,ext) | L.null (L.drop 1 ext) -> if L.null fn then []
                                                                                 else [fn]
                                         | ".mtl" <- L.take 4 ext ->
                                                if L.all isSpace (L.take 1 $ L.drop 4 ext)
                                                    then (fn <> ".mtl") : slurp (findToken args $ L.drop 4 ext)
                                                    else let f:fs = slurp (L.drop 3 ext) in (fn <> L.take 3 ext <> f) : fs
                                         | otherwise -> let (f:fs) = slurp (L.drop 1 ext)
                                                        in (fn <> L.take 1 ext <> f) : fs
                        mtllib builder (map L.toStrict $ slurp fnn)
                        parseOBJ builder args bs'
        _    -> bad bs
    where
        bs = findToken args bs0
        bad bs = case findNewLine [] args bs of
            (x,bs') -> do badToken builder x
                          parseOBJ builder args bs'
        next n xs = nextToken (findToken args) $ L.drop n xs
        parseChar c tok cont = case L.uncons tok of
                        Just (x,cs) | x==c -> cont True $ next 0 cs
                        _                  -> cont False tok
        parseO build n = case findNewLine [] args $ L.drop n bs of
            (fn,bs') -> do
                build builder $ sanitizeOBJFilename fn
                parseOBJ builder args bs'
        parseUV tok cont = parseChar 'u' tok $ \isU bs' -> do
            cont (if isU then ParamU else ParamV)
                 (if isU then bs' else L.drop 1 bs')
        parseV build n = do
                parseFloats (findToken args) (L.drop n bs) $ \vs bs' -> do
                build builder vs
                parseOBJ builder args bs'
        parseI build n = do
                parseInts (findToken args) (L.drop n bs) $ \vs bs' -> do
                build builder vs
                parseOBJ builder args bs'
        parseT build n = do
                parseTriples (findToken args) (L.drop n bs) $ \vs bs' -> do
                build builder vs
                parseOBJ builder args bs'
        parseOffOrNumber tok cont = parseIntsN 1 (findToken args) tok $ \is bs' -> do
            let (sg,bs'') = case is of
                        (i:_)                    -> (i,bs')
                        _ | lengthLessThan 2 tok -> (0,tok)
                        _                        -> (if L.index tok 1 == 'f' then 0 else 1, next 1 tok)
            cont sg bs''
        parseOF build n =
                let tok = findToken args (next n bs)
                in if lengthLessThan 2 tok
                    then bad tok
                    else let flag = case L.index tok 1 of
                                    'f' -> build builder False -- off
                                    _   -> build builder True  -- on
                          in parseOBJ builder args (next 2 tok)


sanitizeOBJFilename :: L.ByteString -> S.ByteString
sanitizeOBJFilename fn = case S.breakEnd isSpace $ L.toStrict $ L.dropWhile isSpace fn of
    (stripped,_) -> case S.breakEnd (=='.') stripped of
        (basename,ext) | S.null basename -> ext <> ".obj"
                       | otherwise       -> stripped