-- |
-- 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') <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
d String
s
  , Bool -> Bool
not (Char -> Bool
isSymbolChar Char
p') = [Char
p] forall a. a -> [a] -> [a]
: forall {a}. a -> [[a]] -> [[a]]
conshead Char
p' (String -> String -> [String]
split String
d String
s')
  | Bool
otherwise = forall {a}. a -> [[a]] -> [[a]]
conshead Char
p 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
cforall a. a -> [a] -> [a]
:[a]
h)forall a. a -> [a] -> [a]
:[[a]]
t

patToPat :: TH.Pat -> TH.Pat
patToPat :: Pat -> Pat
patToPat = Pat -> Pat
ptp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Data a => (forall b. Data b => b -> b) -> a -> a
gmapT forall b. Data b => b -> b
pta where
  pta :: Data a => a -> a
  pta :: forall b. Data b => b -> b
pta = forall a. a -> Maybe a -> a
fromMaybe forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (
#if MIN_VERSION_template_haskell(2,16,0)
  forall a. a -> Maybe a
Just 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (
#if MIN_VERSION_template_haskell(2,16,0)
  forall a. a -> Maybe a
Just 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) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
f -> Exp -> Exp -> Exp
TH.AppE Exp
f 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pat -> Exp
patToExp Pat
l) (Name -> Exp
TH.ConE Name
o) (forall a. a -> Maybe a
Just 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 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a b. (a -> b) -> a -> b
$ 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) (String
"Failed to parse pattern '" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"': ")) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Either String Pat
parsePat String
s

biExp :: String -> TH.ExpQ
biExp :: String -> ExpQ
biExp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, Pat)] -> Exp
ie forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q (Pat, Pat)
ic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> String -> [String]
split 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [(Pat, Pat)] -> Exp
ce [(Pat, Pat)]
l) (Name -> Exp
TH.ConE '(:<->:)) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [(Pat, Pat)] -> Exp
ce forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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] 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 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 =
      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 = 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 = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in types"
  , quotePat :: String -> PatQ
quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in patterns"
  , quoteDec :: String -> Q [Dec]
quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"biCase not supported in declarations"
  }