uhc-light-1.1.9.1: src/UHC/Light/Compiler/Deriving.hs
module UHC.Light.Compiler.Deriving
( DerivCls (..), DerivClsFld (..), DerivClsMp
, emptyDerivCls
, dccMkTy
, mkDerivClsMp )
where
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.TermLike
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Gam.Full
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Core
import UHC.Light.Compiler.Core.Utils
import UHC.Light.Compiler.AbstractCore
import qualified Data.Map as Map
import Data.List
import UHC.Util.Utils
import UHC.Light.Compiler.Ty.FitsInCommon2
import UHC.Light.Compiler.Ty.Trf.Canonic
{-# LINE 25 "src/ehc/Deriving.chs" #-}
data DerivClsExtraCtxt
= DerivClsExtraCtxt_Fixed -- fixed predicate, independent of type over which is derived
{ dccClsClNm :: !HsName -- class name
, dccClsTyNm :: !HsName -- and its type arg
}
data DerivCls
= DerivCls
{ dclNm :: !HsName -- name of class
, dclFldL :: ![DerivClsFld] -- field info
, dclExtraCtxt :: ![DerivClsExtraCtxt] -- additional instances to prove (and use)
}
data DerivClsFld
= DerivClsFld
{ dcfNm :: !HsName -- name of class field
, dcfTy :: !Ty -- type of class field, expanded w.r.t. type synonyms
, dcfMkCPat :: -- make the pattern for each alternative
Int -- index of alternative (the actual Enum ordering)
-> CTag -- tag
-> Int -- arity
-> Maybe [HsName] -- optional list of names for constituents
-> CPat
, dcfInitialArgL :: ![HsName] -- initial arguments for function, passed to dcfFoldSubsCExpr
, dcfInitialSubArgL :: DataTagInfo -> [CExpr] -- initial arguments for constituents
, dcfNrOmitTailArg :: !Int -- nr of args not passed, i.e. how much to omit for partial app
, dcfFoldSubsCExpr :: UID -- construct out of constituents
-> RCEEnv
-> DataTagInfo -- this tag info
-> (Int,Int) -- (index (a la toEnum), nr of alts)
-> [HsName] -- names of initial args (usually same as dcfInitialArgL)
-> [CExpr] -- constituents
-> CExpr
, dcfNoArgSubsCExpr :: RCEEnv
-> [(DataTagInfo,[CExpr])] -- all tag info + sub calls parameterized with appropriate instance
-> Int -- nr of alts
-> CExpr -- instance under construction
-> [CExpr] -- instances corresponding to dclExtraCtxt
-> [HsName] -- names of initial args (usually same as dcfInitialArgL)
-> CExpr -- when class member takes no args
, dcfAllTagLtCExpr :: !CExpr -- when tags are < previous
, dcfAllTagGtCExpr :: !CExpr -- when tags are > previous
, dcfWrapCase :: -- wrap case expr in derived function
EHCOpts
-> DataGamInfo -- info of data ty
-> Int -- nr of alts
-> HsName -- name of expr inspected by case expr
-> [HsName] -- names of initial args (usually same as dcfInitialArgL)
-> CExpr -- case expr
-> CExpr
}
type DerivClsMp = Map.Map HsName DerivCls
{-# LINE 81 "src/ehc/Deriving.chs" #-}
emptyDerivCls :: DerivCls
emptyDerivCls = DerivCls hsnUnknown [] []
{-# LINE 86 "src/ehc/Deriving.chs" #-}
dccMkTy :: DerivClsExtraCtxt -> Ty
dccMkTy (DerivClsExtraCtxt_Fixed clNm tyNm) = appConApp clNm [appCon tyNm]
{-# LINE 93 "src/ehc/Deriving.chs" #-}
mkDerivClsMp :: FIEnv -> ValGam -> DataGam -> DerivClsMp
mkDerivClsMp fe valGam dataGam
= Map.unions
$ map (uncurry Map.singleton)
$ [
-- Eq
{-
-}
mkc ehbnClassEq []
[
-- Eq((==))
mkf ehbnClassEqFldEq
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
(\_ _ _ _ _ vs
-> case vs of
[] -> true
_ -> foldr1 and vs
)
Nothing -- no zero arg
false false
nowrap
]
-- Ord
, mkc ehbnClassOrd []
[
-- Ord(compare)
mkf ehbnClassOrdFldCompare
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
(\uniq env _ _ _ vs
-> case vs of
[] -> eq
_ -> foldr1 (\l r -> acoreStrictSatCaseTy env (Just (nStrict,acoreTyErr "Deriving.Ord.compare")) l
[ acoreAlt (acorePatTagArityMbNms (rceEHCOpts env) (orderingTag eqNm) 0 Nothing) r
, acoreAlt (acorePatTagArityMbNms (rceEHCOpts env) (orderingTag ltNm) 0 Nothing) lt
, acoreAlt (acorePatTagArityMbNms (rceEHCOpts env) (orderingTag gtNm) 0 Nothing) gt
]
) vs
where n = mkHNm uniq
nStrict = hsnUniqifyEval n
)
Nothing -- no zero arg
gt lt
nowrap
]
-- Enum
, mkc ehbnClassEnum [DerivClsExtraCtxt_Fixed (fn ehbnClassEnum) hsnInt]
[
-- Enum(enumFrom)
mkf ehbnClassEnumFldEnumFrom
Nothing -- only data constructor patterns
(take 1 hsnLclSupply)
Nothing -- no extra args for recursion on constituents
0
nononzeroargs
(Just $
\_ dtiSubs nrOfAlts self _ [argFrom]
-> let (dti,_) = last' (panic "Deriving.Enum.enumFrom.dtiSubs") dtiSubs
in acoreBuiltinApp opts ehbnClassEnumFldEnumFromTo [self,acoreVar argFrom,CExpr_Tup (dtiCTag dti)]
)
undef undef
nowrap
-- Enum(enumFromThen)
, mkf ehbnClassEnumFldEnumFromThen
Nothing -- only data constructor patterns
(take 2 hsnLclSupply)
Nothing -- no extra args for recursion on constituents
0
nononzeroargs
(Just $
\_ dtiSubs nrOfAlts self _ [argFrom,argThen]
-> let (dti1,_) = head dtiSubs
(dti2,_) = last' (panic "Deriving.Enum.enumFromThen.dtiSubs") dtiSubs
in acoreBuiltinApp opts ehbnClassEnumFldEnumFromThenTo
[ self
, acoreVar argFrom
, acoreVar argThen
, acoreIf opts Nothing
(acoreBuiltinApp opts ehbnPrimGtInt
[ acoreBuiltinApp opts ehbnClassEnumFldFromEnum [self, acoreVar argFrom]
, acoreBuiltinApp opts ehbnClassEnumFldFromEnum [self, acoreVar argThen]
]
)
(CExpr_Tup (dtiCTag dti1))
(CExpr_Tup (dtiCTag dti2))
]
)
undef undef
nowrap
-- Enum(fromEnum)
, mkf ehbnClassEnumFldFromEnum
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
(\_ env _ (altInx,_) _ []
-> acoreInt opts altInx
)
Nothing -- no zero arg
undef undef
nowrap
-- Enum(toEnum)
, mkf ehbnClassEnumFldToEnum
(Just $ \altInx _ _ _ -> CPat_Int altInx)
[]
Nothing -- no extra args for recursion on constituents
0
(\_ _ dti _ _ []
-> CExpr_Tup (dtiCTag dti)
)
Nothing -- no zero arg
undef undef
(\opts dgi nrOfAlts cNm _ body
-> let cNmv = acoreVar cNm
cNm1 = hsnUniqifyStr HsNameUniqifier_Evaluated "boundCheck" cNm
in acoreIf opts (Just cNm1)
(acoreBuiltinApp opts ehbnPrimGtInt [cNmv,acoreInt opts (nrOfAlts-1)])
(acoreBuiltinError opts $ "too high for toEnum to " ++ show (dgiTyNm dgi))
(acoreIf opts (Just cNm1)
(acoreBuiltinApp opts ehbnPrimGtInt [acoreInt opts 0,cNmv])
(acoreBuiltinError opts $ "too low for toEnum to " ++ show (dgiTyNm dgi))
body
)
)
-- Enum(succ)
, mkf ehbnClassEnumFldSucc
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
(\_ env dti (altInx,nrOfAlts) _ []
-> if altInx < nrOfAlts - 1
then acoreInt opts $ altInx + 1
else acoreBuiltinError opts $ "cannot succ last constructor: " ++ show (dtiConNm dti)
)
Nothing -- no zero arg
undef undef
nowrap
-- Enum(pred)
, mkf ehbnClassEnumFldPred
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
(\_ env dti (altInx,_) _ []
-> if altInx > 0
then acoreInt opts $ altInx - 1
else acoreBuiltinError opts $ "cannot pred first constructor: " ++ show (dtiConNm dti)
)
Nothing -- no zero arg
undef undef
nowrap
]
-- Bounded
{-
-}
, mkc ehbnClassBounded []
[
-- Bounded(maxBound)
mkf ehbnClassBoundedFldMaxBound
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
nononzeroargs
(Just $
\_ dtiSubs _ _ _ _
-> let (dti,subs) = last dtiSubs
in acoreTagTup (dtiCTag dti) subs
)
undef undef
nowrap
-- Bounded(minBound)
, mkf ehbnClassBoundedFldMinBound
Nothing -- only data constructor patterns
[]
Nothing -- no extra args for recursion on constituents
0
nononzeroargs
(Just $
\_ dtiSubs _ _ _ _
-> let (dti,subs) = head dtiSubs
in acoreTagTup (dtiCTag dti) subs
)
undef undef
nowrap
]
-- Show
, mkc ehbnClassShow []
[
-- Show(showsPrec)
mkf ehbnClassShowFldShowsPrec
Nothing -- only data constructor patterns
[precDepthNm]
(Just $ \dti -> [acoreInt opts $ maybe (fixityAppPrio + 1) ((+1) . fst) $ dtiMbFixityPrio dti])
1
(\_ _ dti _ [dNm] vs
-> let mk needParen v = acoreApp (acoreVar $ fn ehbnPrelShowParen) [needParen,v]
in case (vs,dtiMbFixityPrio dti) of
([],_)
-> showString $ tag2str (dtiCTag dti)
([v1,v2],Just (p,_))
-> mk (acoreBuiltinGtInt opts (acoreVar dNm) p)
$ foldr1 compose ([v1] ++ [ showString $ " " ++ tag2str (dtiCTag dti) ++ " " ] ++ [v2])
_ -> mk (acoreBuiltinGtInt opts (acoreVar dNm) fixityAppPrio)
$ foldr1 compose ([showString $ tag2str (dtiCTag dti) ++ " "] ++ intersperse (showString " ") vs)
)
Nothing -- no zero arg
undef undef
nowrap
]
-- Ix
{-
-}
, mkc ehbnClassIx []
[
-- Ix(range)
-- Ix(index)
-- Ix(inRange)
]
-- Read
, mkc ehbnClassRead []
[
-- Read(readsPrec)
mkf ehbnClassReadFldReadsPrec
Nothing -- only data constructor patterns
[precDepthNm,remInputNm]
Nothing -- no extra args for recursion on constituents
0
nononzeroargs
(Just $
\env dtiSubs _ _ _ [dNm,rNm]
-> let mkSub (dti,subCalls)
= acoreApp (acoreVar $ fn ehbnPrelReadParen) [needParen,v,acoreVar rNm]
where nSub = length subCalls
nms seed = take (nSub+1) $ hsnLclSupplyWith $ mkHNmHidden seed
remNmL = nms "v"
nmL = zip4 (nms "uv") (rNm:remNmL) (nms "u") remNmL
nmLRemFinal = last' (panic "Deriving.nmLRemFinal") remNmL
mkLamTup x res rem cont = acoreLam1Ty x (acoreTyErr "Deriving.Read.mkLamTup.lam") $ acoreMatchTupleTy env [res,rem] (acoreTyErr "Deriving.Read.mkLamTup.tup") cont (acoreVar x)
mkLamStr str x res rem cont = mkLamTup x res rem $ acoreMatchStringTy env str (acoreTyErr "Deriving.Read.mkLamStr.match") cont nil (acoreVar res)
mkConcatMapTup lam prio rem subCall = acoreApp (acoreVar $ fn ehbnPrelConcatMap) [lam,acoreApp subCall [prio,acoreVar rem]]
mkConcatMapStr lam rem = acoreApp (acoreVar $ fn ehbnPrelConcatMap) [lam,acoreApp (acoreVar $ fn ehbnPrelLex) [acoreVar rem]]
mkPrio prio = acoreInt opts (prio + 1)
mkRes resL rem = acoreBuiltinListSingleton opts $ acoreTup [acoreTagTup (dtiCTag dti) $ map acoreVar resL,acoreVar rem]
mkConRead (resrem,remprev,res,rem) = \cont -> mkConcatMapStr (mkLamStr (tag2str (dtiCTag dti)) resrem res rem cont) remprev
mkSubReads tlNmL subCalls = [ (\cont -> mkConcatMapTup (mkLamTup resrem res rem cont) (mkPrio fixityAppPrio) remPrev subCall, res) | ((resrem,remPrev,res,rem),subCall) <- zip tlNmL subCalls ]
(needParen,v)
= case (subCalls,dtiMbFixityPrio dti,nmL) of
([subCall1,subCall2],Just (p,_),(subNms1:conNms:subNms2:_))
-> ( acoreBuiltinGtInt opts (acoreVar dNm) p
, acoreLam1Ty rNm (acoreTyErr "Deriving.Read.") $ sub1 $ mkConRead conNms $ sub2 $ mkRes subResNmL nmLRemFinal
)
where ([sub1,sub2],subResNmL) = unzip $ mkSubReads [subNms1,subNms2] subCalls
(_,_,(conNms:subNmsL))
-> ( acoreBuiltinGtInt opts (acoreVar dNm) fixityAppPrio
, acoreLam1Ty rNm (acoreTyErr "Deriving.Read.") $ foldr ($) (mkRes subResNmL nmLRemFinal) (mkConRead conNms : subs)
)
where (subs,subResNmL) = unzip $ mkSubReads subNmsL subCalls
in foldr1 (\ds e -> acoreApp (acoreVar $ fn ehbnPrelConcat2) [ds,e])
$ map mkSub dtiSubs
)
undef undef
nowrap
]
]
where mkc c extraCtxt flds
= (c', DerivCls c' flds extraCtxt)
where c' = fn c
mkf f mbMkPat as mbAsSubs omTl cAllMatch mbCNoArg cLT cGT wrap
= DerivClsFld f' (tyCanonic (emptyTyBetaRedEnv' fe) t) mkPat as asSubs omTl cAllMatch cNoArg cLT cGT wrap
where f' = fn f
(t,_) = valGamLookupTy f' valGam
mkPat = maybe (const $ acorePatTagArityMbNms opts) id mbMkPat
asSubs = maybe (const []) id mbAsSubs
cNoArg = maybe (\_ _ _ _ _ _ -> undef) id mbCNoArg
fn f = ehcOptBuiltin opts f
false, true :: CExpr
false = acoreVar $ fn ehbnBoolFalse
true = acoreVar $ fn ehbnBoolTrue
nil = CExpr_Tup $ ctagNil opts
and l r = (acoreVar $ fn ehbnBoolAnd) `acoreApp` [l,r]
compose l r = (acoreVar $ fn ehbnPrelCompose) `acoreApp` [l,r]
showString s = (acoreVar $ fn ehbnPrelShowString) `acoreApp` [acoreBuiltinString opts s]
eq = acoreVar eqNm
lt = acoreVar ltNm
gt = acoreVar gtNm
undef = acoreBuiltinUndefined opts
tag2str = show . hsnQualified . ctagNm
orderingTag conNm
= dtiCTag
$ dgiDtiOfCon conNm
$ panicJust "mkDerivClsMp.dataGamLookup"
$ dataGamLookup (fn ehbnDataOrdering) dataGam
nowrap _ _ _ _ _ x = x
nononzeroargs _ _ _ _ _ _ = undef
opts = feEHCOpts fe
eqNm = fn ehbnDataOrderingAltEQ
ltNm = fn ehbnDataOrderingAltLT
gtNm = fn ehbnDataOrderingAltGT
precDepthNm = mkHNm "d"
remInputNm = mkHNm "r"