{-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification, ScopedTypeVariables #-}{- |
Internal module, do not import or use.
-}moduleData.Generics.Uniplate.Internal.DatawhereimportData.Generics.StrimportData.Generics.Uniplate.Internal.UtilsimportData.DataimportData.GenericsimportData.MaybeimportData.ListimportData.IORefimportControl.ExceptionimportControl.MonadimportSystem.Environment(getEnv)importqualifiedData.IntMapasIntMap;importData.IntMap(IntMap)#if __GLASGOW_HASKELL__ < 606----------------------------------------------------------------------- GHC 6.4 and belowimportqualifiedData.SetasSetimportqualifiedData.MapasMaptypeTypeKey=TypeReptypeTypeSet=Set.SetTypeKeytypeTypeMap=Map.MapTypeKeytypeKey::Typeablea=>a->TypeKeytypeKey=typeOf#elif __GLASGOW_HASKELL__ < 702----------------------------------------------------------------------- GHC 6.6 to 7.0 (has typeRepKey)importqualifiedData.IntSetasSetimportqualifiedData.IntMapasMaptypeTypeKey=InttypeTypeSet=Set.IntSettypeTypeMap=Map.IntMaptypeKey::Typeablea=>a->TypeKeytypeKeyx=inlinePerformIO$typeRepKey$typeOfx#else----------------------------------------------------------------------- GHC 7.2 and above (using fingerprint)importGHC.Fingerprint.Type(Fingerprint(..))importData.Typeable.Internal(TypeRep(..))importData.HashableimportqualifiedData.HashMap.StrictasMapimportqualifiedData.HashSetasSettypeTypeSet=Set.HashSetTypeKeytypeTypeMap=Map.HashMapTypeKeytypeTypeKey=TypeReptypeKey::Typeablea=>a->TypeKeytypeKey=typeOfinstanceHashableTypeRepwhere-- Fingerprint is just the MD5, so taking any Int from it is finehash(TypeRep(Fingerprintx_)__)=fromIntegralx#endif#if __GLASGOW_HASKELL__ < 702----------------------------------------------------------------------- GHC 7.0 and below (using containers API)(!)=(Map.!)map_findWithDefault=Map.findWithDefaultmap_fromAscList=Map.fromAscListmap_keysSet=Map.keysSetmap_member=Map.memberset_partition=Set.partitionset_toAscList=Set.toAscListset_unions=Set.unions#else----------------------------------------------------------------------- GHC 7.2 and above (using unordered-containers API)(!)mpk=Map.lookupDefault(error"Could not find element")kmpmap_findWithDefault=Map.lookupDefaultmap_fromAscList=Map.fromListmap_keysSet=Set.fromList.Map.keysmap_memberxxs=isJust$Map.lookupxxsset_partitionfx=(Set.filterfx,Set.filter(not.f)x)set_toAscList=Set.toListset_unions=foldrSet.unionSet.empty#endif{-# NOINLINE uniplateVerbose #-}uniplateVerbose::Int-- 0 = quiet, 1 = errors only, 2 = everythinguniplateVerbose=unsafePerformIO$dofmapread(getEnv"UNIPLATE_VERBOSE")`Control.Exception.catch`\(_::SomeException)->return0----------------------------------------------------------------------- HIT TESTdataAnswera=Hit{fromHit::a}-- you just hit the element you were after (here is a cast)|Follow-- go forward, you will find something|Miss-- you failed to sink my battleship!dataOracleto=Oracle{fromOracle::forallon.Typeableon=>on->Answerto}{-# INLINE hitTest #-}hitTest::(Datafrom,Datato)=>from->to->OracletohitTestfromto=letkto=typeKeytoincasereadCacheFollower(dataBoxfrom)ktoofNothing->Oracle$\on->iftypeKeyon==ktothenHit$unsafeCoerceonelseFollowJusttest->Oracle$\on->letkon=typeKeyoninifkon==ktothenHit$unsafeCoerceonelseiftestkonthenFollowelseMiss----------------------------------------------------------------------- CACHE-- Store and compute the Follower and HitMapdataCache=CacheHitMap(TypeMap2(MaybeFollower))-- Indexed by the @from@ type, then the @to@ type-- Nothing means that we can't perform the trick on the set{-# NOINLINE cache #-}cache::IORefCachecache=unsafePerformIO$newIORef$CacheemptyHitMapMap.emptyreadCacheFollower::DataBox->TypeKey->MaybeFollowerreadCacheFollowerfrom@(DataBoxkfromvfrom)kto=inlinePerformIO$doCachehitfollow<-readIORefcachecaselookup2kfromktofollowofJustans->returnansNothing->dores<-Control.Exception.try(return$!insertHitMapfromhit)(hit,fol)<-return$caseresofLeft_->(hit,Nothing)Righthit->(hit,Just$followerkfromktohit)letmsg="# Uniplate lookup on ("++show(typeOfvfrom)++"), from ("++showkfrom++"), to ("++showkto++"): "++either(\(msg::SomeException)->"FAILURE ("++showmsg++")")(const"Success")reswhen(uniplateVerbose+maybe1(const0)fol>=2)$putStrLnmsgwhen(uniplateVerbose<0&&isNothingfol)$errormsgatomicModifyIORefcache$\(Cache_follow)->(Cachehit(insert2kfromktofolfollow),())returnfol-- from which values, what can you reachreadCacheHitMap::DataBox->MaybeHitMapreadCacheHitMapfrom@(DataBoxkfromvfrom)=inlinePerformIO$doCachehit_<-readIORefcachecaseMap.lookupkfromhitofJust_->return$JusthitNothing->dores<-Control.Exception.catch(return$!Just$!insertHitMapfromhit)(\(_::SomeException)->returnNothing)caseresofNothing->returnNothingJusthit->doatomicModifyIORefcache$\(Cache_follow)->(Cachehitfollow,())return$Justhit----------------------------------------------------------------------- TYPEMAP2/INTMAP2typeTypeMap2a=TypeMap(TypeMapa)lookup2::TypeKey->TypeKey->TypeMap2a->Maybealookup2xymp=Map.lookupxmp>>=Map.lookupyinsert2::TypeKey->TypeKey->a->TypeMap2a->TypeMap2ainsert2xyvmp=Map.insertWith(const$Map.insertyv)x(Map.singletonyv)mptypeIntMap2a=IntMap(IntMapa)intLookup2::Int->Int->IntMap2a->MaybeaintLookup2xymp=IntMap.lookupxmp>>=IntMap.lookupyintInsert2::Int->Int->a->IntMap2a->IntMap2aintInsert2xyvmp=IntMap.insertWith(const$IntMap.insertyv)x(IntMap.singletonyv)mp----------------------------------------------------------------------- FOLLOWER-- Function to test if you should followtypeFollower=TypeKey->Bool-- HitMap must have addHitMap on the keyfollower::TypeKey->TypeKey->HitMap->Followerfollowerfromtomp|Set.nullhit=constFalse|Set.nullmiss=constTrue|Set.sizehit<Set.sizemiss=\k->k`Set.member`hit|otherwise=\k->not$k`Set.member`misswhere(hit,miss)=set_partition(\x->to`Set.member`grabx)(Set.insertfrom$grabfrom)grabx=map_findWithDefault(error"couldn't grab in follower")xmp----------------------------------------------------------------------- DATA/TYPEABLE OPERATIONS-- | An existential box representing a type which supports SYB-- operations.dataDataBox=foralla.(Dataa)=>DataBox{dataBoxKey::TypeKey,dataBoxVal::a}dataBox::Dataa=>a->DataBoxdataBoxx=DataBox(typeKeyx)x-- NOTE: This function is partial, but all exceptions are caught later onsybChildren::Dataa=>a->[DataBox]sybChildrenx|isAlgTypedtyp=concatMapfctrs|isNorepTypedtyp=[]-- Extensive discussions with Lennart and Roman decided that if something returns NorepType, it really wants to be atomic-- so we should let it be, and pretend it has no children.-- The most common types which say this are Data.Set/Data.Map, and we think that's a bug in their Data instances.-- error $ "Data.Generics.Uniplate.Data: sybChildren on data type which returns NorepType, " ++ show (typeOf x) ++ ", " ++ show dtyp|otherwise=[]wherefctr=gmapQdataBox(asTypeOf(fromConstrctr)x)ctrs=dataTypeConstrsdtypdtyp=dataTypeOfx----------------------------------------------------------------------- HITMAP-- What is the transitive closure of a type keytypeHitMap=TypeMapTypeSetemptyHitMap::HitMapemptyHitMap=Map.fromList[(tRational,Set.singletontInteger),(tInteger,Set.empty)]wheretRational=typeKey(undefined::Rational)tInteger=typeKey(0::Integer)insertHitMap::DataBox->HitMap->HitMapinsertHitMapboxhit=fixEqtrans(populatebox)`Map.union`hitwhere-- create a fresh box with all the necessary children that aren't in hitpopulate::DataBox->HitMappopulatex=fxMap.emptywheref(DataBoxkeyval)mp|key`map_member`hit||key`map_member`mp=mp|otherwise=fscs$Map.insertkey(Set.fromList$mapdataBoxKeycs)mpwherecs=sybChildrenvalfs[]mp=mpfs(x:xs)mp=fsxs(fxmp)-- update every one to be the transitive closuretrans::HitMap->HitMaptransmp=Map.mapfmpwherefx=set_unions$x:mapg(Set.toListx)gx=map_findWithDefault(hit!x)xmpfixEq::Eqa=>(a->a)->a->afixEqfx=ifx==x2thenx2elsefixEqfx2wherex2=fx----------------------------------------------------------------------- INSTANCE FUNCTIONSnewtypeCxa=C{fromC::CCxa}typeCCxa=(Strx,Strx->a)biplateData::(Dataon,Datawith)=>(foralla.Typeablea=>a->Answerwith)->on->CCwithonbiplateDataoraclex=caseoraclexofHity->(Oney,\(Onex)->unsafeCoercex)Follow->uniplateDataoraclexMiss->(Zero,\_->x)uniplateData::forallonwith.(Dataon,Datawith)=>(foralla.Typeablea=>a->Answerwith)->on->CCwithonuniplateDataoracleitem=fromC$gfoldlcombinecreateitemwherecombine::Dataa=>Cwith(a->b)->a->Cwithbcombine(C(c,g))x=casebiplateDataoraclexof(c2,g2)->C(Twocc2,\(Twoc'c2')->gc'(g2c2'))create::g->Cwithgcreatex=C(Zero,\_->x)descendData::Dataon=>(foralla.Typeablea=>a->Answeron)->(on->on)->on->ondescendDataoracleop=gmapT(descendBiDataoracleop)descendBiData::(Dataon,Datawith)=>(foralla.Typeablea=>a->Answerwith)->(with->with)->on->ondescendBiDataoracleopx=caseoraclexofHity->unsafeCoerce$opyFollow->gmapT(descendBiDataoracleop)xMiss->x----------------------------------------------------------------------- FUSIONdataTransformer=foralla.Dataa=>TransformerTypeKey(a->a)-- | Wrap up a @(a -> a)@ transformation function, to use with 'transformBis'transformer::Dataa=>(a->a)->Transformertransformer=transformer_-- Don't export directly, as don't want Haddock to see the foralltransformer_::foralla.Dataa=>(a->a)->Transformertransformer_=Transformer(typeKey(undefined::a))-- | Apply a sequence of transformations in order. This function obeys the equivalence:---- > transformBis [[transformer f],[transformer g],...] == transformBi f . transformBi g . ...---- Each item of type @[Transformer]@ is applied in turn, right to left. Within each-- @[Transformer]@, the individual @Transformer@ values may be interleaved.---- The implementation will attempt to perform fusion, and avoid walking any part of the-- data structure more than necessary. To further improve performance, you may wish to-- partially apply the first argument, which will calculate information about the relationship-- between the transformations.transformBis::foralla.Dataa=>[[Transformer]]->a->atransformBis=transformBis_transformBis_::foralla.Dataa=>[[Transformer]]->a->a-- basic algorithm:-- as you go down, given transformBis [fN..f1]-- if x is not in the set reachable by fN..f1, return x-- if x is in the reachable set, gmap (transformBis [fN..f1]) x-- if x is one of fN..f1, pick the lowest fi then-- transformBis [fN..f(i+1)] $ fi $ gmap (transformBis [fi..f1]) xtransformBis_ts|isJusthitBoxM=op(sliceMe1n)whereon=dataBox(undefined::a)hitBoxM=readCacheHitMaponhitBox=fromJusthitBoxMuniv=set_toAscList$Set.insert(dataBoxKeyon)$hitBox!dataBoxKeyonn=lengthts-- (a,b), where a < b, and both in range 1..nsliceMeij=fromMaybeMap.empty$intLookup2ijslicesslices::IntMap2(TypeMap(MaybeTransformer))slices=IntMap.fromAscList[(i,IntMap.fromAscList[(j,sliceijts)|(j,ts)<-zip[i..n](tail$initsts)])|(i,ts)<-zip[1..n](tails$reversets)]slice::Int->Int->[[Transformer]]->TypeMap(MaybeTransformer)slicefromtotts=selfwhereself=fMap.empty(zip[from..]tts)-- FIXME: flattening out here gives different results...fa((i,[Transformertktr]):ts)|tk`map_member`a=fats|otherwise=f(Map.inserttkta)tswheret=Just$Transformertk$op(sliceMe(i+1)to).tr.gmapT(op$sliceMefromi)fa[]=a`Map.union`map_fromAscList(mapMaybe(g$map_keysSeta)univ)gat=ifbthenNothingelseJust(t,Nothing)whereb=Set.null$a`Set.intersection`(hitBox!t)op::forallb.Datab=>TypeMap(MaybeTransformer)->b->bopslice=caseMap.lookup(typeKey(undefined::b))sliceofNothing->idJustNothing->gmapT(opslice)Just(Just(Transformer_t))->unsafeCoerce.t.unsafeCoercetransformBis_[]=idtransformBis_([]:xs)=transformBis_xstransformBis_((Transformer_t:x):xs)=everywhere(mkTt).transformBis_(x:xs)