* OpenAFP is now converted to use Data.Binary; most things are now pure!

Makefile

@@ -3,7 +3,7 @@ all :: dist/build/libHSOpenAFP-1.0.a binaries
 ghci ::
 	ghci -isrc src/OpenAFP.hs
 
-binaries :: afp-validate afp-udcfix afp-replace afp-dump
+binaries :: afp-validate afp-replace afp-dump
 
 afp-validate ::
 	ghc -H128m --make -static -o afp-validate -O bin/afp-validate.hs

OpenAFP.cabal

@@ -84,7 +84,7 @@ exposed-modules:    OpenAFP.Internals.Binary OpenAFP.Internals.Ebc2Asc
 category:           Data
 includes:           unicode/ucnv.h
 extensions:         CPP, ForeignFunctionInterface
-build-depends:      base, mtl, haskell98, regex-compat, directory, process
+build-depends:      base, mtl, haskell98, regex-compat, directory, process, array, containers, binary, bytestring
 include-dirs:       /usr/include /usr/local/include /opt/local/include
 extra-lib-dirs:     /usr/lib /usr/local/lib /opt/local/lib
 ld-options:         -licuuc

bin/afp-page.hs

@@ -2,7 +2,7 @@
 
 module Main where
 import OpenAFP
-import Data.ByteString as B (findIndex)
+import Data.ByteString as S (findIndex, take, drop)
 import Data.ByteString.Internal (fromForeignPtr)
 import System.Exit
 
@@ -14,8 +14,6 @@ main = do
     let outputFile = case args of
             (_:fn:_)    -> fn
             _           -> "output.afp"
-    fh  <- openBinaryFile outputFile WriteMode
-    bh  <- openBinIO_ fh
     cs' <- cs !==>!
         [ _MCF === (`filterChunks`
             [ _MCF_T === (`filterChunks`
@@ -29,8 +27,7 @@ main = do
             , _PTX_SCFL ... io . writeIORef currentFont
             ])
         ]
-    put bh cs'
-    hClose fh
+    writeAFP outputFile cs'
 
 cs !==>! list = iter cs
     where
@@ -49,8 +46,7 @@ trnHandler trn = do
     scanTrn 0 0 Nil
     io $ touchForeignPtr pstr'
     where
-    (pstr, len) = bufToPStrLen $ ptx_trn trn
-    bs          = fromForeignPtr pstr' 0 len
+    bs@(PS pstr off len) = bufToPStrLen $ ptx_trn trn
     isDBCS 0x40 = Nil
     isDBCS ch   = if (ch >= 0x41 && ch <= 0x7F) then DBCS else SBCS
 
@@ -69,7 +65,7 @@ trnHandler trn = do
     isPunctuation _    = False
 
     pstr'       = castForeignPtr pstr
-    cstr        = unsafeForeignPtrToPtr pstr'
+    cstr        = unsafeForeignPtrToPtr pstr' `plusPtr` off
     scanTrn i prev mode = {-# SCC "scanTrn" #-} do
         if i == len
             then case mode of
@@ -105,14 +101,13 @@ trnHandler trn = do
                     _       -> emit >> scanTrn (i+1) i SBCS
         where
         emit = {-# SCC "emit" #-} do
-            fptr    <- io $ newForeignPtr_ (cstr `plusPtr` prev)
             scfl    <- io $ readIORef currentFont
-            let curTRN = trn{ ptx_trn = bufFromPStrLen (fptr, i - prev) }
+            let curTRN = trn{ ptx_trn = bufFromPStrLen (S.take (i-prev) (S.drop prev bs)) }
             case mode of
                 SBCS    -> do
                     push scfl
                     push curTRN
-                DBCS | prev > 0 || i /= len || isJust (B.findIndex (not . isPunctuation) bs) -> do
+                DBCS | prev > 0 || i /= len || isJust (S.findIndex (not . isPunctuation) bs) -> do
                     c <- io $ readIORef cnt  
                     push scfl{ ptx_scfl = if c >= 35 then 36 else 1 }
                     push curTRN
@@ -138,8 +133,8 @@ cnt = unsafePerformIO (newIORef 0)
 fqnHandler fqn = do
     c <- io $ readIORef cnt  
     let fqn' = case c of
-            0  -> fqn{ t_fqn = toA8 "T0XXXX" }
-            35 -> fqn{ t_fqn = toA8 "T0XXXX" }
+            0  -> fqn{ t_fqn = toAStr "T0XXXX" }
+            35 -> fqn{ t_fqn = toAStr "T0XXXX" }
             _  -> fqn
     push fqn'
     return ()

bin/afp2line.hs

@@ -81,7 +81,7 @@ mcfHandler r = do
             let cs = readChunks mcf
             ids   <- sequence [ t_rli `applyToChunk` c | c <- cs, c ~~ _T_RLI ]
             fonts <- sequence [ t_fqn `applyToChunk` c | c <- cs, c ~~ _T_FQN ]
-            insertFonts (ids `zip` map fromA8 fonts)
+            insertFonts (ids `zip` map fromAStr fonts)
         ]
 
 
@@ -146,23 +146,19 @@ ptxGroupDump (scfl:cs) = do
                 ]
 
 packAStr :: AStr -> IO B.ByteString
-packAStr astr = do
-    let (pstr, len) = bufToPStrLen astr 
-    withForeignPtr (castForeignPtr pstr) $ \cstr -> do
-        fmap (B.map (ebc2ascWord !)) (B.packCStringLen (cstr, len))
+packAStr astr = return $ B.map (ebc2ascWord !) (packBuf astr)
 
 pack835 :: NStr -> IO B.ByteString
-pack835 nstr = do
-    let (pstr, len) = bufToPStrLen nstr 
-    withForeignPtr (castForeignPtr pstr) $ \cstr -> do
-        forM_ [0..(len `div` 2)-1] $ \i -> do
-            hi  <- peekElemOff cstr (i*2)   :: IO Word8
-            lo  <- peekElemOff cstr (i*2+1) :: IO Word8
-            let cp950       = convert835to950 (fromEnum hi * 256 + fromEnum lo)
-                (hi', lo')  = cp950 `divMod` 256
-            pokeElemOff cstr (i*2)   (toEnum hi')
-            pokeElemOff cstr (i*2+1) (toEnum lo')
-        B.packCStringLen (castPtr cstr, len)
+pack835 nstr = B.useAsCStringLen (packBuf nstr) $ \(cstr', len) -> do
+    let cstr = castPtr cstr'
+    forM_ [0..(len `div` 2)-1] $ \i -> do
+        hi  <- peekElemOff cstr (i*2)       :: IO Word8
+        lo  <- peekElemOff cstr (i*2+1)     :: IO Word8
+        let cp950       = convert835to950 (fromEnum hi * 256 + fromEnum lo)
+            (hi', lo')  = cp950 `divMod` 256
+        pokeElemOff cstr (i*2)   (toEnum hi' :: Word8)
+        pokeElemOff cstr (i*2+1) (toEnum lo' :: Word8)
+    B.packCStringLen (castPtr cstr, len)
 
 ebc2ascWord :: UArray Word8 Word8
 ebc2ascWord = listArray (0x00, 0xff) [

src/OpenAFP.hs

@@ -25,7 +25,7 @@ module OpenAFP (
     module OpenAFP.Prelude.Instances,
     module OpenAFP.Internals.UConv,
 
-    readAFP, writeAFP, filterAFP,
+    readAFP, writeAFP, -- filterAFP,
     readArgs, afp_Chunks,
 ) where
 import OpenAFP.Types
@@ -36,19 +36,18 @@ import OpenAFP.Prelude.Utils
 import OpenAFP.Prelude.Lookups
 import OpenAFP.Prelude.Instances
 import OpenAFP.Prelude.Exts
+import qualified Data.ByteString.Lazy as L
 
 afp_Chunks :: FilePath -> [AFP_]
 afp_Chunks filename = unsafePerformIO $ readAFP filename
 
 writeAFP :: (Binary a) => FilePath -> [a] -> IO ()
 writeAFP "-" c = do
     hSetBinaryMode stdout True
-    openBinIO_ stdout >>= (`put` c)
-writeAFP filename c = do
-    fh  <- openBinaryFile filename WriteMode
-    openBinIO_ fh >>= (`put` c)
-    hClose fh
+    L.hPut stdout (encodeList c)
+writeAFP filename c = encodeListFile filename c
 
+{-
 filterAFP :: FilePath -> FilePath -> [(ChunkType, AFP_ -> IO [AFP_])] -> IO ()
 filterAFP input output filters = do
     ifh  <- openBinaryFile input ReadMode
@@ -75,6 +74,7 @@ filterChunk c possibleFilters bh
     where
 	filters = filter (\(t, _) -> (t == chunkType c)) possibleFilters
 
+-}
 instance RecChunk FilePath AFP_ N3 Buffer2 where
     readChunks = afp_Chunks
 
@@ -83,11 +83,8 @@ instance Rec Char
 readAFP :: (MonadIO m) => FilePath -> m [AFP_]
 readAFP "-" = io $ do
     hSetBinaryMode stdin True
-    openBinIO_ stdin >>= get
-
-readAFP filename = io $ do
-    fh  <- openBinaryFile filename ReadMode
-    openBinIO_ fh >>= get
+    fmap decodeList (L.hGetContents stdin)
+readAFP filename = io $ decodeListFile filename
 
 readArgs :: (MonadIO m) => Int -> m [String]
 readArgs n = io $ do

src/OpenAFP/Internals.hs

@@ -18,7 +18,7 @@
 module OpenAFP.Internals (
     module X,
 
-    IOm, StateIO,
+    IOm, StateIO, BS,
 
     hashNew, hashLookup, hashInsert, hashDelete,
     stateGet, statePut
@@ -67,12 +67,17 @@ import GHC.IOBase                as X (IOArray, newIOArray, readIOArray, writeIO
 import qualified Control.Monad.RWS (get, put)
 import qualified Control.Monad.State (MonadState)
 import qualified Data.HashTable (lookup, insert, delete, new)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
 
 hashNew     = Data.HashTable.new
 hashLookup  = Data.HashTable.lookup
 hashInsert  = Data.HashTable.insert
 hashDelete  = Data.HashTable.delete
 
+type BS = S.ByteString
+type BL = L.ByteString
+
 stateGet :: (Control.Monad.State.MonadState s m) => m s
 stateGet = Control.Monad.RWS.get
 statePut :: (Control.Monad.State.MonadState s m) => s -> m ()