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

-- | Module containing Template Haskell functions to automically intertwine the
-- base functors of the given types.
module Data.Functor.Foldable.Exotic.TH
    ( -- * Template Haskell helpers
      entangleFunctors
    , entanglePair
    ) where

import           Control.Monad                (join)
import           Data.Functor.Foldable.Exotic
import           Language.Haskell.TH

-- | Entangle a list of functors. As an example,
--
-- > entangleFunctors [(''Data, ''Codata)]
--
-- will generate
--
-- > instance SubHom DataF CodataF Data Codata
-- > instance SubType Codata
entangleFunctors :: [(Name, Name)] -> Q [Dec]
entangleFunctors = fmap join . traverse (uncurry entanglePair)

-- | Entangle types, creating a 'SubHom' instance with their base functors.
-- 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"