content: {-|
  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 = mkName "isX"
  hasUndefinedName = mkName "hasUndefined"
  deepErrorXName = mkName "deepErrorX"
  rnfXName = mkName "rnfX"
  ensureSpineName = mkName "ensureSpine"
  
  showxName :: Name
  showxName = mkName "ShowX"
  
  showXFnName :: Name
  showXFnName = mkName "showX"
  
  showsPrecXName :: Name
  showsPrecXName = mkName "showsPrecX"
  
  nfdataxName :: Name
  nfdataxName = mkName "NFDataX"
  
  mkTup :: [Type] -> Type
  mkTup names@(length -> n) =
    foldl AppT (TupleT n) names
  
  -- | Creates an instance of the form:
  --
  --  instance (ShowX a0, ShowX a1) => ShowX (a0, a1)
  --
  -- With /n/ number of variables.
  mkShowXTupleInstance :: Int -> Dec
  mkShowXTupleInstance n =
    InstanceD Nothing constraints instanceTyp [showsPrecXDecl, showXDecl]
   where
    constraints = fmap (AppT (ConT showxName)) vars
    instanceTyp = ConT showxName `AppT` mkTup vars
    names = fmap (mkName . ('a':) . show) [0..n-1]
    vars = fmap VarT names
  
    x = mkName "x"
    s = mkName "s"
  
    showsPrecXDecl = FunD showsPrecXName
      [ Clause
          [WildP, VarP x, VarP s]
          (NormalB
            (VarE 'mappend `AppE` (VarE showXFnName `AppE` VarE x) `AppE` VarE s))
          []
      ]
  
    showXDecl = FunD showXFnName
      [ Clause
          [TupP (fmap VarP names)]
          (NormalB
            (VarE 'mconcat `AppE` (ListE
              ([LitE (StringL "(")]
                 <> intersperse (LitE (StringL ",")) (fmap toShowX names)
                 <> [LitE (StringL ")")]))))
          []
      ]
     where
      toShowX a = VarE showXFnName `AppE` VarE a
  
  -- | Creates instances of ShowX for all tuple sizes listed.
  -- See 'mkShowXTupleInstance' for more information.
  mkShowXTupleInstances :: [Int] -> Q [Dec]
  mkShowXTupleInstances tupSizes =
    return (fmap mkShowXTupleInstance tupSizes)
  
  -- | Creates an instance of the form:
  --
  --  instance (NFDataX a0, NFDataX a1) => NFDataX (a0, a1)
  --
  -- With /n/ number of variables.
  mkNFDataXTupleInstance :: Int -> Dec
  mkNFDataXTupleInstance n =
    InstanceD
      Nothing
      constraints
      instanceTyp
      [ ensureSpineDecl
      , hasUndefinedDecl
      , deepErrorXDecl
      , rnfXDecl
      ]
   where
    constraints = map (AppT (ConT nfdataxName)) vars
    instanceTyp = ConT nfdataxName `AppT` mkTup vars
    names = map (mkName . ('a':) . show) [0..n-1]
    vars = map VarT names
  
    t = mkName "t"
    s = mkName "s"
  
    rnfXDecl = FunD rnfXName [
      Clause
        [AsP t (TildeP (TupP (map VarP names)))]
        (NormalB (
          CondE
            (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t))
            (TupE [])
            (case names of
              (nm:nms) -> foldl
                (\e1 e2 -> UInfixE e1 (VarE 'seq) (VarE rnfXName `AppE` e2))
                (VarE rnfXName `AppE` VarE nm)
                (map VarE nms)
              [] -> error ("mkNFDataXTupleInstance, n must be atleast 1: " <> show n))
        ))
        []
      ]
  
    hasUndefinedDecl = FunD hasUndefinedName [
      Clause
        [AsP t (TildeP (TupP (map VarP names)))]
        (NormalB (
          CondE
            (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t))
            (ConE 'True)
            (VarE 'or `AppE` ListE
              (map ((VarE hasUndefinedName `AppE`) . VarE) names))
        ))
        []
      ]
  
    ensureSpineDecl = FunD ensureSpineName  [
      Clause
        [TildeP (TupP (map VarP names))]
        (NormalB (mkTupE (map (AppE (VarE ensureSpineName) . VarE) names)))
        []
      ]
  
    deepErrorXDecl = FunD deepErrorXName [
       Clause
         [VarP s]
         (NormalB (mkTupE (replicate n (VarE deepErrorXName `AppE` VarE s))))
         []
       ]
  
  mkNFDataXTupleInstances :: [Int] -> Q [Dec]
  mkNFDataXTupleInstances tupSizes =
    pure (map mkNFDataXTupleInstance tupSizes)
  