{-# LANGUAGE PatternGuards, ViewPatterns #-}moduleSettings(Severity(..),FuncName,Setting(..),isClassify,isMatchExp,defaultHintName,isUnifyVar,readSettings,readPragma,findSettings)whereimportHSE.AllimportData.CharimportData.ListimportSystem.FilePathimportUtildefaultHintName="Use alternative"-- | How severe an error is.dataSeverity=Ignore-- ^ Ignored errors are only returned when @--show@ is passed.|Warning-- ^ Warnings are things that some people may consider improvements, but some may not.|Error-- ^ Errors are suggestions that should nearly always be a good idea to apply.deriving(Eq,Ord,Show,Read,Bounded,Enum)getSeverity::String->MaybeSeveritygetSeverity"ignore"=JustIgnoregetSeverity"warn"=JustWarninggetSeverity"warning"=JustWarninggetSeverity"error"=JustErrorgetSeverity_=Nothing-- (modulename,functionname)-- either being blank implies universal matchingtypeFuncName=(String,String)-- Any 1-letter variable names are assumed to be unification variablesisUnifyVar::String->BoolisUnifyVar[x]=x=='?'||isAlphaxisUnifyVar_=FalseaddInfixx=x{infixes=infix_(-1)["==>"]++infixesx}----------------------------------------------------------------------- TYPEdataSetting=Classify{severityS::Severity,hintS::String,funcS::FuncName}|MatchExp{severityS::Severity,hintS::String,scope::Scope,lhs::Exp_,rhs::Exp_,side::MaybeExp_,notes::String}|BuiltinString-- use a builtin hint set|InfixFixityderivingShowisClassifyClassify{}=True;isClassify_=FalseisMatchExpMatchExp{}=True;isMatchExp_=False----------------------------------------------------------------------- READ A SETTINGS FILE-- Given a list of hint files to start from-- Return the list of settings commandsreadSettings::FilePath->[FilePath]->IO[Setting]readSettingsdataDirxs=do(builtin,mods)<-fmapunzipEither$concatMapM(readHintsdataDir)xsletfm=concatMap(readSetting$moduleScopem)$concatMapgetEquations$moduleDeclsmreturn$mapBuiltinbuiltin++concatMapfmods-- Read a hint file, and all hint files it importsreadHints::FilePath->FilePath->IO[EitherStringModule_]readHintsdataDirfile=doy<-parseResult$parseFile(addInfixparseFlags)fileys<-concatM[f$fromNamed$importModulei|i<-moduleImportsy,importPkgi`elem`[Just"hint",Just"hlint"]]return$Righty:yswherefx|"HLint.Builtin."`isPrefixOf`x=return[Left$drop14x]|"HLint."`isPrefixOf`x=readHintsdataDir$dataDir</>drop6x<.>"hs"|otherwise=readHintsdataDir$x<.>"hs"readSetting::Scope->Decl_->[Setting]readSettings(FunBind_[Match_(Ident_(getSeverity->Justseverity))pats(UnGuardedRhs_bod)bind])|InfixApp_lhsoprhs<-bod,opExpop~="==>"=let(a,b)=readSide$childrenBibindin[MatchExpseverity(ifnullnamesthendefaultHintNameelseheadnames)s(fromParenlhs)(fromParenrhs)ab]|otherwise=[Classifyseveritynfunc|n<-names2,func<-readFuncsbod]wherenames=filternotNull$getNamespatsbodnames2=[""|nullnames]++namesreadSettingsx|"test"`isPrefixOf`maptoLower(fromNamedx)=[]readSettingsx@AnnPragma{}|Justy<-readPragmax=[y]readSettings(PatBindan(PVar_name)_bodbind)=readSettings$FunBindan[Matchanname[]bodbind]readSettings(FunBindanxs)|lengthxs/=1=concatMap(readSettings.FunBindan.return)xsreadSettings(SpliceDeclan(App_(Var_x)(Lit_y)))=readSettings$FunBindan[Matchan(toNamed$fromNamedx)[PLitany](UnGuardedRhsan$Litan$Stringan"""")Nothing]readSettingsx@InfixDecl{}=mapInfix$getFixityxreadSettingsx=errorOnx"bad hint"-- return Nothing if it is not an HLint pragma, otherwise all the settingsreadPragma::Decl_->MaybeSettingreadPragmao@(AnnPragma_p)=fpwheref(Ann_namex)=g(fromNamedname)xf(TypeAnn_namex)=g(fromNamedname)xf(ModuleAnn_x)=g""xgname(Lit_(String_s_))|"hlint:"`isPrefixOf`maptoLowers=casegetSeverityaofNothing->errorOno"bad classify pragma"Justseverity->Just$Classifyseverity(ltrimb)("",name)where(a,b)=breakisSpace$ltrim$drop6sreadPragma_=NothingreadSide::[Decl_]->(MaybeExp_,String)readSide=foldlf(Nothing,"")wheref(Nothing,warn)(PatBind_PWildCard{}Nothing(UnGuardedRhs_side)Nothing)=(Justside,warn)f(side,"")(PatBind_(fromNamed->"note")Nothing(UnGuardedRhs_(Lit_(String_warn_)))Nothing)=(side,warn)f_x=errorOnx"bad side condition"-- Note: Foo may be ("","Foo") or ("Foo",""), return bothreadFuncs::Exp_->[FuncName]readFuncs(App_xy)=readFuncsx++readFuncsyreadFuncs(Lit_(String_""_))=[("","")]readFuncs(Var_(UnQual_name))=[("",fromNamedname)]readFuncs(Var_(Qual_(ModuleName_mod)name))=[(mod,fromNamedname)]readFuncs(Con_(UnQual_name))=[(fromNamedname,""),("",fromNamedname)]readFuncs(Con_(Qual_(ModuleName_mod)name))=[(mod++"."++fromNamedname,""),(mod,fromNamedname)]readFuncsx=errorOnx"bad classification rule"getNames::[Pat_]->Exp_->[String]getNamesps_|ps/=[]&&allisPStringps=mapfromPStringpsgetNames[](InfixApp_lhsoprhs)|opExpop~="==>"=map("Use "++)nameswherelnames=mapf$childrenSlhsrnames=mapf$childrenSrhsnames=filter(not.isUnifyVar)$(rnames\\lnames)++rnamesf(Ident_x)=xf(Symbol_x)=xgetNames__=[]errorOn::(Annotatedast,Pretty(astS))=>astS->String->berrorOnvalmsg=exitMessage$showSrcLoc(getPointLoc$annval)++": Error while reading hint file, "++msg++"\n"++prettyPrintval----------------------------------------------------------------------- FIND SETTINGS IN A SOURCE FILE-- find definitions in a source filefindSettings::ParseFlags->FilePath->IO(String,[Setting])findSettingsflagsfile=dox<-parseFileflagsfilecasesndxofParseFailedslmsg->return("-- Parse error "++showSrcLocsl++": "++msg,[])ParseOkm->doletxs=concatMap(findSetting$UnQualan)(moduleDeclsm)s=unlines$["-- hints found in "++file]++mapprettyPrintxs++["-- no hints found"|nullxs]r=concatMap(readSettingemptyScope)xsreturn(s,r)findSetting::(NameS->QNameS)->Decl_->[Decl_]findSettingqual(InstDecl___(Justxs))=concatMap(findSettingqual)[x|InsDecl_x<-xs]findSettingqual(PatBind_(PVar_name)Nothing(UnGuardedRhs_bod)Nothing)=findExp(qualname)[]bodfindSettingqual(FunBind_[InfixMatch_p1namepsrhsbind])=findSettingqual$FunBindan[Matchanname(p1:ps)rhsbind]findSettingqual(FunBind_[Match_nameps(UnGuardedRhs_bod)Nothing])=findExp(qualname)[]$LambdaanpsbodfindSetting_x@InfixDecl{}=[x]findSetting__=[]-- given a result function name, a list of variables, a body expression, give some hintsfindExp::QNameS->[String]->Exp_->[Decl_]findExpnamevs(Lambda_psbod)|lengthps2==lengthps=findExpname(vs++ps2)bod|otherwise=[]whereps2=[x|PVar_x<-mapviewps]findExpnamevsVar{}=[]findExpnamevs(InfixApp_xdoty)|isDotdot=findExpname(vs++["_hlint"])$Appanx$Parenan$Appany(toNamed"_hlint")findExpnamevsbod=[PatBindan(toNamed"warn")Nothing(UnGuardedRhsan$InfixAppanlhs(toNamed"==>")rhs)Nothing]wherelhs=g$transformfbodrhs=apps$Varanname:mapsndreprep=zipvs$map(toNamed.return)['a'..]fxx|Var_x<-viewxx,Justy<-lookupxrep=yf(InfixApp_xdoly)|isDoldol=Appanx(pareny)fx=xgo@(InfixApp___x)|isAnyAppx||isAtomx=ogo@App{}=ogo=pareno