    {-|
    Copyright   :  (C) 2019, Myrtle Software Ltd,
                       2021, QBayLogic B.V.
                       2022, Google Inc
    License     :  BSD2 (see the file LICENSE)
    Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

    Template Haskell utilities for "Clash.Core.TermLiteral".
    -}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE TemplateHaskell #-}

    module Clash.Core.TermLiteral.TH
      ( deriveTermToData
      , deriveShowsTypePrec
      , deriveTermLiteral
         -- Stop exporting @dcName'@  once `ghcide` stops type-checking expanded
         -- TH splices
      ,  dcName'
      ) where

    import           Data.Either
    import qualified Data.Text                       as Text
    import           Data.List                       (intersperse)
    import qualified Data.List.NonEmpty              as NE
    import           Data.Proxy
    import           Data.Maybe                      (isNothing)
    import           Language.Haskell.TH.Syntax
    import           Language.Haskell.TH.Lib         hiding (match)

    import           Clash.Core.DataCon
    import           Clash.Core.Term                 (collectArgs, Term(Data))
    import           Clash.Core.Name                 (nameOcc)

    -- Workaround for a strange GHC bug, where it complains about Subst only
    -- existing as a boot file:
    --
    -- module Clash.Core.Subst cannot be linked; it is only available as a boot module
    import Clash.Core.Subst ()

    #if __GLASGOW_HASKELL__ >= 900
    type CompatTyVarBndr = TyVarBndr ()
    #else
    type CompatTyVarBndr = TyVarBndr
    #endif

    dcName' :: DataCon -> String
    dcName' :: DataCon -> String
    dcName' = Text -> String
    Text.unpack (Text -> String) -> (DataCon -> Text) -> DataCon -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name DataCon -> Text
    forall a. Name a -> Text
    nameOcc (Name DataCon -> Text)
    -> (DataCon -> Name DataCon) -> DataCon -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DataCon -> Name DataCon
    dcName

    termToDataName :: Name
    termToDataName :: Name
    termToDataName =
      -- Note that we can't use a fully qualified name here: GHC disallows fully
      -- qualified names in instance function declarations.
      String -> Name
    mkName String
    "termToData"

    showsTypePrecName :: Name
    showsTypePrecName :: Name
    showsTypePrecName =
      -- Note that we can't use a fully qualified name here: GHC disallows fully
      -- qualified names in instance function declarations.
      String -> Name
    mkName String
    "showsTypePrec"

    termLiteralName :: Name
    termLiteralName :: Name
    termLiteralName = String -> Name
    mkName String
    "Clash.Core.TermLiteral.TermLiteral"

    -- | Extracts variable names from a 'TyVarBndr'.
    typeVarName :: CompatTyVarBndr -> Q (Name, Maybe Type)
    typeVarName :: CompatTyVarBndr -> Q (Name, Maybe Type)
    typeVarName = \case
    #if __GLASGOW_HASKELL__ >= 900
      PlainTV Name
    typVarName ()        -> (Name, Maybe Type) -> Q (Name, Maybe Type)
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Name
    typVarName, Maybe Type
    forall a. Maybe a
    Nothing)
      KindedTV Name
    typVarName () Type
    StarT -> (Name, Maybe Type) -> Q (Name, Maybe Type)
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Name
    typVarName, Maybe Type
    forall a. Maybe a
    Nothing)
      KindedTV Name
    typVarName () Type
    kind  -> (Name, Maybe Type) -> Q (Name, Maybe Type)
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Name
    typVarName, Type -> Maybe Type
    forall a. a -> Maybe a
    Just Type
    kind)
    #else
      PlainTV typVarName        -> pure (typVarName, Nothing)
      KindedTV typVarName StarT -> pure (typVarName, Nothing)
      KindedTV typVarName kind  -> pure (typVarName, Just kind)
    #endif

    -- | Derive a t'Clash.Core.TermLiteral.TermLiteral' instance for given type
    deriveTermLiteral :: Name -> Q [Dec]
    deriveTermLiteral :: Name -> Q [Dec]
    deriveTermLiteral Name
    typName = do
      TyConI (DataD Cxt
    _ Name
    _ [CompatTyVarBndr]
    typeVars Maybe Type
    _ [Con]
    _ [DerivClause]
    _) <- Name -> Q Info
    reify Name
    typName
    #if MIN_VERSION_template_haskell(2,21,0)
      typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars
    #else
      [(Name, Maybe Type)]
    typeVarNames <- (CompatTyVarBndr -> Q (Name, Maybe Type))
    -> [CompatTyVarBndr] -> Q [(Name, Maybe Type)]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM CompatTyVarBndr -> Q (Name, Maybe Type)
    typeVarName [CompatTyVarBndr]
    typeVars
    #endif
      Dec
    showsTypePrec <- Name -> Q Dec
    deriveShowsTypePrec Name
    typName
      Exp
    termToDataBody <- Name -> Q Exp
    deriveTermToData Name
    typName
      let
        termToData :: Dec
    termToData = Name -> [Clause] -> Dec
    FunD Name
    termToDataName [[Pat] -> Body -> [Dec] -> Clause
    Clause [] (Exp -> Body
    NormalB Exp
    termToDataBody) []]
        innerInstanceType :: Type
    innerInstanceType = (Type -> Type -> Type) -> Type -> Cxt -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: Type -> Type) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    typName) (((Name, Maybe Type) -> Type) -> [(Name, Maybe Type)] -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Type
    VarT (Name -> Type)
    -> ((Name, Maybe Type) -> Name) -> (Name, Maybe Type) -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, Maybe Type) -> Name
    forall a b. (a, b) -> a
    fst) [(Name, Maybe Type)]
    typeVarNames)
        instanceType :: Type
    instanceType = Name -> Type
    ConT Name
    termLiteralName Type -> Type -> Type
    `AppT` Type
    innerInstanceType
        constraint :: Name -> m Type
    constraint Name
    typVarName = [t| $(Name -> m Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    conT Name
    termLiteralName) $(Name -> m Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT Name
    typVarName) |]
      Cxt
    constraints <- ((Name, Maybe Type) -> Q Type) -> [(Name, Maybe Type)] -> Q Cxt
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    constraint (Name -> Q Type)
    -> ((Name, Maybe Type) -> Name) -> (Name, Maybe Type) -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, Maybe Type) -> Name
    forall a b. (a, b) -> a
    fst) (((Name, Maybe Type) -> Bool)
    -> [(Name, Maybe Type)] -> [(Name, Maybe Type)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Maybe Type -> Bool
    forall a. Maybe a -> Bool
    isNothing (Maybe Type -> Bool)
    -> ((Name, Maybe Type) -> Maybe Type) -> (Name, Maybe Type) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, Maybe Type) -> Maybe Type
    forall a b. (a, b) -> b
    snd) [(Name, Maybe Type)]
    typeVarNames)
      [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
    forall a b. (a -> b) -> a -> b
    $ [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing Cxt
    constraints Type
    instanceType [Dec
    showsTypePrec, Dec
    termToData]]

    -- | For 'Maybe', constructs:
    --
    -- > showsTypePrec n _
    -- >   = let
    -- >       showSpace = showChar ' '
    -- >       precCalls = [showsTypePrec 11 (Proxy @a)]
    -- >       interspersedPrecCalls = intersperse showSpace precCalls
    -- >       showType = foldl (.) (showString "Maybe") (showSpace : interspersedPrecCalls)
    -- >     in
    -- >       showParen (n > 10) showType
    --
    deriveShowsTypePrec :: Name -> Q Dec
    deriveShowsTypePrec :: Name -> Q Dec
    deriveShowsTypePrec Name
    typName = do
      TyConI (DataD Cxt
    _ Name
    _ [CompatTyVarBndr]
    typeVars Maybe Type
    _ [Con]
    _ [DerivClause]
    _) <- Name -> Q Info
    reify Name
    typName
    #if MIN_VERSION_template_haskell(2,21,0)
      typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars
    #else
      [(Name, Maybe Type)]
    typeVarNames <- (CompatTyVarBndr -> Q (Name, Maybe Type))
    -> [CompatTyVarBndr] -> Q [(Name, Maybe Type)]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM CompatTyVarBndr -> Q (Name, Maybe Type)
    typeVarName [CompatTyVarBndr]
    typeVars
    #endif
      Exp
    showTypeBody <- [(Name, Maybe Type)] -> Q Exp
    mkShowTypeBody [(Name, Maybe Type)]
    typeVarNames
      Dec -> Q Dec
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Name -> [Clause] -> Dec
    FunD Name
    showsTypePrecName [[Pat] -> Body -> [Dec] -> Clause
    Clause [Name -> Pat
    VarP Name
    nName, Pat
    WildP] (Exp -> Body
    NormalB Exp
    showTypeBody) []])
     where
      showTypeName :: Q Exp
    showTypeName = [| showString $(Lit -> Q Exp
    forall (m :: Type -> Type). Quote m => Lit -> m Exp
    litE (String -> Lit
    StringL (Name -> String
    nameBase Name
    typName))) |]

      -- Constructs:
      --
      -- > showsTypePrec 11 (Proxy @a)
      --
      -- where the 'a' is given as an argument. The surrounding operator precedence
      -- is set to indicate "function" application. I.e., it instructs the call to
      -- wrap the type string in parentheses.
      --
      mkTypePrecCall :: (Name, Maybe a) -> Q Exp
    mkTypePrecCall = \case
        (Name
    typVarName, Maybe a
    Nothing) ->
          [| $(Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    showsTypePrecName) 11 (Proxy @($(Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT Name
    typVarName))) |]
        (Name
    _, Just a
    _) ->
          -- XXX: Not sure how to deal with non-Type type variables so we do the dumb
          --      thing and insert an underscore.
          [| showString "_" |]

      -- Constructs:
      --
      -- > showString "Maybe" . showChar ' ' . showsTypePrec 11 (Proxy @a)
      --
      -- This is wrapped in an if-statement wrapping the result in parentheses if the
      -- incoming prec is more than 10 (function application).
      --
      mkShowTypeBody :: [(Name, Maybe Type)] -> Q Exp
      mkShowTypeBody :: [(Name, Maybe Type)] -> Q Exp
    mkShowTypeBody [(Name, Maybe Type)]
    typeVarNames =
        case [(Name, Maybe Type)]
    typeVarNames of
          [] ->
            -- We seq on `n` here to prevent _unused variable_ warnings. This is a
            -- bit of a hack (the real solution would be to selectively pattern
            -- match).
            [| $(Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    nName) `seq` $(Q Exp
    showTypeName) |]
          [(Name, Maybe Type)]
    _  -> [|
            let
              showSpace = showChar ' '
              precCalls = $([Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    listE (((Name, Maybe Type) -> Q Exp) -> [(Name, Maybe Type)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name, Maybe Type) -> Q Exp
    forall {a}. (Name, Maybe a) -> Q Exp
    mkTypePrecCall [(Name, Maybe Type)]
    typeVarNames))
              interspersedPrecCalls = intersperse showSpace precCalls
              showType = foldl (.) $(Q Exp
    showTypeName) (showSpace : interspersedPrecCalls)
            in
              showParen ($(Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE Name
    nName) > 10) showType
           |]

      nName :: Name
    nName = String -> Name
    mkName String
    "n"

    deriveTermToData :: Name -> Q Exp
    deriveTermToData :: Name -> Q Exp
    deriveTermToData Name
    typName = do
      TyConI (DataD Cxt
    _ Name
    _ [CompatTyVarBndr]
    _ Maybe Type
    _ [Con]
    constrs [DerivClause]
    _) <- Name -> Q Info
    reify Name
    typName
      Exp -> Q Exp
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure ([(Name, Int)] -> Exp
    deriveTermToData1 ((Con -> (Name, Int)) -> [Con] -> [(Name, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map Con -> (Name, Int)
    toConstr' [Con]
    constrs))
     where
      toConstr' :: Con -> (Name, Int)
    toConstr' (NormalC Name
    cName [BangType]
    fields) = (Name
    cName, [BangType] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [BangType]
    fields)
      toConstr' (RecC Name
    cName [VarBangType]
    fields) = (Name
    cName, [VarBangType] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [VarBangType]
    fields)
      toConstr' Con
    c = String -> (Name, Int)
    forall a. HasCallStack => String -> a
    error (String -> (Name, Int)) -> String -> (Name, Int)
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected constructor: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Con -> String
    forall a. Show a => a -> String
    show Con
    c

    deriveTermToData1 :: [(Name, Int)] -> Exp
    deriveTermToData1 :: [(Name, Int)] -> Exp
    deriveTermToData1 [(Name, Int)]
    constrs =
      [Match] -> Exp
    LamCaseE
        [ Pat -> Body -> [Dec] -> Match
    Match Pat
    pat (Exp -> Body
    NormalB (if [Dec] -> Bool
    forall a. [a] -> Bool
    forall (t :: Type -> Type) a. Foldable t => t a -> Bool
    null [Dec]
    args then Exp
    theCase else [Dec] -> Exp -> Exp
    LetE [Dec]
    args Exp
    theCase)) []
        , Pat -> Body -> [Dec] -> Match
    Match (Name -> Pat
    VarP Name
    termName) (Exp -> Body
    NormalB ((Name -> Exp
    ConE 'Left Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    termName))) []

        ]
     where
      nArgs :: Int
    nArgs = [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
    maximum (((Name, Int) -> Int) -> [(Name, Int)] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name, Int) -> Int
    forall a b. (a, b) -> b
    snd [(Name, Int)]
    constrs)

      args :: [Dec]
      args :: [Dec]
    args = (Int -> Name -> Dec) -> [Int] -> [Name] -> [Dec]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Int
    n Name
    nm -> Pat -> Body -> [Dec] -> Dec
    ValD (Name -> Pat
    VarP Name
    nm) (Exp -> Body
    NormalB (Integer -> Exp
    arg (Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger Int
    n))) []) [Int
    0..Int
    nArgsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1] (NonEmpty Name -> [Name]
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty Name
    argNames)
      arg :: Integer -> Exp
    arg Integer
    n = Exp -> Exp -> Exp -> Exp
    UInfixE (Name -> Exp
    VarE Name
    argsName) (Name -> Exp
    VarE '(!!)) (Lit -> Exp
    LitE (Integer -> Lit
    IntegerL Integer
    n))

      -- case nm of {"ConstrOne" -> ConstOne <$> termToData arg0; "ConstrTwo" -> ...}
      theCase :: Exp
      theCase :: Exp
    theCase =
        Exp -> [Match] -> Exp
    CaseE
          (Name -> Exp
    VarE Name
    nameName)
          (((Name, Int) -> Match) -> [(Name, Int)] -> [Match]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name, Int) -> Match
    match [(Name, Int)]
    constrs [Match] -> [Match] -> [Match]
    forall a. [a] -> [a] -> [a]
    ++ [Match
    emptyMatch])

      emptyMatch :: Match
    emptyMatch = Pat -> Body -> [Dec] -> Match
    Match Pat
    WildP (Exp -> Body
    NormalB (Name -> Exp
    ConE 'Left Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    termName)) []

      match :: (Name, Int) -> Match
      match :: (Name, Int) -> Match
    match (Name
    cName, Int
    nFields) =
        Pat -> Body -> [Dec] -> Match
    Match (Lit -> Pat
    LitP (String -> Lit
    StringL (Name -> String
    forall a. Show a => a -> String
    show Name
    cName))) (Exp -> Body
    NormalB (Name -> Int -> Exp
    mkCall Name
    cName Int
    nFields)) []

      mkCall :: Name -> Int -> Exp
      mkCall :: Name -> Int -> Exp
    mkCall Name
    cName Int
    0  = Name -> Exp
    ConE 'Right Exp -> Exp -> Exp
    `AppE` Name -> Exp
    ConE Name
    cName
      mkCall Name
    cName Int
    1 =
        Exp -> Exp -> Exp -> Exp
    UInfixE
          (Name -> Exp
    ConE Name
    cName)
          (Name -> Exp
    VarE '(<$>))
          (Name -> Exp
    VarE Name
    termToDataName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE (NonEmpty Name -> Name
    forall a. NonEmpty a -> a
    NE.head NonEmpty Name
    argNames))
      mkCall Name
    cName Int
    nFields =
        (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: Type -> Type) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl
          (\Exp
    e Name
    aName ->
            Exp -> Exp -> Exp -> Exp
    UInfixE
              Exp
    e
              (Name -> Exp
    VarE '(<*>))
              (Name -> Exp
    VarE Name
    termToDataName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    aName))
          (Name -> Int -> Exp
    mkCall Name
    cName Int
    1)
          (Int -> [Name] -> [Name]
    forall a. Int -> [a] -> [a]
    take (Int
    nFieldsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) (NonEmpty Name -> [Name]
    forall a. NonEmpty a -> [a]
    NE.tail NonEmpty Name
    argNames))

      -- term@(collectArgs -> (Data (dcName' -> nm), args))
      pat :: Pat
      pat :: Pat
    pat =
        Name -> Pat -> Pat
    AsP
          Name
    termName
          (Exp -> Pat -> Pat
    ViewP
            (Name -> Exp
    VarE 'collectArgs)
    #if MIN_VERSION_template_haskell(2,18,0)
            ([Pat] -> Pat
    TupP [ Name -> Cxt -> [Pat] -> Pat
    ConP 'Data [] [Exp -> Pat -> Pat
    ViewP (Name -> Exp
    VarE 'dcName') (Name -> Pat
    VarP Name
    nameName)]
    #else
            (TupP [ ConP 'Data [ViewP (VarE 'dcName') (VarP nameName)]
    #endif
                  , Exp -> Pat -> Pat
    ViewP
                     (Name -> Exp
    VarE 'lefts)
                     (if Int
    nArgs Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 then Pat
    WildP else Name -> Pat
    VarP Name
    argsName)]))

      termName :: Name
    termName = String -> Name
    mkName String
    "term"
      argsName :: Name
    argsName = String -> Name
    mkName String
    "args"
      argNames :: NonEmpty Name
    argNames = (Word -> Name) -> NonEmpty Word -> NonEmpty Name
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (String -> Name
    mkName (String -> Name) -> (Word -> String) -> Word -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    "arg" <>) (String -> String) -> (Word -> String) -> Word -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Word -> String
    forall a. Show a => a -> String
    show) ((Word -> Word) -> Word -> NonEmpty Word
    forall a. (a -> a) -> a -> NonEmpty a
    NE.iterate (Word -> Word -> Word
    forall a. Num a => a -> a -> a
    +Word
    1) (Word
    0 :: Word))
      nameName :: Name
    nameName = String -> Name
    mkName String
    "nm"