crayne parser: shadow_obj and trace_obj

1 files changed, 29 insertions, 7 deletions

diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index 208e5bf..6378d08 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -46,6 +46,8 @@ data ObjBuilder m = ObjBuilder
     , maplib           :: [S.ByteString] -> m ()
     , c_interp         :: Bool -> m ()
     , d_interp         :: Bool -> m ()
+    , trace_obj        :: S.ByteString -> m ()
+    , shadow_obj       :: S.ByteString -> m ()
     , badToken         :: L.ByteString -> m ()
     }
 
@@ -85,6 +87,8 @@ nullBuilder = ObjBuilder
     , maplib           = \fns            -> pure ()
     , c_interp         = \b              -> pure ()
     , d_interp         = \b              -> pure ()
+    , trace_obj        = \obj            -> pure ()
+    , shadow_obj       = \obj            -> pure ()
     , badToken         = \bs             -> pure ()
     }
 
@@ -202,12 +206,12 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' ||
     28  x   res
     29      s
     30      scrv
-    31  x   shadow_obj
+    31      shadow_obj
     32      sp
     33      stech -- for all except these,
     34      step  -- Two chars suffice to distinguish
     35      surf
-    36  x   trace_obj -- for all except these,
+    36      trace_obj -- for all except these,
     37      trim      -- Two chars suffice to distinguish
     38      usemap -- for all except these,
     39      usemtl -- Two chars suffice to distinguish
@@ -460,6 +464,8 @@ parseOBJ builder args bs0
                 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
@@ -505,10 +511,16 @@ parseOBJ builder args bs0
                         let u0:u1:v0:v1:_ = fs ++ repeat 0
                         surf builder u0 u1 v0 v1 ts
                         parseOBJ builder args bs''
-        "tr" -> -- trim
-                parseCurveSpecs (findToken args) (next 2 bs) $ \ss bs' -> do
-                    trim builder ss
-                    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
@@ -554,13 +566,17 @@ parseOBJ builder args bs0
         _    -> bad bs
     where
         bs = findToken args bs0
-        bad bs = case L.break (=='\n') bs of
+        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')
@@ -582,3 +598,9 @@ parseOBJ builder args bs0
                         _ | lengthLessThan 2 tok -> (0,tok)
                         _                        -> (if L.index tok 1 == 'f' then 0 else 1, next 1 tok)
             cont sg bs''
+
+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