Poc.hs

{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

import           Control.Applicative        hiding ((<**>))
import           Control.Lens
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)

makePrisms ''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 5 <$$$>
infixl 4 <||>
infixr 6 <**>

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

    -- The opposite of above. That thing.
    (<$$$>) :: Prism' a b -> f a -> f b

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

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

    value :: f Value

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

instance NSTransformSyntax Parser where
    p <$$> Parser f =
        Parser $ f >=> review (_Just . p)

    p <$$$> Parser f =
        Parser $ f >=> preview p

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

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

    value = Parser Just

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

instance NSTransformSyntax Printer where
    p <$$> Printer f =
        Printer $ preview p >=> f

    p <$$$> Printer f =
        Printer $ review (_Just . 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

    value = Printer Just

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

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

-- | 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 . _Flat <$$> boolField "foo" <**> integerField "bar" <**> boolField "baz"
            <||> _Paid   <$$> integerField "bar"

class Flat a where
  type TupleTree a
  _Flat :: Iso' a (TupleTree a)

instance Flat (a,b,c) where
  type TupleTree (a,b,c) = (a,(b,c))
  _Flat = iso (\(a,b,c) -> (a,(b,c))) (\(a,(b,c)) -> (a,b,c))

instance Flat (a,b,c,d) where
  type TupleTree (a,b,c,d) = (a,(b,(c,d)))
  _Flat = iso (\(a,b,c,d) -> (a,(b,(c,d)))) (\(a,(b,(c,d))) -> (a,b,c,d))

thing :: NSTransformSyntax s => s Integer -> s Int
thing a = iso fromIntegral fromIntegral <$$> a