{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}

module Data.Functor.Foldable.Extensions.TH
    ( -- | Template Haskell helpers
      entangleFunctors
    , entanglePair
    ) where

import           Data.Functor.Foldable.Extensions
import           Language.Haskell.TH

-- | Make the abscissae a subtype of the ordinates.
entangleFunctors :: [(Name, Name)] -> Q [Dec]
entangleFunctors = fmap concat . traverse (uncurry entanglePair)

-- | Entangle two functors, creating a 'SubHom' instance. Note that this is rather strict with regards to naming.
entanglePair :: Name -> Name -> Q [Dec]
entanglePair sub top = pure [subHomInstance, subTypeInstance]
    where

          subTypeInstance = InstanceD Nothing [] (subType `AppT` topT) funTypeDecls
          subHomInstance = InstanceD Nothing (fmap (AppT functor) [subFT, topFT]) (subHom `AppT` subFT `AppT` topFT `AppT` subT `AppT` topT) funDecls

          functor = ConT ''Functor
          subHom = ConT ''SubHom
          subType = ConT ''SubType

          toN = mkName . (++ "F") . show
          mN = mkName . show
          toF = ConT . toN
          subFT = toF sub
          topFT = toF top
          subT = ConT sub
          topT = ConT top

          -- TODO this is kind of sloppy.
          getConstructor = mkName . show

          funTypeDecls = [FunD switchN [switchClause, switchBoringClause]]

          switchClause = Clause [ConP (getConstructor top) [ConP (getConstructor sub) [VarP (mkName "a")]]] (NormalB (VarE (mkName "a"))) []
          switchBoringClause = Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []

          funDecls = [FunD homoN [homoComplicated, homoSimple]]
          dummySig = SigE (VarE dummyN) topT

          homoComplicated = Clause [(VarP taN), (VarP saN), (ConP (toN top) [VarP (mkName "top")])] atlas []
          homoSimple = Clause [WildP, (VarP fN), (VarP eN)] body []

          atlas = NormalB ((ConE (mN top)) `AppE` ((VarE dendroN) `AppE` dummySig `AppE` (VarE saN) `AppE` (VarE taN) `AppE` (VarE (mkName "top"))))
          body = NormalB ((VarE fN) `AppE` (VarE eN))

          homoN = mkName "homo"
          switchN = mkName "switch"
          dendroN = mkName "dendro"
          dummyN = mkName "dummy"
          fN = mkName "f"
          eN = mkName "e"
          saN = mkName "subAlg"
          taN = mkName "topAlg"