From 2fb2b76a7ec0f9f977c2a7c4db1c7117920d9cb4 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 14 Dec 2022 15:13:23 +1300
Subject: [PATCH] Expose convenience APIs for coercing values & pattern
 properties to a type.

---
 Graphics/Text/Font/Choose/Pattern.hs |  4 +++-
 Graphics/Text/Font/Choose/Value.hs   | 27 ++++++++++++++++++++++++++-
 2 files changed, 29 insertions(+), 2 deletions(-)

diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs
index 5e328cd..c26580e 100644
--- a/Graphics/Text/Font/Choose/Pattern.hs
+++ b/Graphics/Text/Font/Choose/Pattern.hs
@@ -3,7 +3,7 @@ module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
     normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
     Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer,
 
-    setValue, setValues, unset,
+    setValue, setValues, unset, getValue, getValue0,
     parseFontFamily, parseFontFeatures, parseFontVars, parseLength,
     parseFontStretch, parseFontWeight) where
 
@@ -49,6 +49,8 @@ setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat
 getValue :: String -> Pattern -> Value
 getValue key pat | Just ((_, ret):_) <- lookup key pat = ret
     | otherwise = ValueVoid
+getValue0 :: ToValue x => String -> Pattern -> x
+getValue0 key pat = fromValue' $ getValue key pat
 
 unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]
 
diff --git a/Graphics/Text/Font/Choose/Value.hs b/Graphics/Text/Font/Choose/Value.hs
index 22d4a02..8591bd2 100644
--- a/Graphics/Text/Font/Choose/Value.hs
+++ b/Graphics/Text/Font/Choose/Value.hs
@@ -8,6 +8,7 @@ import Graphics.Text.Font.Choose.CharSet (CharSet, withCharSet, thawCharSet)
 import FreeType.Core.Base (FT_Face(..))
 import Graphics.Text.Font.Choose.LangSet (LangSet, withLangSet, thawLangSet)
 import Graphics.Text.Font.Choose.Range (Range, withRange, thawRange)
+import Control.Exception (throw)
 
 import Foreign.Ptr (Ptr, castPtr)
 import Foreign.Storable (Storable(..))
@@ -17,7 +18,7 @@ import Foreign.C.String (withCString, peekCString)
 
 import GHC.Generics (Generic)
 import Data.Hashable (Hashable)
-import Graphics.Text.Font.Choose.Result (throwNull)
+import Graphics.Text.Font.Choose.Result (throwNull, Error(ErrTypeMismatch))
 
 data Value = ValueVoid
     | ValueInt Int
@@ -34,27 +35,51 @@ instance Hashable Value
 
 class ToValue x where
     toValue :: x -> Value
+    fromValue :: Value -> Maybe x
+    fromValue' :: Value -> x -- throws Result.Error
+    fromValue' self | Just ret <- fromValue self = ret
+    fromValue' _ = throw ErrTypeMismatch
 
 instance ToValue () where
     toValue () = ValueVoid
+    fromValue ValueVoid = Just ()
+    fromValue _ = Nothing
 instance ToValue Int where
     toValue = ValueInt
+    fromValue (ValueInt x) = Just x
+    fromValue _ = Nothing
 instance ToValue Double where
     toValue = ValueDouble
+    fromValue (ValueDouble x) = Just x
+    fromValue _ = Nothing
 instance ToValue String where
     toValue = ValueString
+    fromValue (ValueString x) = Just x
+    fromValue _ = Nothing
 instance ToValue Bool where
     toValue = ValueBool
+    fromValue (ValueBool x) = Just x
+    fromValue _ = Nothing
 instance ToValue (M22 Double) where
     toValue = ValueMatrix
+    fromValue (ValueMatrix x) = Just x
+    fromValue _ = Nothing
 instance ToValue CharSet where
     toValue = ValueCharSet
+    fromValue (ValueCharSet x) = Just x
+    fromValue _ = Nothing
 instance ToValue FT_Face where
     toValue = ValueFTFace
+    fromValue (ValueFTFace x) = Just x
+    fromValue _ = Nothing
 instance ToValue LangSet where
     toValue = ValueLangSet
+    fromValue (ValueLangSet x) = Just x
+    fromValue _ = Nothing
 instance ToValue Range where
     toValue = ValueRange
+    fromValue (ValueRange x) = Just x
+    fromValue _ = Nothing
 
 ------
 --- Low-level
-- 
2.30.2