    {-|
    Copyright  :  (C) 2019, Myrtle Software Ltd
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
    -}

    {-# LANGUAGE TemplateHaskellQuotes #-}

    module Clash.XException.TH
      ( mkShowXTupleInstances
      , mkNFDataXTupleInstances
      , mkShowXTupleInstance
      ) where

    import Data.Either (isLeft)
    import Data.List (intersperse)
    import Language.Haskell.TH.Compat
    import Language.Haskell.TH.Syntax

    -- Spliced in in XException, so these names should be in scope:
    isXName, hasUndefinedName, deepErrorXName, rnfXName, ensureSpineName :: Name
    isXName :: Name
    isXName = String -> Name
    mkName String
    "isX"
    hasUndefinedName :: Name
    hasUndefinedName = String -> Name
    mkName String
    "hasUndefined"
    deepErrorXName :: Name
    deepErrorXName = String -> Name
    mkName String
    "deepErrorX"
    rnfXName :: Name
    rnfXName = String -> Name
    mkName String
    "rnfX"
    ensureSpineName :: Name
    ensureSpineName = String -> Name
    mkName String
    "ensureSpine"

    showxName :: Name
    showxName :: Name
    showxName = String -> Name
    mkName String
    "ShowX"

    showXFnName :: Name
    showXFnName :: Name
    showXFnName = String -> Name
    mkName String
    "showX"

    showsPrecXName :: Name
    showsPrecXName :: Name
    showsPrecXName = String -> Name
    mkName String
    "showsPrecX"

    nfdataxName :: Name
    nfdataxName :: Name
    nfdataxName = String -> Name
    mkName String
    "NFDataX"

    mkTup :: [Type] -> Type
    mkTup :: [Type] -> Type
    mkTup names :: [Type]
    names@([Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length -> Int
    n) =
      (Type -> Type -> Type) -> Type -> [Type] -> 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 (Int -> Type
    TupleT Int
    n) [Type]
    names

    -- | Creates an instance of the form:
    --
    --  instance (ShowX a0, ShowX a1) => ShowX (a0, a1)
    --
    -- With /n/ number of variables.
    mkShowXTupleInstance :: Int -> Dec
    mkShowXTupleInstance :: Int -> Dec
    mkShowXTupleInstance Int
    n =
      Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD Maybe Overlap
    forall a. Maybe a
    Nothing [Type]
    constraints Type
    instanceTyp [Dec
    showsPrecXDecl, Dec
    showXDecl]
     where
      constraints :: [Type]
    constraints = (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    showxName)) [Type]
    vars
      instanceTyp :: Type
    instanceTyp = Name -> Type
    ConT Name
    showxName Type -> Type -> Type
    `AppT` [Type] -> Type
    mkTup [Type]
    vars
      names :: [Name]
    names = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (String -> Name
    mkName (String -> Name) -> (Int -> String) -> Int -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) (String -> String) -> (Int -> String) -> Int -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show) [Int
    0..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]
      vars :: [Type]
    vars = (Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Type
    VarT [Name]
    names

      x :: Name
    x = String -> Name
    mkName String
    "x"
      s :: Name
    s = String -> Name
    mkName String
    "s"

      showsPrecXDecl :: Dec
    showsPrecXDecl = Name -> [Clause] -> Dec
    FunD Name
    showsPrecXName
        [ [Pat] -> Body -> [Dec] -> Clause
    Clause
            [Pat
    WildP, Name -> Pat
    VarP Name
    x, Name -> Pat
    VarP Name
    s]
            (Exp -> Body
    NormalB
              (Name -> Exp
    VarE 'mappend Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE Name
    showXFnName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    x) Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    s))
            []
        ]

      showXDecl :: Dec
    showXDecl = Name -> [Clause] -> Dec
    FunD Name
    showXFnName
        [ [Pat] -> Body -> [Dec] -> Clause
    Clause
            [[Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Pat
    VarP [Name]
    names)]
            (Exp -> Body
    NormalB
              (Name -> Exp
    VarE 'mconcat Exp -> Exp -> Exp
    `AppE` ([Exp] -> Exp
    ListE
                ([Lit -> Exp
    LitE (String -> Lit
    StringL String
    "(")]
                   [Exp] -> [Exp] -> [Exp]
    forall a. Semigroup a => a -> a -> a
    <> Exp -> [Exp] -> [Exp]
    forall a. a -> [a] -> [a]
    intersperse (Lit -> Exp
    LitE (String -> Lit
    StringL String
    ",")) ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Name -> Exp
    toShowX [Name]
    names)
                   [Exp] -> [Exp] -> [Exp]
    forall a. Semigroup a => a -> a -> a
    <> [Lit -> Exp
    LitE (String -> Lit
    StringL String
    ")")]))))
            []
        ]
       where
        toShowX :: Name -> Exp
    toShowX Name
    a = Name -> Exp
    VarE Name
    showXFnName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    a

    -- | Creates instances of ShowX for all tuple sizes listed.
    -- See 'mkShowXTupleInstance' for more information.
    mkShowXTupleInstances :: [Int] -> Q [Dec]
    mkShowXTupleInstances :: [Int] -> Q [Dec]
    mkShowXTupleInstances [Int]
    tupSizes =
      [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ((Int -> Dec) -> [Int] -> [Dec]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Int -> Dec
    mkShowXTupleInstance [Int]
    tupSizes)

    -- | Creates an instance of the form:
    --
    --  instance (NFDataX a0, NFDataX a1) => NFDataX (a0, a1)
    --
    -- With /n/ number of variables.
    mkNFDataXTupleInstance :: Int -> Dec
    mkNFDataXTupleInstance :: Int -> Dec
    mkNFDataXTupleInstance Int
    n =
      Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
    InstanceD
        Maybe Overlap
    forall a. Maybe a
    Nothing
        [Type]
    constraints
        Type
    instanceTyp
        [ Dec
    ensureSpineDecl
        , Dec
    hasUndefinedDecl
        , Dec
    deepErrorXDecl
        , Dec
    rnfXDecl
        ]
     where
      constraints :: [Type]
    constraints = (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    nfdataxName)) [Type]
    vars
      instanceTyp :: Type
    instanceTyp = Name -> Type
    ConT Name
    nfdataxName Type -> Type -> Type
    `AppT` [Type] -> Type
    mkTup [Type]
    vars
      names :: [Name]
    names = (Int -> Name) -> [Int] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Name
    mkName (String -> Name) -> (Int -> String) -> Int -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) (String -> String) -> (Int -> String) -> Int -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show) [Int
    0..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]
      vars :: [Type]
    vars = (Name -> Type) -> [Name] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Type
    VarT [Name]
    names

      t :: Name
    t = String -> Name
    mkName String
    "t"
      s :: Name
    s = String -> Name
    mkName String
    "s"

      rnfXDecl :: Dec
    rnfXDecl = Name -> [Clause] -> Dec
    FunD Name
    rnfXName [
        [Pat] -> Body -> [Dec] -> Clause
    Clause
          [Name -> Pat -> Pat
    AsP Name
    t (Pat -> Pat
    TildeP ([Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    names)))]
          (Exp -> Body
    NormalB (
            Exp -> Exp -> Exp -> Exp
    CondE
              (Name -> Exp
    VarE 'isLeft Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE Name
    isXName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    t))
              ([Maybe Exp] -> Exp
    TupE [])
              (case [Name]
    names of
                (Name
    nm:[Name]
    nms) -> (Exp -> Exp -> Exp) -> Exp -> [Exp] -> 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
    e1 Exp
    e2 -> Exp -> Exp -> Exp -> Exp
    UInfixE Exp
    e1 (Name -> Exp
    VarE 'seq) (Name -> Exp
    VarE Name
    rnfXName Exp -> Exp -> Exp
    `AppE` Exp
    e2))
                  (Name -> Exp
    VarE Name
    rnfXName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    nm)
                  ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Exp
    VarE [Name]
    nms)
                [] -> String -> Exp
    forall a. HasCallStack => String -> a
    error (String
    "mkNFDataXTupleInstance, n must be atleast 1: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Int -> String
    forall a. Show a => a -> String
    show Int
    n))
          ))
          []
        ]

      hasUndefinedDecl :: Dec
    hasUndefinedDecl = Name -> [Clause] -> Dec
    FunD Name
    hasUndefinedName [
        [Pat] -> Body -> [Dec] -> Clause
    Clause
          [Name -> Pat -> Pat
    AsP Name
    t (Pat -> Pat
    TildeP ([Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    names)))]
          (Exp -> Body
    NormalB (
            Exp -> Exp -> Exp -> Exp
    CondE
              (Name -> Exp
    VarE 'isLeft Exp -> Exp -> Exp
    `AppE` (Name -> Exp
    VarE Name
    isXName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    t))
              (Name -> Exp
    ConE 'True)
              (Name -> Exp
    VarE 'or Exp -> Exp -> Exp
    `AppE` [Exp] -> Exp
    ListE
                ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Name -> Exp
    VarE Name
    hasUndefinedName Exp -> Exp -> Exp
    `AppE`) (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Exp
    VarE) [Name]
    names))
          ))
          []
        ]

      ensureSpineDecl :: Dec
    ensureSpineDecl = Name -> [Clause] -> Dec
    FunD Name
    ensureSpineName  [
        [Pat] -> Body -> [Dec] -> Clause
    Clause
          [Pat -> Pat
    TildeP ([Pat] -> Pat
    TupP ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    names))]
          (Exp -> Body
    NormalB ([Exp] -> Exp
    mkTupE ((Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    ensureSpineName) (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Exp
    VarE) [Name]
    names)))
          []
        ]

      deepErrorXDecl :: Dec
    deepErrorXDecl = Name -> [Clause] -> Dec
    FunD Name
    deepErrorXName [
         [Pat] -> Body -> [Dec] -> Clause
    Clause
           [Name -> Pat
    VarP Name
    s]
           (Exp -> Body
    NormalB ([Exp] -> Exp
    mkTupE (Int -> Exp -> [Exp]
    forall a. Int -> a -> [a]
    replicate Int
    n (Name -> Exp
    VarE Name
    deepErrorXName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    s))))
           []
         ]

    mkNFDataXTupleInstances :: [Int] -> Q [Dec]
    mkNFDataXTupleInstances :: [Int] -> Q [Dec]
    mkNFDataXTupleInstances [Int]
    tupSizes =
      [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure ((Int -> Dec) -> [Int] -> [Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map Int -> Dec
    mkNFDataXTupleInstance [Int]
    tupSizes)