Apply.hs

{-# LANGUAGE TemplateHaskell #-}

-- | Generate 'HApply' and related instances via @TemplateHaskell@
module Hyper.TH.Apply
    ( makeHApply
    , makeHApplyAndBases
    , makeHApplicativeBases
    ) where

import Control.Applicative (liftA2)
import qualified Control.Lens as Lens
import Hyper.Class.Apply (HApply (..))
import Hyper.TH.Functor (makeHFunctor)
import Hyper.TH.Internal.Utils
import Hyper.TH.Nodes (makeHNodes)
import Hyper.TH.Pointed (makeHPointed)
import Language.Haskell.TH

import Hyper.Internal.Prelude

-- | Generate instances of 'HApply',
-- 'Hyper.Class.Functor.HFunctor', 'Hyper.Class.Pointed.HPointed' and 'Hyper.Class.Nodes.HNodes',
-- which together form 'HApplicative'.
makeHApplicativeBases :: Name -> DecsQ
makeHApplicativeBases x =
    sequenceA
        [ makeHPointed x
        , makeHApplyAndBases x
        ]
        <&> concat

-- | Generate an instance of 'HApply'
-- along with its bases 'Hyper.Class.Functor.HFunctor' and 'Hyper.Class.Nodes.HNodes'
makeHApplyAndBases :: Name -> DecsQ
makeHApplyAndBases x =
    sequenceA
        [ makeHNodes x
        , makeHFunctor x
        , makeHApply x
        ]
        <&> concat

-- | Generate an instance of 'HApply'
makeHApply :: Name -> DecsQ
makeHApply typeName = makeTypeInfo typeName >>= makeHApplyForType

makeHApplyForType :: TypeInfo -> DecsQ
makeHApplyForType info =
    do
        (name, _, fields) <-
            case tiConstructors info of
                [x] -> pure x
                _ -> fail "makeHApply only supports types with a single constructor"
        let xVars = makeConstructorVars "x" fields
        let yVars = makeConstructorVars "y" fields
        instanceD
            (makeContext info >>= simplifyContext)
            [t|HApply $(pure (tiInstance info))|]
            [ InlineP 'hzip Inline FunLike AllPhases & PragmaD & pure
            , funD
                'hzip
                [ clause
                    [ consPat name xVars
                    , consPat name yVars
                    ]
                    (normalB (foldl appE (conE name) (zipWith f xVars yVars)))
                    []
                ]
            ]
            <&> (: [])
    where
        bodyFor (Right x) = bodyForPat x
        bodyFor Left{} = [|(<>)|]
        bodyForPat Node{} = [|(:*:)|]
        bodyForPat GenEmbed{} = [|hzip|]
        bodyForPat FlatEmbed{} = [|hzip|]
        bodyForPat (InContainer _ pat) = [|liftA2 $(bodyForPat pat)|]
        f (p, x) (_, y) = [|$(bodyFor p) $(varE x) $(varE y)|]

makeContext :: TypeInfo -> Q [Pred]
makeContext info =
    tiConstructors info >>= (^. Lens._3) & traverse ctxFor <&> mconcat
    where
        ctxFor (Right x) = ctxForPat x
        ctxFor (Left x) = [t|Semigroup $(pure x)|] <&> (: [])
        ctxForPat (InContainer t pat) = (:) <$> [t|Applicative $(pure t)|] <*> ctxForPat pat
        ctxForPat (GenEmbed t) = [t|HApply $(pure t)|] <&> (: [])
        ctxForPat (FlatEmbed t) = makeContext t
        ctxForPat _ = pure []