singletons-th-3.2: src/Data/Singletons/TH/Single/Defun.hs
-----------------------------------------------------------------------------
-- |
-- Module : Data.Singletons.TH.Single.Defun
-- Copyright : (C) 2018 Ryan Scott
-- License : BSD-style (see LICENSE)
-- Maintainer : Ryan Scott
-- Stability : experimental
-- Portability : non-portable
--
-- Creates 'SingI' instances for promoted types' defunctionalization symbols.
--
-----------------------------------------------------------------------------
module Data.Singletons.TH.Single.Defun (singDefuns) where
import Control.Monad
import Data.Foldable
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Promote.Defun
import Data.Singletons.TH.Single.Monad
import Data.Singletons.TH.Single.Type
import Data.Singletons.TH.Util
import Language.Haskell.TH.Desugar
import Language.Haskell.TH.Syntax
-- Given the Name of something, take the defunctionalization symbols for its
-- promoted counterpart and create SingI{,1,2} instances for them. As a concrete
-- example, if you have:
--
-- foo :: Eq a => a -> a -> Bool
--
-- Then foo's promoted counterpart, Foo, will have two defunctionalization
-- symbols:
--
-- FooSym0 :: a ~> a ~> Bool
-- FooSym1 :: a -> a ~> Bool
--
-- We can declare SingI and SingI1 instances for these two symbols like so:
--
-- instance SEq a => SingI (FooSym0 :: a ~> a ~> Bool) where
-- sing = singFun2 sFoo
--
-- instance (SEq a, SingI x) => SingI (FooSym1 x :: a ~> Bool) where
-- sing = singFun1 (sFoo (sing @_ @x))
--
-- instance SEq a => SingI1 (FooSym1 :: a -> a ~> Bool) where
-- liftSing s = singFun1 (sFoo s)
--
-- Only FooSym1 will have a SingI1 instance, as unlike FooSym0, it is able to
-- be partially applied (using normal function application) to a single
-- argument. Neither FooSym0 nor FooSym1 can be partially applied to two
-- arguments, so neither will receive a SingI2 instance.
--
-- Note that singDefuns takes Maybe DKinds for the promoted argument and result
-- types, in case we have an entity whose type needs to be inferred.
-- See Note [singDefuns and type inference].
singDefuns :: Name -- The Name of the thing to promote.
-> NameSpace -- Whether the above Name is a value, data constructor,
-- or a type constructor.
-> DCxt -- The type's context.
-> [Maybe DKind] -- The promoted argument types (if known).
-> Maybe DKind -- The promoted result type (if known).
-> SgM [DDec]
singDefuns n ns ty_ctxt mb_ty_args mb_ty_res =
case mb_ty_args of
[] -> pure [] -- If a function has no arguments, then it has no
-- defunctionalization symbols, so there's nothing to be done.
_ -> do opts <- getOptions
sty_ctxt <- mapM singPred ty_ctxt
names <- replicateM (length mb_ty_args) $ qNewName "d"
let tvbs = zipWith inferMaybeKindTV names mb_ty_args
(_, insts) <- go opts 0 sty_ctxt [] tvbs
pure insts
where
num_ty_args :: Int
num_ty_args = length mb_ty_args
-- The inner loop. @go n ctxt arg_tvbs res_tvbs@ returns @(m_result, insts)@.
-- Using one particular example:
--
-- @
-- instance (SingI a, SingI b, SEq c, SEq d) =>
-- SingI (ExampleSym2 (x :: a) (y :: b) :: c ~> d ~> Type) where ...
-- @
--
-- We have:
--
-- * @n@ is 2. This is incremented in each iteration of `go`.
--
-- * @ctxt@ is (SEq c, SEq d). The (SingI a, SingI b) part of the instance
-- context is added separately.
--
-- * @arg_tvbs@ is [(x :: a), (y :: b)].
--
-- * @res_tvbs@ is [(z :: c), (w :: d)]. The kinds of these type variable
-- binders appear in the result kind.
--
-- * @m_result@ is `Just (c ~> d ~> Type)`. @m_result@ is returned so
-- that earlier defunctionalization symbols can build on the result
-- kinds of later symbols. For instance, ExampleSym1 would get the
-- result kind `b ~> c ~> d ~> Type` by prepending `b` to ExampleSym2's
-- result kind `c ~> d ~> Type`.
--
-- * @insts@ are all of the instance declarations corresponding to
-- ExampleSym2 and later defunctionalization symbols. This is the main
-- payload of the function.
--
-- This function is quadratic because it appends a variable at the end of
-- the @arg_tvbs@ list at each iteration. In practice, this is unlikely
-- to be a performance bottleneck since the number of arguments rarely
-- gets to be that large.
go :: Options -> Int -> DCxt -> [DTyVarBndrUnit] -> [DTyVarBndrUnit]
-> SgM (Maybe DKind, [DDec])
go _ _ _ _ [] = pure (mb_ty_res, [])
go opts sym_num sty_ctxt arg_tvbs (res_tvb:res_tvbs) = do
(mb_res, insts) <- go opts (sym_num + 1) sty_ctxt (arg_tvbs ++ [res_tvb]) res_tvbs
new_insts <- mapMaybeM (mb_new_inst mb_res) [0, 1, 2]
pure (mk_inst_kind [] res_tvb mb_res, new_insts ++ insts)
where
sing_fun_num :: Int
sing_fun_num = num_ty_args - sym_num
-- Construct the arrow kind used to annotate the defunctionalization
-- symbol. For example, this constructs the `a -> b -> c ~> Bool` in
-- `SingI1 (FooSym1 :: a -> b -> c ~> Bool)`, where:
--
-- * The first argument to `mk_inst_kind` gives the kinds [a, b], which
-- are used with normal function arrows.
-- * The second argumen to `mk_inst_kind` gives the kind `c`, which is
-- used with a defunctionalized function arrow.
--
-- If any of the argument kinds or result kind isn't known (i.e., is
-- Nothing), then we opt not to construct this arrow kind altogether.
-- See Note [singDefuns and type inference]
mk_inst_kind :: [DTyVarBndrUnit] -> DTyVarBndrUnit -> Maybe DKind -> Maybe DKind
mk_inst_kind funTvbs defunTvb mbKind =
foldr buildFunArrow_maybe
(buildTyFunArrow_maybe (extractTvbKind defunTvb) mbKind)
(map extractTvbKind funTvbs)
-- @mb_new_inst mb_res k@ returns 'Just' an instance of @SingI<k>@ if
-- @k@ is less than or equal to the number of arguments to which the
-- defunctionalization symbol can be partially applied using normal
-- function application. Otherwise, it returns 'Nothing'.
mb_new_inst :: Maybe DKind -> Int -> SgM (Maybe DDec)
mb_new_inst mb_res k
| k <= sym_num
= do vs <- replicateM k $ qNewName "s"
let sing_vs = zipWith (\v arg_tvb ->
DSigP (DVarP v)
(singFamily `DAppT` dTyVarBndrToDType arg_tvb))
vs last_arg_tvbs
pure $ Just $
DInstanceD Nothing Nothing
(sty_ctxt ++ singI_ctxt)
(DConT (mkSingIName k) `DAppT` mk_inst_ty (mk_defun_inst_ty init_arg_tvbs))
[ DLetDec $ DFunD (mkSingMethName k)
[ DClause sing_vs
$ wrapSingFun sing_fun_num (mk_defun_inst_ty arg_tvbs)
$ mk_sing_fun_expr sing_exp vs
]
]
| otherwise
= pure Nothing
where
init_arg_tvbs, last_arg_tvbs :: [DTyVarBndrUnit]
(init_arg_tvbs, last_arg_tvbs) = splitAt (sym_num - k) arg_tvbs
mk_defun_inst_ty :: [DTyVarBndrUnit] -> DType
mk_defun_inst_ty tvbs =
foldType (DConT (defunctionalizedName opts n sym_num))
(map dTyVarBndrToDType tvbs)
sing_exp :: DExp
sing_exp = case ns of
DataName -> DConE $ singledDataConName opts n
_ -> DVarE $ singledValueName opts n
mk_sing_fun_expr :: DExp -> [Name] -> DExp
mk_sing_fun_expr sing_expr vs =
foldl' DAppE sing_expr
(map (\arg_tvb -> DVarE singMethName `DAppTypeE`
DVarT (extractTvbName arg_tvb))
init_arg_tvbs ++
map DVarE vs)
singI_ctxt :: DCxt
singI_ctxt = map (DAppT (DConT singIName) . tvbToType) init_arg_tvbs
mk_inst_ty :: DType -> DType
mk_inst_ty inst_head
= case mk_inst_kind last_arg_tvbs res_tvb mb_res of
Just inst_kind -> inst_head `DSigT` inst_kind
Nothing -> inst_head
-- Shorthand for building (k1 -> k2)
buildFunArrow :: DKind -> DKind -> DKind
buildFunArrow k1 k2 = DArrowT `DAppT` k1 `DAppT` k2
buildFunArrow_maybe :: Maybe DKind -> Maybe DKind -> Maybe DKind
buildFunArrow_maybe m_k1 m_k2 = buildFunArrow <$> m_k1 <*> m_k2
{-
Note [singDefuns and type inference]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following function:
foo :: a -> Bool
foo _ = True
singDefuns would give the following SingI instance for FooSym0, with an
explicit kind signature:
instance SingI (FooSym0 :: a ~> Bool) where ...
What happens if we leave off the type signature for foo?
foo _ = True
Can singDefuns still do its job? Yes! It will simply generate:
instance SingI FooSym0 where ...
In general, if any of the promoted argument or result types given to singDefun
are Nothing, then we avoid crafting an explicit kind signature. You might worry
that this could lead to SingI instances being generated that GHC cannot infer
the type for, such as:
bar x = x == x
==>
instance SingI BarSym0 -- Missing an SEq constraint?
This is true, but also not unprecedented, as the singled version of bar, sBar,
will /also/ fail to typecheck due to a missing SEq constraint. Therefore, this
design choice fits within the existing tradition of type inference in
singletons-th.
-}