module Data.Singletons.TH.Promote where
import Language.Haskell.TH hiding ( Q, cxt )
import Language.Haskell.TH.Syntax ( NameSpace(..), Quasi(..), Uniq )
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OMap.Strict as OMap
import Language.Haskell.TH.Desugar.OMap.Strict (OMap)
import qualified Language.Haskell.TH.Desugar.OSet as OSet
import Data.Singletons.TH.Deriving.Bounded
import Data.Singletons.TH.Deriving.Enum
import Data.Singletons.TH.Deriving.Eq
import Data.Singletons.TH.Deriving.Ord
import Data.Singletons.TH.Deriving.Show
import Data.Singletons.TH.Deriving.Util
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Partition
import Data.Singletons.TH.Promote.Defun
import Data.Singletons.TH.Promote.Monad
import Data.Singletons.TH.Promote.Type
import Data.Singletons.TH.Syntax
import Data.Singletons.TH.Util
import Prelude hiding (exp)
import Control.Applicative (Alternative(..))
import Control.Arrow (second)
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Writer
import Data.List (nub)
import qualified Data.Map.Strict as Map
import Data.Map.Strict ( Map )
import Data.Maybe
import qualified GHC.LanguageExtensions.Type as LangExt
genPromotions :: OptionsMonad q => [Name] -> q [Dec]
genPromotions :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
genPromotions [Name]
names = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
withOptions opts{genQuotedDecs = False} $ do
checkForRep names
infos <- mapM reifyWithLocals names
dinfos <- mapM dsInfo infos
ddecs <- promoteM_ [] $ mapM_ promoteInfo dinfos
return $ decsToTH ddecs
promote :: OptionsMonad q => q [Dec] -> q [Dec]
promote :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
promote q [Dec]
qdecs = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
withOptions opts{genQuotedDecs = True} $ promote' $ lift qdecs
promoteOnly :: OptionsMonad q => q [Dec] -> q [Dec]
promoteOnly :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
promoteOnly q [Dec]
qdecs = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
withOptions opts{genQuotedDecs = False} $ promote' $ lift qdecs
promote' :: OptionsMonad q => q [Dec] -> q [Dec]
promote' :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
promote' q [Dec]
qdecs = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
decs <- qdecs
ddecs <- withLocalDeclarations decs $ dsDecs decs
promDecs <- promoteM_ decs $ promoteDecs ddecs
let origDecs | Options -> Bool
genQuotedDecs Options
opts = [Dec]
decs
| Bool
otherwise = []
return $ origDecs ++ decsToTH promDecs
genDefunSymbols :: OptionsMonad q => [Name] -> q [Dec]
genDefunSymbols :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
genDefunSymbols [Name]
names = do
[Name] -> q ()
forall (q :: * -> *). Quasi q => [Name] -> q ()
checkForRep [Name]
names
infos <- (Name -> q DInfo) -> [Name] -> q [DInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (Info -> q DInfo) -> (Name -> q Info) -> Name -> q DInfo
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals) [Name]
names
decs <- promoteMDecs [] $ concatMapM defunInfo infos
return $ decsToTH decs
promoteEqInstances :: OptionsMonad q => [Name] -> q [Dec]
promoteEqInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
promoteEqInstances = (Name -> q [Dec]) -> [Name] -> q [Dec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [Dec]
forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteEqInstance
promoteEqInstance :: OptionsMonad q => Name -> q [Dec]
promoteEqInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteEqInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEqInstance String
"Eq"
promoteOrdInstances :: OptionsMonad q => [Name] -> q [Dec]
promoteOrdInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
promoteOrdInstances = (Name -> q [Dec]) -> [Name] -> q [Dec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [Dec]
forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteOrdInstance
promoteOrdInstance :: OptionsMonad q => Name -> q [Dec]
promoteOrdInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteOrdInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkOrdInstance String
"Ord"
promoteBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]
promoteBoundedInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
promoteBoundedInstances = (Name -> q [Dec]) -> [Name] -> q [Dec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [Dec]
forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteBoundedInstance
promoteBoundedInstance :: OptionsMonad q => Name -> q [Dec]
promoteBoundedInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteBoundedInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkBoundedInstance String
"Bounded"
promoteEnumInstances :: OptionsMonad q => [Name] -> q [Dec]
promoteEnumInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
promoteEnumInstances = (Name -> q [Dec]) -> [Name] -> q [Dec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [Dec]
forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteEnumInstance
promoteEnumInstance :: OptionsMonad q => Name -> q [Dec]
promoteEnumInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteEnumInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEnumInstance String
"Enum"
promoteShowInstances :: OptionsMonad q => [Name] -> q [Dec]
promoteShowInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
promoteShowInstances = (Name -> q [Dec]) -> [Name] -> q [Dec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Name -> q [Dec]
forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteShowInstance
promoteShowInstance :: OptionsMonad q => Name -> q [Dec]
promoteShowInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
promoteShowInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance String
"Show"
promoteInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]
promoteInstance :: forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
promoteInstance DerivDesc q
mk_inst String
class_name Name
name = do
(df, tvbs, cons) <- String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
getDataD (String
"I cannot make an instance of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
class_name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for it.") Name
name
tvbs' <- mapM dsTvbVis tvbs
let data_ty = DType -> [DTyVarBndrVis] -> DType
foldTypeTvbs (Name -> DType
DConT Name
name) [DTyVarBndrVis]
tvbs'
cons' <- concatMapM (dsCon tvbs' data_ty) cons
let data_decl = DataFlavor -> Name -> [DTyVarBndrVis] -> [DCon] -> DataDecl
DataDecl DataFlavor
df Name
name [DTyVarBndrVis]
tvbs' [DCon]
cons'
raw_inst <- mk_inst Nothing data_ty data_decl
decs <- promoteM_ [] $ void $
promoteInstanceDec OMap.empty Map.empty raw_inst
return $ decsToTH decs
promoteInfo :: DInfo -> PrM ()
promoteInfo :: DInfo -> PrM ()
promoteInfo (DTyConI DDec
dec Maybe [DDec]
_instances) = [DDec] -> PrM ()
promoteDecs [DDec
dec]
promoteInfo (DPrimTyConI Name
_name Int
_numArgs Bool
_unlifted) =
String -> PrM ()
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Promotion of primitive type constructors not supported"
promoteInfo (DVarI Name
_name DType
_ty Maybe Name
_mdec) =
String -> PrM ()
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Promotion of individual values not supported"
promoteInfo (DTyVarI Name
_name DType
_ty) =
String -> PrM ()
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Promotion of individual type variables not supported"
promoteInfo (DPatSynI {}) =
String -> PrM ()
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Promotion of pattern synonyms not supported"
promoteDecs :: [DDec] -> PrM ()
promoteDecs :: [DDec] -> PrM ()
promoteDecs [DDec]
raw_decls = do
decls <- [DDec] -> PrM [DDec]
forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expand [DDec]
raw_decls
checkForRepInDecls decls
PDecs { pd_let_decs = let_decs
, pd_class_decs = classes
, pd_instance_decs = insts
, pd_data_decs = datas
, pd_ty_syn_decs = ty_syns
, pd_open_type_family_decs = o_tyfams
, pd_closed_type_family_decs = c_tyfams } <- partitionDecs decls
defunTopLevelTypeDecls ty_syns c_tyfams o_tyfams
rec_sel_let_decs <- promoteDataDecs datas
_ <- promoteLetDecs Nothing $ rec_sel_let_decs ++ let_decs
mapM_ promoteClassDec classes
let orig_meth_sigs = (UClassDecl -> OMap Name DType) -> [UClassDecl] -> OMap Name DType
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (LetDecEnv Unannotated -> OMap Name DType
forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name DType
lde_types (LetDecEnv Unannotated -> OMap Name DType)
-> (UClassDecl -> LetDecEnv Unannotated)
-> UClassDecl
-> OMap Name DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClassDecl -> LetDecEnv Unannotated
forall (ann :: AnnotationFlag). ClassDecl ann -> LetDecEnv ann
cd_lde) [UClassDecl]
classes
cls_tvbs_map = [(Name, [DTyVarBndrVis])] -> Map Name [DTyVarBndrVis]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, [DTyVarBndrVis])] -> Map Name [DTyVarBndrVis])
-> [(Name, [DTyVarBndrVis])] -> Map Name [DTyVarBndrVis]
forall a b. (a -> b) -> a -> b
$ (UClassDecl -> (Name, [DTyVarBndrVis]))
-> [UClassDecl] -> [(Name, [DTyVarBndrVis])]
forall a b. (a -> b) -> [a] -> [b]
map (\UClassDecl
cd -> (UClassDecl -> Name
forall (ann :: AnnotationFlag). ClassDecl ann -> Name
cd_name UClassDecl
cd, UClassDecl -> [DTyVarBndrVis]
forall (ann :: AnnotationFlag). ClassDecl ann -> [DTyVarBndrVis]
cd_tvbs UClassDecl
cd)) [UClassDecl]
classes
mapM_ (promoteInstanceDec orig_meth_sigs cls_tvbs_map) insts
promoteLetDecs :: Maybe Uniq
-> [DLetDec] -> PrM ([LetBind], ALetDecEnv)
promoteLetDecs :: Maybe Uniq -> [DLetDec] -> PrM ([LetBind], ALetDecEnv)
promoteLetDecs Maybe Uniq
mb_let_uniq [DLetDec]
decls = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let_dec_env <- buildLetDecEnv decls
all_locals <- allLocals
let binds = [ (Name
name, DType -> DCxt -> DType
foldType (Name -> DType
DConT Name
sym) ((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
all_locals))
| (Name
name, LetDecRHS Unannotated
_) <- OMap Name (LetDecRHS Unannotated)
-> [(Name, LetDecRHS Unannotated)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs (OMap Name (LetDecRHS Unannotated)
-> [(Name, LetDecRHS Unannotated)])
-> OMap Name (LetDecRHS Unannotated)
-> [(Name, LetDecRHS Unannotated)]
forall a b. (a -> b) -> a -> b
$ LetDecEnv Unannotated -> OMap Name (LetDecRHS Unannotated)
forall (ann :: AnnotationFlag).
LetDecEnv ann -> OMap Name (LetDecRHS ann)
lde_defns LetDecEnv Unannotated
let_dec_env
, let proName :: Name
proName = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name Maybe Uniq
mb_let_uniq
sym :: Name
sym = Options -> Name -> Int -> Name
defunctionalizedName Options
opts Name
proName ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
all_locals) ]
(decs, let_dec_env') <- letBind binds $ promoteLetDecEnv mb_let_uniq let_dec_env
emitDecs decs
return (binds, let_dec_env' { lde_proms = OMap.fromList binds })
promoteDataDecs :: [DataDecl] -> PrM [DLetDec]
promoteDataDecs :: [DataDecl] -> PrM [DLetDec]
promoteDataDecs = (DataDecl -> PrM [DLetDec]) -> [DataDecl] -> PrM [DLetDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DataDecl -> PrM [DLetDec]
promoteDataDec
promoteDataDec :: DataDecl -> PrM [DLetDec]
promoteDataDec :: DataDecl -> PrM [DLetDec]
promoteDataDec (DataDecl DataFlavor
_ Name
_ [DTyVarBndrVis]
_ [DCon]
ctors) = do
let rec_sel_names :: [Name]
rec_sel_names = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (DCon -> [Name]) -> [DCon] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DCon -> [Name]
extractRecSelNames [DCon]
ctors
fld_sels <- Extension -> PrM Bool
forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled Extension
LangExt.FieldSelectors
rec_sel_let_decs <- if fld_sels then getRecordSelectors ctors else pure []
ctorSyms <- buildDefunSymsDataD ctors
infix_decs <- promoteReifiedInfixDecls rec_sel_names
emitDecs $ ctorSyms ++ infix_decs
pure rec_sel_let_decs
promoteClassDec :: UClassDecl -> PrM AClassDecl
promoteClassDec :: UClassDecl -> PrM AClassDecl
promoteClassDec decl :: UClassDecl
decl@(ClassDecl { cd_name :: forall (ann :: AnnotationFlag). ClassDecl ann -> Name
cd_name = Name
cls_name
, cd_tvbs :: forall (ann :: AnnotationFlag). ClassDecl ann -> [DTyVarBndrVis]
cd_tvbs = [DTyVarBndrVis]
tvbs
, cd_fds :: forall (ann :: AnnotationFlag). ClassDecl ann -> [FunDep]
cd_fds = [FunDep]
fundeps
, cd_atfs :: forall (ann :: AnnotationFlag).
ClassDecl ann -> [OpenTypeFamilyDecl]
cd_atfs = [OpenTypeFamilyDecl]
atfs
, cd_lde :: forall (ann :: AnnotationFlag). ClassDecl ann -> LetDecEnv ann
cd_lde = lde :: LetDecEnv Unannotated
lde@LetDecEnv
{ lde_defns :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> OMap Name (LetDecRHS ann)
lde_defns = OMap Name (LetDecRHS Unannotated)
defaults
, lde_types :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name DType
lde_types = OMap Name DType
meth_sigs
, lde_infix :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name Fixity
lde_infix = OMap Name Fixity
infix_decls } }) = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let pClsName = Options -> Name -> Name
promotedClassName Options
opts Name
cls_name
meth_sigs_list = OMap Name DType -> [LetBind]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name DType
meth_sigs
meth_names = (LetBind -> Name) -> [LetBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LetBind -> Name
forall a b. (a, b) -> a
fst [LetBind]
meth_sigs_list
defaults_list = OMap Name (LetDecRHS Unannotated)
-> [(Name, LetDecRHS Unannotated)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name (LetDecRHS Unannotated)
defaults
defaults_names = ((Name, LetDecRHS Unannotated) -> Name)
-> [(Name, LetDecRHS Unannotated)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, LetDecRHS Unannotated) -> Name
forall a b. (a, b) -> a
fst [(Name, LetDecRHS Unannotated)]
defaults_list
mb_cls_sak <- dsReifyType cls_name
sig_decs <- mapM (uncurry promote_sig) meth_sigs_list
(default_decs, ann_rhss, prom_rhss)
<- mapAndUnzip3M (promoteMethod DefaultMethods meth_sigs) defaults_list
defunAssociatedTypeFamilies tvbs atfs
infix_decls' <- mapMaybeM (uncurry (promoteInfixDecl Nothing)) $
OMap.assocs infix_decls
cls_infix_decls <- promoteReifiedInfixDecls $ cls_name:meth_names
let pro_cls_dec = DCxt -> Name -> [DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec
DClassD [] Name
pClsName [DTyVarBndrVis]
tvbs [FunDep]
fundeps
([DDec]
sig_decs [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
default_decs [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
infix_decls')
mb_pro_cls_sak = (DType -> DDec) -> Maybe DType -> Maybe DDec
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> DType -> DDec
DKiSigD Name
pClsName) Maybe DType
mb_cls_sak
emitDecs $ maybeToList mb_pro_cls_sak ++ pro_cls_dec:cls_infix_decls
let defaults_list' = [Name] -> [ALetDecRHS] -> [(Name, ALetDecRHS)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
defaults_names [ALetDecRHS]
ann_rhss
proms = [Name] -> DCxt -> [LetBind]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
defaults_names DCxt
prom_rhss
return (decl { cd_lde = lde { lde_defns = OMap.fromList defaults_list'
, lde_proms = OMap.fromList proms } })
where
promote_sig :: Name -> DType -> PrM DDec
promote_sig :: Name -> DType -> PrM DDec
promote_sig Name
name DType
ty = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let proName = Options -> Name -> Name
promotedTopLevelValueName Options
opts Name
name
(_, argKs, resK) <- promoteUnraveled ty
args <- mapM (const $ qNewName "arg") argKs
let proTvbs = (Name -> DType -> DTyVarBndrVis)
-> [Name] -> DCxt -> [DTyVarBndrVis]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> BndrVis -> DType -> DTyVarBndrVis
forall flag. Name -> flag -> DType -> DTyVarBndr flag
`DKindedTV` BndrVis
BndrReq) [Name]
args DCxt
argKs
meth_sak_tvbs = Specificity -> [DTyVarBndr ()] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndr ()] -> [DTyVarBndrSpec])
-> [DTyVarBndr ()] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> a -> b
$
DCxt -> [DTyVarBndr ()]
toposortTyVarsOf (DCxt -> [DTyVarBndr ()]) -> DCxt -> [DTyVarBndr ()]
forall a b. (a -> b) -> a -> b
$ DCxt
argKs DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ [DType
resK]
meth_sak = [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType [DTyVarBndrSpec]
meth_sak_tvbs [] DCxt
argKs DType
resK
m_fixity <- reifyFixityWithLocals name
emitDecsM $ defunctionalize proName m_fixity $ DefunSAK meth_sak
return $ DOpenTypeFamilyD (DTypeFamilyHead proName
proTvbs
(DKindSig resK)
Nothing)
promoteInstanceDec :: OMap Name DType
-> Map Name [DTyVarBndrVis]
-> UInstDecl -> PrM AInstDecl
promoteInstanceDec :: OMap Name DType
-> Map Name [DTyVarBndrVis] -> UInstDecl -> PrM AInstDecl
promoteInstanceDec OMap Name DType
orig_meth_sigs Map Name [DTyVarBndrVis]
cls_tvbs_map
decl :: UInstDecl
decl@(InstDecl { id_name :: forall (ann :: AnnotationFlag). InstDecl ann -> Name
id_name = Name
cls_name
, id_arg_tys :: forall (ann :: AnnotationFlag). InstDecl ann -> DCxt
id_arg_tys = DCxt
inst_tys
, id_sigs :: forall (ann :: AnnotationFlag). InstDecl ann -> OMap Name DType
id_sigs = OMap Name DType
inst_sigs
, id_meths :: forall (ann :: AnnotationFlag).
InstDecl ann -> [(Name, LetDecRHS ann)]
id_meths = [(Name, LetDecRHS Unannotated)]
meths }) = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
cls_tvbs <- lookup_cls_tvbs
inst_kis <- mapM promoteType inst_tys
let pClsName = Options -> Name -> Name
promotedClassName Options
opts Name
cls_name
cls_tvb_names = (DTyVarBndrVis -> Name) -> [DTyVarBndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrVis -> Name
forall flag. DTyVarBndr flag -> Name
extractTvbName [DTyVarBndrVis]
cls_tvbs
subst = [LetBind] -> Map Name DType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([LetBind] -> Map Name DType) -> [LetBind] -> Map Name DType
forall a b. (a -> b) -> a -> b
$ [Name] -> DCxt -> [LetBind]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
cls_tvb_names DCxt
inst_kis
meth_impl = OMap Name DType -> Map Name DType -> MethodSort
InstanceMethods OMap Name DType
inst_sigs Map Name DType
subst
(meths', ann_rhss, _)
<- mapAndUnzip3M (promoteMethod meth_impl orig_meth_sigs) meths
emitDecs [DInstanceD Nothing Nothing [] (foldType (DConT pClsName)
inst_kis) meths']
return (decl { id_meths = zip (map fst meths) ann_rhss })
where
lookup_cls_tvbs :: PrM [DTyVarBndrVis]
lookup_cls_tvbs :: PrM [DTyVarBndrVis]
lookup_cls_tvbs =
case Name -> Map Name [DTyVarBndrVis] -> Maybe [DTyVarBndrVis]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
cls_name Map Name [DTyVarBndrVis]
cls_tvbs_map of
Just [DTyVarBndrVis]
tvbs -> [DTyVarBndrVis] -> PrM [DTyVarBndrVis]
forall a. a -> PrM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrVis]
tvbs
Maybe [DTyVarBndrVis]
Nothing -> PrM [DTyVarBndrVis]
reify_cls_tvbs
reify_cls_tvbs :: PrM [DTyVarBndrVis]
reify_cls_tvbs :: PrM [DTyVarBndrVis]
reify_cls_tvbs = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let pClsName = Options -> Name -> Name
promotedClassName Options
opts Name
cls_name
mk_tvbs = PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis]
extract_tvbs (Name -> PrM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReifyTypeNameInfo Name
pClsName)
MaybeT PrM [DTyVarBndrVis]
-> MaybeT PrM [DTyVarBndrVis] -> MaybeT PrM [DTyVarBndrVis]
forall a. MaybeT PrM a -> MaybeT PrM a -> MaybeT PrM a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis]
extract_tvbs (Name -> PrM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReifyTypeNameInfo Name
cls_name)
mb_tvbs <- runMaybeT mk_tvbs
case mb_tvbs of
Just [DTyVarBndrVis]
tvbs -> [DTyVarBndrVis] -> PrM [DTyVarBndrVis]
forall a. a -> PrM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrVis]
tvbs
Maybe [DTyVarBndrVis]
Nothing -> String -> PrM [DTyVarBndrVis]
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PrM [DTyVarBndrVis]) -> String -> PrM [DTyVarBndrVis]
forall a b. (a -> b) -> a -> b
$ String
"Cannot find class declaration annotation for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
cls_name
extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis]
extract_tvbs :: PrM (Maybe DInfo) -> MaybeT PrM [DTyVarBndrVis]
extract_tvbs PrM (Maybe DInfo)
reify_info = do
mb_info <- PrM (Maybe DInfo) -> MaybeT PrM (Maybe DInfo)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift PrM (Maybe DInfo)
reify_info
case mb_info of
Just (DTyConI (DClassD DCxt
_ Name
_ [DTyVarBndrVis]
tvbs [FunDep]
_ [DDec]
_) Maybe [DDec]
_) -> [DTyVarBndrVis] -> MaybeT PrM [DTyVarBndrVis]
forall a. a -> MaybeT PrM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrVis]
tvbs
Maybe DInfo
_ -> MaybeT PrM [DTyVarBndrVis]
forall a. MaybeT PrM a
forall (f :: * -> *) a. Alternative f => f a
empty
data MethodSort
= DefaultMethods
| InstanceMethods (OMap Name DType)
(Map Name DKind)
deriving Int -> MethodSort -> String -> String
[MethodSort] -> String -> String
MethodSort -> String
(Int -> MethodSort -> String -> String)
-> (MethodSort -> String)
-> ([MethodSort] -> String -> String)
-> Show MethodSort
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MethodSort -> String -> String
showsPrec :: Int -> MethodSort -> String -> String
$cshow :: MethodSort -> String
show :: MethodSort -> String
$cshowList :: [MethodSort] -> String -> String
showList :: [MethodSort] -> String -> String
Show
promoteMethod :: MethodSort
-> OMap Name DType
-> (Name, ULetDecRHS)
-> PrM (DDec, ALetDecRHS, DType)
promoteMethod :: MethodSort
-> OMap Name DType
-> (Name, LetDecRHS Unannotated)
-> PrM (DDec, ALetDecRHS, DType)
promoteMethod MethodSort
meth_sort OMap Name DType
orig_sigs_map (Name
meth_name, LetDecRHS Unannotated
meth_rhs) = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
(meth_arg_kis, meth_res_ki) <- promote_meth_ty
meth_arg_tvs <- replicateM (length meth_arg_kis) (qNewName "a")
let proName = Options -> Name -> Name
promotedTopLevelValueName Options
opts Name
meth_name
helperNameBase = case Name -> String
nameBase Name
proName of
Char
first:String
_ | Bool -> Bool
not (Char -> Bool
isHsLetter Char
first) -> String
"TFHelper"
String
alpha -> String
alpha
family_args = (Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
meth_arg_tvs
helperName <- newUniqueName helperNameBase
let helperDefunName = Options -> Name -> Name
defunctionalizedName0 Options
opts Name
helperName
(pro_decs, defun_decs, ann_rhs)
<- promoteLetDecRHS (ClassMethodRHS meth_arg_kis meth_res_ki)
OMap.empty OMap.empty
Nothing helperName meth_rhs
emitDecs (pro_decs ++ defun_decs)
return ( DTySynInstD
(DTySynEqn Nothing
(foldType (DConT proName) family_args)
(foldApply (DConT helperDefunName) (map DVarT meth_arg_tvs)))
, ann_rhs
, DConT helperDefunName )
where
promote_meth_ty :: PrM ([DKind], DKind)
promote_meth_ty :: PrM (DCxt, DType)
promote_meth_ty =
case MethodSort
meth_sort of
MethodSort
DefaultMethods ->
PrM (DCxt, DType)
lookup_meth_ty
InstanceMethods OMap Name DType
inst_sigs_map Map Name DType
cls_subst ->
case Name -> OMap Name DType -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
meth_name OMap Name DType
inst_sigs_map of
Just DType
ty -> do
(_tvbs, arg_kis, res_ki) <- DType -> PrM ([DTyVarBndrSpec], DCxt, DType)
forall (m :: * -> *).
OptionsMonad m =>
DType -> m ([DTyVarBndrSpec], DCxt, DType)
promoteUnraveled DType
ty
pure (arg_kis, res_ki)
Maybe DType
Nothing -> do
(arg_kis, res_ki) <- PrM (DCxt, DType)
lookup_meth_ty
let arg_kis' = (DType -> DType) -> DCxt -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (Map Name DType -> DType -> DType
substKind Map Name DType
cls_subst) DCxt
arg_kis
res_ki' = Map Name DType -> DType -> DType
substKind Map Name DType
cls_subst DType
res_ki
pure (arg_kis', res_ki')
lookup_meth_ty :: PrM ([DKind], DKind)
lookup_meth_ty :: PrM (DCxt, DType)
lookup_meth_ty = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let proName = Options -> Name -> Name
promotedTopLevelValueName Options
opts Name
meth_name
case OMap.lookup meth_name orig_sigs_map of
Just DType
ty -> do
(_tvbs, arg_kis, res_ki) <- DType -> PrM ([DTyVarBndrSpec], DCxt, DType)
forall (m :: * -> *).
OptionsMonad m =>
DType -> m ([DTyVarBndrSpec], DCxt, DType)
promoteUnraveled DType
ty
pure (arg_kis, res_ki)
Maybe DType
Nothing -> do
mb_info <- Name -> PrM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReifyTypeNameInfo Name
proName
case mb_info of
Just (DTyConI (DOpenTypeFamilyD (DTypeFamilyHead Name
_ [DTyVarBndrVis]
tvbs DFamilyResultSig
mb_res_ki Maybe InjectivityAnn
_)) Maybe [DDec]
_)
-> let arg_kis :: DCxt
arg_kis = (DTyVarBndrVis -> DType) -> [DTyVarBndrVis] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DType -> DType
defaultMaybeToTypeKind (Maybe DType -> DType)
-> (DTyVarBndrVis -> Maybe DType) -> DTyVarBndrVis -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrVis -> Maybe DType
forall flag. DTyVarBndr flag -> Maybe DType
extractTvbKind) [DTyVarBndrVis]
tvbs
res_ki :: DType
res_ki = Maybe DType -> DType
defaultMaybeToTypeKind (DFamilyResultSig -> Maybe DType
resultSigToMaybeKind DFamilyResultSig
mb_res_ki)
in (DCxt, DType) -> PrM (DCxt, DType)
forall a. a -> PrM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DCxt
arg_kis, DType
res_ki)
Maybe DInfo
_ -> String -> PrM (DCxt, DType)
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PrM (DCxt, DType)) -> String -> PrM (DCxt, DType)
forall a b. (a -> b) -> a -> b
$ String
"Cannot find type annotation for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
proName
promoteLetDecEnv :: Maybe Uniq -> ULetDecEnv -> PrM ([DDec], ALetDecEnv)
promoteLetDecEnv :: Maybe Uniq -> LetDecEnv Unannotated -> PrM ([DDec], ALetDecEnv)
promoteLetDecEnv Maybe Uniq
mb_let_uniq (LetDecEnv { lde_defns :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> OMap Name (LetDecRHS ann)
lde_defns = OMap Name (LetDecRHS Unannotated)
value_env
, lde_types :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name DType
lde_types = OMap Name DType
type_env
, lde_infix :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name Fixity
lde_infix = OMap Name Fixity
fix_env }) = do
infix_decls <- ((Name, Fixity) -> PrM (Maybe DDec))
-> [(Name, Fixity)] -> PrM [DDec]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((Name -> Fixity -> PrM (Maybe DDec))
-> (Name, Fixity) -> PrM (Maybe DDec)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Maybe Uniq -> Name -> Fixity -> PrM (Maybe DDec)
forall (q :: * -> *).
OptionsMonad q =>
Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)
promoteInfixDecl Maybe Uniq
mb_let_uniq)) ([(Name, Fixity)] -> PrM [DDec]) -> [(Name, Fixity)] -> PrM [DDec]
forall a b. (a -> b) -> a -> b
$
OMap Name Fixity -> [(Name, Fixity)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name Fixity
fix_env
let (names, rhss) = unzip $ OMap.assocs value_env
(pro_decs, defun_decss, ann_rhss)
<- fmap unzip3 $
zipWithM (promoteLetDecRHS LetBindingRHS type_env fix_env mb_let_uniq)
names rhss
emitDecs $ concat defun_decss
let decs = [[DDec]] -> [DDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DDec]]
pro_decs [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
infix_decls
let let_dec_env' = LetDecEnv { lde_defns :: OMap Name ALetDecRHS
lde_defns = [(Name, ALetDecRHS)] -> OMap Name ALetDecRHS
forall k v. Ord k => [(k, v)] -> OMap k v
OMap.fromList ([(Name, ALetDecRHS)] -> OMap Name ALetDecRHS)
-> [(Name, ALetDecRHS)] -> OMap Name ALetDecRHS
forall a b. (a -> b) -> a -> b
$ [Name] -> [ALetDecRHS] -> [(Name, ALetDecRHS)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [ALetDecRHS]
ann_rhss
, lde_types :: OMap Name DType
lde_types = OMap Name DType
type_env
, lde_infix :: OMap Name Fixity
lde_infix = OMap Name Fixity
fix_env
, lde_proms :: IfAnn Annotated (OMap Name DType) ()
lde_proms = OMap Name DType
IfAnn Annotated (OMap Name DType) ()
forall k v. OMap k v
OMap.empty
}
return (decs, let_dec_env')
promoteInfixDecl :: forall q. OptionsMonad q
=> Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)
promoteInfixDecl :: forall (q :: * -> *).
OptionsMonad q =>
Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)
promoteInfixDecl Maybe Uniq
mb_let_uniq Name
name Fixity
fixity = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
fld_sels <- qIsExtEnabled LangExt.FieldSelectors
mb_ns <- reifyNameSpace name
case mb_ns of
Maybe NameSpace
Nothing -> q (Maybe DDec)
promote_val
Just NameSpace
VarName -> q (Maybe DDec)
promote_val
Just (FldName String
_)
| Bool
fld_sels -> q (Maybe DDec)
promote_val
| Bool
otherwise -> q (Maybe DDec)
never_mind
Just NameSpace
DataName -> q (Maybe DDec)
never_mind
Just NameSpace
TcClsName -> do
mb_info <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
name
case mb_info of
Just (DTyConI DClassD{} Maybe [DDec]
_)
-> Name -> q (Maybe DDec)
finish (Name -> q (Maybe DDec)) -> Name -> q (Maybe DDec)
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
promotedClassName Options
opts Name
name
Maybe DInfo
_ -> q (Maybe DDec)
never_mind
where
finish :: Name -> q (Maybe DDec)
finish :: Name -> q (Maybe DDec)
finish = Maybe DDec -> q (Maybe DDec)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DDec -> q (Maybe DDec))
-> (Name -> Maybe DDec) -> Name -> q (Maybe DDec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DDec -> Maybe DDec
forall a. a -> Maybe a
Just (DDec -> Maybe DDec) -> (Name -> DDec) -> Name -> Maybe DDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLetDec -> DDec
DLetDec (DLetDec -> DDec) -> (Name -> DLetDec) -> Name -> DDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fixity -> NamespaceSpecifier -> Name -> DLetDec
DInfixD Fixity
fixity NamespaceSpecifier
NoNamespaceSpecifier
never_mind :: q (Maybe DDec)
never_mind :: q (Maybe DDec)
never_mind = Maybe DDec -> q (Maybe DDec)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DDec
forall a. Maybe a
Nothing
promote_val :: q (Maybe DDec)
promote_val :: q (Maybe DDec)
promote_val = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let promoted_name :: Name
promoted_name = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name Maybe Uniq
mb_let_uniq
if nameBase name == nameBase promoted_name && genQuotedDecs opts
then never_mind
else finish promoted_name
promoteReifiedInfixDecls :: forall q. OptionsMonad q => [Name] -> q [DDec]
promoteReifiedInfixDecls :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [DDec]
promoteReifiedInfixDecls = (Name -> q (Maybe DDec)) -> [Name] -> q [DDec]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Name -> q (Maybe DDec)
tryPromoteFixityDeclaration
where
tryPromoteFixityDeclaration :: Name -> q (Maybe DDec)
tryPromoteFixityDeclaration :: Name -> q (Maybe DDec)
tryPromoteFixityDeclaration Name
name =
q (Maybe DDec) -> q (Maybe DDec) -> q (Maybe DDec)
forall a. q a -> q a -> q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (Maybe DDec -> q (Maybe DDec)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DDec
forall a. Maybe a
Nothing) (q (Maybe DDec) -> q (Maybe DDec))
-> q (Maybe DDec) -> q (Maybe DDec)
forall a b. (a -> b) -> a -> b
$ do
mFixity <- Name -> q (Maybe Fixity)
forall (m :: * -> *). Quasi m => Name -> m (Maybe Fixity)
qReifyFixity Name
name
case mFixity of
Maybe Fixity
Nothing -> Maybe DDec -> q (Maybe DDec)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DDec
forall a. Maybe a
Nothing
Just Fixity
fixity -> Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)
forall (q :: * -> *).
OptionsMonad q =>
Maybe Uniq -> Name -> Fixity -> q (Maybe DDec)
promoteInfixDecl Maybe Uniq
forall a. Maybe a
Nothing Name
name Fixity
fixity
data LetDecRHSSort
= LetBindingRHS
| ClassMethodRHS
[DKind] DKind
deriving Int -> LetDecRHSSort -> String -> String
[LetDecRHSSort] -> String -> String
LetDecRHSSort -> String
(Int -> LetDecRHSSort -> String -> String)
-> (LetDecRHSSort -> String)
-> ([LetDecRHSSort] -> String -> String)
-> Show LetDecRHSSort
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LetDecRHSSort -> String -> String
showsPrec :: Int -> LetDecRHSSort -> String -> String
$cshow :: LetDecRHSSort -> String
show :: LetDecRHSSort -> String
$cshowList :: [LetDecRHSSort] -> String -> String
showList :: [LetDecRHSSort] -> String -> String
Show
promoteLetDecRHS :: LetDecRHSSort
-> OMap Name DType
-> OMap Name Fixity
-> Maybe Uniq
-> Name
-> ULetDecRHS
-> PrM ( [DDec]
, [DDec]
, ALetDecRHS )
promoteLetDecRHS :: LetDecRHSSort
-> OMap Name DType
-> OMap Name Fixity
-> Maybe Uniq
-> Name
-> LetDecRHS Unannotated
-> PrM ([DDec], [DDec], ALetDecRHS)
promoteLetDecRHS LetDecRHSSort
rhs_sort OMap Name DType
type_env OMap Name Fixity
fix_env Maybe Uniq
mb_let_uniq Name
name LetDecRHS Unannotated
let_dec_rhs = do
all_locals <- PrM [Name]
forall (m :: * -> *). MonadReader PrEnv m => m [Name]
allLocals
case let_dec_rhs of
UValue DExp
exp -> do
(m_ldrki, ty_num_args) <- [Name] -> Int -> PrM (Maybe LetDecRHSKindInfo, Int)
promote_let_dec_ty [Name]
all_locals Int
0
if ty_num_args == 0
then do
prom_fun_lhs <- promoteLetDecName mb_let_uniq name m_ldrki all_locals
promote_let_dec_rhs all_locals m_ldrki 0 (promoteExp exp)
(\DType
exp' -> [Maybe [DTyVarBndr ()] -> DType -> DType -> DTySynEqn
DTySynEqn Maybe [DTyVarBndr ()]
forall a. Maybe a
Nothing DType
prom_fun_lhs DType
exp'])
AValue
else
promote_function_rhs all_locals [DClause [] exp]
UFunction [DClause]
clauses -> [Name] -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)
promote_function_rhs [Name]
all_locals [DClause]
clauses
where
promote_function_rhs :: [Name]
-> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)
promote_function_rhs :: [Name] -> [DClause] -> PrM ([DDec], [DDec], ALetDecRHS)
promote_function_rhs [Name]
all_locals [DClause]
clauses = do
numArgs <- [DClause] -> PrM Int
count_args [DClause]
clauses
(m_ldrki, ty_num_args) <- promote_let_dec_ty all_locals numArgs
expClauses <- mapM (etaContractOrExpand ty_num_args numArgs) clauses
let promote_clause = Maybe Uniq
-> Name
-> Maybe LetDecRHSKindInfo
-> [Name]
-> DClause
-> PrM (DTySynEqn, ADClause)
promoteClause Maybe Uniq
mb_let_uniq Name
name Maybe LetDecRHSKindInfo
m_ldrki [Name]
all_locals
promote_let_dec_rhs all_locals m_ldrki ty_num_args
(mapAndUnzipM promote_clause expClauses)
id (AFunction ty_num_args)
promote_let_dec_rhs
:: [Name]
-> Maybe LetDecRHSKindInfo
-> Int
-> PrM (prom_a, a)
-> (prom_a -> [DTySynEqn])
-> (a -> ALetDecRHS)
-> PrM ([DDec], [DDec], ALetDecRHS)
promote_let_dec_rhs :: forall prom_a a.
[Name]
-> Maybe LetDecRHSKindInfo
-> Int
-> PrM (prom_a, a)
-> (prom_a -> [DTySynEqn])
-> (a -> ALetDecRHS)
-> PrM ([DDec], [DDec], ALetDecRHS)
promote_let_dec_rhs [Name]
all_locals Maybe LetDecRHSKindInfo
m_ldrki Int
ty_num_args
PrM (prom_a, a)
promote_thing prom_a -> [DTySynEqn]
mk_prom_eqns a -> ALetDecRHS
mk_alet_dec_rhs = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
tyvarNames <- replicateM ty_num_args (qNewName "a")
let proName = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name Maybe Uniq
mb_let_uniq
local_tvbs = (Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` BndrVis
BndrReq) [Name]
all_locals
m_fixity = Name -> OMap Name Fixity -> Maybe Fixity
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name Fixity
fix_env
mk_tf_head :: [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
mk_tf_head [DTyVarBndrVis]
arg_tvbs DFamilyResultSig
res_sig =
Name
-> [Name] -> [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
dTypeFamilyHead_with_locals Name
proName [Name]
all_locals [DTyVarBndrVis]
arg_tvbs DFamilyResultSig
res_sig
(lde_kvs_to_bind, m_sak_dec, defun_ki, tf_head) =
case m_ldrki of
Maybe LetDecRHSKindInfo
Nothing ->
let arg_tvbs :: [DTyVarBndrVis]
arg_tvbs = (Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` BndrVis
BndrReq) [Name]
tyvarNames in
( OSet Name
forall a. OSet a
OSet.empty
, Maybe DDec
forall a. Maybe a
Nothing
, [DTyVarBndrVis] -> Maybe DType -> DefunKindInfo
DefunNoSAK ([DTyVarBndrVis]
local_tvbs [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrVis]
arg_tvbs) Maybe DType
forall a. Maybe a
Nothing
, [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
mk_tf_head [DTyVarBndrVis]
arg_tvbs DFamilyResultSig
DNoSig
)
Just (LDRKI Maybe DType
m_sak [DTyVarBndrSpec]
tvbs DCxt
argKs DType
resK) ->
let arg_tvbs :: [DTyVarBndrVis]
arg_tvbs = (Name -> DType -> DTyVarBndrVis)
-> [Name] -> DCxt -> [DTyVarBndrVis]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> BndrVis -> DType -> DTyVarBndrVis
forall flag. Name -> flag -> DType -> DTyVarBndr flag
`DKindedTV` BndrVis
BndrReq) [Name]
tyvarNames DCxt
argKs
lde_kvs_to_bind' :: OSet Name
lde_kvs_to_bind' = [Name] -> OSet Name
forall a. Ord a => [a] -> OSet a
OSet.fromList ((DTyVarBndrSpec -> Name) -> [DTyVarBndrSpec] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> Name
forall flag. DTyVarBndr flag -> Name
extractTvbName [DTyVarBndrSpec]
tvbs) in
case Maybe DType
m_sak of
Maybe DType
Nothing ->
( OSet Name
lde_kvs_to_bind'
, Maybe DDec
forall a. Maybe a
Nothing
, [DTyVarBndrVis] -> Maybe DType -> DefunKindInfo
DefunNoSAK ([DTyVarBndrVis]
local_tvbs [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrVis]
arg_tvbs) (DType -> Maybe DType
forall a. a -> Maybe a
Just DType
resK)
, [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
mk_tf_head [DTyVarBndrVis]
arg_tvbs (DType -> DFamilyResultSig
DKindSig DType
resK)
)
Just DType
sak ->
let tvbs' :: [DTyVarBndrSpec]
tvbs' | [DTyVarBndrSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndrSpec]
tvbs
= Specificity -> [DTyVarBndr ()] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndr ()] -> [DTyVarBndrSpec])
-> [DTyVarBndr ()] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> a -> b
$
DCxt -> [DTyVarBndr ()]
toposortTyVarsOf (DCxt
argKs DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ [DType
resK])
| Bool
otherwise
= [DTyVarBndrSpec]
tvbs
arg_tvbs' :: [DTyVarBndrVis]
arg_tvbs' = [DTyVarBndrSpec] -> [DTyVarBndrVis]
tvbSpecsToBndrVis [DTyVarBndrSpec]
tvbs' [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrVis]
arg_tvbs in
( OSet Name
lde_kvs_to_bind'
, DDec -> Maybe DDec
forall a. a -> Maybe a
Just (DDec -> Maybe DDec) -> DDec -> Maybe DDec
forall a b. (a -> b) -> a -> b
$ Name -> DType -> DDec
DKiSigD Name
proName DType
sak
, DType -> DefunKindInfo
DefunSAK DType
sak
, [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
mk_tf_head [DTyVarBndrVis]
arg_tvbs' (DType -> DFamilyResultSig
DKindSig DType
resK)
)
defun_decs <- defunctionalize proName m_fixity defun_ki
(prom_thing, thing) <- scopedBind lde_kvs_to_bind promote_thing
return ( catMaybes [ m_sak_dec
, Just $ DClosedTypeFamilyD tf_head (mk_prom_eqns prom_thing)
]
, defun_decs
, mk_alet_dec_rhs thing )
promote_let_dec_ty :: [Name]
-> Int
-> PrM (Maybe LetDecRHSKindInfo, Int)
promote_let_dec_ty :: [Name] -> Int -> PrM (Maybe LetDecRHSKindInfo, Int)
promote_let_dec_ty [Name]
all_locals Int
default_num_args =
case LetDecRHSSort
rhs_sort of
ClassMethodRHS DCxt
arg_kis DType
res_ki
->
let sak :: DType
sak = [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType [] [] DCxt
arg_kis DType
res_ki in
(Maybe LetDecRHSKindInfo, Int)
-> PrM (Maybe LetDecRHSKindInfo, Int)
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LetDecRHSKindInfo -> Maybe LetDecRHSKindInfo
forall a. a -> Maybe a
Just (Maybe DType
-> [DTyVarBndrSpec] -> DCxt -> DType -> LetDecRHSKindInfo
LDRKI (DType -> Maybe DType
forall a. a -> Maybe a
Just DType
sak) [] DCxt
arg_kis DType
res_ki), DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
arg_kis)
LetDecRHSSort
LetBindingRHS
| Just DType
ty <- Name -> OMap Name DType -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name DType
type_env
-> do
(tvbs, argKs, resultK) <- DType -> PrM ([DTyVarBndrSpec], DCxt, DType)
forall (m :: * -> *).
OptionsMonad m =>
DType -> m ([DTyVarBndrSpec], DCxt, DType)
promoteUnraveled DType
ty
let m_sak | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
all_locals = DType -> Maybe DType
forall a. a -> Maybe a
Just (DType -> Maybe DType) -> DType -> Maybe DType
forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType [DTyVarBndrSpec]
tvbs [] DCxt
argKs DType
resultK
| Bool
otherwise = Maybe DType
forall a. Maybe a
Nothing
return (Just (LDRKI m_sak tvbs argKs resultK), length argKs)
| Bool
otherwise
-> (Maybe LetDecRHSKindInfo, Int)
-> PrM (Maybe LetDecRHSKindInfo, Int)
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LetDecRHSKindInfo
forall a. Maybe a
Nothing, Int
default_num_args)
etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause
etaContractOrExpand :: Int -> Int -> DClause -> PrM DClause
etaContractOrExpand Int
ty_num_args Int
clause_num_args (DClause [DPat]
pats DExp
exp)
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = do
names <- Int -> PrM Name -> PrM [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> PrM Name
forall (m :: * -> *). Quasi m => String -> m Name
newUniqueName String
"a")
let newPats = (Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
names
newArgs = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
names
return $ DClause (pats ++ newPats) (foldExp exp newArgs)
| Bool
otherwise = do
let ([DPat]
clausePats, [DPat]
lamPats) = Int -> [DPat] -> ([DPat], [DPat])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
ty_num_args [DPat]
pats
lamExp <- [DPat] -> DExp -> PrM DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
lamPats DExp
exp
return $ DClause clausePats lamExp
where
n :: Int
n = Int
ty_num_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
clause_num_args
count_args :: [DClause] -> PrM Int
count_args :: [DClause] -> PrM Int
count_args (DClause [DPat]
pats DExp
_ : [DClause]
_) = Int -> PrM Int
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> PrM Int) -> Int -> PrM Int
forall a b. (a -> b) -> a -> b
$ [DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats
count_args [DClause]
_ = String -> PrM Int
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PrM Int) -> String -> PrM Int
forall a b. (a -> b) -> a -> b
$ String
"Impossible! A function without clauses."
data LetDecRHSKindInfo =
LDRKI (Maybe DKind)
[DTyVarBndrSpec]
[DKind]
DKind
promoteClause :: Maybe Uniq
-> Name
-> Maybe LetDecRHSKindInfo
-> [Name]
-> DClause -> PrM (DTySynEqn, ADClause)
promoteClause :: Maybe Uniq
-> Name
-> Maybe LetDecRHSKindInfo
-> [Name]
-> DClause
-> PrM (DTySynEqn, ADClause)
promoteClause Maybe Uniq
mb_let_uniq Name
name Maybe LetDecRHSKindInfo
m_ldrki [Name]
all_locals (DClause [DPat]
pats DExp
exp) = do
((types, pats'), prom_pat_infos) <- QWithAux PromDPatInfos PrM (DCxt, [ADPat])
-> PrM ((DCxt, [ADPat]), PromDPatInfos)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair (QWithAux PromDPatInfos PrM (DCxt, [ADPat])
-> PrM ((DCxt, [ADPat]), PromDPatInfos))
-> QWithAux PromDPatInfos PrM (DCxt, [ADPat])
-> PrM ((DCxt, [ADPat]), PromDPatInfos)
forall a b. (a -> b) -> a -> b
$ (DPat -> QWithAux PromDPatInfos PrM (DType, ADPat))
-> [DPat] -> QWithAux PromDPatInfos PrM (DCxt, [ADPat])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat [DPat]
pats
scoped_tvs <- qIsExtEnabled LangExt.ScopedTypeVariables
let types_w_kinds =
case Maybe LetDecRHSKindInfo
m_ldrki of
Just (LDRKI Maybe DType
_ [DTyVarBndrSpec]
tvbs DCxt
kinds DType
_)
| Bool -> Bool
not ([DTyVarBndrSpec] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndrSpec]
tvbs) Bool -> Bool -> Bool
&& Bool
scoped_tvs
-> (DType -> DType -> DType) -> DCxt -> DCxt -> DCxt
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DType -> DType -> DType
DSigT DCxt
types DCxt
kinds
Maybe LetDecRHSKindInfo
_ -> DCxt
types
let PromDPatInfos { prom_dpat_vars = new_vars
, prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos
(ty, ann_exp) <- scopedBind sig_kvs $
lambdaBind new_vars $
promoteExp exp
pro_clause_fun <- promoteLetDecName mb_let_uniq name m_ldrki all_locals
return ( DTySynEqn Nothing (foldType pro_clause_fun types_w_kinds) ty
, ADClause new_vars pats' ann_exp )
promoteMatch :: DType
-> DMatch -> PrM (DTySynEqn, ADMatch)
promoteMatch :: DType -> DMatch -> PrM (DTySynEqn, ADMatch)
promoteMatch DType
pro_case_fun (DMatch DPat
pat DExp
exp) = do
((ty, pat'), prom_pat_infos) <- QWithAux PromDPatInfos PrM (DType, ADPat)
-> PrM ((DType, ADPat), PromDPatInfos)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair (QWithAux PromDPatInfos PrM (DType, ADPat)
-> PrM ((DType, ADPat), PromDPatInfos))
-> QWithAux PromDPatInfos PrM (DType, ADPat)
-> PrM ((DType, ADPat), PromDPatInfos)
forall a b. (a -> b) -> a -> b
$ DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat DPat
pat
let PromDPatInfos { prom_dpat_vars = new_vars
, prom_dpat_sig_kvs = sig_kvs } = prom_pat_infos
(rhs, ann_exp) <- scopedBind sig_kvs $
lambdaBind new_vars $
promoteExp exp
return $ ( DTySynEqn Nothing (pro_case_fun `DAppT` ty) rhs
, ADMatch new_vars pat' ann_exp)
promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat :: DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat (DLitP Lit
lit) = (, Lit -> ADPat
ADLitP Lit
lit) (DType -> (DType, ADPat))
-> QWithAux PromDPatInfos PrM DType
-> QWithAux PromDPatInfos PrM (DType, ADPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lit -> QWithAux PromDPatInfos PrM DType
forall (m :: * -> *). MonadFail m => Lit -> m DType
promoteLitPat Lit
lit
promotePat (DVarP Name
name) = do
tyName <- Name -> QWithAux PromDPatInfos PrM Name
forall (q :: * -> *). Quasi q => Name -> q Name
mkTyName Name
name
tell $ PromDPatInfos [(name, tyName)] OSet.empty
return (DVarT tyName, ADVarP name)
promotePat (DConP Name
name DCxt
tys [DPat]
pats) = do
opts <- QWithAux PromDPatInfos PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
kis <- traverse (promoteType_options conOptions) tys
(types, pats') <- mapAndUnzipM promotePat pats
let name' = Options -> Name -> Name
promotedDataTypeOrConName Options
opts Name
name
return (foldType (foldl DAppKindT (DConT name') kis) types, ADConP name kis pats')
where
conOptions :: PromoteTypeOptions
conOptions :: PromoteTypeOptions
conOptions = PromoteTypeOptions
defaultPromoteTypeOptions{ptoAllowWildcards = True}
promotePat (DTildeP DPat
pat) = do
String -> QWithAux PromDPatInfos PrM ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning String
"Lazy pattern converted into regular pattern in promotion"
(ADPat -> ADPat) -> (DType, ADPat) -> (DType, ADPat)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ADPat -> ADPat
ADTildeP ((DType, ADPat) -> (DType, ADPat))
-> QWithAux PromDPatInfos PrM (DType, ADPat)
-> QWithAux PromDPatInfos PrM (DType, ADPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat DPat
pat
promotePat (DBangP DPat
pat) = do
String -> QWithAux PromDPatInfos PrM ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning String
"Strict pattern converted into regular pattern in promotion"
(ADPat -> ADPat) -> (DType, ADPat) -> (DType, ADPat)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ADPat -> ADPat
ADBangP ((DType, ADPat) -> (DType, ADPat))
-> QWithAux PromDPatInfos PrM (DType, ADPat)
-> QWithAux PromDPatInfos PrM (DType, ADPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> QWithAux PromDPatInfos PrM (DType, ADPat)
promotePat DPat
pat
promotePat (DSigP DPat
pat DType
ty) = do
wildless_pat <- DPat -> QWithAux PromDPatInfos PrM DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
(promoted, pat') <- promotePat wildless_pat
ki <- promoteType ty
tell $ PromDPatInfos [] (fvDType ki)
return (DSigT promoted ki, ADSigP promoted pat' ki)
promotePat DPat
DWildP = (DType, ADPat) -> QWithAux PromDPatInfos PrM (DType, ADPat)
forall a. a -> QWithAux PromDPatInfos PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType
DWildCardT, ADPat
ADWildP)
promotePat p :: DPat
p@(DTypeP DType
_) = String -> QWithAux PromDPatInfos PrM (DType, ADPat)
forall a. String -> QWithAux PromDPatInfos PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Embedded type patterns cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DPat -> String
forall a. Show a => a -> String
show DPat
p)
promotePat p :: DPat
p@(DInvisP DType
_) = String -> QWithAux PromDPatInfos PrM (DType, ADPat)
forall a. String -> QWithAux PromDPatInfos PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invisible type patterns cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DPat -> String
forall a. Show a => a -> String
show DPat
p)
promoteExp :: DExp -> PrM (DType, ADExp)
promoteExp :: DExp -> PrM (DType, ADExp)
promoteExp (DVarE Name
name) = (DType -> (DType, ADExp)) -> PrM DType -> PrM (DType, ADExp)
forall a b. (a -> b) -> PrM a -> PrM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Name -> ADExp
ADVarE Name
name) (PrM DType -> PrM (DType, ADExp))
-> PrM DType -> PrM (DType, ADExp)
forall a b. (a -> b) -> a -> b
$ Name -> PrM DType
lookupVarE Name
name
promoteExp (DConE Name
name) = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
return (DConT $ defunctionalizedName0 opts name, ADConE name)
promoteExp (DLitE Lit
lit) = (DType -> (DType, ADExp)) -> PrM DType -> PrM (DType, ADExp)
forall a b. (a -> b) -> PrM a -> PrM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Lit -> ADExp
ADLitE Lit
lit) (PrM DType -> PrM (DType, ADExp))
-> PrM DType -> PrM (DType, ADExp)
forall a b. (a -> b) -> a -> b
$ Lit -> PrM DType
forall (q :: * -> *). OptionsMonad q => Lit -> q DType
promoteLitExp Lit
lit
promoteExp (DAppE DExp
exp1 DExp
exp2) = do
(exp1', ann_exp1) <- DExp -> PrM (DType, ADExp)
promoteExp DExp
exp1
(exp2', ann_exp2) <- promoteExp exp2
return (apply exp1' exp2', ADAppE ann_exp1 ann_exp2)
promoteExp (DAppTypeE DExp
exp DType
_) = do
String -> PrM ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning String
"Visible type applications are ignored by `singletons-th`."
DExp -> PrM (DType, ADExp)
promoteExp DExp
exp
promoteExp (DLamE [Name]
names DExp
exp) = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
lambdaName <- newUniqueName "Lambda"
tyNames <- mapM mkTyName names
let var_proms = [Name] -> [Name] -> VarPromotions
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [Name]
tyNames
(rhs, ann_exp) <- lambdaBind var_proms $ promoteExp exp
all_locals <- allLocals
let tvbs = (Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` BndrVis
BndrReq) [Name]
tyNames
all_args = [Name]
all_locals [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
tyNames
all_tvbs = (Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` BndrVis
BndrReq) [Name]
all_args
tfh = Name
-> [Name] -> [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
dTypeFamilyHead_with_locals Name
lambdaName [Name]
all_locals [DTyVarBndrVis]
tvbs DFamilyResultSig
DNoSig
emitDecs [DClosedTypeFamilyD
tfh
[DTySynEqn Nothing
(foldType (DConT lambdaName) (map DVarT all_args))
rhs]]
emitDecsM $ defunctionalize lambdaName Nothing $ DefunNoSAK all_tvbs Nothing
let promLambda = DType -> DCxt -> DType
foldApply (Name -> DType
DConT (Options -> Name -> Int -> Name
defunctionalizedName Options
opts Name
lambdaName Int
0))
((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
all_locals)
return (promLambda, ADLamE tyNames promLambda names ann_exp)
promoteExp (DCaseE DExp
exp [DMatch]
matches) = do
caseTFName <- String -> PrM Name
forall (m :: * -> *). Quasi m => String -> m Name
newUniqueName String
"Case"
all_locals <- allLocals
let prom_case = DType -> DCxt -> DType
foldType (Name -> DType
DConT Name
caseTFName) ((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
all_locals)
(exp', ann_exp) <- promoteExp exp
(eqns, ann_matches) <- mapAndUnzipM (promoteMatch prom_case) matches
tyvarName <- qNewName "t"
let tvbs = [Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
tyvarName BndrVis
BndrReq]
tfh = Name
-> [Name] -> [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
dTypeFamilyHead_with_locals Name
caseTFName [Name]
all_locals [DTyVarBndrVis]
tvbs DFamilyResultSig
DNoSig
emitDecs [DClosedTypeFamilyD tfh eqns]
let applied_case = DType
prom_case DType -> DType -> DType
`DAppT` DType
exp'
return ( applied_case
, ADCaseE ann_exp ann_matches applied_case )
promoteExp (DLetE [DLetDec]
decs DExp
exp) = do
unique <- PrM Uniq
forall (q :: * -> *). DsMonad q => q Uniq
qNewUnique
(binds, ann_env) <- promoteLetDecs (Just unique) decs
(exp', ann_exp) <- letBind binds $ promoteExp exp
return (exp', ADLetE ann_env ann_exp)
promoteExp (DSigE DExp
exp DType
ty) = do
(exp', ann_exp) <- DExp -> PrM (DType, ADExp)
promoteExp DExp
exp
ty' <- promoteType ty
return (DSigT exp' ty', ADSigE exp' ann_exp ty')
promoteExp e :: DExp
e@(DStaticE DExp
_) = String -> PrM (DType, ADExp)
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Static expressions cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DExp -> String
forall a. Show a => a -> String
show DExp
e)
promoteExp e :: DExp
e@(DTypedBracketE DExp
_) = String -> PrM (DType, ADExp)
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Typed bracket expressions cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DExp -> String
forall a. Show a => a -> String
show DExp
e)
promoteExp e :: DExp
e@(DTypedSpliceE DExp
_) = String -> PrM (DType, ADExp)
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Typed splice expressions cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DExp -> String
forall a. Show a => a -> String
show DExp
e)
promoteExp e :: DExp
e@(DTypeE DType
_) = String -> PrM (DType, ADExp)
forall a. String -> PrM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Embedded type expressions cannot be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DExp -> String
forall a. Show a => a -> String
show DExp
e)
promoteLitExp :: OptionsMonad q => Lit -> q DType
promoteLitExp :: forall (q :: * -> *). OptionsMonad q => Lit -> q DType
promoteLitExp (IntegerL Uniq
n) = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let tyFromIntegerName = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
fromIntegerName Maybe Uniq
forall a. Maybe a
Nothing
tyNegateName = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
negateName Maybe Uniq
forall a. Maybe a
Nothing
if n >= 0
then return $ (DConT tyFromIntegerName `DAppT` DLitT (NumTyLit n))
else return $ (DConT tyNegateName `DAppT`
(DConT tyFromIntegerName `DAppT` DLitT (NumTyLit (-n))))
promoteLitExp (StringL String
str) = do
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let prom_str_lit = TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
str)
os_enabled <- qIsExtEnabled LangExt.OverloadedStrings
pure $ if os_enabled
then DConT (promotedValueName opts fromStringName Nothing) `DAppT` prom_str_lit
else prom_str_lit
promoteLitExp (CharL Char
c) = DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ TyLit -> DType
DLitT (Char -> TyLit
CharTyLit Char
c)
promoteLitExp Lit
lit =
String -> q DType
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Only string, natural number, and character literals can be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Lit -> String
forall a. Show a => a -> String
show Lit
lit)
promoteLitPat :: MonadFail m => Lit -> m DType
promoteLitPat :: forall (m :: * -> *). MonadFail m => Lit -> m DType
promoteLitPat (IntegerL Uniq
n)
| Uniq
n Uniq -> Uniq -> Bool
forall a. Ord a => a -> a -> Bool
>= Uniq
0 = DType -> m DType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> m DType) -> DType -> m DType
forall a b. (a -> b) -> a -> b
$ (TyLit -> DType
DLitT (Uniq -> TyLit
NumTyLit Uniq
n))
| Bool
otherwise =
String -> m DType
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m DType) -> String -> m DType
forall a b. (a -> b) -> a -> b
$ String
"Negative literal patterns are not allowed,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"because literal patterns are promoted to natural numbers."
promoteLitPat (StringL String
str) = DType -> m DType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> m DType) -> DType -> m DType
forall a b. (a -> b) -> a -> b
$ TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
str)
promoteLitPat (CharL Char
c) = DType -> m DType
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> m DType) -> DType -> m DType
forall a b. (a -> b) -> a -> b
$ TyLit -> DType
DLitT (Char -> TyLit
CharTyLit Char
c)
promoteLitPat Lit
lit =
String -> m DType
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Only string, natural number, and character literals can be promoted: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Lit -> String
forall a. Show a => a -> String
show Lit
lit)
promoteLetDecName ::
Maybe Uniq
-> Name
-> Maybe LetDecRHSKindInfo
-> [Name]
-> PrM DType
promoteLetDecName :: Maybe Uniq
-> Name -> Maybe LetDecRHSKindInfo -> [Name] -> PrM DType
promoteLetDecName Maybe Uniq
mb_let_uniq Name
name Maybe LetDecRHSKindInfo
m_ldrki [Name]
all_locals = do
opts <- PrM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let proName = Options -> Name -> Maybe Uniq -> Name
promotedValueName Options
opts Name
name Maybe Uniq
mb_let_uniq
type_args =
case Maybe LetDecRHSKindInfo
m_ldrki of
Just (LDRKI Maybe DType
m_sak [DTyVarBndrSpec]
tvbs DCxt
_ DType
_)
| Maybe DType -> Bool
forall a. Maybe a -> Bool
isJust Maybe DType
m_sak
-> (DTyVarBndrVis -> DTypeArg) -> [DTyVarBndrVis] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArg ([DTyVarBndrVis] -> [DTypeArg]) -> [DTyVarBndrVis] -> [DTypeArg]
forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> [DTyVarBndrVis]
tvbSpecsToBndrVis [DTyVarBndrSpec]
tvbs
Maybe LetDecRHSKindInfo
_ ->
(Name -> DTypeArg) -> [Name] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DTypeArg
DTANormal (DType -> DTypeArg) -> (Name -> DType) -> Name -> DTypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DType
DVarT) [Name]
all_locals
pure $ applyDType (DConT proName) type_args
dTypeFamilyHead_with_locals ::
Name
-> [Name]
-> [DTyVarBndrVis]
-> DFamilyResultSig
-> DTypeFamilyHead
dTypeFamilyHead_with_locals :: Name
-> [Name] -> [DTyVarBndrVis] -> DFamilyResultSig -> DTypeFamilyHead
dTypeFamilyHead_with_locals Name
tf_nm [Name]
local_nms [DTyVarBndrVis]
arg_tvbs DFamilyResultSig
res_sig =
Name
-> [DTyVarBndrVis]
-> DFamilyResultSig
-> Maybe InjectivityAnn
-> DTypeFamilyHead
DTypeFamilyHead
Name
tf_nm
((Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> BndrVis -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` BndrVis
BndrReq) [Name]
local_nms' [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrVis]
arg_tvbs')
DFamilyResultSig
res_sig'
Maybe InjectivityAnn
forall a. Maybe a
Nothing
where
local_nms' :: [Name]
local_nms' = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
noExactName [Name]
local_nms
subst1 :: Map Name DType
subst1 = [LetBind] -> Map Name DType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([LetBind] -> Map Name DType) -> [LetBind] -> Map Name DType
forall a b. (a -> b) -> a -> b
$
(Name -> Name -> LetBind) -> [Name] -> [Name] -> [LetBind]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Name
local_nm Name
local_nm' -> (Name
local_nm, Name -> DType
DVarT Name
local_nm'))
[Name]
local_nms
[Name]
local_nms'
(Map Name DType
subst2, [DTyVarBndrVis]
arg_tvbs') = Map Name DType
-> [DTyVarBndrVis] -> (Map Name DType, [DTyVarBndrVis])
forall flag.
Map Name DType
-> [DTyVarBndr flag] -> (Map Name DType, [DTyVarBndr flag])
substTvbs Map Name DType
subst1 [DTyVarBndrVis]
arg_tvbs
(Map Name DType
_subst3, DFamilyResultSig
res_sig') = Map Name DType
-> DFamilyResultSig -> (Map Name DType, DFamilyResultSig)
substFamilyResultSig Map Name DType
subst2 DFamilyResultSig
res_sig