ginger-0.8.3.0: src/Text/Ginger/GVal.hs
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE RankNTypes #-}
-- | GVal is a generic unitype value, representing the kind of values that
-- Ginger can understand.
--
-- Most of the types in this module are parametrized over an 'm' type, which
-- is the host monad for template execution, as passed to 'runGingerT'. For
-- most kinds of values, 'm' is transparent, and in many cases a 'ToGVal'
-- instance can be written that works for all possible 'm'; the reason we need
-- to parametrize the values themselves over the carrier monad is because we
-- want to support impure functions, which requires access to the underlying
-- carrier monad (e.g. 'IO').
module Text.Ginger.GVal
where
import Prelude ( (.), ($), (==), (/=)
, (++), (+), (-), (*), (/), div
, (=<<), (>>=), return
, (||), (&&)
, undefined, otherwise, id, const
, fmap
, Maybe (..)
, Bool (..)
, Either (..)
, Char
, Int
, Integer
, Double
, Show, show
, Integral
, fromIntegral, floor
, not
, fst, snd
, Monad
, Functor
)
import qualified Prelude
import Data.Maybe ( fromMaybe, catMaybes, isJust, mapMaybe )
import Data.Text (Text)
import Data.String (IsString, fromString)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.List as List
import Safe (readMay, atMay)
import Data.Monoid
import Data.Scientific ( Scientific
, floatingOrInteger
, toBoundedInteger
, toRealFloat
, scientific
, coefficient
, base10Exponent
)
import Data.Fixed (Fixed (..), Pico)
import Control.Applicative
import qualified Data.Aeson as JSON
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import qualified Data.Vector as Vector
import Control.Monad ((<=<), forM, mapM)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Default (Default, def)
import Text.Printf
import Debug.Trace (trace)
import Data.Time ( Day (..)
, defaultTimeLocale
, toModifiedJulianDay
, formatTime
, toGregorian
, fromGregorian
, LocalTime (..)
, ZonedTime (..)
, TimeOfDay (..)
, TimeZone (..)
, TimeLocale (..)
)
import Text.Ginger.Html
-- * The Ginger Value type
--
-- | A variant type designed as the unitype for the template language. Any
-- value referenced in a template, returned from within a template, or used
-- in a template context, will be a 'GVal'.
-- @m@, in most cases, should be a 'Monad'.
--
-- Some laws apply here, most notably:
--
-- - when 'isNull' is 'True', then all of 'asFunction', 'asText', 'asNumber',
-- 'asHtml', 'asList', 'asDictItems', and 'length' should produce 'Nothing'
-- - when 'isNull' is 'True', then 'asBoolean' should produce 'False'
-- - when 'asNumber' is not 'Nothing', then 'asBoolean' should only return
-- 'False' for exactly zero
-- - 'Nothing'-ness of 'length' should match one or both of 'asList' / 'asDictItems'
data GVal m =
GVal
{ asList :: Maybe [GVal m] -- ^ Convert value to list, if possible
, asDictItems :: Maybe [(Text, GVal m)] -- ^ Convert value to association list ("dictionary"), if possible
, asLookup :: Maybe (Text -> Maybe (GVal m)) -- ^ Convert value to a lookup function
, asHtml :: Html -- ^ Render value as HTML
, asText :: Text -- ^ Render value as plain-text
, asBoolean :: Bool -- ^ Get value's truthiness
, asNumber :: Maybe Scientific -- ^ Convert value to a number, if possible
, asFunction :: Maybe (Function m) -- ^ Access value as a callable function, if it is one
, length :: Maybe Int -- ^ Get length of value, if it is a collection (list/dict)
, isNull :: Bool -- ^ Check if the value is null
, asJSON :: Maybe JSON.Value -- ^ Provide a custom JSON representation of the value
}
gappend :: GVal m -> GVal m -> GVal m
gappend a b =
GVal
{ asList = (++) <$> asList a <*> asList b
, asDictItems = (++) <$> asDictItems a <*> asDictItems b
, asLookup = do
lookupA <- asLookup a
lookupB <- asLookup b
return $ \k -> lookupA k <|> lookupB k
, asHtml = asHtml a <> asHtml b
, asText = asText a <> asText b
, asBoolean = (asBoolean a || asBoolean b) && not (isNull a || isNull b)
, asNumber = readMay . Text.unpack $ (asText a <> asText b)
, asFunction = Nothing
, isNull = isNull a || isNull b
, asJSON = case (JSON.toJSON a, JSON.toJSON b) of
(JSON.Array x, JSON.Array y) -> Just $ JSON.Array (x <> y)
(JSON.Object x, JSON.Object y) -> Just $ JSON.Object (x <> y)
(JSON.String x, JSON.String y) -> Just $ JSON.String (x <> y)
(JSON.Null, b) -> Just $ b
(a, JSON.Null) -> Just $ a
_ -> Nothing -- If JSON tags mismatch, use default toJSON impl
, length = (+) <$> length a <*> length b
}
-- | Marshal a GVal between carrier monads.
-- This will lose 'asFunction' information, because functions cannot be
-- transferred to other carrier monads, but it will keep all other data
-- structures intact.
marshalGVal :: GVal m -> GVal n
marshalGVal g =
GVal
{ asList = fmap marshalGVal <$> asList g
, asDictItems = fmap (\items -> [(k, marshalGVal v) | (k, v) <- items]) (asDictItems g)
, asLookup = fmap (fmap marshalGVal .) (asLookup g)
, asHtml = asHtml g
, asText = asText g
, asBoolean = asBoolean g
, asNumber = asNumber g
, asFunction = Nothing
, isNull = isNull g
, length = length g
, asJSON = asJSON g
}
-- | Marshal a GVal between carrier monads.
-- Unlike 'marshalGVal', 'asFunction' information is retained by hoisting
-- them using the provided hoisting functions. For 'Run' monads, which is
-- what 'GVal' is typically used with, the 'hoistRun' function can be used
-- to construct suitable hoisting functions.
marshalGValEx :: (Functor m, Functor n)
=> (forall a. m a -> n a)
-> (forall a. n a -> m a)
-> GVal m
-> GVal n
marshalGValEx hoist unhoist g =
GVal
{ asList = fmap (marshalGValEx hoist unhoist) <$> asList g
, asDictItems = fmap (\items -> [(k, marshalGValEx hoist unhoist v) | (k, v) <- items]) (asDictItems g)
, asLookup = fmap (fmap (marshalGValEx hoist unhoist) .) (asLookup g)
, asHtml = asHtml g
, asText = asText g
, asBoolean = asBoolean g
, asNumber = asNumber g
, asFunction = marshalFunction hoist unhoist <$> asFunction g
, isNull = isNull g
, length = length g
, asJSON = asJSON g
}
marshalFunction :: (Functor m, Functor n) => (forall a. m a -> n a) -> (forall a. n a -> m a) -> Function m -> Function n
-- [(Maybe Text, GVal m)] -> m (GVal m)
marshalFunction hoist unhoist f args =
let args' = [ (name, marshalGValEx unhoist hoist value)
| (name, value) <- args
]
in marshalGValEx hoist unhoist <$> hoist (f args')
-- | Convenience wrapper around 'asDictItems' to represent a 'GVal' as a
-- 'HashMap'.
asHashMap :: GVal m -> Maybe (HashMap Text (GVal m))
asHashMap g = HashMap.fromList <$> asDictItems g
-- | The default 'GVal' is equivalent to NULL.
instance Default (GVal m) where
def = GVal
{ asList = Nothing
, asDictItems = Nothing
, asLookup = Nothing
, asHtml = unsafeRawHtml ""
, asText = ""
, asBoolean = False
, asNumber = Nothing
, asFunction = Nothing
, isNull = True
, length = Nothing
, asJSON = Nothing
}
-- | Conversion to JSON values attempts the following conversions, in order:
--
-- - check the 'isNull' property; if it is 'True', always return 'Null',
-- even if the GVal implements 'asJSON'
-- - 'asJSON'
-- - 'asList'
-- - 'asDictItems' (through 'asHashMap')
-- - 'asNumber'
-- - 'asText'
--
-- Note that the default conversions will never return booleans unless 'asJSON'
-- explicitly does this, because 'asText' will always return *something*.
instance JSON.ToJSON (GVal m) where
toJSON g =
if isNull g
then JSON.Null
else fromMaybe (JSON.toJSON $ asText g) $
asJSON g <|>
(JSON.toJSON <$> asList g) <|>
(JSON.toJSON <$> asHashMap g) <|>
(JSON.toJSON <$> asNumber g)
-- | For convenience, 'Show' is implemented in a way that looks similar to
-- JavaScript / JSON
instance Show (GVal m) where
show v
| isNull v = "null"
| isJust (asFunction v) = "<<function>>"
| isJust (asDictItems v) =
let items = [ show k <> ": " <> show v | (k, v) <- fromMaybe [] (asDictItems v) ]
++ [ show k <> ": " <> show v | (k, v) <- Prelude.zip [0..] (fromMaybe [] $ asList v) ]
in "{" <> (mconcat . List.intersperse ", " $ items) <> "}"
| isJust (asList v) = "[" <> (mconcat . List.intersperse ", " . Prelude.map show $ fromMaybe [] (asList v)) <> "]"
| isJust (asNumber v) =
case floatingOrInteger <$> asNumber v :: Maybe (Either Double Integer) of
Just (Left x) -> show (asNumber v)
Just (Right x) -> show x
Nothing -> ""
| otherwise = show $ asText v
-- | Converting to HTML hooks into the ToHtml instance for 'Text' for most tags.
-- Tags that have no obvious textual representation render as empty HTML.
instance ToHtml (GVal m) where
toHtml = asHtml
instance PrintfArg (GVal m) where
formatArg x fmt =
case fmtChar (vFmt 's' fmt) of
's' -> formatString
(Text.unpack $ asText x)
(fmt { fmtChar = 's', fmtPrecision = Nothing })
'c' -> formatString
(Text.unpack $ asText x)
fmt
f -> if f `Prelude.elem` ['f', 'F', 'g', 'G', 'e', 'E']
then formatRealFloat (toRealFloat . fromMaybe 0 . asNumber $ x) fmt
else formatInteger (Prelude.round . fromMaybe 0 . asNumber $ x) fmt
-- * Representing functions as 'GVal's
--
-- | A function that can be called from within a template execution context.
type Function m = [(Maybe Text, GVal m)] -> m (GVal m)
-- | Match arguments passed to a function at runtime against a list of declared
-- argument names.
-- @matchFuncArgs argNames argsPassed@ returns @(matchedArgs, positionalArgs, namedArgs)@,
-- where @matchedArgs@ is a list of arguments matched against declared names
-- (by name or by position), @positionalArgs@ are the unused positional
-- (unnamed) arguments, and @namedArgs@ are the unused named arguments.
matchFuncArgs :: [Text] -> [(Maybe Text, GVal m)] -> (HashMap Text (GVal m), [GVal m], HashMap Text (GVal m))
matchFuncArgs names args =
(matched, positional, named)
where
positionalRaw = [ v | (Nothing, v) <- args ]
namedRaw = HashMap.fromList [ (n, v) | (Just n, v) <- args ]
fromPositional = Prelude.zip names positionalRaw
numPositional = Prelude.length fromPositional
namesRemaining = Prelude.drop numPositional names
positional = Prelude.drop numPositional positionalRaw
fromNamed = mapMaybe lookupName namesRemaining
lookupName n = do
v <- HashMap.lookup n namedRaw
return (n, v)
matched = HashMap.fromList $ fromPositional ++ fromNamed
named = HashMap.difference namedRaw (HashMap.fromList fromNamed)
-- * Marshalling from Haskell to 'GVal'
--
-- | Types that implement conversion to 'GVal'.
class ToGVal m a where
toGVal :: a -> GVal m
-- | Trivial instance for 'GVal' itself.
instance ToGVal m (GVal m) where
toGVal = id
instance ToGVal m () where
toGVal = const def
-- | 'Nothing' becomes NULL, 'Just' unwraps.
instance ToGVal m v => ToGVal m (Maybe v) where
toGVal Nothing = def { asJSON = Just JSON.Null }
toGVal (Just x) = toGVal x
-- | Haskell lists become list-like 'GVal's
instance ToGVal m v => ToGVal m [v] where
toGVal xs = helper (Prelude.map toGVal xs)
where
helper :: [GVal m] -> GVal m
helper xs =
def
{ asHtml = mconcat . Prelude.map asHtml $ xs
, asText = mconcat . Prelude.map asText $ xs
, asBoolean = not . List.null $ xs
, isNull = False
, asList = Just $ Prelude.map toGVal xs
, length = Just $ Prelude.length xs
}
-- | 'HashMap' of 'Text' becomes a dictionary-like 'GVal'
instance ToGVal m v => ToGVal m (HashMap Text v) where
toGVal xs = helper (HashMap.map toGVal xs)
where
helper :: HashMap Text (GVal m) -> GVal m
helper xs =
def
{ asHtml = mconcat . Prelude.map asHtml . HashMap.elems $ xs
, asText = mconcat . Prelude.map asText . HashMap.elems $ xs
, asBoolean = not . HashMap.null $ xs
, isNull = False
, asLookup = Just (`HashMap.lookup` xs)
, asDictItems = Just $ HashMap.toList xs
}
instance ToGVal m Int where
toGVal x =
def
{ asHtml = html . Text.pack . show $ x
, asText = Text.pack . show $ x
, asBoolean = x /= 0
, asNumber = Just . fromIntegral $ x
, isNull = False
}
instance ToGVal m Integer where
toGVal x =
def
{ asHtml = html . Text.pack . show $ x
, asText = Text.pack . show $ x
, asBoolean = x /= 0
, asNumber = Just . fromIntegral $ x
, isNull = False
}
instance ToGVal m Scientific where
toGVal x =
def
{ asHtml = html $ scientificToText x
, asText = scientificToText x
, asBoolean = x /= 0
, asNumber = Just x
, isNull = False
}
instance ToGVal m Day where
toGVal x =
let dayDict = dayToDict x
julian = toModifiedJulianDay x
formatted = Text.pack $ formatTime defaultTimeLocale "%0Y-%m-%d" x
in (orderedDict dayDict)
{ asHtml = html $ formatted
, asText = formatted
, asBoolean = True
, asNumber = Just . fromIntegral $ julian
, asList = Just (List.map snd dayDict)
}
dayToDict :: Day -> [(Text, GVal m)]
dayToDict x =
let (year, month, day) = toGregorian x
in [ "year" ~> year
, "month" ~> month
, "day" ~> day
]
instance ToGVal m TimeOfDay where
toGVal x =
let timeDict = timeToDict x
formatted = Text.pack $ formatTime defaultTimeLocale "%H:%M:%S" x
in (orderedDict timeDict)
{ asHtml = html $ formatted
, asText = formatted
, asBoolean = True
, asNumber = Nothing
, asList = Just (List.map snd timeDict)
}
timeToDict :: TimeOfDay -> [(Text, GVal m)]
timeToDict (TimeOfDay hours minutes seconds) =
[ "hours" ~> hours
, "minutes" ~> minutes
, "seconds" ~> picoToScientific seconds
]
instance ToGVal m LocalTime where
toGVal x =
let dtDict = localTimeToDict x
formatted = Text.pack $ formatTime defaultTimeLocale "%0Y-%m-%d %H:%M:%S" x
in (orderedDict $
dtDict ++
[ "date" ~> localDay x
, "time" ~> localTimeOfDay x
])
{ asHtml = html $ formatted
, asText = formatted
, asBoolean = True
, asNumber = Nothing
, asList = Just (List.map snd dtDict)
}
localTimeToDict :: LocalTime -> [(Text, GVal m)]
localTimeToDict x =
let dayDict = dayToDict $ localDay x
timeDict = timeToDict $ localTimeOfDay x
in dayDict ++ timeDict
instance ToGVal m TimeZone where
toGVal = dict . timeZoneToDict
timeZoneToDict :: TimeZone -> [(Text, GVal m)]
timeZoneToDict (TimeZone minutes summerOnly name) =
[ "minutes" ~> minutes
, "summerOnly" ~> summerOnly
, "name" ~> name
]
instance ToGVal m TimeLocale where
toGVal t =
let formattedExample =
Text.pack . formatTime t "%c" $
LocalTime (fromGregorian 2000 1 1) (TimeOfDay 13 15 00)
timeLocaleDict = timeLocaleToDict t
in (dict timeLocaleDict)
{ asHtml = html $ formattedExample
, asText = formattedExample
, asBoolean = True
, asNumber = Nothing
}
timeLocaleToDict :: TimeLocale -> [(Text, GVal m)]
timeLocaleToDict t =
[ "wDays" ~> List.map packPair (wDays t)
, "months" ~> List.map packPair (months t)
, "amPm" ~> packPair (amPm t)
, "dateTimeFmt" ~> Text.pack (dateTimeFmt t)
, "dateFmt" ~> Text.pack (dateFmt t)
, "timeFmt" ~> Text.pack (timeFmt t)
, "time12Fmt" ~> Text.pack (time12Fmt t)
-- TODO
-- , "knownTimeZones" ~> knownTimeZones t
, "knownTimeZones" ~> ([] :: [Text])
]
-- TODO: ToGVal instance for ZonedTime
instance ToGVal m ZonedTime where
toGVal x =
let dtDict = zonedTimeToDict x
formatted = Text.pack $ formatTime defaultTimeLocale "%0Y-%m-%d %H:%M:%S%z" x
in (dict dtDict)
{ asHtml = html $ formatted
, asText = formatted
, asBoolean = True
, asNumber = Nothing
}
zonedTimeToDict :: ZonedTime -> [(Text, GVal m)]
zonedTimeToDict t =
("tz", toGVal $ zonedTimeZone t):localTimeToDict (zonedTimeToLocalTime t)
instance (ToGVal m a, ToGVal m b) => ToGVal m (a, b) where
toGVal (a, b) = toGVal ([ toGVal a, toGVal b ] :: [GVal m])
instance (ToGVal m a, ToGVal m b, ToGVal m c) => ToGVal m (a, b, c) where
toGVal (a, b, c) = toGVal ([ toGVal a, toGVal b, toGVal c ] :: [GVal m])
instance (ToGVal m a, ToGVal m b, ToGVal m c, ToGVal m d) => ToGVal m (a, b, c, d) where
toGVal (a, b, c, d) = toGVal ([ toGVal a, toGVal b, toGVal c, toGVal d ] :: [GVal m])
-- | Silly helper function, needed to bypass the default 'Show' instance of
-- 'Scientific' in order to make integral 'Scientific's look like integers.
scientificToText :: Scientific -> Text
scientificToText x =
Text.pack $ case floatingOrInteger x of
Left x -> show x
Right x -> show x
-- | Booleans render as 1 or empty string, and otherwise behave as expected.
instance ToGVal m Bool where
toGVal x =
def
{ asHtml = if x then html "1" else html ""
, asText = if x then "1" else ""
, asBoolean = x
, asNumber = Just $ if x then 1 else 0
, isNull = False
, asJSON = Just (JSON.Bool x)
}
-- | 'String' -> 'GVal' conversion uses the 'IsString' class; because 'String'
-- is an alias for '[Char]', there is also a 'ToGVal' instance for 'String',
-- but it marshals strings as lists of characters, i.e., calling 'toGVal' on
-- a string produces a list of characters on the 'GVal' side.
instance IsString (GVal m) where
fromString x =
def
{ asHtml = html . Text.pack $ x
, asText = Text.pack x
, asBoolean = not $ Prelude.null x
, asNumber = readMay x
, isNull = False
, length = Just . Prelude.length $ x
}
-- | Single characters are treated as length-1 'Text's.
instance ToGVal m Char where
toGVal = toGVal . Text.singleton
instance ToGVal m Text where
toGVal x =
def
{ asHtml = html x
, asText = x
, asBoolean = not $ Text.null x
, asNumber = readMay . Text.unpack $ x
, isNull = False
}
instance ToGVal m LText.Text where
toGVal x =
def
{ asHtml = html (LText.toStrict x)
, asText = LText.toStrict x
, asBoolean = not $ LText.null x
, asNumber = readMay . LText.unpack $ x
, isNull = False
}
-- | This instance is slightly wrong; the 'asBoolean', 'asNumber', and 'asText'
-- methods all treat the HTML source as plain text. We do this to avoid parsing
-- the HTML back into a 'Text' (and dealing with possible parser errors); the
-- reason this instance exists at all is that we still want to be able to pass
-- pre-rendered HTML around sometimes, and as long as we don't call any numeric
-- or string functions on it, everything is fine. When such HTML values
-- accidentally do get used as strings, the HTML source will bleed into the
-- visible text, but at least this will not introduce an XSS vulnerability.
--
-- It is therefore recommended to avoid passing 'Html' values into templates,
-- and also to avoid calling any string functions on 'Html' values inside
-- templates (e.g. capturing macro output and then passing it through a textual
-- filter).
instance ToGVal m Html where
toGVal x =
def
{ asHtml = x
, asText = htmlSource x
, asBoolean = not . Text.null . htmlSource $ x
, asNumber = readMay . Text.unpack . htmlSource $ x
, isNull = False
}
-- | Convert Aeson 'Value's to 'GVal's over an arbitrary host monad. Because
-- JSON cannot represent functions, this conversion will never produce a
-- 'Function'. Further, the 'ToJSON' instance for such a 'GVal' will always
-- produce the exact 'Value' that was use to construct the it.
instance ToGVal m JSON.Value where
toGVal j = (rawJSONToGVal j) { asJSON = Just j }
rawJSONToGVal :: JSON.Value -> GVal m
rawJSONToGVal (JSON.Number n) = toGVal n
rawJSONToGVal (JSON.String s) = toGVal s
rawJSONToGVal (JSON.Bool b) = toGVal b
rawJSONToGVal JSON.Null = def
rawJSONToGVal (JSON.Array a) = toGVal $ Vector.toList a
rawJSONToGVal (JSON.Object o) = toGVal o
-- | Turn a 'Function' into a 'GVal'
fromFunction :: Function m -> GVal m
fromFunction f =
def
{ asHtml = html ""
, asText = ""
, asBoolean = True
, isNull = False
, asFunction = Just f
, asJSON = Just "<<function>>"
}
-- * Convenience API for constructing heterogenous dictionaries.
--
-- Example usage:
--
-- > context :: GVal m
-- > context = dict [ "number" ~> (15 :: Int), "name" ~> ("Joe" :: String) ]
-- | A key/value pair, used for constructing dictionary GVals using a
-- compact syntax.
type Pair m = (Text, GVal m)
-- | Construct a dictionary GVal from a list of pairs. Internally, this uses
-- a hashmap, so element order will not be preserved.
dict :: [Pair m] -> GVal m
dict = toGVal . HashMap.fromList
-- | Construct an ordered dictionary GVal from a list of pairs. Internally,
-- this conversion uses both a hashmap (for O(1) lookup) and the original list,
-- so element order is preserved, but there is a bit of a memory overhead.
orderedDict :: [Pair m] -> GVal m
orderedDict xs =
def
{ asHtml = mconcat . Prelude.map (asHtml . snd) $ xs
, asText = mconcat . Prelude.map (asText . snd) $ xs
, asBoolean = not . Prelude.null $ xs
, isNull = False
, asLookup = Just (`HashMap.lookup` hm)
, asDictItems = Just xs
}
where
hm = HashMap.fromList xs
-- | Construct a pair from a key and a value.
(~>) :: ToGVal m a => Text -> a -> Pair m
k ~> v = (k, toGVal v)
infixr 8 ~>
-- * Convenience API for constructing heterogenous lists
type Cons m = [GVal m]
-- | Alias for '(~:)'.
gcons :: ToGVal m a => a -> Cons m -> Cons m
gcons = (:) . toGVal
-- | This operator allows constructing heterogenous lists using cons-style
-- syntax, e.g.:
--
-- >>> asText $ list ("Found " ~: (6 :: Int) ~: " items" ~: [] :: [GVal IO])
-- "Found 6 items"
(~:) :: ToGVal m a => a -> Cons m -> Cons m
(~:) = gcons
infixr 5 ~:
-- | Construct a GVal from a list of GVals. This is equivalent to the 'toGVal'
-- implementation of @[GVal m]@, but typed more narrowly for clarity and
-- disambiguation.
list :: Cons m -> GVal m
list = toGVal
-- * Inspecting 'GVal's / Marshalling 'GVal' to Haskell
-- | Check if the given GVal is a list-like object
isList :: GVal m -> Bool
isList = isJust . asList
-- | Check if the given GVal is a dictionary-like object
isDict :: GVal m -> Bool
isDict = isJust . asDictItems
-- | Treat a 'GVal' as a flat list and look up a value by integer index.
-- If the value is not a List, or if the index exceeds the list length,
-- return 'Nothing'.
lookupIndex :: Int -> GVal m -> Maybe (GVal m)
lookupIndex = lookupIndexMay . Just
-- | Helper function; look up a value by an integer index when the index may or
-- may not be available. If no index is given, return 'Nothing'.
lookupIndexMay :: Maybe Int -> GVal m -> Maybe (GVal m)
lookupIndexMay i v = do
index <- i
items <- asList v
atMay items index
-- | Strictly-typed lookup: treat value as a dictionary-like object and look
-- up the value at a given key.
lookupKey :: Text -> GVal m -> Maybe (GVal m)
lookupKey k v = do
lf <- asLookup v
lf k
-- | Loosely-typed lookup: try dictionary-style lookup first (treat index as
-- a string, and container as a dictionary), if that doesn't yield anything
-- (either because the index is not string-ish, or because the container
-- doesn't provide dictionary-style access), try index-based lookup.
lookupLoose :: GVal m -> GVal m -> Maybe (GVal m)
lookupLoose k v =
lookupKey (asText k) v <|> lookupIndexMay (floor <$> asNumber k) v
-- | Like 'lookupLoose', but fall back to the given default value if
-- the key is not in the dictionary, or if the indexee is not a
-- dictionary-like object.
lookupLooseDef :: GVal m -> GVal m -> GVal m -> GVal m
lookupLooseDef d k = fromMaybe d . lookupLoose k
(~!) :: (FromGVal m v) => GVal m -> GVal m -> Maybe v
g ~! k = lookupLoose k g >>= fromGVal
-- | Treat a 'GVal' as a dictionary and list all the keys, with no particular
-- ordering.
keys :: GVal m -> Maybe [Text]
keys v = Prelude.map fst <$> asDictItems v
-- | Convert a 'GVal' to a number.
toNumber :: GVal m -> Maybe Scientific
toNumber = asNumber
-- | Convert a 'GVal' to an 'Int'.
-- The conversion will fail when the value is not numeric, and also if
-- it is too large to fit in an 'Int'.
toInt :: GVal m -> Maybe Int
toInt = toBoundedInteger <=< toNumber
-- | Convert a 'GVal' to an 'Integer'
-- The conversion will fail when the value is not an integer
toInteger :: GVal m -> Maybe Integer
toInteger = Prelude.either (const Nothing) Just . floatingOrInteger <=< asNumber
-- | Convert a 'GVal' to an 'Int', falling back to the given
-- default if the conversion fails.
toIntDef :: Int -> GVal m -> Int
toIntDef d = fromMaybe d . toInt
-- | Convert a 'GVal' to an 'Int', falling back to zero (0)
-- if the conversion fails.
toInt0 :: GVal m -> Int
toInt0 = toIntDef 0
-- | Loose cast to boolean.
--
-- Numeric zero, empty strings, empty lists, empty objects, 'Null', and boolean
-- 'False' are considered falsy, anything else (including functions) is
-- considered true-ish.
toBoolean :: GVal m -> Bool
toBoolean = asBoolean
-- | Dynamically cast to a function.
-- This yields 'Just' a 'Function' if the value is a function, 'Nothing' if
-- it's not.
toFunction :: GVal m -> Maybe (Function m)
toFunction = asFunction
picoToScientific :: Pico -> Scientific
picoToScientific (MkFixed x) = scientific x (-12)
scientificToPico :: Scientific -> Pico
scientificToPico s =
MkFixed (Prelude.floor $ scientific (coefficient s) (base10Exponent s + 12))
{-#RULES "GVal/round-trip-Maybe" fromGVal . toGVal = Just #-}
{-#RULES "GVal/round-trip-Either" fromGValEither . toGVal = Right #-}
{-#RULES "GVal/text-shortcut" asText . toGVal = id #-}
class FromGVal m a where
fromGValEither :: GVal m -> Either Prelude.String a
fromGValEither = Prelude.maybe (Left "Conversion from GVal failed") Right . fromGVal
fromGVal :: GVal m -> Maybe a
fromGVal = Prelude.either (const Nothing) Just . fromGValEither
fromGValM :: (Monad m, FromGVal m a) => GVal m -> m a
fromGValM = Prelude.either Prelude.fail return . fromGValEither
instance FromGVal m Int where
fromGVal = toInt
instance FromGVal m Scientific where
fromGVal = asNumber
instance FromGVal m Integer where
fromGVal = toInteger
instance FromGVal m Text where
fromGVal = Just . asText
instance FromGVal m (GVal m) where
fromGVal = Just
instance FromGVal m a => FromGVal m (Maybe a) where
fromGVal = \g ->
if isNull g
then
Just Nothing
else
Just <$> fromGVal g
instance FromGVal m Bool where
fromGVal = Just . asBoolean
instance FromGVal m JSON.Value where
fromGVal = asJSON
instance FromGVal m () where
fromGVal g = if isNull g then Just () else Nothing
instance FromGVal m a => FromGVal m [a] where
fromGVal g = asList g >>= mapM fromGVal
instance ( FromGVal m a
, FromGVal m b
) => FromGVal m (a, b) where
fromGVal g = case asList g of
Just [a, b] ->
(,) <$> fromGVal a
<*> fromGVal b
_ -> Nothing
instance ( FromGVal m a
, FromGVal m b
, FromGVal m c
) => FromGVal m (a, b, c) where
fromGVal g = case asList g of
Just [a, b, c] ->
(,,) <$> fromGVal a
<*> fromGVal b
<*> fromGVal c
_ -> Nothing
instance ( FromGVal m a
, FromGVal m b
, FromGVal m c
, FromGVal m d
) => FromGVal m (a, b, c, d) where
fromGVal g = case asList g of
Just [a, b, c, d] ->
(,,,) <$> fromGVal a
<*> fromGVal b
<*> fromGVal c
<*> fromGVal d
_ -> Nothing
instance FromGVal m Day where
fromGVal g = do
year <- fromIntegral <$> (g ~! "year" :: Maybe Int)
month <- g ~! "month"
day <- g ~! "day"
return $ fromGregorian year month day
instance FromGVal m TimeOfDay where
fromGVal g = do
hours <- g ~! "hours"
minutes <- g ~! "minutes"
seconds <- scientificToPico <$> g ~! "seconds"
return $ TimeOfDay hours minutes seconds
instance FromGVal m LocalTime where
fromGVal g = do
date <- fromGVal g <|> g ~! "date"
time <- fromGVal g <|> g ~! "time"
return $ LocalTime date time
instance FromGVal m ZonedTime where
fromGVal g = do
localTime <- fromGVal g
timeZone <- g ~! "tz"
return $ ZonedTime localTime timeZone
instance FromGVal m TimeZone where
fromGVal g =
TimeZone
<$> g ~! "minutes"
<*> g ~! "summerOnly"
<*> (Text.unpack <$> g ~! "name")
instance FromGVal m TimeLocale where
fromGVal g =
if isDict g
then
Just $ TimeLocale
(fromMaybe (wDays defaultTimeLocale) $ List.map unpackPair <$> g ~! "wDays")
(fromMaybe (months defaultTimeLocale) $ List.map unpackPair <$> g ~! "months")
(fromMaybe (amPm defaultTimeLocale) $ unpackPair <$> g ~! "amPm")
(fromMaybe (dateTimeFmt defaultTimeLocale) $ Text.unpack <$> g ~! "dateTimeFmt")
(fromMaybe (dateFmt defaultTimeLocale) $ Text.unpack <$> g ~! "dateFmt")
(fromMaybe (timeFmt defaultTimeLocale) $ Text.unpack <$> g ~! "timeFmt")
(fromMaybe (time12Fmt defaultTimeLocale) $ Text.unpack <$> g ~! "time12Fmt")
(fromMaybe (knownTimeZones defaultTimeLocale) $ g ~! "knownTimeZones")
else
Nothing
pairwise :: (a -> b) -> (a, a) -> (b, b)
pairwise f (a, b) = (f a, f b)
packPair :: ([Char], [Char]) -> (Text, Text)
packPair = pairwise Text.pack
unpackPair :: (Text, Text) -> ([Char], [Char])
unpackPair = pairwise Text.unpack