{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoPolyKinds #-}
{- | Description : quasiquoter inspired by -XNamedFieldPuns -}
module Data.HList.RecordPuns (
    -- $ex
    pun

    ) where

import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.HList.Record
import Data.HList.FakePrelude
import Data.List
import Data.HList.HList

{- $ex

>>> :set -XQuasiQuotes -XViewPatterns

[@patterns@]

>>> let y = Label :: Label "y"
>>> let x = Label :: Label "x"
>>> [pun| x y |] <- return (x .=. 3 .*. y .=. "hi" .*. emptyRecord)
>>> print (x,y)
(3,"hi")

[@expressions@]

Compare with the standard way to construct records above

>>> let x = 3; y = "hi"
>>> [pun|x y|]
Record{x=3,y="hi"}

[@nesting@]

Nesting is supported. Variables inside
@{ }@ and @( )@ are one level deeper, like the built-in syntax.
Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more
cluttered than @[pun|x|]@.
More concretely the pattern:


> let [pun| ab@{ a b } y z c{d} |] = x

is short for:

> let ab = x.ab
>     a = x.ab.a
>     b = x.ab.b
>     y = x.y
>     z = x.z
>     -- c is not bound
>     d = x.c.d

Where here `.` is a left-associative field lookup (as it is in other languages).

The pun quasiquoter can also be used in an expression context:

> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |]
>     x = mkX ab b y z d

Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has
fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via
'hLeftUnion' = '.<++.') . In other words,

> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_
>                               in [pun| ab y z c{d} |]

For patterns, any order and additional fields are allowed if @{ }@ is used,
just as in built-in record syntax. But it is often necessary to restrict the
order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'.
So use @( )@ instead:

> let [pun| (x _ y{}) |] = list
> -- desugars to something like:
> Record ((Tagged x :: Tagged "x" s1) `HCons`
>         (Tagged _ :: Tagged t   s2) `HCons`
>         (Tagged _ :: Tagged "y" s3) `HCons`
>          HNil) = list

Note that this also introduces the familiar wild card pattern (@_@),
and shows again how to ensure a label is present but not bind a variable
to it.

For comparison, here are three equivalent ways to define variables `x` and `y`

> let [pun| x y{} |] = r
> let [pun|{ x y{} }|] = r -- or this
> let x = r .!. (Label :: Label "x")
>     y = constrainType (r .!. (Label :: Label "y"))
>     constrainType :: Record t -> Record t
>     constrainType = id

See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with
'Variant' too.

-}


-- | requires labels to be promoted strings (kind Symbol), as provided by
-- "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@),
-- or "Data.HList.Labelable"
pun :: QuasiQuoter
pun :: QuasiQuoter
pun = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {
    quotePat :: String -> Q Pat
quotePat = (Tree -> Q Pat) -> Tree -> Q Pat
forall p. (Tree -> p) -> Tree -> p
suppressWarning Tree -> Q Pat
mp (Tree -> Q Pat) -> (String -> Tree) -> String -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tree
parseRec,
    quoteExp :: String -> Q Exp
quoteExp = (Tree -> Q Exp) -> Tree -> Q Exp
forall p. (Tree -> p) -> Tree -> p
suppressWarning Tree -> Q Exp
me (Tree -> Q Exp) -> (String -> Tree) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tree
parseRec,
    quoteDec :: String -> Q [Dec]
quoteDec  = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Data.HList.RecordPuns.quoteDec",
    quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"Data.HList.RecordPuns.quoteType"
 }


-- | the warning about @implicit {} added@ doesn't
-- make sense at top level (but it does if you say
-- have  [pun| x @ y |]
suppressWarning :: (Tree -> p) -> Tree -> p
suppressWarning Tree -> p
f (V String
a) = Tree -> p
f ([Tree] -> Tree
C [String -> Tree
V String
a])
suppressWarning Tree -> p
f Tree
x = Tree -> p
f Tree
x

-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2),
-- where x1 = Label :: Label "x1"
extracts :: [String] -> Q Exp
extracts [String]
xs = do
    Name
record <- String -> Q Name
newName String
"record"
    -- to fix #5 I could comment out the ensureLength below
    [Q Pat] -> Q Exp -> Q Exp
lamE [Name -> Q Pat
varP Name
record] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
tupE
            [ [| $(varE record) .!. $label  |]
                | String
x <- [String]
xs,
                let label :: Q Exp
label = [| Label :: Label $(litT (strTyLit x)) |],
                String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"_"
                ]

mkPair :: String -> ExpQ -> ExpQ
mkPair :: String -> Q Exp -> Q Exp
mkPair String
x Q Exp
xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |]



me :: Tree -> ExpQ
me :: Tree -> Q Exp
me (C [Tree]
as) = ((String, Q Exp) -> Q Exp -> Q Exp)
-> Q Exp -> [(String, Q Exp)] -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(String
l,Q Exp
e) Q Exp
acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] ([Tree] -> [(String, Q Exp)]
mes [Tree]
as)
me (D [Tree]
_as) = String -> Q Exp
forall a. HasCallStack => String -> a
error String
"Data.HList.RecordPuns.mp impossible"
me Tree
a = do
    String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Data.HList.RecordPuns.mp implicit {} added around:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tree -> String
forall a. Show a => a -> String
show Tree
a
    Tree -> Q Exp
me ([Tree] -> Tree
C [Tree
a])

mes :: [Tree] -> [(String, ExpQ)]
mes :: [Tree] -> [(String, Q Exp)]
mes (V String
a : V String
"@": Tree
b : [Tree]
c) = (String
a, [| $(me b) `hLeftUnion` $(dyn a) |]) (String, Q Exp) -> [(String, Q Exp)] -> [(String, Q Exp)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Exp)]
mes [Tree]
c
mes (V String
a : C [Tree]
b : [Tree]
c)      = (String
a, Tree -> Q Exp
me ([Tree] -> Tree
C [Tree]
b)) (String, Q Exp) -> [(String, Q Exp)] -> [(String, Q Exp)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Exp)]
mes [Tree]
c
mes (V String
a : D [Tree]
b : [Tree]
c)      = (String
a, Tree -> Q Exp
me ([Tree] -> Tree
C [Tree]
b)) (String, Q Exp) -> [(String, Q Exp)] -> [(String, Q Exp)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Exp)]
mes [Tree]
c
mes (V String
a : [Tree]
b)            = (String
a, Name -> Q Exp
varE (String -> Name
mkName String
a)) (String, Q Exp) -> [(String, Q Exp)] -> [(String, Q Exp)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Exp)]
mes [Tree]
b
mes [] = []
mes [Tree]
inp = String -> [(String, Q Exp)]
forall a. HasCallStack => String -> a
error (String -> [(String, Q Exp)]) -> String -> [(String, Q Exp)]
forall a b. (a -> b) -> a -> b
$ String
"Data.HList.RecordPuns.mes: cannot translate remaining:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        [String] -> String
forall a. Show a => a -> String
show ((Tree -> String) -> [Tree] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> String
ppTree [Tree]
inp)

mp :: Tree -> PatQ
mp :: Tree -> Q Pat
mp (C [Tree]
as) =
    let extractPats :: [(String, Q Pat)]
extractPats = [Tree] -> [(String, Q Pat)]
mps [Tree]
as
        tupleP :: Q Pat
tupleP = [Q Pat] -> Q Pat
tupP [ Q Pat
p | (String
binding, Q Pat
p) <- [(String, Q Pat)]
extractPats, String
binding String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"_" ]
    in Q Exp -> Q Pat -> Q Pat
viewP ([String] -> Q Exp
extracts (((String, Q Pat) -> String) -> [(String, Q Pat)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Q Pat) -> String
forall a b. (a, b) -> a
fst [(String, Q Pat)]
extractPats)) Q Pat
tupleP


mp (D [Tree]
as) = Name -> [Q Pat] -> Q Pat
conP 'Record
  [((String, Q Pat) -> Q Pat -> Q Pat)
-> Q Pat -> [(String, Q Pat)] -> Q Pat
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ( \ (String
n,Q Pat
p) Q Pat
xs -> Name -> [Q Pat] -> Q Pat
conP 'HCons
                [ let ty :: Q Exp
ty
                          | String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_"  = [| undefined :: Tagged anyLabel t |]
                          | Bool
otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |]
                  in Q Exp -> Q Pat -> Q Pat
viewP [| \x -> x `asTypeOf` $ty |]
                      (Name -> [Q Pat] -> Q Pat
conP 'Tagged [Q Pat
p]),
                Q Pat
xs])
          (Name -> [Q Pat] -> Q Pat
conP 'HNil [])
          ([Tree] -> [(String, Q Pat)]
mps [Tree]
as)]
mp Tree
a = do
    String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Data.HList.RecordPuns.mp implicit {} added around:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tree -> String
forall a. Show a => a -> String
show Tree
a
    Tree -> Q Pat
mp ([Tree] -> Tree
C [Tree
a])

mps :: [Tree] -> [(String, PatQ)]
mps :: [Tree] -> [(String, Q Pat)]
mps (V String
a : V String
"@" : Tree
b : [Tree]
c) = (String
a, Name -> Q Pat -> Q Pat
asP (String -> Name
mkName String
a) (Tree -> Q Pat
mp Tree
b)) (String, Q Pat) -> [(String, Q Pat)] -> [(String, Q Pat)]
forall a. a -> [a] -> [a]
:  [Tree] -> [(String, Q Pat)]
mps [Tree]
c
mps (V String
a : C [Tree]
b : [Tree]
c) = (String
a, Tree -> Q Pat
mp ([Tree] -> Tree
C [Tree]
b)) (String, Q Pat) -> [(String, Q Pat)] -> [(String, Q Pat)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Pat)]
mps [Tree]
c
mps (V String
a : D [Tree]
b : [Tree]
c) = (String
a, Tree -> Q Pat
mp ([Tree] -> Tree
D [Tree]
b)) (String, Q Pat) -> [(String, Q Pat)] -> [(String, Q Pat)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Pat)]
mps [Tree]
c
mps (V String
"_" : [Tree]
b) = (String
"_", Q Pat
wildP) (String, Q Pat) -> [(String, Q Pat)] -> [(String, Q Pat)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Pat)]
mps [Tree]
b
mps (V String
a : [Tree]
b) = (String
a, Name -> Q Pat
varP (String -> Name
mkName String
a)) (String, Q Pat) -> [(String, Q Pat)] -> [(String, Q Pat)]
forall a. a -> [a] -> [a]
: [Tree] -> [(String, Q Pat)]
mps [Tree]
b
mps [] = []
mps [Tree]
inp = String -> [(String, Q Pat)]
forall a. HasCallStack => String -> a
error (String -> [(String, Q Pat)]) -> String -> [(String, Q Pat)]
forall a b. (a -> b) -> a -> b
$ String
"Data.HList.RecordPuns.mps: cannot translate remaining pattern:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        [String] -> String
forall a. Show a => a -> String
show ((Tree -> String) -> [Tree] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> String
ppTree [Tree]
inp)

data Tree = C [Tree] -- ^ curly @{ }@
          | D [Tree] -- ^ @(  )@
          | V String -- ^ variable
  deriving Int -> Tree -> String -> String
[Tree] -> String -> String
Tree -> String
(Int -> Tree -> String -> String)
-> (Tree -> String) -> ([Tree] -> String -> String) -> Show Tree
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Tree] -> String -> String
$cshowList :: [Tree] -> String -> String
show :: Tree -> String
$cshow :: Tree -> String
showsPrec :: Int -> Tree -> String -> String
$cshowsPrec :: Int -> Tree -> String -> String
Show

{- |

>>> parseRec "{ a b c {d e f}  } d"
C [C [V "a",V "b",V "c",C [V "d",V "e",V "f"]],V "d"]

>>> ppTree $ parseRec "{a b c {d e {} f @ g}}"
"{a b c {d e {} f @ g}}"

>>> ppTree $ parseRec "a b c {d e {} f @ g}"
"{a b c {d e {} f @ g}}"

>>> ppTree $ parseRec "(a b { (d) e } )"
"(a b {(d) e})"

-}
parseRec :: String -> Tree
parseRec :: String -> Tree
parseRec String
str = case Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' Int
0 Int
0 [[]] ([String] -> [Tree]) -> [String] -> [Tree]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lexing String
str of
    [Tree
x] -> Tree
x -- avoid adding another layer if possible
    [Tree]
x -> [Tree] -> Tree
C ([Tree] -> [Tree]
forall a. [a] -> [a]
reverse [Tree]
x)

parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' Int
n Int
m [[Tree]]
accum  (String
"{" : [String]
rest)  = Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
m ([] [Tree] -> [[Tree]] -> [[Tree]]
forall a. a -> [a] -> [a]
: [[Tree]]
accum) [String]
rest
parseRec' Int
n Int
m [[Tree]]
accum  (String
"(" : [String]
rest)  = Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec'  Int
n (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([] [Tree] -> [[Tree]] -> [[Tree]]
forall a. a -> [a] -> [a]
: [[Tree]]
accum) [String]
rest
parseRec' Int
n Int
m ([Tree]
a:[Tree]
b:[[Tree]]
c) (String
"}" : [String]
rest) = Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
m (([Tree] -> Tree
C ([Tree] -> [Tree]
forall a. [a] -> [a]
reverse [Tree]
a) Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Tree]
b) [Tree] -> [[Tree]] -> [[Tree]]
forall a. a -> [a] -> [a]
: [[Tree]]
c)  [String]
rest
parseRec' Int
n Int
m ([Tree]
a:[Tree]
b:[[Tree]]
c) (String
")" : [String]
rest) = Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' Int
n (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (([Tree] -> Tree
D ([Tree] -> [Tree]
forall a. [a] -> [a]
reverse [Tree]
a) Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Tree]
b) [Tree] -> [[Tree]] -> [[Tree]]
forall a. a -> [a] -> [a]
: [[Tree]]
c)  [String]
rest
parseRec' Int
n Int
m ([Tree]
b:[[Tree]]
c) (String
a   : [String]
rest)
         | String
a String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"{",String
"}",String
"(",String
")"] = Int -> Int -> [[Tree]] -> [String] -> [Tree]
parseRec' Int
n Int
m   ((String -> Tree
V String
a Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Tree]
b) [Tree] -> [[Tree]] -> [[Tree]]
forall a. a -> [a] -> [a]
: [[Tree]]
c) [String]
rest
parseRec' Int
0 Int
0 ([Tree]
a:[[Tree]]
_) []             = [Tree]
a
parseRec' Int
_ Int
_ [[Tree]]
accum [String]
e              = String -> [Tree]
forall a. HasCallStack => String -> a
error (String
"Data.HList.RecordPuns.parseRec' unexpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
e
                                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n parsed:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [[Tree]] -> String
forall a. Show a => a -> String
show ([[Tree]] -> [[Tree]]
forall a. [a] -> [a]
reverse [[Tree]]
accum))

ppTree :: Tree -> String
ppTree :: Tree -> String
ppTree (C [Tree]
ts) = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Tree -> String) -> [Tree] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> String
ppTree [Tree]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
ppTree (D [Tree]
ts) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Tree -> String) -> [Tree] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> String
ppTree [Tree]
ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
ppTree (V String
x)  = String
x

lexing :: String -> [String]
lexing = (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\String
v -> case ReadS String
lex String
v of
                    (String
"", String
"") : [(String, String)]
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
                    (String, String)
e : [(String, String)]
_ -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String, String)
e
                    [(String, String)]
_ -> Maybe (String, String)
forall a. Maybe a
Nothing)