{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Singletons.TH.Single where
import Prelude hiding ( exp )
import Language.Haskell.TH hiding ( cxt )
import Language.Haskell.TH.Syntax (NameSpace(..), Quasi(..))
import Data.Singletons.TH.Deriving.Bounded
import Data.Singletons.TH.Deriving.Enum
import Data.Singletons.TH.Deriving.Eq
import Data.Singletons.TH.Deriving.Infer
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
import Data.Singletons.TH.Promote.Defun
import Data.Singletons.TH.Promote.Monad ( promoteM )
import Data.Singletons.TH.Promote.Type
import Data.Singletons.TH.Single.Data
import Data.Singletons.TH.Single.Decide
import Data.Singletons.TH.Single.Defun
import Data.Singletons.TH.Single.Fixity
import Data.Singletons.TH.Single.Monad
import Data.Singletons.TH.Single.Type
import Data.Singletons.TH.Syntax
import Data.Singletons.TH.Util
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 Data.Map.Strict as Map
import Data.Map.Strict ( Map )
import Data.Maybe
import qualified Data.Set as Set
import Control.Monad
import Control.Monad.Trans.Class
import Data.List (unzip6, zipWith4)
import qualified GHC.LanguageExtensions.Type as LangExt
genSingletons :: OptionsMonad q => [Name] -> q [Dec]
genSingletons :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
genSingletons [Name]
names = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Options -> OptionsM q [Dec] -> q [Dec]
forall (m :: * -> *) a. Options -> OptionsM m a -> m a
withOptions Options
opts{genQuotedDecs = False} (OptionsM q [Dec] -> q [Dec]) -> OptionsM q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ do
[Name] -> OptionsM q ()
forall (q :: * -> *). Quasi q => [Name] -> q ()
checkForRep [Name]
names
[DDec]
ddecs <- (Name -> OptionsM q [DDec]) -> [Name] -> OptionsM q [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM (DInfo -> OptionsM q [DDec]
forall (q :: * -> *). OptionsMonad q => DInfo -> q [DDec]
singInfo (DInfo -> OptionsM q [DDec])
-> (Name -> OptionsM q DInfo) -> Name -> OptionsM q [DDec]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Info -> OptionsM q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (Info -> OptionsM q DInfo)
-> (Name -> OptionsM q Info) -> Name -> OptionsM q DInfo
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> OptionsM q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals) [Name]
names
[Dec] -> OptionsM q [Dec]
forall a. a -> OptionsM q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> OptionsM q [Dec]) -> [Dec] -> OptionsM q [Dec]
forall a b. (a -> b) -> a -> b
$ [DDec] -> [Dec]
decsToTH [DDec]
ddecs
singletons :: OptionsMonad q => q [Dec] -> q [Dec]
singletons :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
singletons q [Dec]
qdecs = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Options -> OptionsM q [Dec] -> q [Dec]
forall (m :: * -> *) a. Options -> OptionsM m a -> m a
withOptions Options
opts{genQuotedDecs = True} (OptionsM q [Dec] -> q [Dec]) -> OptionsM q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ OptionsM q [Dec] -> OptionsM q [Dec]
forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
singletons' (OptionsM q [Dec] -> OptionsM q [Dec])
-> OptionsM q [Dec] -> OptionsM q [Dec]
forall a b. (a -> b) -> a -> b
$ q [Dec] -> OptionsM q [Dec]
forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q [Dec]
qdecs
singletonsOnly :: OptionsMonad q => q [Dec] -> q [Dec]
singletonsOnly :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
singletonsOnly q [Dec]
qdecs = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Options -> OptionsM q [Dec] -> q [Dec]
forall (m :: * -> *) a. Options -> OptionsM m a -> m a
withOptions Options
opts{genQuotedDecs = False} (OptionsM q [Dec] -> q [Dec]) -> OptionsM q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ OptionsM q [Dec] -> OptionsM q [Dec]
forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
singletons' (OptionsM q [Dec] -> OptionsM q [Dec])
-> OptionsM q [Dec] -> OptionsM q [Dec]
forall a b. (a -> b) -> a -> b
$ q [Dec] -> OptionsM q [Dec]
forall (m :: * -> *) a. Monad m => m a -> OptionsM m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift q [Dec]
qdecs
singletons' :: OptionsMonad q => q [Dec] -> q [Dec]
singletons' :: forall (q :: * -> *). OptionsMonad q => q [Dec] -> q [Dec]
singletons' q [Dec]
qdecs = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
[Dec]
decs <- q [Dec]
qdecs
[DDec]
ddecs <- [Dec] -> DsM q [DDec] -> q [DDec]
forall (q :: * -> *) a. DsMonad q => [Dec] -> DsM q a -> q a
withLocalDeclarations [Dec]
decs (DsM q [DDec] -> q [DDec]) -> DsM q [DDec] -> q [DDec]
forall a b. (a -> b) -> a -> b
$ [Dec] -> DsM q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs
[DDec]
singDecs <- [Dec] -> [DDec] -> q [DDec]
forall (q :: * -> *). OptionsMonad q => [Dec] -> [DDec] -> q [DDec]
singTopLevelDecs [Dec]
decs [DDec]
ddecs
let origDecs :: [Dec]
origDecs | Options -> Bool
genQuotedDecs Options
opts = [Dec]
decs
| Bool
otherwise = []
[Dec] -> q [Dec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> q [Dec]) -> [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
origDecs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [DDec] -> [Dec]
decsToTH [DDec]
singDecs
singEqInstances :: OptionsMonad q => [Name] -> q [Dec]
singEqInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singEqInstances = (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]
singEqInstance
singEqInstance :: OptionsMonad q => Name -> q [Dec]
singEqInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singEqInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEqInstance String
"Eq"
singDecideInstances :: OptionsMonad q => [Name] -> q [Dec]
singDecideInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singDecideInstances = (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]
singDecideInstance
singDecideInstance :: OptionsMonad q => Name -> q [Dec]
singDecideInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singDecideInstance Name
name = do
(DataFlavor
_df, [TyVarBndrUnit]
tvbs, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD (String
"I cannot make an instance of SDecide for it.") Name
name
[DTyVarBndrUnit]
dtvbs <- (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
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 TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
let data_ty :: DType
data_ty = DType -> [DTyVarBndrUnit] -> DType
forall flag. DType -> [DTyVarBndr flag] -> DType
foldTypeTvbs (Name -> DType
DConT Name
name) [DTyVarBndrUnit]
dtvbs
[DCon]
dcons <- (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
dtvbs DType
data_ty) [Con]
cons
([DCon]
scons, [DDec]
_) <- [Dec] -> SgM [DCon] -> q ([DCon], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> SgM a -> q (a, [DDec])
singM [] (SgM [DCon] -> q ([DCon], [DDec]))
-> SgM [DCon] -> q ([DCon], [DDec])
forall a b. (a -> b) -> a -> b
$ (DCon -> SgM DCon) -> [DCon] -> SgM [DCon]
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 (Name -> DCon -> SgM DCon
singCtor Name
name) [DCon]
dcons
DDec
sDecideInstance <- Maybe DCxt -> DType -> [DCon] -> [DCon] -> q DDec
forall (q :: * -> *).
OptionsMonad q =>
Maybe DCxt -> DType -> [DCon] -> [DCon] -> q DDec
mkDecideInstance Maybe DCxt
forall a. Maybe a
Nothing DType
data_ty [DCon]
dcons [DCon]
scons
[DDec]
testInstances <- (TestInstance -> q DDec) -> [TestInstance] -> q [DDec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe DCxt -> DType -> Name -> [DCon] -> TestInstance -> q DDec
forall (q :: * -> *).
OptionsMonad q =>
Maybe DCxt -> DType -> Name -> [DCon] -> TestInstance -> q DDec
mkTestInstance Maybe DCxt
forall a. Maybe a
Nothing DType
data_ty Name
name [DCon]
dcons)
[TestInstance
TestEquality, TestInstance
TestCoercion]
[Dec] -> q [Dec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> q [Dec]) -> [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ [DDec] -> [Dec]
decsToTH (DDec
sDecideInstanceDDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[DDec]
testInstances)
singOrdInstances :: OptionsMonad q => [Name] -> q [Dec]
singOrdInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singOrdInstances = (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]
singOrdInstance
singOrdInstance :: OptionsMonad q => Name -> q [Dec]
singOrdInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singOrdInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkOrdInstance String
"Ord"
singBoundedInstances :: OptionsMonad q => [Name] -> q [Dec]
singBoundedInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singBoundedInstances = (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]
singBoundedInstance
singBoundedInstance :: OptionsMonad q => Name -> q [Dec]
singBoundedInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singBoundedInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkBoundedInstance String
"Bounded"
singEnumInstances :: OptionsMonad q => [Name] -> q [Dec]
singEnumInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singEnumInstances = (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]
singEnumInstance
singEnumInstance :: OptionsMonad q => Name -> q [Dec]
singEnumInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singEnumInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEnumInstance String
"Enum"
singShowInstance :: OptionsMonad q => Name -> q [Dec]
singShowInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
singShowInstance = DerivDesc q -> String -> Name -> q [Dec]
forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance String
"Show"
singShowInstances :: OptionsMonad q => [Name] -> q [Dec]
singShowInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singShowInstances = (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]
singShowInstance
showSingInstance :: OptionsMonad q => Name -> q [Dec]
showSingInstance :: forall (q :: * -> *). OptionsMonad q => Name -> q [Dec]
showSingInstance Name
name = do
(DataFlavor
df, [TyVarBndrUnit]
tvbs, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD (String
"I cannot make an instance of Show for it.") Name
name
[DTyVarBndrUnit]
dtvbs <- (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
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 TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
let data_ty :: DType
data_ty = DType -> [DTyVarBndrUnit] -> DType
forall flag. DType -> [DTyVarBndr flag] -> DType
foldTypeTvbs (Name -> DType
DConT Name
name) [DTyVarBndrUnit]
dtvbs
[DCon]
dcons <- (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
dtvbs DType
data_ty) [Con]
cons
let tyvars :: DCxt
tyvars = (DTyVarBndrUnit -> DType) -> [DTyVarBndrUnit] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> DType
DVarT (Name -> DType)
-> (DTyVarBndrUnit -> Name) -> DTyVarBndrUnit -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrUnit -> Name
forall flag. DTyVarBndr flag -> Name
extractTvbName) [DTyVarBndrUnit]
dtvbs
kind :: DType
kind = DType -> DCxt -> DType
foldType (Name -> DType
DConT Name
name) DCxt
tyvars
data_decl :: DataDecl
data_decl = DataFlavor -> Name -> [DTyVarBndrUnit] -> [DCon] -> DataDecl
DataDecl DataFlavor
df Name
name [DTyVarBndrUnit]
dtvbs [DCon]
dcons
deriv_show_decl :: DerivedDecl cls
deriv_show_decl = DerivedDecl { ded_mb_cxt :: Maybe DCxt
ded_mb_cxt = Maybe DCxt
forall a. Maybe a
Nothing
, ded_type :: DType
ded_type = DType
kind
, ded_type_tycon :: Name
ded_type_tycon = Name
name
, ded_decl :: DataDecl
ded_decl = DataDecl
data_decl }
([DDec]
show_insts, [DDec]
_) <- [Dec] -> SgM [DDec] -> q ([DDec], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> SgM a -> q (a, [DDec])
singM [] (SgM [DDec] -> q ([DDec], [DDec]))
-> SgM [DDec] -> q ([DDec], [DDec])
forall a b. (a -> b) -> a -> b
$ DerivedShowDecl -> SgM [DDec]
singDerivedShowDecs DerivedShowDecl
forall {cls :: * -> Constraint}. DerivedDecl cls
deriv_show_decl
[Dec] -> q [Dec]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> q [Dec]) -> [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ [DDec] -> [Dec]
decsToTH [DDec]
show_insts
showSingInstances :: OptionsMonad q => [Name] -> q [Dec]
showSingInstances :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
showSingInstances = (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]
showSingInstance
singITyConInstances :: DsMonad q => [Int] -> q [Dec]
singITyConInstances :: forall (q :: * -> *). DsMonad q => [Int] -> q [Dec]
singITyConInstances = (Int -> q Dec) -> [Int] -> q [Dec]
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 Int -> q Dec
forall (q :: * -> *). DsMonad q => Int -> q Dec
singITyConInstance
singITyConInstance :: DsMonad q => Int -> q Dec
singITyConInstance :: forall (q :: * -> *). DsMonad q => Int -> q Dec
singITyConInstance Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
= String -> q Dec
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q Dec) -> String -> q Dec
forall a b. (a -> b) -> a -> b
$ String
"Argument must be a positive number (given " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
| Bool
otherwise
= do [Name]
as <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"a")
[Name]
ks <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"k")
Name
k_last <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"k_last"
Name
f <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"f"
Name
x <- String -> q Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"x"
let k_penult :: Name
k_penult = [Name] -> Name
forall a. HasCallStack => [a] -> a
last [Name]
ks
k_fun :: DType
k_fun = [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType [] [] ((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
ks) (Name -> DType
DVarT Name
k_last)
f_ty :: DType
f_ty = Name -> DType
DVarT Name
f
a_tys :: DCxt
a_tys = (Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
as
mk_fun :: DType -> DType -> DType -> DType
mk_fun DType
arrow DType
t1 DType
t2 = DType
arrow DType -> DType -> DType
`DAppT` DType
t1 DType -> DType -> DType
`DAppT` DType
t2
matchable_apply_fun :: DType
matchable_apply_fun = DType -> DType -> DType -> DType
mk_fun DType
DArrowT (Name -> DType
DVarT Name
k_penult) (Name -> DType
DVarT Name
k_last)
unmatchable_apply_fun :: DType
unmatchable_apply_fun = DType -> DType -> DType -> DType
mk_fun (Name -> DType
DConT Name
tyFunArrowName) (Name -> DType
DVarT Name
k_penult) (Name -> DType
DVarT Name
k_last)
ctxt :: DCxt
ctxt = [ DForallTelescope -> DType -> DType
DForallT ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis ((Name -> DTyVarBndrSpec) -> [Name] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> DTyVarBndrSpec
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` Specificity
SpecifiedSpec) [Name]
as)) (DType -> DType) -> DType -> DType
forall a b. (a -> b) -> a -> b
$
DCxt -> DType -> DType
DConstrainedT ((DType -> DType) -> DCxt -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
singIName)) DCxt
a_tys)
(Name -> DType
DConT Name
singIName DType -> DType -> DType
`DAppT` DType -> DCxt -> DType
foldType DType
f_ty DCxt
a_tys)
, Name -> DType
DConT Name
equalityName
DType -> DType -> DType
`DAppT` (Name -> DType
DConT Name
applyTyConName DType -> DType -> DType
`DSigT`
DType -> DType -> DType -> DType
mk_fun DType
DArrowT DType
matchable_apply_fun DType
unmatchable_apply_fun)
DType -> DType -> DType
`DAppT` Name -> DType
DConT Name
applyTyConAux1Name
]
Dec -> q Dec
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> q Dec) -> Dec -> q Dec
forall a b. (a -> b) -> a -> b
$ DDec -> Dec
decToTH
(DDec -> Dec) -> DDec -> Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap
-> Maybe [DTyVarBndrUnit] -> DCxt -> DType -> [DDec] -> DDec
DInstanceD
Maybe Overlap
forall a. Maybe a
Nothing Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing DCxt
ctxt
(Name -> DType
DConT Name
singIName DType -> DType -> DType
`DAppT` (Name -> DType
DConT (Int -> Name
mkTyConName Int
n) DType -> DType -> DType
`DAppT` (DType
f_ty DType -> DType -> DType
`DSigT` DType
k_fun)))
[DLetDec -> DDec
DLetDec (DLetDec -> DDec) -> DLetDec -> DDec
forall a b. (a -> b) -> a -> b
$ Name -> [DClause] -> DLetDec
DFunD Name
singMethName
[[DPat] -> DExp -> DClause
DClause [] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
Int -> DType -> DExp -> DExp
wrapSingFun Int
1 DType
DWildCardT (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
[Name] -> DExp -> DExp
DLamE [Name
x] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
withSingIName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
x
DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
singMethName]]
singInstance :: OptionsMonad q => DerivDesc q -> String -> Name -> q [Dec]
singInstance :: forall (q :: * -> *).
OptionsMonad q =>
DerivDesc q -> String -> Name -> q [Dec]
singInstance DerivDesc q
mk_inst String
inst_name Name
name = do
(DataFlavor
df, [TyVarBndrUnit]
tvbs, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD (String
"I cannot make an instance of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inst_name
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for it.") Name
name
[DTyVarBndrUnit]
dtvbs <- (TyVarBndrUnit -> q DTyVarBndrUnit)
-> [TyVarBndrUnit] -> q [DTyVarBndrUnit]
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 TyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
let data_ty :: DType
data_ty = DType -> [DTyVarBndrUnit] -> DType
forall flag. DType -> [DTyVarBndr flag] -> DType
foldTypeTvbs (Name -> DType
DConT Name
name) [DTyVarBndrUnit]
dtvbs
[DCon]
dcons <- (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
dtvbs DType
data_ty) [Con]
cons
let data_decl :: DataDecl
data_decl = DataFlavor -> Name -> [DTyVarBndrUnit] -> [DCon] -> DataDecl
DataDecl DataFlavor
df Name
name [DTyVarBndrUnit]
dtvbs [DCon]
dcons
UInstDecl
raw_inst <- DerivDesc q
mk_inst Maybe DCxt
forall a. Maybe a
Nothing DType
data_ty DataDecl
data_decl
(AInstDecl
a_inst, [DDec]
decs) <- [Dec] -> PrM AInstDecl -> q (AInstDecl, [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [] (PrM AInstDecl -> q (AInstDecl, [DDec]))
-> PrM AInstDecl -> q (AInstDecl, [DDec])
forall a b. (a -> b) -> a -> b
$
OMap Name DType
-> Map Name [DTyVarBndrUnit] -> UInstDecl -> PrM AInstDecl
promoteInstanceDec OMap Name DType
forall k v. OMap k v
OMap.empty Map Name [DTyVarBndrUnit]
forall k a. Map k a
Map.empty UInstDecl
raw_inst
[DDec]
decs' <- [Dec] -> SgM [DDec] -> q [DDec]
forall (q :: * -> *).
OptionsMonad q =>
[Dec] -> SgM [DDec] -> q [DDec]
singDecsM [] (SgM [DDec] -> q [DDec]) -> SgM [DDec] -> q [DDec]
forall a b. (a -> b) -> a -> b
$ (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> SgM DDec -> SgM [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AInstDecl -> SgM DDec
singInstD AInstDecl
a_inst
[Dec] -> q [Dec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> q [Dec]) -> [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ [DDec] -> [Dec]
decsToTH ([DDec]
decs [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
decs')
singInfo :: OptionsMonad q => DInfo -> q [DDec]
singInfo :: forall (q :: * -> *). OptionsMonad q => DInfo -> q [DDec]
singInfo (DTyConI DDec
dec Maybe [DDec]
_) =
[Dec] -> [DDec] -> q [DDec]
forall (q :: * -> *). OptionsMonad q => [Dec] -> [DDec] -> q [DDec]
singTopLevelDecs [] [DDec
dec]
singInfo (DPrimTyConI Name
_name Int
_numArgs Bool
_unlifted) =
String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Singling of primitive type constructors not supported"
singInfo (DVarI Name
_name DType
_ty Maybe Name
_mdec) =
String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Singling of value info not supported"
singInfo (DTyVarI Name
_name DType
_ty) =
String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Singling of type variable info not supported"
singInfo (DPatSynI {}) =
String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Singling of pattern synonym info not supported"
singTopLevelDecs :: OptionsMonad q => [Dec] -> [DDec] -> q [DDec]
singTopLevelDecs :: forall (q :: * -> *). OptionsMonad q => [Dec] -> [DDec] -> q [DDec]
singTopLevelDecs [Dec]
locals [DDec]
raw_decls = [Dec] -> DsM q [DDec] -> q [DDec]
forall (q :: * -> *) a. DsMonad q => [Dec] -> DsM q a -> q a
withLocalDeclarations [Dec]
locals (DsM q [DDec] -> q [DDec]) -> DsM q [DDec] -> q [DDec]
forall a b. (a -> b) -> a -> b
$ do
[DDec]
decls <- [DDec] -> DsM q [DDec]
forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expand [DDec]
raw_decls
PDecs { pd_let_decs :: PartitionedDecs -> [DLetDec]
pd_let_decs = [DLetDec]
letDecls
, pd_class_decs :: PartitionedDecs -> [UClassDecl]
pd_class_decs = [UClassDecl]
classes
, pd_instance_decs :: PartitionedDecs -> [UInstDecl]
pd_instance_decs = [UInstDecl]
insts
, pd_data_decs :: PartitionedDecs -> [DataDecl]
pd_data_decs = [DataDecl]
datas
, pd_ty_syn_decs :: PartitionedDecs -> [TySynDecl]
pd_ty_syn_decs = [TySynDecl]
ty_syns
, pd_open_type_family_decs :: PartitionedDecs -> [OpenTypeFamilyDecl]
pd_open_type_family_decs = [OpenTypeFamilyDecl]
o_tyfams
, pd_closed_type_family_decs :: PartitionedDecs -> [ClosedTypeFamilyDecl]
pd_closed_type_family_decs = [ClosedTypeFamilyDecl]
c_tyfams
, pd_derived_eq_decs :: PartitionedDecs -> [DerivedEqDecl]
pd_derived_eq_decs = [DerivedEqDecl]
derivedEqDecs
, pd_derived_show_decs :: PartitionedDecs -> [DerivedShowDecl]
pd_derived_show_decs = [DerivedShowDecl]
derivedShowDecs } <- [DDec] -> DsM q PartitionedDecs
forall (m :: * -> *). OptionsMonad m => [DDec] -> m PartitionedDecs
partitionDecs [DDec]
decls
((ALetDecEnv
letDecEnv, [AClassDecl]
classes', [AInstDecl]
insts'), [DDec]
promDecls) <- [Dec]
-> PrM (ALetDecEnv, [AClassDecl], [AInstDecl])
-> DsM q ((ALetDecEnv, [AClassDecl], [AInstDecl]), [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [Dec]
locals (PrM (ALetDecEnv, [AClassDecl], [AInstDecl])
-> DsM q ((ALetDecEnv, [AClassDecl], [AInstDecl]), [DDec]))
-> PrM (ALetDecEnv, [AClassDecl], [AInstDecl])
-> DsM q ((ALetDecEnv, [AClassDecl], [AInstDecl]), [DDec])
forall a b. (a -> b) -> a -> b
$ do
[TySynDecl]
-> [ClosedTypeFamilyDecl] -> [OpenTypeFamilyDecl] -> PrM ()
defunTopLevelTypeDecls [TySynDecl]
ty_syns [ClosedTypeFamilyDecl]
c_tyfams [OpenTypeFamilyDecl]
o_tyfams
[DLetDec]
recSelLetDecls <- [DataDecl] -> PrM [DLetDec]
promoteDataDecs [DataDecl]
datas
([LetBind]
_, ALetDecEnv
letDecEnv) <- Maybe Integer -> [DLetDec] -> PrM ([LetBind], ALetDecEnv)
promoteLetDecs Maybe Integer
forall a. Maybe a
Nothing ([DLetDec] -> PrM ([LetBind], ALetDecEnv))
-> [DLetDec] -> PrM ([LetBind], ALetDecEnv)
forall a b. (a -> b) -> a -> b
$ [DLetDec]
recSelLetDecls [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. [a] -> [a] -> [a]
++ [DLetDec]
letDecls
[AClassDecl]
classes' <- (UClassDecl -> PrM AClassDecl) -> [UClassDecl] -> PrM [AClassDecl]
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 UClassDecl -> PrM AClassDecl
promoteClassDec [UClassDecl]
classes
let meth_sigs :: OMap Name DType
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 :: Map Name [DTyVarBndrUnit]
cls_tvbs_map = [(Name, [DTyVarBndrUnit])] -> Map Name [DTyVarBndrUnit]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, [DTyVarBndrUnit])] -> Map Name [DTyVarBndrUnit])
-> [(Name, [DTyVarBndrUnit])] -> Map Name [DTyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (UClassDecl -> (Name, [DTyVarBndrUnit]))
-> [UClassDecl] -> [(Name, [DTyVarBndrUnit])]
forall a b. (a -> b) -> [a] -> [b]
map (\UClassDecl
cd -> (UClassDecl -> Name
forall (ann :: AnnotationFlag). ClassDecl ann -> Name
cd_name UClassDecl
cd, UClassDecl -> [DTyVarBndrUnit]
forall (ann :: AnnotationFlag). ClassDecl ann -> [DTyVarBndrUnit]
cd_tvbs UClassDecl
cd)) [UClassDecl]
classes
[AInstDecl]
insts' <- (UInstDecl -> PrM AInstDecl) -> [UInstDecl] -> PrM [AInstDecl]
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 (OMap Name DType
-> Map Name [DTyVarBndrUnit] -> UInstDecl -> PrM AInstDecl
promoteInstanceDec OMap Name DType
meth_sigs Map Name [DTyVarBndrUnit]
cls_tvbs_map) [UInstDecl]
insts
(ALetDecEnv, [AClassDecl], [AInstDecl])
-> PrM (ALetDecEnv, [AClassDecl], [AInstDecl])
forall a. a -> PrM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ALetDecEnv
letDecEnv, [AClassDecl]
classes', [AInstDecl]
insts')
[Dec] -> SgM [DDec] -> DsM q [DDec]
forall (q :: * -> *).
OptionsMonad q =>
[Dec] -> SgM [DDec] -> q [DDec]
singDecsM [Dec]
locals (SgM [DDec] -> DsM q [DDec]) -> SgM [DDec] -> DsM q [DDec]
forall a b. (a -> b) -> a -> b
$ do
[(Name, DExp)]
dataLetBinds <- (DataDecl -> SgM [(Name, DExp)])
-> [DataDecl] -> SgM [(Name, DExp)]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DataDecl -> SgM [(Name, DExp)]
forall (q :: * -> *).
OptionsMonad q =>
DataDecl -> q [(Name, DExp)]
buildDataLets [DataDecl]
datas
[(Name, DExp)]
methLetBinds <- (UClassDecl -> SgM [(Name, DExp)])
-> [UClassDecl] -> SgM [(Name, DExp)]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM UClassDecl -> SgM [(Name, DExp)]
forall (q :: * -> *).
OptionsMonad q =>
UClassDecl -> q [(Name, DExp)]
buildMethLets [UClassDecl]
classes
let letBinds :: [(Name, DExp)]
letBinds = [(Name, DExp)]
dataLetBinds [(Name, DExp)] -> [(Name, DExp)] -> [(Name, DExp)]
forall a. [a] -> [a] -> [a]
++ [(Name, DExp)]
methLetBinds
([DLetDec]
newLetDecls, [DDec]
singIDefunDecls, [DDec]
newDecls)
<- [(Name, DExp)]
-> SgM ([DLetDec], [DDec], [DDec])
-> SgM ([DLetDec], [DDec], [DDec])
forall a. [(Name, DExp)] -> SgM a -> SgM a
bindLets [(Name, DExp)]
letBinds (SgM ([DLetDec], [DDec], [DDec])
-> SgM ([DLetDec], [DDec], [DDec]))
-> SgM ([DLetDec], [DDec], [DDec])
-> SgM ([DLetDec], [DDec], [DDec])
forall a b. (a -> b) -> a -> b
$
ALetDecEnv -> SgM [DDec] -> SgM ([DLetDec], [DDec], [DDec])
forall a. ALetDecEnv -> SgM a -> SgM ([DLetDec], [DDec], a)
singLetDecEnv ALetDecEnv
letDecEnv (SgM [DDec] -> SgM ([DLetDec], [DDec], [DDec]))
-> SgM [DDec] -> SgM ([DLetDec], [DDec], [DDec])
forall a b. (a -> b) -> a -> b
$ do
[DDec]
newDataDecls <- (DataDecl -> SgM [DDec]) -> [DataDecl] -> SgM [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DataDecl -> SgM [DDec]
singDataD [DataDecl]
datas
[DDec]
newClassDecls <- (AClassDecl -> SgM DDec) -> [AClassDecl] -> SgM [DDec]
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 AClassDecl -> SgM DDec
singClassD [AClassDecl]
classes'
[DDec]
newInstDecls <- (AInstDecl -> SgM DDec) -> [AInstDecl] -> SgM [DDec]
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 AInstDecl -> SgM DDec
singInstD [AInstDecl]
insts'
[DDec]
newDerivedEqDecs <- (DerivedEqDecl -> SgM [DDec]) -> [DerivedEqDecl] -> SgM [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DerivedEqDecl -> SgM [DDec]
singDerivedEqDecs [DerivedEqDecl]
derivedEqDecs
[DDec]
newDerivedShowDecs <- (DerivedShowDecl -> SgM [DDec]) -> [DerivedShowDecl] -> SgM [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DerivedShowDecl -> SgM [DDec]
singDerivedShowDecs [DerivedShowDecl]
derivedShowDecs
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DDec] -> SgM [DDec]) -> [DDec] -> SgM [DDec]
forall a b. (a -> b) -> a -> b
$ [DDec]
newDataDecls [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
newClassDecls
[DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
newInstDecls
[DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
newDerivedEqDecs
[DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
newDerivedShowDecs
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DDec] -> SgM [DDec]) -> [DDec] -> SgM [DDec]
forall a b. (a -> b) -> a -> b
$ [DDec]
promDecls [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ ((DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec [DLetDec]
newLetDecls) [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
singIDefunDecls [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
newDecls
buildDataLets :: OptionsMonad q => DataDecl -> q [(Name, DExp)]
buildDataLets :: forall (q :: * -> *).
OptionsMonad q =>
DataDecl -> q [(Name, DExp)]
buildDataLets (DataDecl DataFlavor
_df Name
_name [DTyVarBndrUnit]
_tvbs [DCon]
cons) = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
[(Name, DExp)] -> q [(Name, DExp)]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, DExp)] -> q [(Name, DExp)])
-> [(Name, DExp)] -> q [(Name, DExp)]
forall a b. (a -> b) -> a -> b
$ (DCon -> [(Name, DExp)]) -> [DCon] -> [(Name, DExp)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Options -> DCon -> [(Name, DExp)]
con_num_args Options
opts) [DCon]
cons
where
con_num_args :: Options -> DCon -> [(Name, DExp)]
con_num_args :: Options -> DCon -> [(Name, DExp)]
con_num_args Options
opts (DCon [DTyVarBndrSpec]
_tvbs DCxt
_cxt Name
name DConFields
fields DType
_rty) =
(Name
name, Int -> DType -> DExp -> DExp
wrapSingFun (DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (DConFields -> DCxt
tysOfConFields DConFields
fields))
(Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
name)
(Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
singledDataConName Options
opts Name
name))
(Name, DExp) -> [(Name, DExp)] -> [(Name, DExp)]
forall a. a -> [a] -> [a]
: Options -> DConFields -> [(Name, DExp)]
rec_selectors Options
opts DConFields
fields
rec_selectors :: Options -> DConFields -> [(Name, DExp)]
rec_selectors :: Options -> DConFields -> [(Name, DExp)]
rec_selectors Options
_ (DNormalC {}) = []
rec_selectors Options
opts (DRecC [DVarBangType]
fields) =
let names :: [Name]
names = (DVarBangType -> Name) -> [DVarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DVarBangType -> Name
forall a b c. (a, b, c) -> a
fstOf3 [DVarBangType]
fields in
[ (Name
name, Int -> DType -> DExp -> DExp
wrapSingFun Int
1 (Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
name)
(Name -> DExp
DVarE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
singledValueName Options
opts Name
name))
| Name
name <- [Name]
names ]
buildMethLets :: OptionsMonad q => UClassDecl -> q [(Name, DExp)]
buildMethLets :: forall (q :: * -> *).
OptionsMonad q =>
UClassDecl -> q [(Name, DExp)]
buildMethLets (ClassDecl { cd_lde :: forall (ann :: AnnotationFlag). ClassDecl ann -> LetDecEnv ann
cd_lde = LetDecEnv { lde_types :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name DType
lde_types = OMap Name DType
meth_sigs } }) = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
[(Name, DExp)] -> q [(Name, DExp)]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, DExp)] -> q [(Name, DExp)])
-> [(Name, DExp)] -> q [(Name, DExp)]
forall a b. (a -> b) -> a -> b
$ (LetBind -> (Name, DExp)) -> [LetBind] -> [(Name, DExp)]
forall a b. (a -> b) -> [a] -> [b]
map (Options -> LetBind -> (Name, DExp)
mk_bind Options
opts) (OMap Name DType -> [LetBind]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name DType
meth_sigs)
where
mk_bind :: Options -> LetBind -> (Name, DExp)
mk_bind Options
opts (Name
meth_name, DType
meth_ty) =
( Name
meth_name
, Int -> DType -> DExp -> DExp
wrapSingFun (DType -> Int
countArgs DType
meth_ty) (Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
meth_name)
(Name -> DExp
DVarE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
singledValueName Options
opts Name
meth_name) )
singClassD :: AClassDecl -> SgM DDec
singClassD :: AClassDecl -> SgM DDec
singClassD (ClassDecl { cd_cxt :: forall (ann :: AnnotationFlag). ClassDecl ann -> DCxt
cd_cxt = DCxt
cls_cxt
, cd_name :: forall (ann :: AnnotationFlag). ClassDecl ann -> Name
cd_name = Name
cls_name
, cd_tvbs :: forall (ann :: AnnotationFlag). ClassDecl ann -> [DTyVarBndrUnit]
cd_tvbs = [DTyVarBndrUnit]
cls_tvbs
, cd_fds :: forall (ann :: AnnotationFlag). ClassDecl ann -> [FunDep]
cd_fds = [FunDep]
cls_fundeps
, cd_lde :: forall (ann :: AnnotationFlag). ClassDecl ann -> LetDecEnv ann
cd_lde = LetDecEnv { lde_defns :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> OMap Name (LetDecRHS ann)
lde_defns = OMap Name (LetDecRHS Annotated)
default_defns
, 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
fixities
, lde_proms :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> IfAnn ann (OMap Name DType) ()
lde_proms = IfAnn Annotated (OMap Name DType) ()
promoted_defaults } }) =
DCxt -> SgM DDec -> SgM DDec
forall a. DCxt -> SgM a -> SgM a
bindContext [DType -> [DTyVarBndrUnit] -> DType
forall flag. DType -> [DTyVarBndr flag] -> DType
foldTypeTvbs (Name -> DType
DConT Name
cls_name) [DTyVarBndrUnit]
cls_tvbs] (SgM DDec -> SgM DDec) -> SgM DDec -> SgM DDec
forall a b. (a -> b) -> a -> b
$ do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Maybe DType
mb_cls_sak <- Name -> SgM (Maybe DType)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DType)
dsReifyType Name
cls_name
let sing_cls_name :: Name
sing_cls_name = Options -> Name -> Name
singledClassName Options
opts Name
cls_name
mb_sing_cls_sak :: Maybe DDec
mb_sing_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
sing_cls_name) Maybe DType
mb_cls_sak
[DDec]
cls_infix_decls <- [Name] -> SgM [DDec]
forall (q :: * -> *). OptionsMonad q => [Name] -> q [DDec]
singReifiedInfixDecls ([Name] -> SgM [DDec]) -> [Name] -> SgM [DDec]
forall a b. (a -> b) -> a -> b
$ Name
cls_nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
meth_names
([DLetDec]
sing_sigs, [(Name, DExp)]
_, [[Name]]
tyvar_names, [(Name, DCxt)]
cxts, [Maybe DType]
res_kis, [[DDec]]
singIDefunss)
<- [(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> ([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]])
forall a b c d e f.
[(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])
unzip6 ([(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> ([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]]))
-> SgM
[(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> SgM
([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> DType
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec]))
-> [Name]
-> DCxt
-> SgM
[(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (OMap Name (LetDecRHS Annotated)
-> OMap Name DType
-> Name
-> DType
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
singTySig OMap Name (LetDecRHS Annotated)
forall {a}. a
no_meth_defns OMap Name DType
meth_sigs)
[Name]
meth_names
((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> DType
DConT (Name -> DType) -> (Name -> Name) -> Name -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name -> Name
defunctionalizedName0 Options
opts) [Name]
meth_names)
[DDec] -> SgM ()
forall (m :: * -> *). MonadWriter [DDec] m => [DDec] -> m ()
emitDecs ([DDec] -> SgM ()) -> [DDec] -> SgM ()
forall a b. (a -> b) -> a -> b
$ Maybe DDec -> [DDec]
forall a. Maybe a -> [a]
maybeToList Maybe DDec
mb_sing_cls_sak [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
cls_infix_decls [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [[DDec]] -> [DDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DDec]]
singIDefunss
let default_sigs :: [DDec]
default_sigs = [Maybe DDec] -> [DDec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DDec] -> [DDec]) -> [Maybe DDec] -> [DDec]
forall a b. (a -> b) -> a -> b
$
(Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec)
-> [Name] -> [DLetDec] -> [[Name]] -> [Maybe DType] -> [Maybe DDec]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 (Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec
mk_default_sig Options
opts) [Name]
meth_names [DLetDec]
sing_sigs
[[Name]]
tyvar_names [Maybe DType]
res_kis
[DLetDec]
sing_meths <- ((Name, LetDecRHS Annotated) -> SgM DLetDec)
-> [(Name, LetDecRHS Annotated)] -> SgM [DLetDec]
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 ((Name -> LetDecRHS Annotated -> SgM DLetDec)
-> (Name, LetDecRHS Annotated) -> SgM DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Map Name DCxt -> Name -> LetDecRHS Annotated -> SgM DLetDec
singLetDecRHS ([(Name, DCxt)] -> Map Name DCxt
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, DCxt)]
cxts)))
(OMap Name (LetDecRHS Annotated) -> [(Name, LetDecRHS Annotated)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name (LetDecRHS Annotated)
default_defns)
[DLetDec]
fixities' <- ((Name, Fixity) -> SgM (Maybe DLetDec))
-> [(Name, Fixity)] -> SgM [DLetDec]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((Name -> Fixity -> SgM (Maybe DLetDec))
-> (Name, Fixity) -> SgM (Maybe DLetDec)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Fixity -> SgM (Maybe DLetDec)
forall (q :: * -> *).
OptionsMonad q =>
Name -> Fixity -> q (Maybe DLetDec)
singInfixDecl) ([(Name, Fixity)] -> SgM [DLetDec])
-> [(Name, Fixity)] -> SgM [DLetDec]
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
fixities
DCxt
cls_cxt' <- (DType -> SgM DType) -> DCxt -> SgM DCxt
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 DType -> SgM DType
singPred DCxt
cls_cxt
DDec -> SgM DDec
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DDec -> SgM DDec) -> DDec -> SgM DDec
forall a b. (a -> b) -> a -> b
$ DCxt -> Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec
DClassD DCxt
cls_cxt'
Name
sing_cls_name
[DTyVarBndrUnit]
cls_tvbs
[FunDep]
cls_fundeps
((DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec ([DLetDec]
sing_sigs [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. [a] -> [a] -> [a]
++ [DLetDec]
sing_meths [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. [a] -> [a] -> [a]
++ [DLetDec]
fixities') [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
default_sigs)
where
no_meth_defns :: a
no_meth_defns = String -> a
forall a. HasCallStack => String -> a
error String
"Internal error: can't find declared method type"
meth_names :: [Name]
meth_names = (LetBind -> Name) -> [LetBind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LetBind -> Name
forall a b. (a, b) -> a
fst ([LetBind] -> [Name]) -> [LetBind] -> [Name]
forall a b. (a -> b) -> a -> b
$ OMap Name DType -> [LetBind]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name DType
meth_sigs
mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec
mk_default_sig :: Options -> Name -> DLetDec -> [Name] -> Maybe DType -> Maybe DDec
mk_default_sig Options
opts Name
meth_name (DSigD Name
s_name DType
sty) [Name]
bound_kvs (Just DType
res_ki) =
Name -> DType -> DDec
DDefaultSigD Name
s_name (DType -> DDec) -> Maybe DType -> Maybe DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Name -> DType -> [Name] -> DType -> Maybe DType
add_constraints Options
opts Name
meth_name DType
sty [Name]
bound_kvs DType
res_ki
mk_default_sig Options
_ Name
_ DLetDec
_ [Name]
_ Maybe DType
_ = String -> Maybe DDec
forall a. HasCallStack => String -> a
error String
"Internal error: a singled signature isn't a signature."
add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType
add_constraints :: Options -> Name -> DType -> [Name] -> DType -> Maybe DType
add_constraints Options
opts Name
meth_name (DSigT DType
sty DType
ski) [Name]
bound_kvs DType
res_ki = do
DType
sty' <- Options -> Name -> DType -> [Name] -> DType -> Maybe DType
add_constraints Options
opts Name
meth_name DType
sty [Name]
bound_kvs DType
res_ki
DType -> Maybe DType
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> Maybe DType) -> DType -> Maybe DType
forall a b. (a -> b) -> a -> b
$ DType -> DType -> DType
DSigT DType
sty' DType
ski
add_constraints Options
opts Name
meth_name DType
sty [Name]
bound_kvs DType
res_ki = do
([DTyVarBndrSpec]
tvbs, DCxt
cxt, DCxt
args, DType
res) <- DType -> Maybe ([DTyVarBndrSpec], DCxt, DCxt, DType)
forall (m :: * -> *).
MonadFail m =>
DType -> m ([DTyVarBndrSpec], DCxt, DCxt, DType)
unravelVanillaDType DType
sty
DType
prom_dflt <- 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
IfAnn Annotated (OMap Name DType) ()
promoted_defaults
let tvs :: DCxt
tvs = (DTyVarBndrSpec -> DType) -> [DTyVarBndrSpec] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> DType
forall flag. DTyVarBndr flag -> DType
tvbToType ([DTyVarBndrSpec] -> DCxt) -> [DTyVarBndrSpec] -> DCxt
forall a b. (a -> b) -> a -> b
$
(DTyVarBndrSpec -> Bool) -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DTyVarBndrSpec
tvb -> DTyVarBndrSpec -> Name
forall flag. DTyVarBndr flag -> Name
extractTvbName DTyVarBndrSpec
tvb Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
bound_kv_set) [DTyVarBndrSpec]
tvbs
prom_meth :: DType
prom_meth = Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
meth_name
default_pred :: DType
default_pred = DType -> DCxt -> DType
foldType (Name -> DType
DConT Name
equalityName)
[ DType -> DCxt -> DType
foldApply DType
prom_meth DCxt
tvs DType -> DType -> DType
`DSigT` DType
res_ki
, DType -> DCxt -> DType
foldApply DType
prom_dflt DCxt
tvs ]
DType -> Maybe DType
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> Maybe DType) -> DType -> Maybe DType
forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType [DTyVarBndrSpec]
tvbs (DType
default_pred DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
: DCxt
cxt) DCxt
args DType
res
where
bound_kv_set :: Set Name
bound_kv_set = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
bound_kvs
singInstD :: AInstDecl -> SgM DDec
singInstD :: AInstDecl -> SgM DDec
singInstD (InstDecl { id_cxt :: forall (ann :: AnnotationFlag). InstDecl ann -> DCxt
id_cxt = DCxt
cxt, id_name :: forall (ann :: AnnotationFlag). InstDecl ann -> Name
id_name = Name
inst_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 Annotated)]
ann_meths }) = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let s_inst_name :: Name
s_inst_name = Options -> Name -> Name
singledClassName Options
opts Name
inst_name
DCxt -> SgM DDec -> SgM DDec
forall a. DCxt -> SgM a -> SgM a
bindContext DCxt
cxt (SgM DDec -> SgM DDec) -> SgM DDec -> SgM DDec
forall a b. (a -> b) -> a -> b
$ do
DCxt
cxt' <- (DType -> SgM DType) -> DCxt -> SgM DCxt
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 DType -> SgM DType
singPred DCxt
cxt
DCxt
inst_kis <- (DType -> SgM DType) -> DCxt -> SgM DCxt
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 DType -> SgM DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
promoteType DCxt
inst_tys
[DDec]
meths <- ((Name, LetDecRHS Annotated) -> SgM [DDec])
-> [(Name, LetDecRHS Annotated)] -> SgM [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ((Name -> LetDecRHS Annotated -> SgM [DDec])
-> (Name, LetDecRHS Annotated) -> SgM [DDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> LetDecRHS Annotated -> SgM [DDec]
sing_meth) [(Name, LetDecRHS Annotated)]
ann_meths
DDec -> SgM DDec
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Overlap
-> Maybe [DTyVarBndrUnit] -> DCxt -> DType -> [DDec] -> DDec
DInstanceD Maybe Overlap
forall a. Maybe a
Nothing
Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing
DCxt
cxt'
((DType -> DType -> DType) -> DType -> DCxt -> DType
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DType -> DType -> DType
DAppT (Name -> DType
DConT Name
s_inst_name) DCxt
inst_kis)
[DDec]
meths)
where
sing_meth :: Name -> ALetDecRHS -> SgM [DDec]
sing_meth :: Name -> LetDecRHS Annotated -> SgM [DDec]
sing_meth Name
name LetDecRHS Annotated
rhs = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Maybe DInfo
mb_s_info <- Name -> SgM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify (Options -> Name -> Name
singledValueName Options
opts Name
name)
DCxt
inst_kis <- (DType -> SgM DType) -> DCxt -> SgM DCxt
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 DType -> SgM DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
promoteType DCxt
inst_tys
let mk_subst :: [DTyVarBndr flag] -> Map Name DType
mk_subst [DTyVarBndr flag]
cls_tvbs = [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 ((DTyVarBndr flag -> Name) -> [DTyVarBndr flag] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr flag -> Name
forall flag. DTyVarBndr flag -> Name
extractTvbName [DTyVarBndr flag]
vis_cls_tvbs) DCxt
inst_kis
where
vis_cls_tvbs :: [DTyVarBndr flag]
vis_cls_tvbs = Int -> [DTyVarBndr flag] -> [DTyVarBndr flag]
forall a. Int -> [a] -> [a]
drop ([DTyVarBndr flag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndr flag]
cls_tvbs Int -> Int -> Int
forall a. Num a => a -> a -> a
- DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
inst_kis) [DTyVarBndr flag]
cls_tvbs
sing_meth_ty :: DType -> SgM DType
sing_meth_ty :: DType -> SgM DType
sing_meth_ty DType
inner_ty = do
DType
raw_ty <- DType -> SgM DType
forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expand DType
inner_ty
(DType
s_ty, Int
_num_args, [Name]
_tyvar_names, DCxt
_ctxt, DCxt
_arg_kis, DType
_res_ki)
<- DType -> DType -> SgM (DType, Int, [Name], DCxt, DCxt, DType)
singType (Name -> DType
DConT (Name -> DType) -> Name -> DType
forall a b. (a -> b) -> a -> b
$ Options -> Name -> Name
defunctionalizedName0 Options
opts Name
name) DType
raw_ty
DType -> SgM DType
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
s_ty
DType
s_ty <- case Name -> OMap Name DType -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name DType
inst_sigs of
Just DType
inst_sig ->
DType -> SgM DType
sing_meth_ty DType
inst_sig
Maybe DType
Nothing -> case Maybe DInfo
mb_s_info of
Just (DVarI Name
_ (DForallT (DForallInvis [DTyVarBndrSpec]
cls_tvbs) (DConstrainedT DCxt
_cls_pred DType
s_ty)) Maybe Name
_) ->
DType -> SgM DType
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> SgM DType) -> DType -> SgM DType
forall a b. (a -> b) -> a -> b
$ Map Name DType -> DType -> DType
substType ([DTyVarBndrSpec] -> Map Name DType
forall {flag}. [DTyVarBndr flag] -> Map Name DType
mk_subst [DTyVarBndrSpec]
cls_tvbs) DType
s_ty
Maybe DInfo
_ -> do
Maybe DInfo
mb_info <- Name -> SgM (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
name
case Maybe DInfo
mb_info of
Just (DVarI Name
_ (DForallT (DForallInvis [DTyVarBndrSpec]
cls_tvbs)
(DConstrainedT DCxt
_cls_pred DType
inner_ty)) Maybe Name
_) -> do
DType
s_ty <- DType -> SgM DType
sing_meth_ty DType
inner_ty
DType -> SgM DType
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> SgM DType) -> DType -> SgM DType
forall a b. (a -> b) -> a -> b
$ Map Name DType -> DType -> DType
substType ([DTyVarBndrSpec] -> Map Name DType
forall {flag}. [DTyVarBndr flag] -> Map Name DType
mk_subst [DTyVarBndrSpec]
cls_tvbs) DType
s_ty
Maybe DInfo
_ -> String -> SgM DType
forall a. String -> SgM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> SgM DType) -> String -> SgM DType
forall a b. (a -> b) -> a -> b
$ String
"Cannot find type of method " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
DLetDec
meth' <- Map Name DCxt -> Name -> LetDecRHS Annotated -> SgM DLetDec
singLetDecRHS
Map Name DCxt
forall k a. Map k a
Map.empty
Name
name LetDecRHS Annotated
rhs
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DDec] -> SgM [DDec]) -> [DDec] -> SgM [DDec]
forall a b. (a -> b) -> a -> b
$ (DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec [Name -> DType -> DLetDec
DSigD (Options -> Name -> Name
singledValueName Options
opts Name
name) DType
s_ty, DLetDec
meth']
singLetDecEnv :: ALetDecEnv
-> SgM a
-> SgM ([DLetDec], [DDec], a)
singLetDecEnv :: forall a. ALetDecEnv -> SgM a -> SgM ([DLetDec], [DDec], a)
singLetDecEnv (LetDecEnv { lde_defns :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> OMap Name (LetDecRHS ann)
lde_defns = OMap Name (LetDecRHS Annotated)
defns
, lde_types :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name DType
lde_types = OMap Name DType
types
, lde_infix :: forall (ann :: AnnotationFlag). LetDecEnv ann -> OMap Name Fixity
lde_infix = OMap Name Fixity
infix_decls
, lde_proms :: forall (ann :: AnnotationFlag).
LetDecEnv ann -> IfAnn ann (OMap Name DType) ()
lde_proms = IfAnn Annotated (OMap Name DType) ()
proms })
SgM a
thing_inside = do
let prom_list :: [LetBind]
prom_list = OMap Name DType -> [LetBind]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name DType
IfAnn Annotated (OMap Name DType) ()
proms
([DLetDec]
typeSigs, [(Name, DExp)]
letBinds, [[Name]]
_tyvarNames, [(Name, DCxt)]
cxts, [Maybe DType]
_res_kis, [[DDec]]
singIDefunss)
<- [(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> ([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]])
forall a b c d e f.
[(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])
unzip6 ([(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> ([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]]))
-> SgM
[(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
-> SgM
([DLetDec], [(Name, DExp)], [[Name]], [(Name, DCxt)],
[Maybe DType], [[DDec]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBind
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec]))
-> [LetBind]
-> SgM
[(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType,
[DDec])]
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 ((Name
-> DType
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec]))
-> LetBind
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (OMap Name (LetDecRHS Annotated)
-> OMap Name DType
-> Name
-> DType
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
singTySig OMap Name (LetDecRHS Annotated)
defns OMap Name DType
types)) [LetBind]
prom_list
[DLetDec]
infix_decls' <- ((Name, Fixity) -> SgM (Maybe DLetDec))
-> [(Name, Fixity)] -> SgM [DLetDec]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM ((Name -> Fixity -> SgM (Maybe DLetDec))
-> (Name, Fixity) -> SgM (Maybe DLetDec)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Fixity -> SgM (Maybe DLetDec)
forall (q :: * -> *).
OptionsMonad q =>
Name -> Fixity -> q (Maybe DLetDec)
singInfixDecl) ([(Name, Fixity)] -> SgM [DLetDec])
-> [(Name, Fixity)] -> SgM [DLetDec]
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
infix_decls
[(Name, DExp)]
-> SgM ([DLetDec], [DDec], a) -> SgM ([DLetDec], [DDec], a)
forall a. [(Name, DExp)] -> SgM a -> SgM a
bindLets [(Name, DExp)]
letBinds (SgM ([DLetDec], [DDec], a) -> SgM ([DLetDec], [DDec], a))
-> SgM ([DLetDec], [DDec], a) -> SgM ([DLetDec], [DDec], a)
forall a b. (a -> b) -> a -> b
$ do
[DLetDec]
let_decs <- ((Name, LetDecRHS Annotated) -> SgM DLetDec)
-> [(Name, LetDecRHS Annotated)] -> SgM [DLetDec]
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 ((Name -> LetDecRHS Annotated -> SgM DLetDec)
-> (Name, LetDecRHS Annotated) -> SgM DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Map Name DCxt -> Name -> LetDecRHS Annotated -> SgM DLetDec
singLetDecRHS ([(Name, DCxt)] -> Map Name DCxt
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, DCxt)]
cxts)))
(OMap Name (LetDecRHS Annotated) -> [(Name, LetDecRHS Annotated)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs OMap Name (LetDecRHS Annotated)
defns)
a
thing <- SgM a
thing_inside
([DLetDec], [DDec], a) -> SgM ([DLetDec], [DDec], a)
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec]
infix_decls' [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. [a] -> [a] -> [a]
++ [DLetDec]
typeSigs [DLetDec] -> [DLetDec] -> [DLetDec]
forall a. [a] -> [a] -> [a]
++ [DLetDec]
let_decs, [[DDec]] -> [DDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DDec]]
singIDefunss, a
thing)
singTySig :: OMap Name ALetDecRHS
-> OMap Name DType
-> Name -> DType
-> SgM ( DLetDec
, (Name, DExp)
, [Name]
, (Name, DCxt)
, Maybe DKind
, [DDec]
)
singTySig :: OMap Name (LetDecRHS Annotated)
-> OMap Name DType
-> Name
-> DType
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
singTySig OMap Name (LetDecRHS Annotated)
defns OMap Name DType
types Name
name DType
prom_ty = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let sName :: Name
sName = Options -> Name -> Name
singledValueName Options
opts Name
name
case Name -> OMap Name DType -> Maybe DType
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name DType
types of
Maybe DType
Nothing -> do
Int
num_args <- SgM Int
guess_num_args
(DType
sty, [Name]
tyvar_names) <- Int -> SgM (DType, [Name])
mk_sing_ty Int
num_args
[DDec]
singIDefuns <- Name
-> NameSpace -> DCxt -> [Maybe DType] -> Maybe DType -> SgM [DDec]
singDefuns Name
name NameSpace
VarName []
((Name -> Maybe DType) -> [Name] -> [Maybe DType]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe DType -> Name -> Maybe DType
forall a b. a -> b -> a
const Maybe DType
forall a. Maybe a
Nothing) [Name]
tyvar_names) Maybe DType
forall a. Maybe a
Nothing
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Name -> DType -> DLetDec
DSigD Name
sName DType
sty
, (Name
name, Int -> DType -> DExp -> DExp
wrapSingFun Int
num_args DType
prom_ty (Name -> DExp
DVarE Name
sName))
, [Name]
tyvar_names
, (Name
name, [])
, Maybe DType
forall a. Maybe a
Nothing
, [DDec]
singIDefuns )
Just DType
ty -> do
(DType
sty, Int
num_args, [Name]
tyvar_names, DCxt
ctxt, DCxt
arg_kis, DType
res_ki)
<- DType -> DType -> SgM (DType, Int, [Name], DCxt, DCxt, DType)
singType DType
prom_ty DType
ty
DCxt
bound_cxt <- SgM DCxt
askContext
[DDec]
singIDefuns <- Name
-> NameSpace -> DCxt -> [Maybe DType] -> Maybe DType -> SgM [DDec]
singDefuns Name
name NameSpace
VarName (DCxt
bound_cxt DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ DCxt
ctxt)
((DType -> Maybe DType) -> DCxt -> [Maybe DType]
forall a b. (a -> b) -> [a] -> [b]
map DType -> Maybe DType
forall a. a -> Maybe a
Just DCxt
arg_kis) (DType -> Maybe DType
forall a. a -> Maybe a
Just DType
res_ki)
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
-> SgM
(DLetDec, (Name, DExp), [Name], (Name, DCxt), Maybe DType, [DDec])
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Name -> DType -> DLetDec
DSigD Name
sName DType
sty
, (Name
name, Int -> DType -> DExp -> DExp
wrapSingFun Int
num_args DType
prom_ty (Name -> DExp
DVarE Name
sName))
, [Name]
tyvar_names
, (Name
name, DCxt
ctxt)
, DType -> Maybe DType
forall a. a -> Maybe a
Just DType
res_ki
, [DDec]
singIDefuns )
where
guess_num_args :: SgM Int
guess_num_args :: SgM Int
guess_num_args =
case Name
-> OMap Name (LetDecRHS Annotated) -> Maybe (LetDecRHS Annotated)
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup Name
name OMap Name (LetDecRHS Annotated)
defns of
Maybe (LetDecRHS Annotated)
Nothing -> String -> SgM Int
forall a. String -> SgM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error: promotion known for something not let-bound."
Just (AValue ADExp
_) -> Int -> SgM Int
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
Just (AFunction Int
n [ADClause]
_) -> Int -> SgM Int
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
mk_sing_ty :: Int -> SgM (DType, [Name])
mk_sing_ty :: Int -> SgM (DType, [Name])
mk_sing_ty Int
n = do
[Name]
arg_names <- Int -> SgM Name -> SgM [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (String -> SgM Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"arg")
let sing_w_wildcard :: DType
sing_w_wildcard | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DType
singFamily DType -> DType -> DType
`DAppKindT` DType
DWildCardT
| Bool
otherwise = DType
singFamily
(DType, [Name]) -> SgM (DType, [Name])
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [DTyVarBndrSpec] -> DCxt -> DCxt -> DType -> DType
ravelVanillaDType
((Name -> DTyVarBndrSpec) -> [Name] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> DTyVarBndrSpec
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` Specificity
SpecifiedSpec) [Name]
arg_names)
[]
((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map (\Name
nm -> DType
singFamily DType -> DType -> DType
`DAppT` Name -> DType
DVarT Name
nm) [Name]
arg_names)
(DType
sing_w_wildcard DType -> DType -> DType
`DAppT`
(DType -> DCxt -> DType
foldApply DType
prom_ty ((Name -> DType) -> [Name] -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DVarT [Name]
arg_names)))
, [Name]
arg_names )
singLetDecRHS :: Map Name DCxt
-> Name -> ALetDecRHS -> SgM DLetDec
singLetDecRHS :: Map Name DCxt -> Name -> LetDecRHS Annotated -> SgM DLetDec
singLetDecRHS Map Name DCxt
cxts Name
name LetDecRHS Annotated
ld_rhs = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
DCxt -> SgM DLetDec -> SgM DLetDec
forall a. DCxt -> SgM a -> SgM a
bindContext (DCxt -> Name -> Map Name DCxt -> DCxt
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Name
name Map Name DCxt
cxts) (SgM DLetDec -> SgM DLetDec) -> SgM DLetDec -> SgM DLetDec
forall a b. (a -> b) -> a -> b
$
case LetDecRHS Annotated
ld_rhs of
AValue ADExp
exp ->
DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP (Options -> Name -> Name
singledValueName Options
opts Name
name)) (DExp -> DLetDec) -> SgM DExp -> SgM DLetDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
ADExp -> SgM DExp
singExp ADExp
exp
AFunction Int
_num_arrows [ADClause]
clauses ->
Name -> [DClause] -> DLetDec
DFunD (Options -> Name -> Name
singledValueName Options
opts Name
name) ([DClause] -> DLetDec) -> SgM [DClause] -> SgM DLetDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(ADClause -> SgM DClause) -> [ADClause] -> SgM [DClause]
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 ADClause -> SgM DClause
singClause [ADClause]
clauses
singClause :: ADClause -> SgM DClause
singClause :: ADClause -> SgM DClause
singClause (ADClause VarPromotions
var_proms [ADPat]
pats ADExp
exp) = do
([DPat]
sPats, SingDSigPaInfos
sigPaExpsSigs) <- QWithAux SingDSigPaInfos SgM [DPat]
-> SgM ([DPat], SingDSigPaInfos)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair (QWithAux SingDSigPaInfos SgM [DPat]
-> SgM ([DPat], SingDSigPaInfos))
-> QWithAux SingDSigPaInfos SgM [DPat]
-> SgM ([DPat], SingDSigPaInfos)
forall a b. (a -> b) -> a -> b
$ (ADPat -> QWithAux SingDSigPaInfos SgM DPat)
-> [ADPat] -> QWithAux SingDSigPaInfos SgM [DPat]
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 (Map Name Name -> ADPat -> QWithAux SingDSigPaInfos SgM DPat
singPat (VarPromotions -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList VarPromotions
var_proms)) [ADPat]
pats
DExp
sBody <- ADExp -> SgM DExp
singExp ADExp
exp
DClause -> SgM DClause
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> SgM DClause) -> DClause -> SgM DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
sPats (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$ SingDSigPaInfos -> DExp -> DExp
mkSigPaCaseE SingDSigPaInfos
sigPaExpsSigs DExp
sBody
singPat :: Map Name Name
-> ADPat
-> QWithAux SingDSigPaInfos SgM DPat
singPat :: Map Name Name -> ADPat -> QWithAux SingDSigPaInfos SgM DPat
singPat Map Name Name
var_proms = ADPat -> QWithAux SingDSigPaInfos SgM DPat
go
where
go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat
go :: ADPat -> QWithAux SingDSigPaInfos SgM DPat
go (ADLitP Lit
_lit) =
String -> QWithAux SingDSigPaInfos SgM DPat
forall a. String -> QWithAux SingDSigPaInfos SgM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Singling of literal patterns not yet supported"
go (ADVarP Name
name) = do
Options
opts <- QWithAux SingDSigPaInfos SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Name
tyname <- case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Name
var_proms of
Maybe Name
Nothing ->
String -> QWithAux SingDSigPaInfos SgM Name
forall a. String -> QWithAux SingDSigPaInfos SgM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error: unknown variable when singling pattern"
Just Name
tyname -> Name -> QWithAux SingDSigPaInfos SgM Name
forall a. a -> QWithAux SingDSigPaInfos SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
tyname
DPat -> QWithAux SingDSigPaInfos SgM DPat
forall a. a -> QWithAux SingDSigPaInfos SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DPat -> QWithAux SingDSigPaInfos SgM DPat)
-> DPat -> QWithAux SingDSigPaInfos SgM DPat
forall a b. (a -> b) -> a -> b
$ Name -> DPat
DVarP (Options -> Name -> Name
singledValueName Options
opts Name
name)
DPat -> DType -> DPat
`DSigP` (DType
singFamily DType -> DType -> DType
`DAppT` Name -> DType
DVarT Name
tyname)
go (ADConP Name
name DCxt
tys [ADPat]
pats) = do
Options
opts <- QWithAux SingDSigPaInfos SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Name -> DCxt -> [DPat] -> DPat
DConP (Options -> Name -> Name
singledDataConName Options
opts Name
name) DCxt
tys ([DPat] -> DPat)
-> QWithAux SingDSigPaInfos SgM [DPat]
-> QWithAux SingDSigPaInfos SgM DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ADPat -> QWithAux SingDSigPaInfos SgM DPat)
-> [ADPat] -> QWithAux SingDSigPaInfos SgM [DPat]
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 ADPat -> QWithAux SingDSigPaInfos SgM DPat
go [ADPat]
pats
go (ADTildeP ADPat
pat) = do
String -> QWithAux SingDSigPaInfos SgM ()
forall (q :: * -> *). Quasi q => String -> q ()
qReportWarning
String
"Lazy pattern converted into regular pattern during singleton generation."
ADPat -> QWithAux SingDSigPaInfos SgM DPat
go ADPat
pat
go (ADBangP ADPat
pat) = DPat -> DPat
DBangP (DPat -> DPat)
-> QWithAux SingDSigPaInfos SgM DPat
-> QWithAux SingDSigPaInfos SgM DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ADPat -> QWithAux SingDSigPaInfos SgM DPat
go ADPat
pat
go (ADSigP DType
prom_pat ADPat
pat DType
ty) = do
DPat
pat' <- ADPat -> QWithAux SingDSigPaInfos SgM DPat
go ADPat
pat
(DExp, DType) -> QWithAux SingDSigPaInfos SgM ()
forall (q :: * -> *) elt. Quasi q => elt -> QWithAux [elt] q ()
addElement (DPat -> DExp
dPatToDExp DPat
pat', DType -> DType -> DType
DSigT DType
prom_pat DType
ty)
DPat -> QWithAux SingDSigPaInfos SgM DPat
forall a. a -> QWithAux SingDSigPaInfos SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPat
pat'
go ADPat
ADWildP = DPat -> QWithAux SingDSigPaInfos SgM DPat
forall a. a -> QWithAux SingDSigPaInfos SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPat
DWildP
mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp
mkSigPaCaseE :: SingDSigPaInfos -> DExp -> DExp
mkSigPaCaseE SingDSigPaInfos
exps_with_sigs DExp
exp
| SingDSigPaInfos -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null SingDSigPaInfos
exps_with_sigs = DExp
exp
| Bool
otherwise =
let ([DExp]
exps, DCxt
sigs) = SingDSigPaInfos -> ([DExp], DCxt)
forall a b. [(a, b)] -> ([a], [b])
unzip SingDSigPaInfos
exps_with_sigs
scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkTupleDExp [DExp]
exps
pats :: [DPat]
pats = (DType -> DPat) -> DCxt -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map (DPat -> DType -> DPat
DSigP DPat
DWildP (DType -> DPat) -> (DType -> DType) -> DType -> DPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DType -> DType -> DType
DAppT (Name -> DType
DConT Name
singFamilyName)) DCxt
sigs
in DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee [DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats) DExp
exp]
singExp :: ADExp -> SgM DExp
singExp :: ADExp -> SgM DExp
singExp (ADVarE Name
err `ADAppE` ADExp
arg)
| Name
err Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
errorName = do Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE (Options -> Name -> Name
singledValueName Options
opts Name
err)) (DExp -> DExp) -> SgM DExp -> SgM DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
ADExp -> SgM DExp
singExp ADExp
arg
singExp (ADVarE Name
name) = Name -> SgM DExp
lookupVarE Name
name
singExp (ADConE Name
name) = Name -> SgM DExp
lookupConE Name
name
singExp (ADLitE Lit
lit) = Lit -> SgM DExp
singLit Lit
lit
singExp (ADAppE ADExp
e1 ADExp
e2) = do
DExp
e1' <- ADExp -> SgM DExp
singExp ADExp
e1
DExp
e2' <- ADExp -> SgM DExp
singExp ADExp
e2
if DExp -> Bool
isException DExp
e1'
then DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ DExp
e1' DExp -> DExp -> DExp
`DAppE` DExp
e2'
else DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ (Name -> DExp
DVarE Name
applySingName) DExp -> DExp -> DExp
`DAppE` DExp
e1' DExp -> DExp -> DExp
`DAppE` DExp
e2'
singExp (ADLamE [Name]
ty_names DType
prom_lam [Name]
names ADExp
exp) = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let sNames :: [Name]
sNames = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Options -> Name -> Name
singledValueName Options
opts) [Name]
names
DExp
exp' <- ADExp -> SgM DExp
singExp ADExp
exp
let caseExp :: DExp
caseExp = DExp -> [DMatch] -> DExp
DCaseE ([DExp] -> DExp
mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
sNames))
[DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat
((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map ((DPat
DWildP `DSigP`) (DType -> DPat) -> (Name -> DType) -> Name -> DPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(DType
singFamily `DAppT`) (DType -> DType) -> (Name -> DType) -> Name -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Name -> DType
DVarT) [Name]
ty_names)) DExp
exp']
DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ Int -> DType -> DExp -> DExp
wrapSingFun ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
names) DType
prom_lam (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
sNames DExp
caseExp
singExp (ADCaseE ADExp
exp [ADMatch]
matches DType
ret_ty) =
DExp -> DExp -> DExp
DAppE (DExp -> DType -> DExp
DAppTypeE (Name -> DExp
DVarE 'id)
(DType
singFamily DType -> DType -> DType
`DAppT` DType
ret_ty))
(DExp -> DExp) -> SgM DExp -> SgM DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> [DMatch] -> DExp
DCaseE (DExp -> [DMatch] -> DExp) -> SgM DExp -> SgM ([DMatch] -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ADExp -> SgM DExp
singExp ADExp
exp SgM ([DMatch] -> DExp) -> SgM [DMatch] -> SgM DExp
forall a b. SgM (a -> b) -> SgM a -> SgM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ADMatch -> SgM DMatch) -> [ADMatch] -> SgM [DMatch]
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 ADMatch -> SgM DMatch
singMatch [ADMatch]
matches)
singExp (ADLetE ALetDecEnv
env ADExp
exp) = do
([DLetDec]
let_decs, [DDec]
_, DExp
exp') <- ALetDecEnv -> SgM DExp -> SgM ([DLetDec], [DDec], DExp)
forall a. ALetDecEnv -> SgM a -> SgM ([DLetDec], [DDec], a)
singLetDecEnv ALetDecEnv
env (SgM DExp -> SgM ([DLetDec], [DDec], DExp))
-> SgM DExp -> SgM ([DLetDec], [DDec], DExp)
forall a b. (a -> b) -> a -> b
$ ADExp -> SgM DExp
singExp ADExp
exp
DExp -> SgM DExp
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
let_decs DExp
exp'
singExp (ADSigE DType
prom_exp ADExp
exp DType
ty) = do
DExp
exp' <- ADExp -> SgM DExp
singExp ADExp
exp
DExp -> SgM DExp
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DType -> DExp
DSigE DExp
exp' (DType -> DExp) -> DType -> DExp
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
singFamilyName DType -> DType -> DType
`DAppT` DType -> DType -> DType
DSigT DType
prom_exp DType
ty
singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec]
singDerivedEqDecs :: DerivedEqDecl -> SgM [DDec]
singDerivedEqDecs (DerivedDecl { ded_mb_cxt :: forall (cls :: * -> Constraint). DerivedDecl cls -> Maybe DCxt
ded_mb_cxt = Maybe DCxt
mb_ctxt
, ded_type :: forall (cls :: * -> Constraint). DerivedDecl cls -> DType
ded_type = DType
ty
, ded_type_tycon :: forall (cls :: * -> Constraint). DerivedDecl cls -> Name
ded_type_tycon = Name
ty_tycon
, ded_decl :: forall (cls :: * -> Constraint). DerivedDecl cls -> DataDecl
ded_decl = DataDecl DataFlavor
_ Name
_ [DTyVarBndrUnit]
_ [DCon]
cons }) = do
([DCon]
scons, [DDec]
_) <- [Dec] -> SgM [DCon] -> SgM ([DCon], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> SgM a -> q (a, [DDec])
singM [] (SgM [DCon] -> SgM ([DCon], [DDec]))
-> SgM [DCon] -> SgM ([DCon], [DDec])
forall a b. (a -> b) -> a -> b
$ (DCon -> SgM DCon) -> [DCon] -> SgM [DCon]
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 (Name -> DCon -> SgM DCon
singCtor Name
ty_tycon) [DCon]
cons
Maybe DCxt
mb_sctxt <- (DCxt -> SgM DCxt) -> Maybe DCxt -> SgM (Maybe DCxt)
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) -> Maybe a -> m (Maybe b)
mapM ((DType -> SgM DType) -> DCxt -> SgM DCxt
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 DType -> SgM DType
singPred) Maybe DCxt
mb_ctxt
DType
kind <- DType -> SgM DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
promoteType DType
ty
Maybe DCxt
mb_sctxtDecide <- (DCxt -> SgM DCxt) -> Maybe DCxt -> SgM (Maybe DCxt)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((DType -> SgM DType) -> DCxt -> SgM DCxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse DType -> SgM DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
sEqToSDecide) Maybe DCxt
mb_sctxt
DDec
sDecideInst <- Maybe DCxt -> DType -> [DCon] -> [DCon] -> SgM DDec
forall (q :: * -> *).
OptionsMonad q =>
Maybe DCxt -> DType -> [DCon] -> [DCon] -> q DDec
mkDecideInstance Maybe DCxt
mb_sctxtDecide DType
kind [DCon]
cons [DCon]
scons
[DDec]
testInsts <- (TestInstance -> SgM DDec) -> [TestInstance] -> SgM [DDec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Maybe DCxt -> DType -> Name -> [DCon] -> TestInstance -> SgM DDec
forall (q :: * -> *).
OptionsMonad q =>
Maybe DCxt -> DType -> Name -> [DCon] -> TestInstance -> q DDec
mkTestInstance Maybe DCxt
mb_sctxtDecide DType
kind Name
ty_tycon [DCon]
cons)
[TestInstance
TestEquality, TestInstance
TestCoercion]
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DDec
sDecideInstDDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[DDec]
testInsts)
sEqToSDecide :: OptionsMonad q => DPred -> q DPred
sEqToSDecide :: forall (m :: * -> *). OptionsMonad m => DType -> m DType
sEqToSDecide DType
p = do
Options
opts <- q Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
DType -> q DType
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ (Name -> Name) -> DType -> DType
modifyConNameDType (\Name
n ->
if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Options -> Name -> Name
singledClassName Options
opts Name
eqName
then Name
sDecideClassName
else Name
n) DType
p
singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec]
singDerivedShowDecs :: DerivedShowDecl -> SgM [DDec]
singDerivedShowDecs (DerivedDecl { ded_mb_cxt :: forall (cls :: * -> Constraint). DerivedDecl cls -> Maybe DCxt
ded_mb_cxt = Maybe DCxt
mb_cxt
, ded_type :: forall (cls :: * -> Constraint). DerivedDecl cls -> DType
ded_type = DType
ty
, ded_type_tycon :: forall (cls :: * -> Constraint). DerivedDecl cls -> Name
ded_type_tycon = Name
ty_tycon
, ded_decl :: forall (cls :: * -> Constraint). DerivedDecl cls -> DataDecl
ded_decl = DataDecl DataFlavor
_ Name
_ [DTyVarBndrUnit]
_ [DCon]
cons }) = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
Name
z <- String -> SgM Name
forall (m :: * -> *). Quasi m => String -> m Name
qNewName String
"z"
DCxt
show_cxt <- Maybe DCxt -> DType -> DType -> [DCon] -> SgM DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef ((DCxt -> DCxt) -> Maybe DCxt -> Maybe DCxt
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DCxt -> DCxt
mkShowSingContext Maybe DCxt
mb_cxt)
(Name -> DType
DConT Name
showSingName)
DType
ty [DCon]
cons
DType
ki <- DType -> SgM DType
forall (m :: * -> *). OptionsMonad m => DType -> m DType
promoteType DType
ty
let sty_tycon :: Name
sty_tycon = Options -> Name -> Name
singledDataTypeName Options
opts Name
ty_tycon
show_inst :: DDec
show_inst = Maybe DDerivStrategy
-> Maybe [DTyVarBndrUnit] -> DCxt -> DType -> DDec
DStandaloneDerivD Maybe DDerivStrategy
forall a. Maybe a
Nothing Maybe [DTyVarBndrUnit]
forall a. Maybe a
Nothing DCxt
show_cxt
(Name -> DType
DConT Name
showName DType -> DType -> DType
`DAppT` (Name -> DType
DConT Name
sty_tycon DType -> DType -> DType
`DAppT` DType -> DType -> DType
DSigT (Name -> DType
DVarT Name
z) DType
ki))
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DDec
show_inst]
isException :: DExp -> Bool
isException :: DExp -> Bool
isException (DVarE Name
n) = Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"sUndefined"
isException (DConE {}) = Bool
False
isException (DLitE {}) = Bool
False
isException (DAppE (DVarE Name
fun) DExp
_) | Name -> String
nameBase Name
fun String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"sError" = Bool
True
isException (DAppE DExp
fun DExp
_) = DExp -> Bool
isException DExp
fun
isException (DAppTypeE DExp
e DType
_) = DExp -> Bool
isException DExp
e
isException (DLamE [Name]
_ DExp
_) = Bool
False
isException (DCaseE DExp
e [DMatch]
_) = DExp -> Bool
isException DExp
e
isException (DLetE [DLetDec]
_ DExp
e) = DExp -> Bool
isException DExp
e
isException (DSigE DExp
e DType
_) = DExp -> Bool
isException DExp
e
isException (DStaticE DExp
e) = DExp -> Bool
isException DExp
e
singMatch :: ADMatch -> SgM DMatch
singMatch :: ADMatch -> SgM DMatch
singMatch (ADMatch VarPromotions
var_proms ADPat
pat ADExp
exp) = do
(DPat
sPat, SingDSigPaInfos
sigPaExpsSigs) <- QWithAux SingDSigPaInfos SgM DPat -> SgM (DPat, SingDSigPaInfos)
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair (QWithAux SingDSigPaInfos SgM DPat -> SgM (DPat, SingDSigPaInfos))
-> QWithAux SingDSigPaInfos SgM DPat -> SgM (DPat, SingDSigPaInfos)
forall a b. (a -> b) -> a -> b
$ Map Name Name -> ADPat -> QWithAux SingDSigPaInfos SgM DPat
singPat (VarPromotions -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList VarPromotions
var_proms) ADPat
pat
DExp
sExp <- ADExp -> SgM DExp
singExp ADExp
exp
DMatch -> SgM DMatch
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch -> SgM DMatch) -> DMatch -> SgM DMatch
forall a b. (a -> b) -> a -> b
$ DPat -> DExp -> DMatch
DMatch DPat
sPat (DExp -> DMatch) -> DExp -> DMatch
forall a b. (a -> b) -> a -> b
$ SingDSigPaInfos -> DExp -> DExp
mkSigPaCaseE SingDSigPaInfos
sigPaExpsSigs DExp
sExp
singLit :: Lit -> SgM DExp
singLit :: Lit -> SgM DExp
singLit (IntegerL Integer
n) = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
then DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE (Options -> Name -> Name
singledValueName Options
opts Name
fromIntegerName) DExp -> DExp -> DExp
`DAppE`
(Name -> DExp
DVarE Name
singMethName DExp -> DType -> DExp
`DSigE`
(DType
singFamily DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (Integer -> TyLit
NumTyLit Integer
n)))
else do DExp
sLit <- Lit -> SgM DExp
singLit (Integer -> Lit
IntegerL (-Integer
n))
DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE (Options -> Name -> Name
singledValueName Options
opts Name
negateName) DExp -> DExp -> DExp
`DAppE` DExp
sLit
singLit (StringL String
str) = do
Options
opts <- SgM Options
forall (m :: * -> *). OptionsMonad m => m Options
getOptions
let sing_str_lit :: DExp
sing_str_lit = Name -> DExp
DVarE Name
singMethName DExp -> DType -> DExp
`DSigE`
(DType
singFamily DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
str))
Bool
os_enabled <- Extension -> SgM Bool
forall (m :: * -> *). Quasi m => Extension -> m Bool
qIsExtEnabled Extension
LangExt.OverloadedStrings
DExp -> SgM DExp
forall a. a -> SgM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ if Bool
os_enabled
then Name -> DExp
DVarE (Options -> Name -> Name
singledValueName Options
opts Name
fromStringName) DExp -> DExp -> DExp
`DAppE` DExp
sing_str_lit
else DExp
sing_str_lit
singLit (CharL Char
c) =
DExp -> SgM DExp
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> SgM DExp) -> DExp -> SgM DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
singMethName DExp -> DType -> DExp
`DSigE` (DType
singFamily DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (Char -> TyLit
CharTyLit Char
c))
singLit Lit
lit =
String -> SgM DExp
forall a. String -> SgM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Only string, natural number, and character literals can be singled: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Lit -> String
forall a. Show a => a -> String
show Lit
lit)