{-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-}-- | This module captures annotations on a value, and builds a 'Capture' value.-- This module has two ways of writing annotations:---- /Impure/: The impure method of writing annotations is susceptible to over-optimisation by GHC-- - sometimes @\{\-\# OPTIONS_GHC -fno-cse \#\-\}@ will be required.---- /Pure/: The pure method is more verbose, and lacks some type safety.---- As an example of the two styles:---- > data Foo = Foo {foo :: Int, bar :: Int}---- @ impure = 'capture' $ Foo {foo = 12, bar = 'many' [1 '&=' \"inner\", 2]} '&=' \"top\"@---- @ pure = 'capture_' $ 'record' Foo{} [foo := 12, bar :=+ ['atom' 1 '+=' \"inner\", 'atom' 2]] '+=' \"top\"@---- Both evaluate to:---- > Capture (Ann "top") (Ctor (Foo 12 1) [Value 12, Many [Ann "inner" (Value 1), Value 2]]moduleSystem.Console.CmdArgs.Annotate(-- * Capture frameworkCapture(..),Any(..),fromCapture,defaultMissing,-- * Impurecapture,many,(&=),-- * Purecapture_,many_,(+=),atom,record,Annotate((:=),(:=+)))whereimportControl.MonadimportControl.Monad.Trans.StateimportData.Data(Data,Typeable)importData.ListimportData.MaybeimportData.IORefimportSystem.IO.UnsafeimportControl.ExceptionimportData.Generics.Anyinfixl2&=,+=infix3:=-- | The result of capturing some annotations.dataCaptureann=Many[Captureann]-- ^ Many values collapsed ('many' or 'many_')|Annann(Captureann)-- ^ An annotation attached to a value ('&=' or '+=')|ValueAny-- ^ A value (just a value, or 'atom')|MissingAny-- ^ A missing field (a 'RecConError' exception, or missing from 'record')|CtorAny[Captureann]-- ^ A constructor (a constructor, or 'record')derivingShowinstanceFunctorCapturewherefmapf(Manyxs)=Many$map(fmapf)xsfmapf(Annax)=Ann(fa)$fmapfxfmapf(Valuex)=Valuexfmapf(Missingx)=Missingxfmapf(Ctorxxs)=Ctorx$map(fmapf)xs-- | Return the value inside a capture.fromCapture::Captureann->AnyfromCapture(Many(x:_))=fromCapturexfromCapture(Ann_x)=fromCapturexfromCapture(Valuex)=xfromCapture(Missingx)=xfromCapture(Ctorx_)=x-- | Remove all Missing values by using any previous instances as default valuesdefaultMissing::Captureann->CaptureanndefaultMissingx=evalState(fNothingNothingx)[]wherefctorfield(Manyxs)=fmapMany$mapM(fctorfield)xsfctorfield(Annax)=fmap(Anna)$fctorfieldxfctorfield(Valuex)=return$Valuexf(Justctor)(Justfield)(Missingx)=dos<-getreturn$head$[x2|(ctor2,field2,x2)<-s,typeOfctor==typeOfctor2,field==field2]++err("missing value encountered, no field for "++field++" (of type "++showx++")")f__(Missingx)=err$"missing value encountered, but not as a field (of type "++showx++")"f__(Ctorxxs)|length(fieldsx)==lengthxs=doys<-zipWithM(gx)(fieldsx)xsreturn$Ctor(recomposex$mapfromCaptureys)ysf__(Ctorxxs)=fmap(Ctorx)$mapM(fNothingNothing)xsgctorfieldx=doy<-f(Justctor)(Justfield)xmodify((ctor,field,y):)returnyerrx=error$"System.Console.CmdArgs.Annotate.defaultMissing, "++x----------------------------------------------------------------------- IMPURE BIT-- test = show $ capture $ many [Just ((66::Int) &= P 1 &= P 2), Nothing &= P 8] &= P 3{-
Notes On Purity
---------------
There is a risk that things that are unsafe will be inlined. That can generally be
removed by NOININE on everything.
There is also a risk that things get commoned up. For example:
foo = trace "1" 1
bar = trace "1" 1
main = do
evaluate foo
evaluate bar
Will print "1" only once, since foo and bar share the same pattern. However, if
anything in the value is a lambda they are not seen as equal. We exploit this by
defining const_ and id_ as per this module.
Now anything wrapped in id_ looks different from anything else.
-}{-
The idea is to keep a stack of either continuations, or values
If you encounter 'many' you become a value
If you encounter '&=' you increase the continuation
-}{-# NOINLINE ref #-}ref::IORef[Either(CaptureAny->CaptureAny)(CaptureAny)]ref=unsafePerformIO$newIORef[]push=modifyIORefref(Leftid:)pop=dox:xs<-readIORefref;writeIORefrefxs;returnxchangef=modifyIORefref$\x->casexofLeftg:rest->fg:rest;_->error"Internal error in Capture"addf=change$\x->Left$x.fsetx=change$\f->Right$fx-- | Collapse multiple values in to one.{-# NOINLINE many #-}many::Dataval=>[val]->valmanyxs=unsafePerformIO$doys<-mapM(force.Any)xsset$Manyysreturn$headxs{-# NOINLINE addAnn #-}addAnn::(Dataval,Dataann)=>val->ann->valaddAnnxy=unsafePerformIO$doadd(Ann$Anyy)evaluatexreturnx-- | Capture a value. Note that if the value is evaluated-- more than once the result may be different, i.e.---- > capture x /= capture x{-# NOINLINE capture #-}capture::(Dataval,Dataann)=>val->Captureanncapturex=unsafePerformIO$fmap(fmapfromAny)$force$Anyxforce::Any->IO(CaptureAny)forcex@(Anyxx)=dopushres<-try$evaluatexxy<-popcaseyof_|Left(_::RecConError)<-res->return$MissingxRightr->returnrLeftf|not$isAlgTypex->return$f$Valuex|otherwise->docs<-mapMforce$childrenxreturn$f$Ctorxcs-- | Add an annotation to a value.---- It is recommended that anyone making use of this function redefine-- it with a more restrictive type signature to control the type of the-- annotation (the second argument). Any redefinitions of this function-- should add an INLINE pragma, to reduce the chance of incorrect-- optimisations.{-# INLINE (&=) #-}(&=)::(Dataval,Dataann)=>val->ann->val(&=)xy=addAnn(id_x)(id_y){-# INLINE id_ #-}id_::a->aid_x=caseunitof()->xwhereunit=reverse""`seq`()----------------------------------------------------------------------- PURE PART-- | This type represents an annotated value. The type of the underlying value is not specified.dataAnnotateann=forallcf.(Datac,Dataf)=>(c->f):=f-- ^ Construct a field, @fieldname := value@.|forallcf.(Datac,Dataf)=>(c->f):=+[Annotateann]-- ^ Add annotations to a field.|AAnnann(Annotateann)|AMany[Annotateann]|AAtomAny|ACtorAny[Annotateann]derivingTypeable-- specifically DOES NOT derive Data, to avoid people accidentally including it-- | Add an annotation to a value.(+=)::Annotateann->ann->Annotateann(+=)=flipAAnn-- | Collapse many annotated values in to one.many_::[Annotatea]->Annotateamany_=AMany-- | Lift a pure value to an annotation.atom::Dataval=>val->Annotateannatom=AAtom.Any-- | Create a constructor/record. The first argument should be-- the type of field, the second should be a list of fields constructed-- originally defined by @:=@ or @:=+@.---- This operation is not type safe, and may raise an exception at runtime-- if any field has the wrong type or label.record::Dataa=>a->[Annotateann]->Annotateannrecordab=ACtor(Anya)b-- | Capture the annotations from an annotated value.capture_::Showa=>Annotatea->Captureacapture_(AAnnax)=Anna(capture_x)capture_(AManyxs)=Many(mapcapture_xs)capture_(AAtomx)=Valuexcapture_(_:=c)=Value$Anyccapture_(_:=+c)=Many$mapcapture_ccapture_(ACtorxxs)|not$nullrep=error$"Some fields got repeated under "++showx++"."++ctorx++": "++showrep|otherwise=Ctorx2xs2wherex2=recomposex$mapfromCapturexs2xs2=[fromMaybe(Missingc)$lookupiis|letis=zipinds$mapcapture_xs,(i,c)<-zip[0..]$childrenx]inds=zipWithfromMaybe[0..]$map(fieldIndexx)xsrep=inds\\nubindsfieldIndex::Any->Annotatea->MaybeIntfieldIndexctor(AAnnax)=fieldIndexctorxfieldIndexctor(f:=_)=fieldIndexctor(f:=+[])fieldIndexctor(f:=+_)|isJustres=res|otherwise=error$"Couldn't resolve field for "++showctorwherec=recomposector[Any$throwInti`asTypeOf`x|(i,Anyx)<-zip[0..](childrenctor)]res=catchInt$f$fromAnycfieldIndex__=NothingdataExceptionInt=ExceptionIntIntderiving(Show,Typeable)instanceExceptionExceptionIntthrowInt::Int->athrowInti=throw(ExceptionInti){-# NOINLINE catchInt #-}catchInt::a->MaybeIntcatchIntx=unsafePerformIO$doy<-try(evaluatex)return$caseyofLeft(ExceptionIntz)->Justz_->Nothing