ekmett/lens — pull request #508 by christian-marie (2014-12-13 07:32:48+00:00)
Title: Configuration and alternate field representation for Prism TH

Configuration and alternate field representation for Prism TH

In order to support an alternate form of prism generation with TH
configurability has been added. This was done in the form of a PrismRules
argument that is threaded through to the parts that may need it. This
PrismRules may be passed to makePrismsWith, much the same way as LensRules is
passed about in other parts of the lens API.

This allows the addition of a different prism representation which is also
included in this patch. Ordinarily the prism for a datatype:

data Foo = Foo Int Char Bool

Would produce:

_Foo :: Prism' Foo (Int, Char, Bool)

This alternate representation encodes the fields as pairs ala church encoding
of lists via pairs, producing:

_Foo :: Prism' Foo (Int, (Char, Bool))

The motivating case for this is implementing an applicative syntax on top of
prisms to unify parsing and printing, specifically between JSON and the things
these auto-generated prisms represent.

Please note that this is a WIP, I'd like to see if I'm completely off-base here before putting more work into documenting the Prism TH interface, making it nicer to use and exposing it from Control.Lens.TH and/or Control.Lens. I took one approach to the configuration interface, there may be a much simpler one, this seemed cleanest.

The following PoC, which is the motivating example, runs against this branch:

Output:
```
UNPARSE
{"foo":false,"baz":false,"bar":40}
{"bar":42}
PARSE
Just (Unpaid False 40 False)
Just (Paid 42)
```

Source:
```haskell
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

import Control.Applicative hiding ((<**>))
import Control.Lens
import Control.Lens.Internal.PrismTH
import Control.Monad
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString.Lazy.Char8 as L
import Data.HashMap.Strict (union)
import Data.Text
import qualified Data.Vector as V

data Invoice
= Unpaid Bool Integer Bool
| Paid Integer
deriving (Show)

makePrismsWith (defaultPrismRules { _fieldCtors = pairListCtors }) ''Invoice

main :: IO ()
main = do
putStrLn "UNPARSE"
let Just x = runPrinter invoiceSyntax $ Unpaid False 40 False
let Just y = runPrinter invoiceSyntax $ Paid 42
L.putStrLn $ encode x
L.putStrLn $ encode y
putStrLn "PARSE"
print (runParser invoiceSyntax x)
print (runParser invoiceSyntax y)

infixl 5 <$$>
infixl 4 <||>
infixr 6 <**>

class NSTransformSyntax f where
-- Functor from Prisms to Hask
(<$$>) :: Prism' b a -> f a -> f b

-- Applicative
(<**>) :: f a -> f b -> f (a, b)

-- Choice
(<||>) :: f a -> f a -> f a

liftNS :: Prism' Value b -> f b

newtype Parser a = Parser { runParser :: Value -> Maybe a }

instance NSTransformSyntax Parser where
p <$$> Parser f =
Parser $ f >=> Just . (^. re p)

(Parser a) <**> (Parser b) =
Parser $ \v -> (,) <$> a v <*> b v

(Parser a) <||> (Parser b) =
Parser $ \v -> a v <|> b v

liftNS p = Parser $ \v -> v ^? p

newtype Printer a = Printer { runPrinter :: a -> Maybe Value }

instance NSTransformSyntax Printer where
p <$$> Printer f =
Printer $ \b -> b ^? p >>= f

Printer a <**> Printer b =
Printer $ \(v1,v2) -> do
r1 <- a v1
r2 <- b v2
mush r1 r2
where
mush (Object o1) (Object o2) = Just . Object $ o1 `union` o2
mush (Array a1) (Array a2) = Just . Array $ a1 V.++ a2
mush _ _ = Nothing

Printer a <||> Printer b =
Printer $ \v -> a v <|> b v

liftNS p = Printer $ \v -> Just $ v ^. re p

boolField :: NSTransformSyntax s => Text -> s Bool
boolField t = liftNS $ keyPrism t . _Bool

integerField :: NSTransformSyntax s => Text -> s Integer
integerField t = liftNS $ keyPrism t . _Integer

-- | Only a valid prism if we assume that isomorphism is viewed from the non-JSON
-- end of things. This forgets any context.
keyPrism :: Text -> Prism' Value Value
keyPrism k = prism' (\part -> Object [(k,part)]) (^? key k)

invoiceSyntax :: NSTransformSyntax s => s Invoice
invoiceSyntax = _Unpaid <$$> boolField "foo" <**> integerField "bar" <**> boolField "baz"
<||> _Paid <$$> integerField "bar"
```