{-# LANGUAGE QuasiQuotes #-}
module Indigo.Internal.Expr.TH
( deriveExprBuildable
) where
import qualified Data.Map as M
import qualified Data.Set as S
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Language.Haskell.TH.Syntax as TH
import Prelude hiding (Const)
import qualified Text.Casing as C
pattern CName :: String -> (TH.Name, [BangType])
pattern $mCName :: forall r. (Name, [BangType]) -> (String -> r) -> (Void# -> r) -> r
CName nm <- (TH.Name (OccName nm) _, _)
type UntypedConstr = (Name, [BangType])
deriveExprBuildable :: Name -> Q [Dec]
deriveExprBuildable :: Name -> Q [Dec]
deriveExprBuildable name :: Name
name = do
TyConI (DataD _ dataName :: Name
dataName vars :: [TyVarBndr]
vars _ cons :: [Con]
cons _) <- Name -> Q Info
reify Name
name
let getNameFromVar :: TyVarBndr -> Name
getNameFromVar (PlainTV n :: Name
n) = Name
n
getNameFromVar (KindedTV n :: Name
n _) = Name
n
convertTyVars :: Type -> Type
convertTyVars orig :: Type
orig = (Element [TyVarBndr] -> Type -> Type)
-> Type -> [TyVarBndr] -> Type
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr (\a :: Element [TyVarBndr]
a b :: Type
b -> Type -> Type -> Type
AppT Type
b (Type -> Type) -> (Name -> Type) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ TyVarBndr -> Name
getNameFromVar TyVarBndr
Element [TyVarBndr]
a) Type
orig [TyVarBndr]
vars
unfoldConstructor :: Con -> [(Name, [BangType])]
unfoldConstructor (GadtC cs :: [Name]
cs bangs :: [BangType]
bangs _) = (Name -> (Name, [BangType])) -> [Name] -> [(Name, [BangType])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (,[BangType]
bangs) [Name]
cs
unfoldConstructor (ForallC _ _ c :: Con
c) = Con -> [(Name, [BangType])]
unfoldConstructor Con
c
unfoldConstructor _ = String -> [(Name, [BangType])]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Non GADT constructors are not supported."
(bLeft :: Exp
bLeft, bRight :: Exp
bRight, comma :: Exp
comma) = (Lit -> Exp
LitE (String -> Lit
StringL "("), Lit -> Exp
LitE (String -> Lit
StringL ")"), Lit -> Exp
LitE (String -> Lit
StringL ", "))
mappendAll :: [Exp] -> Exp
mappendAll :: [Exp] -> Exp
mappendAll [] = Text -> Exp
forall a. HasCallStack => Text -> a
error "impossible empty list"
mappendAll (hd :: Exp
hd : rest :: [Exp]
rest) = (Exp -> Element [Exp] -> Exp) -> Exp -> [Exp] -> Exp
forall t b. Container t => (b -> Element t -> b) -> b -> t -> b
foldl (\res :: Exp
res term :: Element [Exp]
term -> Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
res) (Name -> Exp
VarE (String -> Name
mkName "<>")) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
Element [Exp]
term)) Exp
hd [Exp]
rest
omitUnaryConstr :: (Exp -> Exp) -> UntypedConstr -> Q Clause
omitUnaryConstr :: (Exp -> Exp) -> (Name, [BangType]) -> Q Clause
omitUnaryConstr fun :: Exp -> Exp
fun (conName :: Name
conName, _) = do
Name
var <- String -> Q Name
newName "a"
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
ConP Name
conName [Name -> Pat
VarP Name
var]]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
fun (Name -> Exp
VarE Name
var))
[]
toFunName :: (Name, [BangType]) -> String
toFunName (CName "Right'") = "right"
toFunName (CName "Left'") = "left"
toFunName (CName "Concat'") = "concatAll"
toFunName (CName "Int'") = "toInt"
toFunName (TH.Name (OccName nm :: String
nm) _, _) = Identifier String -> String
C.toCamel (Identifier String -> String) -> Identifier String -> String
forall a b. (a -> b) -> a -> b
$ String -> Identifier String
C.fromHumps String
nm
operators :: Map String String
operators :: Map String String
operators = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ("Add", "+"), ("Sub", "-"), ("Mul", "*"), ("Div", "/"), ("Mod", "%")
, ("Lsl", "<<<"), ("Lsr", ">>>"), ("Eq'", "=="), ("Neq", "/="), ("Le", "=<")
, ("Lt", "<"), ("Ge", ">="), ("Gt", ">="), ("Or", "||"), ("Xor", "^"), ("And", "&&")
, ("Cons", ".:"), ("Concant", "<>")
]
braces :: Set String
braces :: Set String
braces = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ["Add", "Sub", "Or", "Xor", "Lsl", "Lsr"]
makeClause :: UntypedConstr -> Q Clause
makeClause :: (Name, [BangType]) -> Q Clause
makeClause c :: (Name, [BangType])
c@(CName "C") = (Exp -> Exp) -> (Name, [BangType]) -> Q Clause
omitUnaryConstr (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "pretty") (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "PrintAsValue")) (Name, [BangType])
c
makeClause c :: (Name, [BangType])
c@(CName "V") = (Exp -> Exp) -> (Name, [BangType]) -> Q Clause
omitUnaryConstr (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "pretty")) (Name, [BangType])
c
makeClause c :: (Name, [BangType])
c@(CName "ObjMan") = (Exp -> Exp) -> (Name, [BangType]) -> Q Clause
omitUnaryConstr (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "pretty")) (Name, [BangType])
c
makeClause c :: (Name, [BangType])
c@(CName "Construct") = (Name, [BangType]) -> Q Clause
forall b. (Name, b) -> Q Clause
construct (Name, [BangType])
c
makeClause c :: (Name, [BangType])
c@(CName "ConstructWithoutNamed") = (Name, [BangType]) -> Q Clause
forall b. (Name, b) -> Q Clause
construct (Name, [BangType])
c
makeClause c :: (Name, [BangType])
c@(CName "StInsertNew") =
String -> (Name, [BangType]) -> Maybe (String, Bool) -> Q Clause
generalClauseImpl "pretty" (Name, [BangType])
c Maybe (String, Bool)
forall a. Maybe a
Nothing
makeClause c :: (Name, [BangType])
c@(TH.Name (OccName nm :: String
nm) _, _) =
String -> (Name, [BangType]) -> Maybe (String, Bool) -> Q Clause
generalClauseImpl "pretty" (Name, [BangType])
c (Maybe (String, Bool) -> Q Clause)
-> Maybe (String, Bool) -> Q Clause
forall a b. (a -> b) -> a -> b
$ (, String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member String
nm Set String
braces) (String -> (String, Bool)) -> Maybe String -> Maybe (String, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
nm Map String String
operators
construct :: (Name, b) -> Q Clause
construct (conName :: Name
conName, _) = do
Name
proxy <- String -> Q Name
newName "proxy"
Name
r <- String -> Q Name
newName "rec"
let showTypeRep :: Exp -> Exp
showTypeRep = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "show") (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "typeRep")
Exp
mappendRec <- [| \x -> mconcat (intersperse "," (recordToList (rmap (\ex -> Const (pretty ex)) x))) |]
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
ConP Name
conName [Name -> Pat
VarP Name
proxy, Name -> Pat
VarP Name
r]]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$
[Exp] -> Exp
mappendAll [Exp -> Exp
showTypeRep (Name -> Exp
VarE Name
proxy), Exp
bLeft, (Exp -> Exp -> Exp
AppE Exp
mappendRec (Name -> Exp
VarE Name
r)), Exp
bRight])
[]
generalClauseImpl :: String -> (Name, [BangType]) -> Maybe (String, Bool) -> Q Clause
generalClauseImpl :: String -> (Name, [BangType]) -> Maybe (String, Bool) -> Q Clause
generalClauseImpl funName :: String
funName c :: (Name, [BangType])
c@(conName :: Name
conName, bangs :: [BangType]
bangs) isInfix :: Maybe (String, Bool)
isInfix = do
[Name]
varNames <- (BangType -> Q Name) -> [BangType] -> Q [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\_ -> String -> Q Name
newName "a") [BangType]
bangs
let funStr :: Exp
funStr = Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ (Name, [BangType]) -> String
toFunName (Name, [BangType])
c)
let pretties :: [Exp]
pretties =
case (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\e :: Name
e -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
funName) (Name -> Exp
VarE Name
e)) [Name]
varNames of
[] -> [Exp
funStr]
[x :: Exp
x, y :: Exp
y] | Just (op :: String
op, False) <- Maybe (String, Bool)
isInfix ->
[Exp
x, Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ " " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
op String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " "), Exp
y]
[x :: Exp
x, y :: Exp
y] | Just (op :: String
op, True) <- Maybe (String, Bool)
isInfix ->
[Exp
bLeft, Exp
x, Lit -> Exp
LitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ " " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
op String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " "), Exp
y, Exp
bRight]
xs :: [Exp]
xs -> Exp
funStr Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: Exp
bLeft Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: (Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
intersperse Exp
comma [Exp]
xs [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp
bRight])
Clause -> Q Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
[Pat] -> Body -> [Dec] -> Clause
Clause
[Name -> [Pat] -> Pat
ConP Name
conName ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> Pat
VarP [Name]
varNames]
(Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mappendAll [Exp]
pretties)
[]
[Clause]
clauses <- ((Name, [BangType]) -> Q Clause)
-> [(Name, [BangType])] -> Q [Clause]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, [BangType]) -> Q Clause
makeClause ([(Name, [BangType])] -> Q [Clause])
-> [(Name, [BangType])] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ [Con]
cons [Con] -> (Con -> [(Name, [BangType])]) -> [(Name, [BangType])]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Con -> [(Name, [BangType])]
unfoldConstructor
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
Maybe Overlap
forall a. Maybe a
Nothing
[]
(Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "Buildable") (Type -> Type
convertTyVars (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
dataName))
[Name -> [Clause] -> Dec
FunD (String -> Name
mkName "build") [Clause]
clauses]
]