{-|
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
  ) 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 (t :: Type -> Type) a. Foldable t => t a -> Int
length -> Int
n) =
  (Type -> Type -> Type) -> Type -> [Type] -> Type
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 (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 (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 (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 (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 (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 (m :: Type -> Type) a. Monad m => a -> m a
return ((Int -> Dec) -> [Int] -> [Dec]
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 [])
          ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
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] -> Name
forall a. [a] -> a
head [Name]
names))
            ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ([Name] -> [Name]
forall a. [a] -> [a]
tail [Name]
names)))
      ))
      []
    ]

  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 (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)