From 95f7c67b576f4e1ae897ea010da90d406681f018 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 14 Jun 2019 16:13:32 -0400 Subject: crayne parser: l command and Rank2.Functor instance. --- src/Wavefront/Lex.hs | 103 +++++++++++++++++++++++++++++++++++++++------------ wavefront-obj.cabal | 1 + 2 files changed, 80 insertions(+), 24 deletions(-) diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs index 501549f..7123184 100644 --- a/src/Wavefront/Lex.hs +++ b/src/Wavefront/Lex.hs @@ -10,6 +10,7 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.ByteString.Lex.Fractional as F import Data.ByteString.Lex.Integral as I +import qualified Rank2 data ObjBuilder m = ObjBuilder { vertex :: [Double] -> m () @@ -17,6 +18,7 @@ data ObjBuilder m = ObjBuilder , vertexN :: [Double] -> m () , vertexP :: [Double] -> m () , face :: [RefTriple] -> m () + , line :: [RefTriple] -> m () , cstype :: Bool -> CSType -> m () , curv2 :: [Int] -> m () , curv :: Double -> Double -> [Int] -> m () @@ -58,6 +60,56 @@ data ObjBuilder m = ObjBuilder , 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 => m () -> ObjBuilder m nullBuilder def = ObjBuilder { vertex = \vs -> def @@ -65,6 +117,7 @@ nullBuilder def = ObjBuilder , vertexN = \vs -> def , vertexP = \vs -> def , face = \is -> def + , line = \is -> def , cstype = \isRat typ -> def , curv2 = \is -> def , curv = \u0 v0 is -> def @@ -188,7 +241,7 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || else ds Nothing -> (L.concat $ reverse $ ts : ps,L.empty) --- The 43 keywords of the OBJ file format: +-- The 44 keywords of the OBJ file format: -- -- 1 bevel -- 2 bmat @@ -210,29 +263,30 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || -- 18 f -- 19 g -- 20 hole --- 21 lod --- 22 maplib --- 23 mg --- 24 mtllib --- 25 o --- 26 p --- 27 parm --- 28 res --- 29 s --- 30 scrv --- 31 shadow_obj --- 32 sp --- 33 stech --- 34 step --- 35 surf --- 36 trace_obj --- 37 trim --- 38 usemap --- 39 usemtl --- 40 v --- 41 vn --- 42 vp --- 43 vt +-- 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 @@ -368,6 +422,7 @@ parseOBJ builder args bs0 (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 diff --git a/wavefront-obj.cabal b/wavefront-obj.cabal index b5cd8df..1ccbc91 100644 --- a/wavefront-obj.cabal +++ b/wavefront-obj.cabal @@ -89,6 +89,7 @@ library , bytestring , bytestring-lexing , pretty-show + , rank2classes hs-source-dirs: src default-language: Haskell2010 -- cgit v1.2.3