-- |
-- Convenient construction of bidirectional functions using case-like syntax.
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell, Trustworthy #-}
module Data.Invertible.TH
  ( biCase
  ) where

import Control.Arrow (second)
import Control.Monad (liftM2)
import Data.Char (isSpace)
import Data.Data (Data, gmapT)
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
import Data.Typeable (cast)
import Language.Haskell.Meta.Parse (parsePat)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
#if MIN_VERSION_base(4,9,0)
import Text.Read.Lex (isSymbolChar)
#endif

import Data.Invertible.Bijection

#if !MIN_VERSION_base(4,9,0)
isSymbolChar :: Char -> Bool
isSymbolChar = (`elem` "!#$%&*+./<=>?@\\^|-~:")
#endif

split :: String -> String -> [String]
split :: String -> String -> [String]
split String
_ [] = []
split String
d (Char
p:String
s)
  | Bool -> Bool
not (Char -> Bool
isSymbolChar Char
p)
  , Just (Char
p':String
s') <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
d String
s
  , Bool -> Bool
not (Char -> Bool
isSymbolChar Char
p') = [Char
p] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> [String] -> [String]
forall {a}. a -> [[a]] -> [[a]]
conshead Char
p' (String -> String -> [String]
split String
d String
s')
  | Bool
otherwise = Char -> [String] -> [String]
forall {a}. a -> [[a]] -> [[a]]
conshead Char
p ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
split String
d String
s
  where
  conshead :: a -> [[a]] -> [[a]]
conshead a
c [] = [[a
c]]
  conshead a
c ([a]
h:[[a]]
t) = (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
h)[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
t

patToPat :: TH.Pat -> TH.Pat
patToPat :: Pat -> Pat
patToPat = Pat -> Pat
ptp (Pat -> Pat) -> (Pat -> Pat) -> Pat -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b. Data b => b -> b) -> Pat -> Pat
forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT b -> b
forall b. Data b => b -> b
pta where
  pta :: Data a => a -> a
  pta :: forall b. Data b => b -> b
pta = (a -> a) -> Maybe (a -> a) -> a -> a
forall a. a -> Maybe a -> a
fromMaybe a -> a
forall a. a -> a
id (Maybe (a -> a) -> a -> a) -> Maybe (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ (Pat -> Pat) -> Maybe (a -> a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Pat -> Pat
patToPat
  ptp :: Pat -> Pat
ptp (TH.ViewP Exp
e Pat
p) = Exp -> Pat -> Pat
TH.ViewP (Name -> Exp
TH.VarE 'biTo Exp -> Exp -> Exp
`TH.AppE` Exp
e) Pat
p
  ptp Pat
p = Pat
p

patToExp :: TH.Pat -> TH.Exp
patToExp :: Pat -> Exp
patToExp (TH.LitP Lit
l) = Lit -> Exp
TH.LitE Lit
l
patToExp (TH.VarP Name
v) = Name -> Exp
TH.VarE Name
v
patToExp (TH.TupP [Pat]
l) = [Maybe Exp] -> Exp
TH.TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Pat -> Maybe Exp) -> [Pat] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (
#if MIN_VERSION_template_haskell(2,16,0)
  Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Pat -> Exp) -> Pat -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
#endif
  Pat -> Exp
patToExp) [Pat]
l
patToExp (TH.UnboxedTupP [Pat]
l) = [Maybe Exp] -> Exp
TH.UnboxedTupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Pat -> Maybe Exp) -> [Pat] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (
#if MIN_VERSION_template_haskell(2,16,0)
  Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Pat -> Exp) -> Pat -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
#endif
  Pat -> Exp
patToExp) [Pat]
l
#if MIN_VERSION_template_haskell(2,12,0)
patToExp (TH.UnboxedSumP Pat
p SumAlt
a SumAlt
n) = Exp -> SumAlt -> SumAlt -> Exp
TH.UnboxedSumE (Pat -> Exp
patToExp Pat
p) SumAlt
a SumAlt
n
#endif
patToExp (TH.ConP Name
c
#if MIN_VERSION_template_haskell(2,18,0)
  [Type]
_ -- [Type], probably should have to be empty
#endif
  [Pat]
a) = (Exp -> Pat -> Exp) -> Exp -> [Pat] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
f -> Exp -> Exp -> Exp
TH.AppE Exp
f (Exp -> Exp) -> (Pat -> Exp) -> Pat -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> Exp
patToExp) (Name -> Exp
TH.ConE Name
c) [Pat]
a
patToExp (TH.InfixP Pat
l Name
o Pat
r) = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
l) (Name -> Exp
TH.ConE Name
o) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
r)
patToExp (TH.UInfixP Pat
l Name
o Pat
r) = Exp -> Exp -> Exp -> Exp
TH.UInfixE (Pat -> Exp
patToExp Pat
l) (Name -> Exp
TH.ConE Name
o) (Pat -> Exp
patToExp Pat
r)
patToExp (TH.ParensP Pat
p) = Exp -> Exp
TH.ParensE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
p
patToExp (TH.TildeP Pat
p) = Pat -> Exp
patToExp Pat
p
patToExp (TH.BangP Pat
p) = Pat -> Exp
patToExp Pat
p
patToExp (TH.AsP Name
_ Pat
p) = Pat -> Exp
patToExp Pat
p
patToExp Pat
TH.WildP = Name -> Exp
TH.VarE 'undefined
patToExp (TH.RecP Name
c [FieldPat]
f) = Name -> [FieldExp] -> Exp
TH.RecConE Name
c ([FieldExp] -> Exp) -> [FieldExp] -> Exp
forall a b. (a -> b) -> a -> b
$ (FieldPat -> FieldExp) -> [FieldPat] -> [FieldExp]
forall a b. (a -> b) -> [a] -> [b]
map ((Pat -> Exp) -> FieldPat -> FieldExp
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Pat -> Exp
patToExp) [FieldPat]
f
patToExp (TH.ListP [Pat]
l) = [Exp] -> Exp
TH.ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Pat -> Exp) -> [Pat] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Pat -> Exp
patToExp [Pat]
l
patToExp (TH.SigP Pat
p Type
t) = Exp -> Type -> Exp
TH.SigE (Pat -> Exp
patToExp Pat
p) Type
t
patToExp (TH.ViewP Exp
e Pat
p) = Name -> Exp
TH.VarE 'biFrom Exp -> Exp -> Exp
`TH.AppE` Exp
e Exp -> Exp -> Exp
`TH.AppE` Pat -> Exp
patToExp Pat
p

parseP :: String -> TH.PatQ
parseP :: String -> PatQ
parseP String
s = (String -> PatQ) -> (Pat -> PatQ) -> Either String Pat -> PatQ
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> PatQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PatQ) -> (String -> String) -> String -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String
"Failed to parse pattern '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': ")) Pat -> PatQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Pat -> PatQ) -> Either String Pat -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Either String Pat
parsePat String
s

biExp :: String -> TH.ExpQ
biExp :: String -> ExpQ
biExp = ([(Pat, Pat)] -> Exp) -> Q [(Pat, Pat)] -> ExpQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Pat)] -> Exp
ie (Q [(Pat, Pat)] -> ExpQ)
-> (String -> Q [(Pat, Pat)]) -> String -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Q (Pat, Pat)) -> [String] -> Q [(Pat, Pat)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Q (Pat, Pat)
ic ([String] -> Q [(Pat, Pat)])
-> (String -> [String]) -> String -> Q [(Pat, Pat)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> String -> [String]
split String
";") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines where
  ie :: [(Pat, Pat)] -> Exp
ie [(Pat, Pat)]
l = Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ [(Pat, Pat)] -> Exp
ce [(Pat, Pat)]
l) (Name -> Exp
TH.ConE '(:<->:)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ [(Pat, Pat)] -> Exp
ce ([(Pat, Pat)] -> Exp) -> [(Pat, Pat)] -> Exp
forall a b. (a -> b) -> a -> b
$ ((Pat, Pat) -> (Pat, Pat)) -> [(Pat, Pat)] -> [(Pat, Pat)]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, Pat) -> (Pat, Pat)
forall a b. (a, b) -> (b, a)
swap [(Pat, Pat)]
l)
  ce :: [(Pat, Pat)] -> Exp
ce [(Pat
p, Pat
e)] = [Pat] -> Exp -> Exp
TH.LamE [Pat -> Pat
patToPat Pat
p] (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
e
  ce [(Pat, Pat)]
l = [Match] -> Exp
TH.LamCaseE [ Pat -> Body -> [Dec] -> Match
TH.Match (Pat -> Pat
patToPat Pat
p) (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
e) [] | (Pat
p, Pat
e) <- [(Pat, Pat)]
l ]
  ic :: String -> Q (Pat, Pat)
ic String
s
    | [String
fs, String
gs] <- String -> String -> [String]
split String
"<->" String
s =
      (Pat -> Pat -> (Pat, Pat)) -> PatQ -> PatQ -> Q (Pat, Pat)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (String -> PatQ
parseP String
fs) (String -> PatQ
parseP String
gs)
    | Bool
otherwise = String -> Q (Pat, Pat)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"each bijection case must contain exactly one '<->'"

-- |Construct an expression representing a function bijection based on a set of newline- or semicolon-separated cases.
-- Each case should be two pattern-expressions separated by @<->@.
-- Each pattern-expression is a haskell pattern that can also be interpreted as an expression.
-- You can think of these as symmetric or bidirectional case expressions.
-- The result will be a bijection that is the combination of two lambdas, one with the cases intepreted forward, and one reverse.
-- For example:
--
-- > newtype T a = C a
-- > biC :: T a <-> a
-- > biC = [biCase| C a <-> a |]
--
-- > isJust :: Maybe () <-> Bool
-- > isJust = [biCase|
-- >     Just () <-> True
-- >     Nothing <-> False
-- >   |]
-- 
biCase :: QuasiQuoter
biCase :: QuasiQuoter
biCase = QuasiQuoter
  { quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
biExp
  , quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in types"
  , quotePat :: String -> PatQ
quotePat = PatQ -> String -> PatQ
forall a b. a -> b -> a
const (PatQ -> String -> PatQ) -> PatQ -> String -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> PatQ
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in patterns"
  , quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in declarations"
  }