Skip to content

Instantly share code, notes, and snippets.

@fizbin fizbin/LensHXTPickle.hs
Last active Dec 26, 2015

Embed
What would you like to do?
A little demonstration of HXT and Lenses including a full worked example to show how to pickle an involved data structure to XML.
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{- A little demonstration of HXT and Lenses -}
module Main where
import Control.Arrow
import Control.Lens
import Control.Monad
import Data.Char
import Text.XML.HXT.Core
{- Setup the framework; skip to "sample application" -}
data PickleBuilder inputT dataT ctorA ctorB = PickleBuilder {
_pbConstructorMangler :: dataT -> ctorA -> Either String ctorB,
_pbReader :: inputT -> dataT,
_pbPickle :: PU dataT
}
normalPB :: (d -> a -> b) -> (i -> d) -> PU d -> PickleBuilder i d a b
normalPB mgl = PickleBuilder (\d c -> Right (mgl d c))
infix 6 ~@~
infixr 2 >@>
(~@~) :: Getter s c -> PU c -> PickleBuilder s c (c -> b) b
lns ~@~ puc = normalPB (\c f -> f c) (^.lns) puc
(>@>) :: PickleBuilder i d a b
-> PickleBuilder i d' b c -> PickleBuilder i (d, d') a c
(PickleBuilder ls la lc) >@> (PickleBuilder rs ra rc) =
PickleBuilder (\(lC, rC) -> ls lC >=> rs rC) (la &&& ra) (xpPair lc rc)
withConstructor :: ctor -> PickleBuilder s d ctor s -> PU s
withConstructor ctor (PickleBuilder cfunc rdfunc puc) =
xpWrapEither (fromPairs, rdfunc) puc
where
fromPairs x = cfunc x ctor
{- sample application: imagine a simple pet registry for an animal shelter or
veterinary practice -}
data ContactInfo = ContactInfo {
_ciName :: String,
_ciStreet :: String,
_ciCity :: String,
_ciProvince :: String,
_ciPostalCode :: String
} deriving (Eq, Show)
makeFields ''ContactInfo
data PetType = Cat | Dog | Cavy | Rabbit
deriving (Enum, Eq, Ord, Read, Show)
data AnimalRegistration = AnimalRegistration {
_arPetType :: PetType,
_arPetName :: String,
_arOwner :: ContactInfo}
makeFields ''AnimalRegistration
data AnimalRegistry = AnimalRegistry [AnimalRegistration]
{-
Now let's turn those data structures into XML.
Most of the XML will be sane, but let's imagine some weirdness
in the ContactInfo xml to show how flexible the PickleBuilder
stuff is. Say, a requirement to encode the city and province as
<city province="Province">City</city>
-}
instance XmlPickler PetType where
xpickle = xpWrapMaybe (readMaybe, show >>> map toLower) xpText
where
readMaybe s = do {(x,""):_ <- return (reads $ capFirst s); return x}
capFirst [] = []
capFirst (x:xs) = toUpper x : xs
instance XmlPickler ContactInfo where
xpickle = xpElem "contact-info" $ withConstructor ContactInfo $
name ~@~ xpElem "name" xpText >@>
street ~@~ xpElem "street" xpText >@>
normalPB (\c f -> uncurry (flip f) c) ((^.province) &&& (^.city))
(xpElem "city" $ xpPair (xpTextAttr "province") xpText) >@>
postalCode ~@~ xpElem "postal" xpText
instance XmlPickler AnimalRegistration where
xpickle = xpElem "registration" $ withConstructor AnimalRegistration $
petType ~@~ xpAttr "type" xpickle >@>
petName ~@~ xpElem "pet-name" xpText >@>
owner ~@~ xpickle
instance XmlPickler AnimalRegistry where
xpickle = xpWrap (AnimalRegistry, \(AnimalRegistry a) -> a)
(xpElem "animal-registry" $ xpList xpickle)
tstPet :: AnimalRegistration
tstPet = AnimalRegistration Cavy "Chancy" $
ContactInfo "Bob Jones"
"123 Bob St."
"Young America" "MN" "55555"
tstPet2 :: AnimalRegistration
tstPet2 = AnimalRegistration Cat "Fred" $
ContactInfo "Jane Smith"
"112 Leon Blvd."
"Janesville" "WI" "53545"
main = (runX $ const (AnimalRegistry [tstPet,
tstPet2]) ^>>
xpickleDocument xpickle [withIndent yes] "-") >> return ()
{- Produces:
$ runghc LensHXT.hs
<?xml version="1.0" encoding="UTF-8"?>
<animal-registry>
<registration type="cavy">
<pet-name>Chancy</pet-name>
<contact-info>
<name>Bob Jones</name>
<street>123 Bob St.</street>
<city province="MN">Young America</city>
<postal>55555</postal>
</contact-info>
</registration>
<registration type="cat">
<pet-name>Fred</pet-name>
<contact-info>
<name>Jane Smith</name>
<street>112 Leon Blvd.</street>
<city province="WI">Janesville</city>
<postal>53545</postal>
</contact-info>
</registration>
</animal-registry>
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.