Skip to content

Commit

Permalink
Introduce Options and OptionsMonad
Browse files Browse the repository at this point in the history 
This patch introduces an `Options` data type and an `mtl`-like
`OptionsMonad` class for monads that carry `Options`. At present,
the only things one can do with `Options` are:

* Toggle the generation of `SingKind` instances. Suppressing
  `SingKind` instances provides an effective workaround for #150.
* Hook into the TH machinery's naming conventions for promoted and
  singled names. This fixes #204.

The vast majority of this patch simply adds plumbing by using
`OptionsMonad` in places that need it. See the `D.S.TH.Options`
module for where most of the new code is housed, as well as the
`T150` and `T204` test cases for examples of how to use it.
  • Loading branch information
@RyanGlScott
RyanGlScott committed Dec 22, 2019
1 parent e83b130 commit 8a28033
Show file tree
Hide file tree
Showing 25 changed files with 1,209 additions and 397 deletions.
19 changes: 19 additions & 0 deletions CHANGES.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,25 @@ Changelog for singletons project
2.7
---
* Require GHC 8.10.
* The Template Haskell machinery now supports fine-grained configuration in
the way of an `Options` data type, which lives in the new
`Data.Singletons.TH.Options` module. Besides `Options`, this module also
contains:
* `Options`' record selectors. Currently, these include ways to toggle
generating `SingKind` instances and configure how `singletons` generates
the names of promoted or singled types. In the future, there may be
additional options.
* A `defaultOptions` value.
* An `mtl`-like `OptionsMonad` class for monads that support carrying
`Option`s. This includes `Q`, which uses `defaultOptions` if it is the
top of the monad transformer stack.
* An `OptionM` monad transformer that turns any `DsMonad` into an
`OptionsMonad`.
* A `withOptions` function which allows passing `Options` to TH functions
(e.g., `promote` or `singletons`). See the `README` for a full example
of how to use `withOptions`.
Most TH functions are now polymorphic over `OptionsMonad` instead of
`DsMonad`.
* `singletons` now does a much better job of preserving the order of type
variables when singling the type signatures of top-level functions and data
constructors. See the `Support for TypeApplications` section of the `README`
Expand Down
23 changes: 23 additions & 0 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -545,6 +545,23 @@ treatment):

All functions that begin with leading underscores are treated similarly.

If desired, you can pick your own naming conventions by using the
`Data.Singletons.TH.Options` module. Here is an example of how this module can
be used to prefix a singled data constructor with `MyS` instead of `S`:

```hs
import Control.Monad.Trans.Class
import Data.Singletons.TH
import Data.Singletons.TH.Options
import Language.Haskell.TH (Name, mkName, nameBase)

$(let myPrefix :: Name -> Name
myPrefix name = mkName ("MyS" ++ nameBase name) in

withOptions defaultOptions{singledDataConName = myPrefix} $
singletons $ lift [d| data T = MkT |])
```

Supported Haskell constructs
----------------------------

Expand Down Expand Up @@ -780,3 +797,9 @@ Known bugs
method :: [a]
method = []
```
* Singling GADTs is likely to fail due to the generated `SingKind` instances
not typechecking. (See
[#150](https://github.com/goldfirere/singletons/issues/150)).
However, one can often work around the issue by suppressing the generation
of `SingKind` instances by using custom `Options`. See the `T150` test case
for an example.
1 change: 1 addition & 0 deletions singletons.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -73,6 +73,7 @@ library
Data.Singletons.CustomStar
Data.Singletons.TypeRepTYPE
Data.Singletons.TH
Data.Singletons.TH.Options
Data.Singletons.Prelude
Data.Singletons.Prelude.Applicative
Data.Singletons.Prelude.Base
Expand Down
3 changes: 2 additions & 1 deletion src/Data/Singletons/CustomStar.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,7 @@ import Data.Singletons.Single
import Data.Singletons.Syntax
import Data.Singletons.Names
import Data.Singletons.TH
import Data.Singletons.TH.Options
import Control.Monad
import Data.Maybe
import Language.Haskell.TH.Desugar
Expand Down Expand Up @@ -70,7 +71,7 @@ import Data.Singletons.Prelude.Bool
-- @Bool@, and @Maybe@, not just promoted data constructors.
--
-- Please note that this function is /very/ experimental. Use at your own risk.
singletonStar :: DsMonad q
singletonStar :: OptionsMonad q
=> [Name] -- ^ A list of Template Haskell @Name@s for types
-> q [Dec]
singletonStar names = do
Expand Down
232 changes: 119 additions & 113 deletions src/Data/Singletons/Deriving/Show.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,7 @@ module Data.Singletons.Deriving.Show (
import Language.Haskell.TH.Syntax hiding (showName)
import Language.Haskell.TH.Desugar
import Data.Singletons.Names
import Data.Singletons.TH.Options
import Data.Singletons.Util
import Data.Singletons.Syntax
import Data.Singletons.Deriving.Infer
Expand All @@ -28,7 +29,7 @@ import Data.Maybe (fromMaybe)
import GHC.Lexeme (startsConSym, startsVarSym)
import GHC.Show (appPrec, appPrec1)

mkShowInstance :: DsMonad q => ShowMode -> DerivDesc q
mkShowInstance :: OptionsMonad q => ShowMode -> DerivDesc q
mkShowInstance mode mb_ctxt ty (DataDecl _ _ cons) = do
clauses <- mk_showsPrec mode cons
constraints <- inferConstraintsDef (fmap (mkShowSingContext mode) mb_ctxt)
Expand All @@ -41,127 +42,131 @@ mkShowInstance mode mb_ctxt ty (DataDecl _ _ cons) = do
, id_sigs = mempty
, id_meths = [ (showsPrecName, UFunction clauses) ] }

mk_showsPrec :: DsMonad q => ShowMode -> [DCon] -> q [DClause]
mk_showsPrec :: OptionsMonad q => ShowMode -> [DCon] -> q [DClause]
mk_showsPrec mode cons = do
p <- newUniqueName "p" -- The precedence argument (not always used)
if null cons
then do v <- newUniqueName "v"
pure [DClause [DWildP, DVarP v] (DCaseE (DVarE v) [])]
else mapM (mk_showsPrec_clause mode p) cons

mk_showsPrec_clause :: forall q. DsMonad q
mk_showsPrec_clause :: forall q. OptionsMonad q
=> ShowMode -> Name -> DCon
-> q DClause
mk_showsPrec_clause mode p (DCon _ _ con_name con_fields _) = go con_fields
where
con_name' :: Name
con_name' = case mode of
ForPromotion -> con_name
ForShowSing{} -> singDataConName con_name

go :: DConFields -> q DClause

-- No fields: print just the constructor name, with no parentheses
go (DNormalC _ []) = return $
DClause [DWildP, DConP con_name' []] $
DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "")

-- Infix constructors have special Show treatment.
go (DNormalC True tys@[_, _])
-- Although the (:) constructor is infix, its singled counterpart SCons
-- is not, which matters if we're deriving a ShowSing instance.
-- Unless we remove this special case (see #234), we will simply
-- shunt it along as if we were dealing with a prefix constructor.
| ForShowSing{} <- mode
, con_name == consName
= go (DNormalC False tys)

| otherwise
= do argL <- newUniqueName "argL"
argR <- newUniqueName "argR"
argTyL <- newUniqueName "argTyL"
argTyR <- newUniqueName "argTyR"
fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name'
let con_prec = case fi of Fixity prec _ -> prec
op_name = nameBase con_name'
infixOpE = DAppE (DVarE showStringName) . dStringE $
if isInfixDataCon op_name
then " " ++ op_name ++ " "
-- Make sure to handle infix data constructors
-- like (Int `Foo` Int)
else " `" ++ op_name ++ "` "
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR]
] $
mk_Show_rhs_sig mode [argTyL, argTyR] $
(DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
`DAppE` dIntegerE con_prec))
`DAppE` (DVarE composeName
`DAppE` showsPrecE (con_prec + 1) argL
`DAppE` (DVarE composeName
`DAppE` infixOpE
`DAppE` showsPrecE (con_prec + 1) argR))

go (DNormalC _ tys) = do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args = map (showsPrecE appPrec1) args
composed_args = foldr1 (\v q -> DVarE composeName
`DAppE` v
`DAppE` (DVarE composeName
`DAppE` DVarE showSpaceName
`DAppE` q)) show_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
DVarE showParenName
`DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
`DAppE` named_args

-- We show a record constructor with no fields the same way we'd show a
-- normal constructor with no fields.
go (DRecC []) = go (DNormalC False [])

go (DRecC tys) = do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args =
concatMap (\((arg_name, _, _), arg) ->
let arg_name' = case mode of
ForPromotion -> arg_name
ForShowSing{} -> singValName arg_name
arg_nameBase = nameBase arg_name'
infix_rec = showParen (isSym arg_nameBase)
(showString arg_nameBase) ""
in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
, showsPrecE 0 arg
, DVarE showCommaSpaceName
])
(zip tys args)
brace_comma_args = (DVarE showCharName `DAppE` dCharE mode '{')
: take (length show_args - 1) show_args
composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
(DVarE showCharName `DAppE` dCharE mode '}')
brace_comma_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
DVarE showParenName
`DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
`DAppE` named_args
go con_fields' = do
opts <- getOptions

let con_name' :: Name
con_name' = case mode of
ForPromotion -> con_name
ForShowSing{} -> singledDataConName opts con_name

case con_fields' of

-- No fields: print just the constructor name, with no parentheses
DNormalC _ [] -> return $
DClause [DWildP, DConP con_name' []] $
DVarE showStringName `DAppE` dStringE (parenInfixConName con_name' "")

-- Infix constructors have special Show treatment.
DNormalC True tys@[_, _]
-- Although the (:) constructor is infix, its singled counterpart SCons
-- is not, which matters if we're deriving a ShowSing instance.
-- Unless we remove this special case (see #234), we will simply
-- shunt it along as if we were dealing with a prefix constructor.
| ForShowSing{} <- mode
, con_name == consName
-> go (DNormalC False tys)

| otherwise
-> do argL <- newUniqueName "argL"
argR <- newUniqueName "argR"
argTyL <- newUniqueName "argTyL"
argTyR <- newUniqueName "argTyR"
fi <- fromMaybe defaultFixity <$> reifyFixityWithLocals con_name'
let con_prec = case fi of Fixity prec _ -> prec
op_name = nameBase con_name'
infixOpE = DAppE (DVarE showStringName) . dStringE $
if isInfixDataCon op_name
then " " ++ op_name ++ " "
-- Make sure to handle infix data constructors
-- like (Int `Foo` Int)
else " `" ++ op_name ++ "` "
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) [argL, argR] [argTyL, argTyR]
] $
mk_Show_rhs_sig mode [argTyL, argTyR] $
(DVarE showParenName `DAppE` (DVarE gtName `DAppE` DVarE p
`DAppE` dIntegerE con_prec))
`DAppE` (DVarE composeName
`DAppE` showsPrecE (con_prec + 1) argL
`DAppE` (DVarE composeName
`DAppE` infixOpE
`DAppE` showsPrecE (con_prec + 1) argR))

DNormalC _ tys -> do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args = map (showsPrecE appPrec1) args
composed_args = foldr1 (\v q -> DVarE composeName
`DAppE` v
`DAppE` (DVarE composeName
`DAppE` DVarE showSpaceName
`DAppE` q)) show_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
DVarE showParenName
`DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
`DAppE` named_args

-- We show a record constructor with no fields the same way we'd show a
-- normal constructor with no fields.
DRecC [] -> go (DNormalC False [])

DRecC tys -> do
args <- mapM (const $ newUniqueName "arg") tys
argTys <- mapM (const $ newUniqueName "argTy") tys
let show_args =
concatMap (\((arg_name, _, _), arg) ->
let arg_name' = case mode of
ForPromotion -> arg_name
ForShowSing{} -> singledValueName opts arg_name
arg_nameBase = nameBase arg_name'
infix_rec = showParen (isSym arg_nameBase)
(showString arg_nameBase) ""
in [ DVarE showStringName `DAppE` dStringE (infix_rec ++ " = ")
, showsPrecE 0 arg
, DVarE showCommaSpaceName
])
(zip tys args)
brace_comma_args = (DVarE showCharName `DAppE` dCharE mode '{')
: take (length show_args - 1) show_args
composed_args = foldr (\x y -> DVarE composeName `DAppE` x `DAppE` y)
(DVarE showCharName `DAppE` dCharE mode '}')
brace_comma_args
named_args = DVarE composeName
`DAppE` (DVarE showStringName
`DAppE` dStringE (parenInfixConName con_name' " "))
`DAppE` composed_args
return $ DClause [ DVarP p
, DConP con_name' $
zipWith (mk_Show_arg_pat mode) args argTys
] $
mk_Show_rhs_sig mode argTys $
DVarE showParenName
`DAppE` (DVarE gtName `DAppE` DVarE p `DAppE` dIntegerE appPrec)
`DAppE` named_args

-- | Parenthesize an infix constructor name if it is being applied as a prefix
-- function (e.g., data Amp a = (:&) a a)
Expand Down Expand Up @@ -218,14 +223,15 @@ mk_Show_name :: ShowMode -> Name
mk_Show_name ForPromotion = showName
mk_Show_name ForShowSing{} = showSingName

-- If we're creating a 'Show' instance for a singleon type, decorate the type
-- If we're creating a 'Show' instance for a singleton type, decorate the type
-- appropriately (e.g., turn @Maybe a@ into @SMaybe (z :: Maybe a)@).
-- Otherwise, return the type (@Maybe a@) unchanged.
mk_Show_inst_ty :: Quasi q => ShowMode -> DType -> q DType
mk_Show_inst_ty :: OptionsMonad q => ShowMode -> DType -> q DType
mk_Show_inst_ty ForPromotion ty = pure ty
mk_Show_inst_ty (ForShowSing ty_tycon) ty = do
opts <- getOptions
z <- qNewName "z"
pure $ DConT (singTyConName ty_tycon) `DAppT` (DVarT z `DSigT` ty)
pure $ DConT (singledDataTypeName opts ty_tycon) `DAppT` (DVarT z `DSigT` ty)

-- If we're creating a 'Show' instance for a singleton type, create a pattern
-- of the form @(sx :: Sing x)@. Otherwise, simply return the pattern @sx@.
Expand Down
Loading

0 comments on commit 8a28033

Please sign in to comment.