Update HPDF library to latest compiler

Graphics/PDF/Draw.hs

@@ -252,9 +252,11 @@ pdfDictMember k (PDFDictionary d)  = M.member k d
 -- | Get a new resource name
 supplyName :: Draw String
 supplyName = do
-    (x:xs) <- gets supplyNames
-    modifyStrict $ \s -> s {supplyNames = xs}
-    return x
+    xs <- gets supplyNames
+    modifyStrict $ \s -> s {supplyNames = tail xs}
+    if xs == []
+        then return ""
+        else return (head xs)
 
 emptyDrawState :: Int -> DrawState
 emptyDrawState ref = 

Graphics/PDF/Fonts/AFMParser.hs

@@ -23,22 +23,15 @@ module Graphics.PDF.Fonts.AFMParser(
     ) where 
 
 import Text.ParserCombinators.Parsec hiding(space)
-import Text.ParserCombinators.Parsec.Prim
-import Text.ParserCombinators.Parsec.Char hiding(space)
 import Text.Parsec(modifyState,getState)
 import Text.Parsec.Prim(parserZero)
 import Data.Char(toUpper)
-import System.Environment
-import Data.Maybe(isJust,fromJust,mapMaybe)
-import qualified Data.IntMap as IM
-import Data.List(intersperse)
 import qualified Data.Map.Strict as M
 import Graphics.PDF.Fonts.Font(emptyFontStructure)
 import Paths_HPDF
 import Graphics.PDF.LowLevel.Types
 import Graphics.PDF.Fonts.Encoding(PostscriptName)
 import Graphics.PDF.Fonts.FontTypes
-import Control.Monad.State
 
 data Metric = Metric { charCode :: Int
                      , metricWidth :: Int
@@ -74,6 +67,7 @@ data AFMFont = AFMFont { metrics :: [Metric]
 
 type AFMParser = GenParser Char AFMFont
 
+emptyAFM :: AFMFont
 emptyAFM = AFMFont { metrics = []
                    , underlinePosition = 0
                    , underlineThickness = 0
@@ -95,11 +89,11 @@ capitalize (h:t) = toUpper h : t
 
 
 line :: AFMParser ()
-line = do string "\r\n" <|> string "\n"
+line = do _ <- string "\r\n" <|> string "\n"
           return ()
 
 toEndOfLine :: AFMParser ()
-toEndOfLine = do many (noneOf "\r\n")
+toEndOfLine = do _ <- many (noneOf "\r\n")
                  line
                  return ()
 
@@ -109,22 +103,21 @@ getString = do
   line
   return c
 
-getSentence :: AFMParser String
-getSentence = do 
-               c <- many1 (alphaNum <|> oneOf " -+")
-               line
-               return c
+-- getSentence :: AFMParser String
+-- getSentence = do 
+--                c <- many1 (alphaNum <|> oneOf " -+")
+--                line
+--                return c
 
 
-getName :: AFMParser String
-getName = do 
-              c <- alphaNum >> many (alphaNum <|> oneOf " -+")
-              line
-              return c
+-- getName :: AFMParser String
+-- getName = do 
+--               c <- alphaNum >> many (alphaNum <|> oneOf " -+")
+--               line
+--               return c
 
 getInt :: AFMParser Int
-getInt  = do c <- getString
-             return $ read c
+getInt  = read <$> getString
 
 getFloat :: AFMParser Double
 getFloat = do 
@@ -133,8 +126,7 @@ getFloat = do
                 return $ read c
 
 getBool :: AFMParser Bool
-getBool = do c <- getString
-             return $ read (capitalize c)
+getBool = read . capitalize <$> getString
 
 data CharacterSet = ExtendedRoman
                   | Special
@@ -145,15 +137,12 @@ data Weight = Medium
             | Roman
             deriving(Eq,Read,Show)
 
-getCharacterSet :: AFMParser CharacterSet
-getCharacterSet = do c <- getString
-                     return $ read c
+-- getCharacterSet :: AFMParser CharacterSet
+-- getCharacterSet = read <$> getString
 
-getWeigth :: AFMParser Weight
-getWeigth = do c <- getString
-               return $ read c
-
-
+-- getWeigth :: AFMParser Weight
+-- getWeigth = read <$> getString
+
 array :: AFMParser [String]  
 array = sepEndBy (many1 (oneOf "-+0123456789")) (many1 (oneOf " "))
 
@@ -184,40 +173,36 @@ data Elem = C Int
           deriving(Eq,Read,Show)    
 
 metricElem :: AFMParser Elem
-metricElem  = do char 'C'
+metricElem  = do _ <- char 'C'
                  spaces
-                 c <- number 
-                 return $ C c
+                 C <$> number 
               <|>
-              do string "WX"
+              do _ <- string "WX"
                  spaces
-                 c <- number   
-                 return $ WX c
+                 WX <$> number 
               <|> 
-              do char 'N'
+              do _ <- char 'N'
                  spaces
                  c <- many1 (alphaNum <|> char '.')
                  return $ N c
               <|>
-              do char 'B'
+              do _ <- char 'B'
                  spaces
                  c <- array
                  return . B . map read $ c   
               <|> 
-              do char 'L'
+              do _ <- char 'L'
                  spaces
-                 many1 letter
+                 _ <- many1 letter
                  spaces
-                 many1 letter
+                 _ <- many1 letter
                  return L
-
-
-
-isEncoded :: Metric -> Bool
-isEncoded (Metric c _ _ _) = c /= (-1)                  
+
+-- isEncoded :: Metric -> Bool
+-- isEncoded (Metric c _ _ _) = c /= (-1)                  
 
 mkMetric :: [Elem] -> Metric
-mkMetric l = foldr addElem (Metric (-1) 0 "" []) l     
+mkMetric = foldr addElem (Metric (-1) 0 "" [])  
  where
      addElem  (C c) m = m {charCode=c}
      addElem  (WX c) m = m {metricWidth=c}
@@ -234,7 +219,7 @@ charMetric = do
 
 
 kernPair :: AFMParser KX
-kernPair = do string "KPX"
+kernPair = do _ <- string "KPX"
               spaces
               namea <- many1 alphaNum
               spaces
@@ -248,20 +233,20 @@ kernPair = do string "KPX"
 
 keyword :: String -> AFMParser () -> AFMParser () 
 keyword s action = do 
-  string s
+  _ <- string s
   spaces
   action
   return ()
 
-anyKeyWord :: AFMParser () 
-anyKeyWord = do 
-  many1 alphaNum
-  spaces 
-  toEndOfLine
+-- anyKeyWord :: AFMParser () 
+-- anyKeyWord = do 
+--   _ <- many1 alphaNum
+--   spaces 
+--   toEndOfLine
 
 header :: String -> AFMParser () 
 header s = do 
-  string s  
+  _ <- string s  
   toEndOfLine 
   return ()
 
@@ -275,16 +260,16 @@ notHeader s = do
       toEndOfLine
 
 specific :: AFMParser () 
-specific = choice [ try $ keyword "FontName" (getString >>= \name -> modifyState $ \afm -> afm {type1BaseFont = name}) 
-                  , try $ keyword "UnderlinePosition" (getInt >>= \name -> modifyState $ \afm -> afm {underlinePosition = name}) 
-                  , try $ keyword "UnderlineThickness" (getInt >>= \name -> modifyState $ \afm -> afm {underlineThickness = name})
-                  , try $ keyword "EncodingScheme" (getEncoding >>= \name -> modifyState $ \afm -> afm {encodingScheme = name})
-                  , try $ keyword "CapHeight" (getInt >>= \name -> modifyState $ \afm -> afm {afmCapHeight = name}) 
-                  , try $ keyword "Ascender" (getInt >>= \name -> modifyState $ \afm -> afm {afmAscent = name})
-                  , try $ keyword "Descender" (getInt >>= \name -> modifyState $ \afm -> afm {afmDescent = name}) 
-                  , try $ keyword "ItalicAngle" (getFloat >>= \name -> modifyState $ \afm -> afm {afmItalic = name}) 
-                  , try $ keyword "IsFixedPitch" (getBool >>= \name -> modifyState $ \afm -> afm {afmFixedPitch = name}) 
-                  , try $ keyword "FontBBox" (getArray >>= \name -> modifyState $ \afm -> afm {afmBBox = name}) 
+specific = choice [ try $ keyword "FontName" (getString >>= \name' -> modifyState $ \afm' -> afm' {type1BaseFont = name'}) 
+                  , try $ keyword "UnderlinePosition" (getInt >>= \name' -> modifyState $ \afm' -> afm' {underlinePosition = name'}) 
+                  , try $ keyword "UnderlineThickness" (getInt >>= \name' -> modifyState $ \afm' -> afm' {underlineThickness = name'})
+                  , try $ keyword "EncodingScheme" (getEncoding >>= \name' -> modifyState $ \afm' -> afm' {encodingScheme = name'})
+                  , try $ keyword "CapHeight" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmCapHeight = name'}) 
+                  , try $ keyword "Ascender" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmAscent = name'})
+                  , try $ keyword "Descender" (getInt >>= \name' -> modifyState $ \afm' -> afm' {afmDescent = name'}) 
+                  , try $ keyword "ItalicAngle" (getFloat >>= \name' -> modifyState $ \afm' -> afm' {afmItalic = name'}) 
+                  , try $ keyword "IsFixedPitch" (getBool >>= \name' -> modifyState $ \afm' -> afm' {afmFixedPitch = name'}) 
+                  , try $ keyword "FontBBox" (getArray >>= \name' -> modifyState $ \afm' -> afm' {afmBBox = name'}) 
                   , try $ notHeader "StartCharMetrics"
                   ]
 
@@ -302,32 +287,32 @@ afm :: AFMParser AFMFont
 afm = 
   do  
     header "StartFontMetrics"
-    many1 specific 
+    _ <- many1 specific 
     header "StartCharMetrics"
     charMetrics <- many1 charMetric
     header "EndCharMetrics"
     kerns <- option Nothing getKernData
-    string "EndFontMetrics"
+    _ <- string "EndFontMetrics"
 
-    modifyState $ \afm -> afm { metrics = charMetrics 
-                              , kernData = kerns
-                              }
+    modifyState $ \afm' -> afm' { metrics = charMetrics 
+                                , kernData = kerns
+                                }
 
-    afm <- getState 
-    let [xmin,ymin,xmax,ymax] = afmBBox afm
-    if afmAscent afm == 0 
+    afm' <- getState 
+    let [_,ymin,_,ymax] = afmBBox afm'
+    if afmAscent afm' == 0 
     then
-       if afmCapHeight afm /= 0 
+       if afmCapHeight afm' /= 0 
           then
-              return $ afm { afmAscent = afmCapHeight afm
-                           }
+              return $ afm' { afmAscent = afmCapHeight afm'
+                            }
           else
               let h = floor (ymax - ymin) in
-              return $ afm { afmAscent = h 
-                           , afmDescent = 0 
-                           }
+              return $ afm' { afmAscent = h 
+                            , afmDescent = 0 
+                            }
     else
-       return $ afm
+       return $ afm'
 
 addMetric :: M.Map PostscriptName GlyphCode -> Metric -> FontStructure -> FontStructure 
 addMetric nameToGlyph m fs = 
@@ -359,39 +344,39 @@ fontToStructure :: AFMFont
                 -> M.Map PostscriptName Char 
                 -> Maybe (M.Map PostscriptName GlyphCode)
                 -> FontStructure 
-fontToStructure afm encoding maybeMapNameToGlyph =
-  let h = (afmAscent afm - afmDescent afm) 
-      fs = emptyFontStructure { descent = fromIntegral $ - (afmDescent afm)
+fontToStructure afm' encoding' maybeMapNameToGlyph =
+  let h = (afmAscent afm' - afmDescent afm') 
+      fs = emptyFontStructure { descent = fromIntegral $ - (afmDescent afm')
                               , height = fromIntegral $ h 
-                              , ascent = fromIntegral $ afmAscent afm
-                              , fontBBox = afmBBox afm
-                              , italicAngle = afmItalic afm
-                              , capHeight = fromIntegral $ afmCapHeight afm
-                              , fixedPitch = afmFixedPitch afm
+                              , ascent = fromIntegral $ afmAscent afm'
+                              , fontBBox = afmBBox afm'
+                              , italicAngle = afmItalic afm'
+                              , capHeight = fromIntegral $ afmCapHeight afm'
+                              , fixedPitch = afmFixedPitch afm'
                               , serif = False
-                              , symbolic = afmSymbolic afm
+                              , symbolic = afmSymbolic afm'
                               , script = False
-                              , nonSymbolic = not (afmSymbolic afm)
+                              , nonSymbolic = not (afmSymbolic afm')
                               , italic = False
                               , allCap = False
                               , smallCap = False
                               , forceBold = False
-                              , baseFont = type1BaseFont afm
+                              , baseFont = type1BaseFont afm'
                               }
       addName m d | charCode m == -1 = d
                   | otherwise = M.insert (name m) (fromIntegral $ charCode m) d 
-      nameToGlyph = maybe (foldr addName M.empty (metrics afm)) id maybeMapNameToGlyph
-      fs1 = foldr (addMetric nameToGlyph) fs (metrics afm)
+      nameToGlyph = maybe (foldr addName M.empty (metrics afm')) id maybeMapNameToGlyph
+      fs1 = foldr (addMetric nameToGlyph) fs (metrics afm')
       addEncodingMapping (pname,glyphcode) d = 
-         let unicodeM = M.lookup pname encoding 
+         let unicodeM = M.lookup pname encoding' 
          in 
          case unicodeM of 
           Nothing -> d 
           Just code -> M.insert code glyphcode d 
       mapping = foldr addEncodingMapping M.empty (M.toList nameToGlyph)
       fs2 = fs1 { encoding = mapping}
   in
-  case kernData afm of
+  case kernData afm' of
     Nothing -> fs2
     Just k -> foldr (addKern nameToGlyph) fs2 k
 
@@ -406,21 +391,21 @@ parseFont (Left s) = do
     r <- afmParseFromFile afm path
     case r of
       Left e -> error (show e)
-      Right r -> return $ Just r
+      Right r' -> return $ Just r'
 parseFont (Right path) = do
     r <- afmParseFromFile afm path
     case r of
       Left e -> error (show e)
-      Right r -> return $ Just r
+      Right r' -> return $ Just r'
 
 getFont :: Either String AFMFont
         -> M.Map PostscriptName Char  -- ^ Glyph name to unicode
         -> Maybe (M.Map PostscriptName GlyphCode)  -- ^ Glyph name to glyph code if not standard coding
         -> IO (Maybe FontStructure)
-getFont (Left s) encoding nameToGlyph = do 
+getFont (Left s) encoding' nameToGlyph = do 
   result <- parseFont (Left s) 
   case result of 
     Nothing -> return Nothing 
-    Just r -> return (Just $ fontToStructure r encoding nameToGlyph)
-getFont (Right result) encoding nameToGlyph = return . Just $ fontToStructure result encoding nameToGlyph
+    Just r -> return (Just $ fontToStructure r encoding' nameToGlyph)
+getFont (Right result) encoding' nameToGlyph = return . Just $ fontToStructure result encoding' nameToGlyph