{-# LANGUAGE CPP #-}-- | Smash functions which return something that can be inferred-- (something of a type with only one element)moduleAgda.Compiler.Epic.SmashingwhereimportControl.Arrow((&&&))importControl.MonadimportControl.Monad.StateimportControl.Monad.TransimportData.ListimportqualifiedData.MapasMimportData.Map(Map)importData.MaybeimportqualifiedData.SetasSimportData.Set(Set)importAgda.Syntax.CommonimportAgda.Syntax.InternalasSIimportAgda.TypeChecking.MonadimportAgda.TypeChecking.SubstituteimportAgda.TypeChecking.TelescopeimportAgda.TypeChecking.PrettyimportAgda.TypeChecking.ReduceimportAgda.TypeChecking.Rules.LHS.UnifyimportAgda.Compiler.Epic.AuxASTasAAimportAgda.Compiler.Epic.CompileStateimportAgda.Compiler.Epic.InterfaceimportAgda.Utils.MonadimportAgda.Utils.SizeimportqualifiedAgda.Utils.HashMapasHM#include "../../undefined.h"importAgda.Utils.ImpossibledefnPars::Integraln=>Defn->ndefnPars(Record{recPars=p})=fromIntegralpdefnPars(Constructor{conPars=p})=fromIntegralpdefnParsd=0-- | Main function, smash as much as possiblesmash'em::[Fun]->CompileTCM[Fun]smash'emfuns=dodefs<-lift(gets(sigDefinitions.stImports))funs'<-forMfuns$\f->casefofAA.Fun{}->casefunQNamef>>=flipHM.lookupdefsofNothing->dolift$reportSDoc"epic.smashing"10$vcat[(text.show)f<+>text" was not found"]returnfJustdef->dolift$reportSLn"epic.smashing"10$"running on:"++(show(funQNamef))minfered<-smashable(length(funArgsf)+defnPars(theDefdef))(defTypedef)caseminferedofJustinfered->dolift$reportSDoc"smashing"5$vcat[prettyTCM(defNamedef)<+>text"is smashable"]returnf{funExpr=infered,funInline=True,funComment=funCommentf++" [SMASHED]"}Nothing->returnf_->dolift$reportSLn"epic.smashing"10$"smashing!"returnfreturnfuns'(+++)::Telescope->Telescope->Telescopexs+++ys=unflattenTelnames$map(raise(sizeys))(flattenTelxs)++flattenTelyswherenames=teleNamesxs++teleNamesys-- | Can a datatype be inferred? If so, return the only possible value.inferable::SetQName->QName->[ArgTerm]->CompileTCM(MaybeExpr)inferablevisiteddatargs|dat`S.member`visited=returnNothinginferablevisiteddatargs=dolift$reportSLn"epic.smashing"10$" inferring:"++(showdat)defs<-lift(gets(sigDefinitions.stImports))letdef=fromMaybe__IMPOSSIBLE__$HM.lookupdatdefscasetheDefdefofd@Datatype{}->docasedataConsdof[c]->inferableArgsc(dataParsd)_->returnNothingr@Record{}->inferableArgs(recConr)(recParsr)f@Function{}->doterm<-lift$normalise$DefdatargsinferableTermvisited'termd->dolift$reportSLn"epic.smashing"10$" failed (inferable): "++(showd)returnNothingwhereinferableArgscpars=dodefs<-lift(gets(sigDefinitions.stImports))letdef=fromMaybe__IMPOSSIBLE__$HM.lookupcdefsforc<-getForcedArgscTelVtel_<-lift$telView(defTypedef`apply`genericTakeparsargs)tag<-getConstrTagclift$reportSDoc"epic.smashing"10$nest2$vcat[text"inferableArgs!",text"tele"<+>prettyTCMtel,text"constr:"<+>prettyTCMc](AA.Contagc<$>)<$>sequence<$>forM(notForcedforc$flattenTeltel)(inferableTermvisited'.unEl.unDom)visited'=S.insertdatvisitedinferableTermvisitedt=casetofDefqas->inferablevisitedqasPi_b->(AA.Lam"_"<$>)<$>inferableTermvisited(unEl$unAbsb)Sort{}->return.return$AA.UNITt->dolift$reportSLn"epic.smashing"10$" failed to infer: "++showtreturnNothing-- | Find the only possible value for a certain type. If we fail return Nothingsmashable::Int->Type->CompileTCM(MaybeExpr)smashableorigAritytyp=dodefs<-lift(gets(sigDefinitions.stImports))TelVteleretType<-lift$telViewtypretType'<-returnretType-- lift $ reduce retTypeinf<-inferableTermS.empty(unElretType')lift$reportSDoc"epic.smashing"10$nest2$vcat[text"Result is",text"inf: "<+>(text.show)inf,text"type: "<+>prettyTCMretType']return$buildLambda(sizetele-origArity)<$>infbuildLambda::(Ordn,Numn)=>n->Expr->ExprbuildLambdane|n<=0=ebuildLambdane|otherwise=AA.Lam"_"(buildLambda(n-1)e)