-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# 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])

-- | Generates an Buildable instance for a Expr GADT. /Note:/ This will not generate
-- additional constraints to the generated instance if those are required.
-- Inspired by 'deriveGADTNFData' from Util.TH.
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

      -- Unfolds multiple constructors of form "A, B, C :: A -> Stuff"
      -- into a list of tuples of constructor names and their data
      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))
            []

      -- Specific to Expr
      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])
            []

      -- Constructs a clause "build (ConName a1 a2) = "CON_NAME" <> "(" <> pretty a1 <> pretty a2 <> ")"
      -- The first argument is a workaround: it returns name of printing function either "pretty" or "show"
      -- by index argument.
      -- This is mainly for 'StInsertNew' constructor to print error with show
      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
        -- useful constants
        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
                -- Nullary operator: "function_name"
                []    -> [Exp
funStr]
                -- Infix binary operator without braces: pretty x <> " operator " <> pretty y
                [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]
                -- Infix binary operator with braces: "(" <> pretty x <> " operator " <> pretty 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]
                -- Infix binary operator with braces: "function_name" <> "(" <> pretty x1 <> "," ... <> pretty xn <> ")"
                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]
    ]