{-# 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]
_
#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 '<->'"
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"
}