module FP.Prelude.TemplateHaskell where

import FP.Prelude.Core
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import FP.Prelude.Lens
import FP.Prelude.Effects
import FP.Prelude.Monads ()
import FP.Prelude.DSL
import FP.Prelude.Lib

import qualified Prelude

class MonadQ (m ∷ ★ → ★) where qio ∷ Q a → m a

instance Functor Q where map = mmap
instance Monad Q where {return = Prelude.return;(≫=) = (Prelude.>>=)}
instance MonadIO Q where io = runIO
instance MonadQ Q where qio = id

instance Apply Exp where (◇⋅) = AppE
instance Tup Exp where tup = TupE

instance Tup Pat where tup = TupP

instance Apply Type where (◇⋅) = AppT
instance Tup Type where tup ts = TupleT (𝕚 $ length ts) ◇⋅| ts
instance Arrow Type where f ◇⇨ x = ArrowT ◇⋅ f ◇⋅ x

thString ∷ 𝕊 → Exp
thString = LitE ∘ StringL ∘ chars
      
thConName ∷ Con → Name
thConName (NormalC n _) = n
thConName (RecC n _) = n
thConName (InfixC _ n _) = n
thConName (ForallC _ _ c) = thConName c

thTyVarBndrName ∷ TyVarBndr → Name
thTyVarBndrName (PlainTV name) = name
thTyVarBndrName (KindedTV name _) = name

thSingleClause ∷ [Pat] → Exp → Clause
thSingleClause p b = Clause p (NormalB b) []

thSingleMatch ∷ Pat → Exp → Match
thSingleMatch p b = Match p (NormalB b) []

thViewSimpleCon ∷ Con → Maybe (Name,[Type])
thViewSimpleCon (NormalC name strictTypes) = Just (name,map snd strictTypes)
thViewSimpleCon (RecC name varStrictTypes) = Just (name,map ff varStrictTypes)
  where ff (_,_,x) = x
thViewSimpleCon (InfixC (_,typeL) name (_,typeR)) = Just (name,[typeL,typeR])
thViewSimpleCon (ForallC _ _ _) = Nothing

thTyConIL ∷ Prism Info Dec
thTyConIL = Prism
  { view = \case
      TyConI d → Just d
      _ → Nothing
  , construct = TyConI
  }

thDataDL ∷ Prism Dec (Cxt,Name,[TyVarBndr],[Con],[Name])
thDataDL = Prism
  { view = \case
      DataD cx t args cs ders → Just (cx,t,args,cs,ders)
      _ → Nothing
  , construct = \ (cx,t,args,cs,ders) → DataD cx t args cs ders
  }

thNewtypeDL ∷ Prism Dec (Cxt,Name,[TyVarBndr],Con,[Name])
thNewtypeDL = Prism
  { view = \case
      NewtypeD cx t args c ders → Just (cx,t,args,c,ders)
      _ → Nothing
  , construct = \ (cx,t,args,c,ders) → NewtypeD cx t args c ders
  }

thViewADT ∷ Dec → Maybe (Cxt,Name,[TyVarBndr],[Con],[Name])
thViewADT d =
  view thDataDL d
  <|>
  (ff ^∘ view thNewtypeDL) d
  where
    ff (cx,t,args,c,ders) = (cx,t,args,[c],ders)

thViewSingleConADT ∷ Dec → Maybe (Cxt,Name,[TyVarBndr],Con,[Name])
thViewSingleConADT dec = do
  (cx,t,args,cs,ders) ← thViewADT dec
  c ← view singleL cs
  return(cx,t,args,c,ders)

thRecCL ∷ Prism Con (Name,[VarStrictType])
thRecCL = Prism
  { view = \case
      RecC n fs → Just (n,fs)
      _ → Nothing
  , construct = \ (n,fs) → RecC n fs
  }