moduleCSPM.DataStructures.TypeswhereimportControl.Monad.TransimportData.IORefimportData.ListimportCSPM.DataStructures.NamesimportUtil.PartialFunctionsimportUtil.PrettyPrint-- *************************************************************************-- Types-- *************************************************************************newtypeTypeVar=TypeVarIntderiving(Eq,Show)dataTypeScheme=ForAll[(TypeVar,[Constraint])]Typederiving(Eq,Show)dataConstraint=Eq|Ordderiving(Eq,Ord,Show)-- During Type Checking we use TDotable a b only when a is something-- atomic. Except, during unification we start doing TDotable (TDot...)-- and may build up large TDotable a b types.dataType=TVarTypeVarRef|TProc|TInt|TBool|TEvent-- Something that can be extended to an event (only used internally)|TEventable|TSetType|TSeqType|TDotTypeType|TTuple[Type]-- Arguments to result type|TFunction[Type]Type-- TDotable a b means that this type can be dotted-- with an a to yield something of type b|TDotableTypeType|TDatatypeNamederiving(Eq,Show)dataTypeVarRef=TypeVarRefTypeVar[Constraint]PTypeinstanceEqTypeVarRefwhere(TypeVarReftv1cs1pt1)==(TypeVarReftv2cs2pt2)=tv1==tv2instanceShowTypeVarRefwhereshow(TypeVarReftvcs_)="TypeVarRef "++showtv++showcsnewtypeIORefMaybea=IORefMaybe(Maybea)typeSymbolTable=PartialFunctionNameTypeSchemetypePType=IORef(MaybeType)typePSymbolTable=IORefSymbolTablereadPType::(MonadIOm)=>PType->m(MaybeType)readPTypeioref=liftIO$readIORefiorefsetPType::(MonadIOm)=>PType->Type->m()setPTypeioreft=liftIO$writeIORefioref(Justt)freshPType::(MonadIOm)=>mPTypefreshPType=liftIO$newIORefNothingreadPSymbolTable::(MonadIOm)=>PSymbolTable->mSymbolTablereadPSymbolTableioref=liftIO$readIORefiorefsetPSymbolTable::(MonadIOm)=>PSymbolTable->SymbolTable->m()setPSymbolTableioreft=liftIO$writeIORefioreftfreshPSymbolTable::(MonadIOm)=>mPSymbolTablefreshPSymbolTable=liftIO$newIORef[]instancePrettyPrintableConstraintwhereprettyPrintEq=text"Eq"prettyPrintOrd=text"Ord"-- | Pretty prints several types using the same variable substitutionsprettyPrintTypes::[Type]->[Doc]prettyPrintTypests=map(prettyPrintTypevmap)tswherevs=(nub.mapfst.concatMapcollectConstraints)ts-- | Map from int to letter to improve presentationvmap=zip(map(\(TypeVarn)->n)vs)['a'..'z']instancePrettyPrintableTypewhereprettyPrintt=prettyPrint(ForAll(collectConstraintst)t)instancePrettyPrintableTypeSchemewhereprettyPrint(ForAlltst)=(iflengthvarsWithCs>0then(iflengthvarsWithCs>1thenparensconstraintsTextelseconstraintsText)<+>text"=> "elseempty)<>prettyPrintTypevmaptwhere-- | Map from int to letter to improve presentationvmap=zip(map(\(TypeVarn,_)->n)ts)['a'..'z']-- | Vars with constraintsvarsWithCs=[(v,c)|(v,cs)<-ts,c<-cs,cs/=[]]constraintsText=hsep(punctuatecomma[prettyPrintc<+>char(applyvmapn)|(TypeVarn,c)<-varsWithCs])prettyPrintType::PartialFunctionIntChar->Type->DocprettyPrintTypevmap(TVar(TypeVarRef(TypeVarn)csioref))=casesafeApplyvmapnofJustc->charcNothing->intnprettyPrintTypevmap(TFunctiontargstr)=parens(hsep(punctuatecomma(map(prettyPrintTypevmap)targs)))<+>text"->"<+>prettyPrintTypevmaptrprettyPrintTypevmap(TSeqt)=char'<'<>prettyPrintTypevmapt<>char'>'prettyPrintTypevmap(TSett)=char'{'<>prettyPrintTypevmapt<>char'}'prettyPrintTypevmap(TTuplets)=parens(hsep(punctuatecomma(map(prettyPrintTypevmap)ts)))prettyPrintTypevmap(TDott1t2)=(caset1ofTDotable__->parens(prettyPrintTypevmapt1)_->prettyPrintTypevmapt1)<>text"."<>prettyPrintTypevmapt2prettyPrintTypevmap(TDotablet1t2)=prettyPrintTypevmapt1<>text"=>"<>prettyPrintTypevmapt2prettyPrintTypevmap(TDatatype(Namen))=textnprettyPrintTypevmap(TBool)=text"Bool"prettyPrintTypevmap(TInt)=text"Int"prettyPrintTypevmap(TProc)=text"Proc"prettyPrintTypevmap(TEvent)=text"Event"prettyPrintTypevmap(TEventable)=text"Event or Channel"collectConstraints::Type->[(TypeVar,[Constraint])]collectConstraints=combine.collectwherecombine::[(TypeVar,[Constraint])]->[(TypeVar,[Constraint])]combinexs=map(\ys->(head(mapfstys),nub(concat(mapsndys))))(groupBy(\(v1,_)(v2,_)->v1==v2)xs)collect::Type->[(TypeVar,[Constraint])]collect(TVar(TypeVarRefvcs_))=[(v,cs)]collect(TFunctiontargstr)=concatMapcollecttargs++collecttrcollect(TSeqt)=collecttcollect(TSett)=collecttcollect(TTuplets)=concatMapcollecttscollect(TDott1t2)=collectt1++collectt2collect(TDotablet1t2)=collectt1++collectt2collect(TDatatype_)=[]collectTBool=[]collectTInt=[]collectTProc=[]collectTEvent=[]collectTEventable=[]