diff --git a/Language/Haskell/Tools/Refactor/Builtin.hs b/Language/Haskell/Tools/Refactor/Builtin.hs --- a/Language/Haskell/Tools/Refactor/Builtin.hs +++ b/Language/Haskell/Tools/Refactor/Builtin.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} -module Language.Haskell.Tools.Refactor.Builtin ( builtinRefactorings ) where +{-# LANGUAGE FlexibleContexts, MonoLocalBinds #-} -import Language.Haskell.Tools.Refactor (RefactoringChoice) +module Language.Haskell.Tools.Refactor.Builtin ( builtinRefactorings, builtinQueries ) where + +import Language.Haskell.Tools.Refactor (RefactoringChoice, QueryChoice) import Language.Haskell.Tools.Refactor.Builtin.ExtractBinding (extractBindingRefactoring) import Language.Haskell.Tools.Refactor.Builtin.FloatOut (floatOutRefactoring) import Language.Haskell.Tools.Refactor.Builtin.GenerateExports (generateExportsRefactoring) @@ -10,6 +11,8 @@ import Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions (organizeExtensionsRefactoring, projectOrganizeExtensionsRefactoring) import Language.Haskell.Tools.Refactor.Builtin.OrganizeImports (organizeImportsRefactoring, projectOrganizeImportsRefactoring) import Language.Haskell.Tools.Refactor.Builtin.RenameDefinition (renameDefinitionRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.GetMatches (getMatchesQuery) +import Language.Haskell.Tools.Refactor.Builtin.AutoCorrect builtinRefactorings :: [RefactoringChoice] builtinRefactorings @@ -23,4 +26,8 @@ , extractBindingRefactoring , organizeExtensionsRefactoring , projectOrganizeExtensionsRefactoring + , autoCorrectRefactoring ] + +builtinQueries :: [QueryChoice] +builtinQueries = [ getMatchesQuery ] diff --git a/Language/Haskell/Tools/Refactor/Builtin/AutoCorrect.hs b/Language/Haskell/Tools/Refactor/Builtin/AutoCorrect.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/AutoCorrect.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleContexts, MonoLocalBinds, ScopedTypeVariables, TupleSections, ViewPatterns #-} + +module Language.Haskell.Tools.Refactor.Builtin.AutoCorrect (autoCorrect, tryItOut, autoCorrectRefactoring) where + +import SrcLoc +import GHC +import Type +-- import Outputable +-- +import Control.Monad.State +import Control.Reference +import Data.List +import Data.Maybe +-- +import Language.Haskell.Tools.Refactor as HT +-- +import Language.Haskell.Tools.PrettyPrint + +autoCorrectRefactoring :: RefactoringChoice +autoCorrectRefactoring = SelectionRefactoring "AutoCorrect" (localRefactoring . autoCorrect) + +tryItOut :: String -> String -> IO () +tryItOut mod sp = tryRefactor (localRefactoring . autoCorrect) mod sp + +autoCorrect :: RealSrcSpan -> LocalRefactoring +autoCorrect sp mod + = do res <- mapM (\f -> f sp mod) [reParen, reOrder] + case catMaybes res of mod':_ -> return mod' + [] -> refactError "Cannot auto-correct the selection." + +-------------------------------------------------------------------------------------------- + +reOrder :: RealSrcSpan -> HT.Module -> LocalRefactor (Maybe HT.Module) +reOrder sp mod = do let accessibleMods = semanticsModule mod : semanticsPrelTransMods mod ++ concatMap semanticsTransMods (mod ^? modImports & annList :: [HT.ImportDecl]) + rng:_ = map getRange (mod ^? nodesContained sp :: [Expr]) + insts <- liftGhc $ fst <$> getInstances accessibleMods + (res,done) <- liftGhc $ flip runStateT False ((nodesContained sp & filtered ((==rng) . getRange) !~ reOrderExpr insts) mod) + return (if done then Just res else Nothing) + +reOrderExpr :: [ClsInst] -> Expr -> StateT Bool Ghc Expr +reOrderExpr insts e@(App (App f a1) a2) + = do funTy <- lift $ typeExpr f + arg1Ty <- lift $ typeExpr a1 + arg2Ty <- lift $ typeExpr a2 + -- liftIO $ putStrLn $ (show $ isJust $ appTypeMatches insts funTy [arg1Ty, arg2Ty]) ++ " " ++ (show $ isJust $ appTypeMatches insts funTy [arg2Ty, arg1Ty]) ++ " " ++ (showSDocUnsafe $ ppr $ funTy) ++ " " ++ (showSDocUnsafe $ ppr $ arg1Ty) ++ " " ++ (showSDocUnsafe $ ppr $ arg2Ty) + if not (isJust (appTypeMatches insts funTy [arg1Ty, arg2Ty])) && isJust (appTypeMatches insts funTy [arg2Ty, arg1Ty]) + then put True >> return (exprArg .= a1 $ exprFun&exprArg .= a2 $ e) + else return e +reOrderExpr insts e@(InfixApp lhs op rhs) + = do let funTy = idType $ semanticsId (op ^. operatorName) + lhsTy <- lift $ typeExpr lhs + rhsTy <- lift $ typeExpr rhs + -- liftIO $ putStrLn $ (show $ isJust $ appTypeMatches insts funTy [lhsTy, rhsTy]) ++ " " ++ (show $ isJust $ appTypeMatches insts funTy [lhsTy, rhsTy]) ++ " " ++ (showSDocUnsafe $ ppr $ funTy) ++ " " ++ (showSDocUnsafe $ ppr $ lhsTy) ++ " " ++ (showSDocUnsafe $ ppr $ rhsTy) + if not (isJust (appTypeMatches insts funTy [lhsTy, rhsTy])) && isJust (appTypeMatches insts funTy [rhsTy, lhsTy]) + then put True >> return (exprLhs .= rhs $ exprRhs .= lhs $ e) + else return e +reOrderExpr _ e = return e + +------------------------------------------------------------------------------------------ + +reParen :: RealSrcSpan -> HT.Module -> LocalRefactor (Maybe HT.Module) +reParen sp mod = do let accessibleMods = semanticsModule mod : semanticsPrelTransMods mod ++ concatMap semanticsTransMods (mod ^? modImports & annList :: [HT.ImportDecl]) + rng:_ = map getRange (mod ^? nodesContained sp :: [Expr]) + insts <- liftGhc $ fst <$> getInstances accessibleMods + (res,done) <- liftGhc $ flip runStateT False ((nodesContained sp & filtered ((==rng) . getRange) !~ reParenExpr insts) mod) + return (if done then Just res else Nothing) + +reParenExpr :: [ClsInst] -> Expr -> StateT Bool Ghc Expr +reParenExpr insts e = do atoms <- lift $ extractAtoms e + case correctParening insts $ map (_2 .- Left) atoms of + [e'] -> put True >> return (wrapAtom e') + [] -> return e + ls -> -- TODO: choose the best one + error $ "multiple correct parentheses were found: " ++ intercalate ", " (map (either prettyPrintAtom prettyPrint) ls) + +data Atom = NameA HT.Name + | OperatorA Operator + | LiteralA Literal + +prettyPrintAtom :: Atom -> String +prettyPrintAtom (NameA n) = prettyPrint n +prettyPrintAtom (OperatorA o) = prettyPrint o +prettyPrintAtom (LiteralA l) = prettyPrint l + +type Build = Either Atom Expr + +extractAtoms :: Expr -> Ghc [(GHC.Type, Atom)] +extractAtoms e = do lits <- mapM (\l -> (, LiteralA l) <$> literalType l) (e ^? biplateRef) + return $ sortOn (srcSpanStart . atomRange . snd) + $ map (\n -> (idType $ semanticsId (n ^. simpleName), NameA n)) (e ^? biplateRef) + ++ map (\o -> (idType $ semanticsId (o ^. operatorName), OperatorA o)) (e ^? biplateRef) + ++ lits + +atomRange :: Atom -> SrcSpan +atomRange (NameA n) = getRange n +atomRange (OperatorA n) = getRange n +atomRange (LiteralA n) = getRange n + +wrapAtom :: Build -> Expr +wrapAtom (Right e) = e +wrapAtom (Left (NameA n)) = mkVar n +wrapAtom (Left (OperatorA (NormalOp o))) = mkVar (mkParenName o) +wrapAtom (Left (OperatorA (BacktickOp n))) = mkVar (mkNormalName n) +wrapAtom (Left (LiteralA l)) = mkLit l + +correctParening :: [ClsInst] -> [(GHC.Type, Build)] -> [Build] +correctParening _ [(_,e)] = [e] +correctParening insts ls = concatMap (correctParening insts) (reduceAtoms insts ls) + +reduceAtoms :: [ClsInst] -> [(GHC.Type, Build)] -> [[(GHC.Type, Build)]] +reduceAtoms _ [(t,e)] = [[(t,e)]] +reduceAtoms insts ls = concatMap (reduceBy insts ls) [0 .. length ls - 2] + +reduceBy :: [ClsInst] -> [(GHC.Type, Build)] -> Int -> [[(GHC.Type, Build)]] +reduceBy insts (zip [0..] -> ls) i = maybeToList (reduceFunctionApp ls i) ++ maybeToList (reduceOperatorApp ls i) + where reduceFunctionApp ls i | Just (funT, fun) <- lookup i ls + , Just (argT, arg) <- lookup (i+1) ls + , Just (subst, resTyp) <- appTypeMatches insts funT [argT] + = Just $ map ((_1 .- substTy subst) . snd) (take i ls) + ++ [(resTyp, mkParen' (mkApp' fun arg))] + ++ map ((_1 .- substTy subst) . snd) (drop (i + 2) ls) + reduceFunctionApp _ _ = Nothing + + reduceOperatorApp ls i | Just (opT, Left (OperatorA op)) <- lookup i ls + , Just (lArgT, lArg) <- lookup (i-1) ls + , Just (rArgT, rArg) <- lookup (i+1) ls + , Just (subst, resTyp) <- appTypeMatches insts opT [lArgT, rArgT] + = Just $ map ((_1 .- substTy subst) . snd) (take (i - 1) ls) + ++ [(resTyp, mkParen' (mkInfixApp' lArg op rArg))] + ++ map ((_1 .- substTy subst) . snd) (drop (i + 2) ls) + reduceOperatorApp _ _ = Nothing + +mkApp' :: Build -> Build -> Build +mkApp' (wrapAtom -> f) (wrapAtom -> a) = Right $ mkApp f a + +mkInfixApp' :: Build -> Operator -> Build -> Build +mkInfixApp' (wrapAtom -> lhs) op (wrapAtom -> rhs) = Right $ mkInfixApp lhs op rhs + +mkParen' :: Build -> Build +mkParen' (wrapAtom -> e) = Right $ mkParen e diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs @@ -1,25 +1,32 @@ module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers - ( module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FlexibleInstancesChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker - , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker + ( module X ) where -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FlexibleInstancesChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ArrowsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstraintKindsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstrainedClassMethodsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DefaultSignaturesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitForAllChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitNamespacesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FlexibleInstancesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FunctionalDependenciesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.GADTsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.KindSignaturesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiParamTypeClassesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiWayIfChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.OverloadedStringsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ParallelListCompChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecursiveDoChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeFamiliesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeOperatorsChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeSynonymInstancesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker as X +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker as X diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ArrowsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ArrowsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ArrowsChecker.hs @@ -0,0 +1,12 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ArrowsChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkArrowsExpr :: CheckNode Expr +-- chkArrowsExpr e@Proc{} = addOccurence Arrows e +chkArrowsExpr e@ArrowApp{} = addOccurence Arrows e +chkArrowsExpr e = return e + +chkArrowsCmd :: CheckNode Cmd +chkArrowsCmd = addOccurence Arrows diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker where import Language.Haskell.Tools.Refactor import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad - --- NOTE: Here we implicitly constrained the type with ExtDomain. --- but we don't really need any. chkBangPatterns :: CheckNode Pattern chkBangPatterns = conditional chkBangPatterns' BangPatterns diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstrainedClassMethodsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstrainedClassMethodsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstrainedClassMethodsChecker.hs @@ -0,0 +1,60 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstrainedClassMethodsChecker where + +import qualified GHC +import qualified Class as GHC +import qualified VarSet as GHC +import qualified TcType as GHC + +import Control.Monad.Trans.Maybe (MaybeT(..)) + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkConstrainedClassMethodsDecl :: CheckNode Decl +chkConstrainedClassMethodsDecl = conditional chkCCMDecl ConstrainedClassMethods + where chkCCMDecl cd@(ClassDecl _ dh _ _) = chkCCMDeclHead dh >> return cd + chkCCMDecl x = return x + +-- | Check a DeclHead for ConstrainedClassMethods. +-- Adds the extension if it is needed or the lookup fails. +chkCCMDeclHead :: CheckNode DeclHead +chkCCMDeclHead dh = do + mNeedsCCM <- runMaybeT . chkCCMDeclHead' $ dh + case mNeedsCCM of + Just False -> return dh + _ -> addOccurence ConstrainedClassMethods dh + + +-- | Helper function for chkCCMDeclHead. +-- True <=> Lookup is succesful and ConstrainedClassMethods is needed +-- False <=> Lookup is succesful, but CCM is not needed, or the argument is not a class DeclHead +-- fails <=> Lookup is unsuccesful (either name or type lookup) +chkCCMDeclHead' :: DeclHead -> MaybeT ExtMonad Bool +chkCCMDeclHead' dh = do + sname <- declHeadSemName dh + tything <- MaybeT . GHC.lookupName $ sname + case tything of + GHC.ATyCon tc | GHC.isClassTyCon tc -> liftMaybe . fmap classNeedsCCM . GHC.tyConClass_maybe $ tc + _ -> return False + + +-- | Decides whether a class really needs the ConstrainedClassMethods extension +-- A class needs CCM iff at least one of its class methods +-- has a constraint with a non-empty type variable set, that contains only class type variables. +classNeedsCCM :: GHC.Class -> Bool +classNeedsCCM cls = any methodNeedsCCM methods + where + methods = GHC.classMethods cls + tyvars = GHC.classTyVars cls + clsTyVarSet = GHC.mkVarSet tyvars + + methodNeedsCCM :: GHC.Id -> Bool + methodNeedsCCM methodId = any constraintNeedsCCM constraints + where + (_,_,tau) = GHC.tcSplitMethodTy . GHC.idType $ methodId + (_,constraints,_) = GHC.tcSplitNestedSigmaTys tau + + constraintNeedsCCM :: GHC.TcPredType -> Bool + constraintNeedsCCM pred = not (GHC.isEmptyVarSet predTyVars) + && predTyVars `GHC.subVarSet` clsTyVarSet + where predTyVars = GHC.tyCoVarsOfType pred diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstraintKindsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstraintKindsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ConstraintKindsChecker.hs @@ -0,0 +1,48 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstraintKindsChecker where + +import Name as GHC (isTyVarName) +import Kind as GHC (returnsConstraintKind) + +import Control.Reference ((^?), (^.), (&)) + +import Data.Generics.Uniplate.Data() +import Data.Generics.Uniplate.Operations + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + + +chkConstraintKindsDecl :: CheckNode Decl +chkConstraintKindsDecl = conditional chkConstraintKindsDecl' ConstraintKinds + +chkConstraintKindsDecl' :: CheckNode Decl +chkConstraintKindsDecl' d@(TypeDecl dh rhs) + -- Has any constraints of form (x t1 t2) + | ctxts <- universeBi rhs :: [Context] + , any hasTyVarHeadAsserts ctxts + = addOccurence ConstraintKinds d + -- Right-hand side has kind Constraint + | otherwise = do + let ty = typeOrKindFromId . declHeadQName $ dh + if hasConstraintKind ty || returnsConstraintKind ty + then addOccurence ConstraintKinds d + else return d +chkConstraintKindsDecl' d = return d + +hasTyVarHeadAsserts :: Context -> Bool +hasTyVarHeadAsserts = hasAnyTyVarHeads . (^. contextAssertion) + +hasAnyTyVarHeads :: Assertion -> Bool +hasAnyTyVarHeads (ClassAssert n _) + | Just n' <- semanticsName n = isTyVarName n' + | otherwise = False +hasAnyTyVarHeads ta@TupleAssert{} + | Just assertions <- ta ^? innerAsserts & annListElems + = any hasAnyTyVarHeads assertions +hasAnyTyVarHeads _ = False + +declHeadQName :: DeclHead -> QualifiedName +declHeadQName (NameDeclHead n) = n ^. simpleName +declHeadQName (ParenDeclHead dh) = declHeadQName dh +declHeadQName (DeclHeadApp dh _) = declHeadQName dh +declHeadQName (InfixDeclHead _ op _) = op ^. operatorName diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DefaultSignaturesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DefaultSignaturesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DefaultSignaturesChecker.hs @@ -0,0 +1,8 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DefaultSignaturesChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkDefaultSigs :: CheckNode ClassElement +chkDefaultSigs ce@ClsDefaultSig{} = addOccurence DefaultSignatures ce +chkDefaultSigs x = return x diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE FlexibleContexts, MultiWayIf, RankNTypes, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, MultiWayIf, ViewPatterns #-} + {- NOTE: We need Decl level checking in order to gain extra information from the newtype and data keywords. @@ -27,13 +28,11 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.Refactor as Refact hiding (Enum) import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad as Ext -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.TypeLookup import Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Data.Map as Map (fromList, lookup) import qualified GHC (Name(..), isNewTyCon) -import qualified Name as GHC (Name) import PrelNames import THNames (liftClassName) @@ -188,7 +187,7 @@ nameFromStock :: InstanceHead -> Maybe GHC.Name nameFromStock x | InstanceHead name <- skipParens x, - Just sname <- getSemName name, + Just sname <- semanticsName name, isStockClass sname = Just sname | otherwise = Nothing @@ -223,7 +222,6 @@ | Just strat' <- strat = do addOccurence_ Ext.DerivingStrategies d addOccurence_ Ext.StandaloneDeriving d - chkSynonym ty chkStrat strat' cls return d | otherwise = do @@ -254,9 +252,6 @@ {- NOTE: Returns false if the type is certainly not a type synonym. Returns true if it is a synonym for a newtype or it could not have been looked up. - NOTE: It always has the following side-effects: - - If the input is a type synonym, then adds TypeSynonymInstances - (regardless of it being a newtype or not) This behaviour will produce false positives. This is desirable since the underlying type might be a newtype @@ -270,6 +265,4 @@ Just tycon -> isSynNewType' tycon where isSynNewType' x = case lookupSynDef x of Nothing -> return False - Just def -> do - addOccurence_ TypeSynonymInstances t - return (GHC.isNewTyCon def) + Just def -> return (GHC.isNewTyCon def) diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitForAllChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitForAllChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitForAllChecker.hs @@ -0,0 +1,27 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitForAllChecker where + +import Control.Reference ((^.)) + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkExplicitForAllType :: CheckNode Type +chkExplicitForAllType = conditional chkType ExplicitForAll + where chkType :: CheckNode Type + chkType t + | UTyForall{} <- t ^. element + = addOccurence ExplicitForAll t + | otherwise = return t + +chkExplicitForAllConDecl :: CheckNode ConDecl +chkExplicitForAllConDecl = conditional (chkQuantifiedTyVarsWith (^. conTypeArgs)) ExplicitForAll + +chkExplicitForAllGadtConDecl :: CheckNode GadtConDecl +chkExplicitForAllGadtConDecl = conditional (chkQuantifiedTyVarsWith (^. gadtConTypeArgs)) ExplicitForAll + +chkQuantifiedTyVarsWith :: HasRange a => (a -> TyVarList) -> CheckNode a +chkQuantifiedTyVarsWith getTyVars conDecl = + if (annLength . getTyVars $ conDecl) > 0 + then addOccurence ExplicitForAll conDecl + else return conDecl diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitNamespacesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitNamespacesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ExplicitNamespacesChecker.hs @@ -0,0 +1,14 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitNamespacesChecker where + +import Control.Reference ((^.)) + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkExplicitNamespacesIESpec :: CheckNode IESpec +chkExplicitNamespacesIESpec = conditional chkIESpec ExplicitNamespaces + where chkIESpec :: CheckNode IESpec + chkIESpec x@(IESpec (AnnJust imod) _ _) + | UImportType <- imod ^. element = addOccurence ExplicitNamespaces x + chkIESpec x = return x diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs @@ -1,102 +1,84 @@ -{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, GADTs, MultiWayIf #-} module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FlexibleInstancesChecker where -import Control.Reference ((^.), (!~), biplateRef) -import Language.Haskell.Tools.Refactor as Refact -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.TypeLookup (lookupSynDefM) +import qualified GHC +import qualified Class as GHC +import qualified TcType as GHC +import qualified Type as GHC +import qualified TyCoRep as GHC +import qualified Name as GHC (isTyVarName, isTyConName, isWiredInName) +import Util (equalLength) +import ListSetOps (hasNoDups) +import Data.Maybe (mapMaybe) import Control.Monad.Trans.Maybe (MaybeT(..)) + import Data.Data (Data(..)) -import Data.List (nub) +import Data.List (nubBy) +import Data.Function (on) +import Control.Reference ((^.), (.-), biplateRef) -import Name as GHC (isTyVarName, isTyConName, isWiredInName) +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad hiding (StandaloneDeriving) +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeSynonymInstancesChecker + {-# ANN module "HLint: ignore Redundant bracket" #-} -- TODO: write "deriving instance ..." tests (should work) --- TODO: should expand type synonyms !!! - --- NOTE: Here we implicitly constrained the type with ExtDomain. --- but we only really need HasNameInfo. - --- NOTE: We need Decl level checking, in order to distinguish --- class instances from data and type family instances. - -chkFlexibleInstances :: CheckNode Decl -chkFlexibleInstances = conditional chkFlexibleInstances' FlexibleInstances - -chkFlexibleInstances' :: CheckNode Decl -chkFlexibleInstances' d@(Refact.StandaloneDeriving _ _ rule) = checkedReturn rule d -chkFlexibleInstances' d@(InstanceDecl rule _) = checkedReturn rule d -chkFlexibleInstances' d = return d - -checkedReturn :: InstanceRule -> a -> ExtMonad a -checkedReturn rule x = chkInstanceRule rule >> return x +-- NOTE: could use AST.SemaInfoTypes.getInstances (but it doesn't have location info) --- this check DOES transform the AST for its internal computations --- but returns the original one in the end --- NOTE: There are two traversals: --- First one on the class level, and the second one one on the type level. --- Since biplateRef is lazy, it won't go down to the type level in the first traversal -chkInstanceRule :: CheckNode InstanceRule -chkInstanceRule r@(InstanceRule _ _ ihead) = do - chkInstanceHead ihead - return $! r -chkInstanceRule r = return r +-- | We need to check declarations because we want to avoid checking type family instances +chkFlexibleInstancesDecl :: CheckNode Decl +chkFlexibleInstancesDecl = conditional (chkInstancesDeclWith $ chkInstanceRuleWith chkInstanceHead) FlexibleInstances -refact :: - (Data.Data.Data (node dom stage), Data.Data.Data (inner dom stage), - Monad m) => - (inner dom stage -> m (inner dom stage)) - -> node dom stage -> m (node dom stage) -refact op = biplateRef !~ op +refact :: (Data.Data.Data (node dom stage), Data.Data.Data (inner dom stage)) => + (inner dom stage -> inner dom stage) -> + node dom stage -> node dom stage +refact op = biplateRef .- op --- one IHApp will only check its own tyvars (their structure and uniqueness) --- thus with MultiParamTypeclasses each param will be checked independently --- (so the same type variable can appear in multiple params) +-- | Checks every single type argument in an instance declaration +-- If the class being instantiated could not have been looked up, it keeps FlexibleInstances chkInstanceHead :: CheckNode InstanceHead -chkInstanceHead x@(InfixInstanceHead tyvars _) = do - tyvars' <- refact rmTypeMisc tyvars - chkTyVars tyvars' - addOccurence_ MultiParamTypeClasses x - addOccurence_ TypeOperators x - return x -chkInstanceHead app@(AppInstanceHead f tyvars) = do - tyvars' <- refact rmTypeMisc tyvars - chkTyVars tyvars' - case f of - AppInstanceHead _ _ -> addOccurence_ MultiParamTypeClasses app - _ -> return () - chkInstanceHead f - return app -chkInstanceHead x@(ParenInstanceHead h) = do - chkInstanceHead h - return x -chkInstanceHead app = return app +chkInstanceHead ih = do + let types = collectTyArgs ih + mCls <- runMaybeT . lookupClassFromInstance $ ih + case mCls of + Just cls -> mapM_ (chkTypeArg cls) types >> return ih + Nothing -> addOccurence FlexibleInstances ih --- TODO: skip other unnecessary parts of the AST (eg.: UType ctors) --- where can UTyPromoted appear? --- can i write forall in instance heads? --- unboxed tuple (has different kind, can't use in ihead), par array? --- TH ctors --- other misc ... --- synonym expansion (runMaybeT . lookupSynDefM $ vars) (now: if synonym, keep FC) -chkTyVars :: CheckNode Type -chkTyVars vars = do - msyn <- runMaybeT . lookupSynDefM $ vars - maybe (performCheck vars) (const $ addOccurence FlexibleInstances vars) msyn +-- | Checks a type argument of class whether it needs FlexibleInstances +-- First checks the structure of the type argument opaquely +-- Then, for type synonyms, it checks whether their GHC representation itself +-- needs the extension. +-- +-- Might find false positive occurences for phantom types: +-- > type Phatom a b = [a] +-- > instance C (Phatnom a a) +-- > instance C (Phantom a Int) +chkTypeArg :: GHC.Class -> Type -> ExtMonad Type +chkTypeArg cls ty = do + chkNormalTypeArg ty + maybeTM (return ty) (chkSynonymTypeArg cls) (semanticsTypeSynRhs ty) + where chkSynonymTypeArg :: GHC.Class -> GHC.Type -> ExtMonad Type + chkSynonymTypeArg cls' ty' + | tyArgNeedsFI cls' ty' = addOccurence FlexibleInstances ty + | otherwise = return ty +-- | Checks a type argument of class whether it has only (distinct) type variable arguments. +chkNormalTypeArg :: CheckNode Type +chkNormalTypeArg vars = performCheck . refact rmTypeMisc $ vars + where performCheck vars = do (isOk, (_, vs)) <- runStateT (runMaybeT (chkAll vars)) ([],[]) case isOk of Just isOk -> - unless (isOk && length vs == (length . nub $ vs)) --tyvars are different + unless (isOk && length vs == (length . nubBy ((==) `on` (semanticsName . (^. simpleName))) $ vs)) --tyvars are different (addOccurence_ FlexibleInstances vars) - Nothing -> error "chkTyVars: Couldn't look up something" + Nothing -> error "chkNormalTypeArg: Couldn't look up something" return vars chkAll x = @@ -117,16 +99,16 @@ -- NOTE: -XHaskell98 operator type variables?? -- NOTE VarType is either TyCon or TyVar -- if it is a TyCon, it cannot be wired in (Int, Char, etc) - if | isTyVarName sname -> addTyVarM x >> return False - | isWiredInName sname -> addTyConM x >> return False - | isTyConName sname -> addTyConM x >> return True - | otherwise -> return True -- NEVER + if | GHC.isTyVarName sname -> addTyVarM x >> return False + | GHC.isWiredInName sname -> addTyConM x >> return False + | GHC.isTyConName sname -> addTyConM x >> return True + | otherwise -> return True -- NEVER chkUnitTyCon _ = return False chkSingleTyVar (VarType x) = do sname <- tyVarSemNameM x - if (isTyVarName sname) + if (GHC.isTyVarName sname) then addTyVarM x >> return True else addTyConM x >> return False chkSingleTyVar _ = return False @@ -152,8 +134,7 @@ (VarType c) -> addTyConM c >> return True _ -> chkOnlyApp f else return False - chkOnlyApp x@(InfixTypeApp lhs op rhs) = do - lift . lift $ addOccurence_ TypeOperators x + chkOnlyApp (InfixTypeApp lhs op rhs) = do addTyConM . mkNormalName $ (op ^. operatorName) lOK <- chkSingleTyVar lhs rOK <- chkSingleTyVar rhs @@ -167,15 +148,36 @@ tyVarSemNameM x = MaybeT . return . semanticsName $ x ^. simpleName -rmTypeMisc :: CheckNode Type -rmTypeMisc = rmTParens >=> rmTKinded +rmTypeMisc :: Type -> Type +rmTypeMisc (KindedType t _) = t +rmTypeMisc (ParenType x) = x +rmTypeMisc x = x -rmTKinded :: CheckNode Type -rmTKinded kt@(KindedType t _) = addOccurence_ KindSignatures kt >> return t -rmTKinded x = return x +-- Decides whether a type argument of a type class constructor need FlexibleInstances +tyArgNeedsFI :: GHC.Class -> GHC.Type -> Bool +tyArgNeedsFI cls arg = not . hasOnlyDistinctTyVars $ tyArg + where [tyArg] = GHC.filterOutInvisibleTypes (GHC.classTyCon cls) [arg] --- removes Parentheses from the AST --- the structure is reserved -rmTParens :: CheckNode Type -rmTParens (ParenType x) = return x -rmTParens x = return x +-- | Checks whether a GHC.Type is an application, and has only (distinct) type variable arguments +-- Logic from TcValidity.tcInstHeadTyAppAllTyVars +hasOnlyDistinctTyVars :: GHC.Type -> Bool +hasOnlyDistinctTyVars ty + | Just (tc, tys) <- GHC.tcSplitTyConApp_maybe (dropCasts ty) + , tys' <- GHC.filterOutInvisibleTypes tc tys + , tyVars <- mapMaybe GHC.tcGetTyVar_maybe tys' + = tyVars `equalLength` tys' && hasNoDups tyVars + | otherwise = False + + +-- | A local helper function from TcValidity +dropCasts :: GHC.Type -> GHC.Type +dropCasts (GHC.CastTy ty _) = dropCasts ty +dropCasts (GHC.AppTy t1 t2) = GHC.mkAppTy (dropCasts t1) (dropCasts t2) +dropCasts (GHC.FunTy t1 t2) = GHC.mkFunTy (dropCasts t1) (dropCasts t2) +dropCasts (GHC.TyConApp tc tys) = GHC.mkTyConApp tc (map dropCasts tys) +dropCasts (GHC.ForAllTy b ty) = GHC.ForAllTy (dropCastsB b) (dropCasts ty) +dropCasts ty = ty + +-- | A local helper function from TcValidity +dropCastsB :: GHC.TyVarBinder -> GHC.TyVarBinder +dropCastsB b = b diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FunctionalDependenciesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FunctionalDependenciesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FunctionalDependenciesChecker.hs @@ -0,0 +1,7 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FunctionalDependenciesChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkFunDeps :: CheckNode FunDepList +chkFunDeps = addOccurence FunctionalDependencies diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/GADTsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/GADTsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/GADTsChecker.hs @@ -0,0 +1,46 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.GADTsChecker where + +import Data.Maybe (catMaybes, fromMaybe) +import Control.Reference ((^.), (&)) +import Control.Monad.Trans.Maybe (MaybeT(..)) + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + + +-- | Checks a GADT-style constructor if GADTSyntax is turned on. +-- Sometimes GADTSyntax is sufficient and GADTs is not even needed. +chkGADTsGadtConDecl :: CheckNode GadtConDecl +chkGADTsGadtConDecl = conditional chkGADTsGadtConDecl' GADTSyntax + +-- | Checks a data constructor declaration if GADTs or ExistentialQuantification is turned on. +-- This function is responsible for checking ExistentialQuantification as well. +-- (there is no separate checker for that extension) +chkConDeclForExistentials :: CheckNode ConDecl +chkConDeclForExistentials = conditionalAny chkConDeclForExistentials' [GADTs, ExistentialQuantification] + +-- If all data constructors are vanilla Haskell 98 data constructors, then only GADTSyntax is needed. +chkGADTsGadtConDecl' :: CheckNode GadtConDecl +chkGADTsGadtConDecl' conDecl = do + let conNames = conDecl ^. (gadtConNames & annListElems) + mres <- mapM (runMaybeT . isVanillaDataConNameM) conNames + if and . catMaybes $ mres + then addOccurence GADTSyntax conDecl + else do addOccurence GADTSyntax conDecl + addRelation (GADTs `lOr` ExistentialQuantification) conDecl + +-- Extracts the name from a ConDecl, and checks whether it is a vanilla +-- data constructor. +chkConDeclForExistentials' :: CheckNode ConDecl +chkConDeclForExistentials' conDecl = liftM (fromMaybe conDecl) . runMaybeT $ + case conDecl ^. element of + UConDecl _ _ n _ -> chkName n + URecordDecl _ _ n _ -> chkName n + UInfixConDecl _ _ _ op _ -> chkName (op ^. operatorName) + where chkName :: HasNameInfo' n => n -> MaybeT ExtMonad ConDecl + chkName n = do + isVanilla <- isVanillaDataConNameM n + if isVanilla + then return conDecl + else lift . addRelation (GADTs `lOr` ExistentialQuantification) $ conDecl diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/KindSignaturesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/KindSignaturesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/KindSignaturesChecker.hs @@ -0,0 +1,8 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.KindSignaturesChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkKindSignaturesKind :: CheckNode Kind +chkKindSignaturesKind = conditional chkKind KindSignatures + where chkKind = addOccurence KindSignatures diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker where import Language.Haskell.Tools.Refactor as Refact diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiParamTypeClassesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiParamTypeClassesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiParamTypeClassesChecker.hs @@ -0,0 +1,42 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiParamTypeClassesChecker where + +import Control.Reference ((^.)) + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkMultiParamTypeClassesDecl :: CheckNode Decl +chkMultiParamTypeClassesDecl = conditional chkMultiParamTypeClassesDecl' MultiParamTypeClasses + + +-- | Decides whether a class or instance declaration needs MultiParamTypeClasses +-- Also handles the NullaryTypeClasses case +chkMultiParamTypeClassesDecl' :: CheckNode Decl +chkMultiParamTypeClassesDecl' cd@(ClassDecl _ dh _ _) + | n <- length . collectTyVars $ dh + , n /= 1 = addOccurence MultiParamTypeClasses dh >> return cd +chkMultiParamTypeClassesDecl' i@(InstanceDecl rule _) + | isMultiParamNeeded (rule ^. irHead) + = addOccurence MultiParamTypeClasses rule >> return i +chkMultiParamTypeClassesDecl' d = return d + + +collectTyVars :: DeclHead -> [TyVar] +collectTyVars (ParenDeclHead dh) = collectTyVars dh +collectTyVars (DeclHeadApp dh tv) = tv : collectTyVars dh +collectTyVars (InfixDeclHead lhs _ rhs) = [lhs,rhs] +collectTyVars _ = [] + + +-- | Decides whether an instance declaration needs MultiParamTypeClasses +-- Also handles the NullaryTypeClasses case +isMultiParamNeeded :: InstanceHead -> Bool +isMultiParamNeeded InstanceHead{} = True +isMultiParamNeeded InfixInstanceHead{} = True +isMultiParamNeeded (ParenInstanceHead ih) = isMultiParamNeeded ih +isMultiParamNeeded (AppInstanceHead f _) = isMultiParamNeeded' f + -- one level deeper + where isMultiParamNeeded' InstanceHead{} = False + isMultiParamNeeded' InfixInstanceHead{} = True + isMultiParamNeeded' (ParenInstanceHead ih) = isMultiParamNeeded' ih + isMultiParamNeeded' (AppInstanceHead _ _) = True diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiWayIfChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiWayIfChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MultiWayIfChecker.hs @@ -0,0 +1,11 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiWayIfChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkMultiWayIfExpr :: CheckNode Expr +chkMultiWayIfExpr = conditional chkMultiWayIfExpr' MultiWayIf + +chkMultiWayIfExpr' :: CheckNode Expr +chkMultiWayIfExpr' e@(MultiIf _) = addOccurence MultiWayIf e +chkMultiWayIfExpr' x = return x diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/OverloadedStringsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/OverloadedStringsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/OverloadedStringsChecker.hs @@ -0,0 +1,19 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.OverloadedStringsChecker where + +import Type as GHC (eqType) +import TysWiredIn as GHC (stringTy) + +import Control.Reference ((^.)) + +import Language.Haskell.Tools.AST +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkOverloadedStringsLiteral :: CheckNode Literal +chkOverloadedStringsLiteral = conditional chkLit OverloadedStrings + where chkLit :: CheckNode Literal + chkLit lit + | UStringLit _ <- lit ^. element + , not . GHC.eqType GHC.stringTy $ semanticsLiteralType lit + = addOccurence OverloadedStrings lit + | otherwise = return lit diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ParallelListCompChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ParallelListCompChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ParallelListCompChecker.hs @@ -0,0 +1,10 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ParallelListCompChecker where + +import Language.Haskell.Tools.AST (annLength) +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkParallelListComp :: CheckNode Expr +chkParallelListComp e@(ListComp _ body) + | annLength body > 1 = addOccurence ParallelListComp e +chkParallelListComp e = return e diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker where import Language.Haskell.Tools.Refactor (PatternSignature, PatternSynonym) diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecursiveDoChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecursiveDoChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecursiveDoChecker.hs @@ -0,0 +1,12 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecursiveDoChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkRecursiveDoExpr :: CheckNode Expr +chkRecursiveDoExpr e@MDo{} = addOccurence RecursiveDo e +chkRecursiveDoExpr e = return e + +chkRecursiveDoStmt :: CheckNode Stmt +chkRecursiveDoStmt s@RecStmt{} = addOccurence RecursiveDo s +chkRecursiveDoStmt s = return s diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeFamiliesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeFamiliesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeFamiliesChecker.hs @@ -0,0 +1,100 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeFamiliesChecker where + +import TyCon as GHC (TyCon()) +import PrelNames as GHC +import Unique as GHC (hasKey) +import qualified Type as GHC (expandTypeSynonyms) + +import Control.Reference ((^.)) +import Control.Monad.Trans.Maybe (MaybeT(..)) + +import Data.List (zipWith) +import Data.Maybe (catMaybes) +import Data.Generics.Uniplate.Data() +import Data.Generics.Uniplate.Operations +import qualified Data.Map.Strict as SMap + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + + +-- | Checks whether any name's corresponding type in the module contains a type equality. +globalChkNamesForTypeEq :: CheckNode Module +globalChkNamesForTypeEq = conditionalAny globalChkNamesForTypeEq' [TypeFamilies, GADTs] + +-- | Checks an operator for syntactic evidence of a ~ b type equality if TypeFamilies or GADTs is turned on. +chkOperatorForTypeEq :: CheckNode Operator +chkOperatorForTypeEq = conditionalAny chkOperatorForTypeEq' [TypeFamilies, GADTs] + + +-- | Checks a declaration if TypeFamilies is turned on. +chkTypeFamiliesDecl :: CheckNode Decl +chkTypeFamiliesDecl = conditional chkTypeFamiliesDecl' TypeFamilies + +-- | Checks a class element if TypeFamilies is turned on. +chkTypeFamiliesClassElement :: CheckNode ClassElement +chkTypeFamiliesClassElement = conditional chkTypeFamiliesClassElement' TypeFamilies + +-- | Checks an instance body if TypeFamilies is turned on. +chkTypeFamiliesInstBodyDecl :: CheckNode InstBodyDecl +chkTypeFamiliesInstBodyDecl = conditional chkTypeFamiliesInstBodyDecl' TypeFamilies + + + +chkTypeFamiliesDecl' :: CheckNode Decl +chkTypeFamiliesDecl' d@TypeFamily{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d@DataFamily{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d@ClosedTypeFamily{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d@TypeInstance{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d@DataInstance{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d@GadtDataInstance{} = addOccurence TypeFamilies d +chkTypeFamiliesDecl' d = return d + +chkTypeFamiliesClassElement' :: CheckNode ClassElement +chkTypeFamiliesClassElement' ce@ClassElemTypeFam{} = addOccurence TypeFamilies ce +chkTypeFamiliesClassElement' ce@ClassElemDataFam{} = addOccurence TypeFamilies ce +chkTypeFamiliesClassElement' ce@ClsDefaultType{} = addOccurence TypeFamilies ce +chkTypeFamiliesClassElement' ce = return ce + +chkTypeFamiliesInstBodyDecl' :: CheckNode InstBodyDecl +chkTypeFamiliesInstBodyDecl' b@InstanceTypeFamilyDef{} = addOccurence TypeFamilies b +chkTypeFamiliesInstBodyDecl' b@InstanceDataFamilyDef{} = addOccurence TypeFamilies b +chkTypeFamiliesInstBodyDecl' b@InstanceDataFamilyGADTDef{} = addOccurence TypeFamilies b +chkTypeFamiliesInstBodyDecl' b = return b + + +chkOperatorForTypeEq' :: CheckNode Operator +chkOperatorForTypeEq' op + | Just name <- semanticsName (op ^. operatorName) + , name == eqTyConName + = addRelation (TypeFamilies `lOr` GADTs) op + | otherwise = return op + +chkNameForTyEqn :: CheckNode Name +chkNameForTyEqn name = do + mty <- runMaybeT . lookupTypeFromId $ name + case mty of + Just ty -> do + let ty' = GHC.expandTypeSynonyms ty + tycons = universeBi ty' :: [GHC.TyCon] + if any isEqTyCon tycons then addRelation (TypeFamilies `lOr` GADTs) name + else return name + Nothing -> return name + + --traceShow (showName name ++ " -- " ++ showOutputable ty') $ + + where isEqTyCon tc = tc `hasKey` eqTyConKey + || tc `hasKey` heqTyConKey + || tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + || tc `hasKey` eqPhantPrimTyConKey + +globalChkNamesForTypeEq' :: CheckNode Module +globalChkNamesForTypeEq' m = do + let origNames = universeBi (m ^. modDecl) :: [Name] + pairedNames = catMaybes . zipWith zf (map semanticsName origNames) $ origNames + uniqueNames = SMap.elems . SMap.fromList . reverse $ pairedNames + mapM_ chkNameForTyEqn uniqueNames + return m + where zf (Just x) y = Just (x,y) + zf _ _ = Nothing diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeOperatorsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeOperatorsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeOperatorsChecker.hs @@ -0,0 +1,65 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeOperatorsChecker where + +import qualified Name as GHC (nameOccName) +import qualified OccName as GHC (isTcOcc, isSymOcc) + +import Data.Generics.Uniplate.Data() +import Data.Generics.Uniplate.Operations + +import Control.Monad.Trans.Maybe (MaybeT(..)) + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +-- | Checks a Type whether it contains any DeclHeads that amy need TypeOperators +chkTypeOperatorsType :: CheckNode Type +chkTypeOperatorsType = conditional chkTypeOperatorsType' TypeOperators + +-- | Checks an Assertion whether it contains any DeclHeads that amy need TypeOperators +chkTypeOperatorsAssertion :: CheckNode Assertion +chkTypeOperatorsAssertion = conditional chkTypeOperatorsAssertion' TypeOperators + +-- | Checks an InstanceHEad whether it contains any DeclHeads that amy need TypeOperators +chkTypeOperatorsInstHead :: CheckNode InstanceHead +chkTypeOperatorsInstHead = conditional chkTypeOperatorsInstHead' TypeOperators + +-- | Checks a Decl whether it contains any DeclHeads that amy need TypeOperators +-- We check Decls to avoid getting multiple occurences of the same DeclHead +-- (e.g. we would check it with and without parentheses) +chkTypeOperatorsDecl :: CheckNode Decl +chkTypeOperatorsDecl = conditional chkTypeOperatorsDecl' TypeOperators + + + +chkTypeOperatorsType' :: CheckNode Type +chkTypeOperatorsType' t@InfixTypeApp{} = addOccurence TypeOperators t +chkTypeOperatorsType' t = return t + +chkTypeOperatorsAssertion' :: CheckNode Assertion +chkTypeOperatorsAssertion' a@InfixAssert{} = addOccurence TypeOperators a +chkTypeOperatorsAssertion' a = return a + +chkTypeOperatorsInstHead' :: CheckNode InstanceHead +chkTypeOperatorsInstHead' ih@InfixInstanceHead{} = addOccurence TypeOperators ih +chkTypeOperatorsInstHead' ih = return ih + +chkTypeOperatorsDecl' :: CheckNode Decl +chkTypeOperatorsDecl' d = do + let dhs = universeBi d :: [DeclHead] + anyNeedsTO <- liftM or $ mapM isOperatorM dhs + if anyNeedsTO then addOccurence TypeOperators d + else return d + +-- OccName: [Type and class operator definitions] + -- We are not just looking for a *syntactically-infix* declaration, + -- but one that uses an operator OccName. +isOperatorM :: DeclHead -> ExtMonad Bool +isOperatorM dh = do + mSemName <- runMaybeT . declHeadSemName $ dh + case mSemName of + Just semName + | occ <- GHC.nameOccName semName + , GHC.isTcOcc occ && GHC.isSymOcc occ + -> return True + | otherwise -> return False + Nothing -> return True diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeSynonymInstancesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeSynonymInstancesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TypeSynonymInstancesChecker.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts, MonoLocalBinds #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeSynonymInstancesChecker + ( chkTypeSynonymInstancesDecl, chkInstancesDeclWith, chkInstanceRuleWith, collectTyArgs) where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad hiding (StandaloneDeriving) + + +{-# ANN module "HLint: ignore Redundant bracket" #-} + +-- TODO: write "deriving instance ..." tests (should work) + +-- | We need to check declarations because we want to avoid checking type family instances +chkTypeSynonymInstancesDecl :: CheckNode Decl +chkTypeSynonymInstancesDecl = conditional (chkInstancesDeclWith $ chkInstanceRuleWith chkInstanceHead) TypeSynonymInstances + +-- | Checks an instance rule in declaration +-- We need to check declarations because we want to avoid checking type family instances +chkInstancesDeclWith :: CheckNode InstanceRule -> CheckNode Decl +chkInstancesDeclWith chkRule d@(StandaloneDeriving _ _ rule) = chkRule rule >> return d +chkInstancesDeclWith chkRule d@(InstanceDecl rule _) = chkRule rule >> return d +chkInstancesDeclWith _ d = return d + +-- | Checks and instance head in an instance rule +chkInstanceRuleWith :: CheckNode InstanceHead -> CheckNode InstanceRule +chkInstanceRuleWith chkHead r@(InstanceRule _ _ ihead) = chkHead ihead >> return r +chkInstanceRuleWith _ r = return r + + +-- | Checks every single type argument in an instance declaration whether it is a synonym +chkInstanceHead :: CheckNode InstanceHead +chkInstanceHead ih = do + let types = collectTyArgs ih + mapM_ chkTypeArg types >> return ih + +-- | Checks a type argument of class whether it is a synonym +chkTypeArg :: Type -> ExtMonad Type +chkTypeArg ty = + maybeTM (return ty) (const . addOccurence TypeSynonymInstances $ ty) (semanticsTypeSynRhs ty) + +-- | Collects the type arguments in an instance declaration +-- Type arguments are the the types that the class is being instantiated with +collectTyArgs :: InstanceHead -> [Type] +collectTyArgs (InstanceHead _) = [] +collectTyArgs (InfixInstanceHead t _) = [t] +collectTyArgs (ParenInstanceHead ih) = collectTyArgs ih +collectTyArgs (AppInstanceHead ih t) = t : collectTyArgs ih diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker where import Language.Haskell.Tools.Refactor diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs @@ -1,20 +1,83 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, StandaloneDeriving #-} -module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap where +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + ( module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + , module Language.Haskell.TH.LanguageExtensions + , Formula(..) + ) where -import Language.Haskell.TH.LanguageExtensions (Extension) +import GHC.Generics +import Control.DeepSeq + import SrcLoc (SrcSpan) +import Data.List +import Data.Monoid hiding (All) +import Data.Function (on) +import qualified Data.Map.Lazy as LMap import qualified Data.Map.Strict as SMap (Map) +import SAT.MiniSat -infix 6 :||: -infix 7 :&&: +import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import Language.Haskell.Tools.Refactor.Utils.Extensions (expandExtension) -data LogicalRelation a = LVar a - | Not (LogicalRelation a) - | LogicalRelation a :&&: LogicalRelation a - | LogicalRelation a :||: LogicalRelation a - deriving (Eq, Show, Functor, Ord) +{-# ANN module "HLint: ignore Redundant lambda" #-} + +deriving instance Ord Extension +deriving instance Read Extension + +instance NFData Extension where + rnf x = seq x () + +deriving instance Generic a => Generic (Formula a) +deriving instance (Generic a, NFData a) => NFData (Formula a) + +type LogicalRelation a = Formula a + type ExtMap = SMap.Map (LogicalRelation Extension) [SrcSpan] + +lVar :: a -> LogicalRelation a +lVar = Var + +lNot :: a -> LogicalRelation a +lNot = Not . Var + +lAnd :: a -> a -> LogicalRelation a +lAnd x y = Var x :&&: Var y + +lOr :: a -> a -> LogicalRelation a +lOr x y = Var x :||: Var y + +lImplies :: a -> a -> LogicalRelation a +lImplies x y = Var x :->: Var y + +lAll :: [LogicalRelation a] -> LogicalRelation a +lAll = All + +complexity :: Extension -> Int +complexity = length . expandExtension + +determineExtensions :: SMap.Map (LogicalRelation Extension) v -> [Extension] +{- NOTE: + We calculate all the possible extension set that satisfy the logical relation, + then for each extension we remove all the extensions implied by it, (mergeImplied) + finally we select the minimal extension set. + + An extension set is minimal if: + - it contains the least amount of extensions + - it contains extension with minimal complexity + - it is lexicographically the first one (based on the Ord instance of Extension) +-} +determineExtensions x = minimal . map toExts $ solution + where solution = solve_all . All . LMap.keys $ x + toExts = mergeImplied . map fst . filter snd . LMap.toList + minimal = minimumBy ((compare `on` length) <> (compare `on` (sum . map complexity)) <> (compare `on` sort)) + +rmImplied :: Extension -> [Extension] -> [Extension] +rmImplied e = flip (\\) implied + where implied = delete e $ expandExtension e + +mergeImplied :: [Extension] -> [Extension] +mergeImplied exts = foldl (flip rmImplied) exts exts diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, StandaloneDeriving, TypeFamilies, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts, MonoLocalBinds, RankNTypes #-} + module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad ( module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + , module Language.Haskell.Tools.Refactor.Utils.Maybe , module Language.Haskell.TH.LanguageExtensions , module Control.Monad.State , module Control.Monad.Reader ) where import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Utils.Maybe import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap import GHC (SrcSpan(..), Ghc(..), runGhc) import GHC.Paths ( libdir ) import Language.Haskell.TH.LanguageExtensions -import SrcLoc (SrcSpan) import Control.Monad.Reader import Control.Monad.State @@ -24,19 +26,15 @@ {-# ANN module "HLint: ignore Use mappend" #-} {-# ANN module "HLint: ignore Use import/export shortcut" #-} -deriving instance Ord Extension -deriving instance Read Extension - --- how could I hide the tyvar a? --- type Asd a = forall m . (MonadReader [Extension] m, MonadState ExtMap m, GhcMonad m) => m a - - -type ExtMonad = ReaderT [Extension] (StateT ExtMap Ghc) +type ExtMonad = ReaderT [Extension] (StateT ExtMap Ghc) -type CheckNode elem = elem -> ExtMonad elem +type CheckNode elem = elem -> ExtMonad elem type CheckUNode uelem = Ann uelem IdDom SrcTemplateStage -> ExtMonad (Ann uelem IdDom SrcTemplateStage) +class Checkable node where + check :: CheckNode node + addOccurence' :: (Ord k, HasRange a) => k -> a -> SMap.Map k [SrcSpan] -> SMap.Map k [SrcSpan] addOccurence' key node = SMap.insertWith (++) key [getRange node] @@ -44,12 +42,20 @@ -- TODO: add isTurnedOn check addOccurence_ :: (MonadState ExtMap m, HasRange node) => Extension -> node -> m () -addOccurence_ extension element = modify $ addOccurence' (LVar extension) element +addOccurence_ extension element = modify $ addOccurence' (lVar extension) element addOccurence :: (MonadState ExtMap m, HasRange node) => Extension -> node -> m node addOccurence ext node = addOccurence_ ext node >> return node +addRelation_ :: (MonadState ExtMap m, HasRange node) => + LogicalRelation Extension -> node -> m () +addRelation_ rel element = modify $ addOccurence' rel element + +addRelation :: (MonadState ExtMap m, HasRange node) => + LogicalRelation Extension -> node -> m node +addRelation rel node = addRelation_ rel node >> return node + isTurnedOn :: Extension -> ExtMonad Bool isTurnedOn ext = do defaults <- ask @@ -79,7 +85,6 @@ conditionalAdd :: HasRange node => Extension -> node -> ExtMonad node conditionalAdd ext = conditional (addOccurence ext) ext - runExtMonadIO :: ExtMonad a -> IO a runExtMonadIO = runGhc (Just libdir) . runExtMonadGHC diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/AppSelector.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/AppSelector.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/AppSelector.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.AppSelector where + +import Data.Generics.ClassyPlate +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +type family HasChecker node where + -- Module-level checks + HasChecker Module = 'True + + -- Node-level checks + HasChecker Decl = 'True + HasChecker Pattern = 'True + HasChecker Expr = 'True + HasChecker Type = 'True + HasChecker PatternField = 'True + HasChecker FieldUpdate = 'True + HasChecker PatternSynonym = 'True + HasChecker PatternSignature = 'True + HasChecker Literal = 'True + HasChecker NamePart = 'True + HasChecker Kind = 'True + HasChecker Splice = 'True + HasChecker QuasiQuote = 'True + HasChecker Bracket = 'True + HasChecker FunDepList = 'True + HasChecker ClassElement = 'True + HasChecker Stmt = 'True + HasChecker Cmd = 'True + HasChecker InstBodyDecl = 'True + HasChecker IESpec = 'True + HasChecker Operator = 'True + HasChecker GadtConDecl = 'True + HasChecker ConDecl = 'True + HasChecker Assertion = 'True + HasChecker InstanceHead = 'True + HasChecker _ = 'False + +type instance AppSelector Checkable node = HasChecker node diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/Checkable.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/Checkable.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Instances/Checkable.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE FlexibleInstances #-} + + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.Checkable where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +-- | Global checks +instance Checkable Module where + check = globalChkNamesForTypeEq + +instance Checkable Decl where + check = chkFlexibleInstancesDecl + >=> chkDerivings + >=> chkTypeFamiliesDecl + >=> chkMultiParamTypeClassesDecl + >=> chkConstraintKindsDecl + >=> chkConstrainedClassMethodsDecl + >=> chkTypeSynonymInstancesDecl + >=> chkTypeOperatorsDecl' + +instance Checkable Pattern where + check = chkBangPatterns + >=> chkViewPatterns + >=> chkUnboxedTuplesPat + +instance Checkable Expr where + check = chkTupleSections + >=> chkUnboxedTuplesExpr + >=> chkLambdaCase + >=> chkRecursiveDoExpr + >=> chkArrowsExpr + >=> chkParallelListComp + >=> chkMultiWayIfExpr + +instance Checkable Type where + check = chkUnboxedTuplesType + >=> chkExplicitForAllType + >=> chkTypeOperatorsType + +instance Checkable PatternField where + check = chkRecordWildCardsPatField + +instance Checkable FieldUpdate where + check = chkRecordWildCardsFieldUpdate + +instance Checkable PatternSynonym where + check = chkPatternSynonymsSyn + +instance Checkable PatternSignature where + check = chkPatternSynonymsTypeSig + +instance Checkable Literal where + check = chkMagicHashLiteral + >=> chkOverloadedStringsLiteral + +instance Checkable NamePart where + check = chkMagicHashNamePart + >=> chkTemplateHaskellhNamePart + +instance Checkable Kind where + check = chkMagicHashKind + >=> chkKindSignaturesKind + +instance Checkable Splice where + check = chkTemplateHaskellSplice + +instance Checkable QuasiQuote where + check = chkTemplateHaskellQuasiQuote + +instance Checkable Bracket where + check = chkTemplateHaskellBracket + +instance Checkable FunDepList where + check = chkFunDeps + +instance Checkable ClassElement where + check = chkDefaultSigs + >=> chkTypeFamiliesClassElement + +instance Checkable Stmt where + check = chkRecursiveDoStmt + +instance Checkable Cmd where + check = chkArrowsCmd + +instance Checkable InstBodyDecl where + check = chkTypeFamiliesInstBodyDecl + +instance Checkable IESpec where + check = chkExplicitNamespacesIESpec + +instance Checkable Operator where + check = chkOperatorForTypeEq + +instance Checkable GadtConDecl where + check = chkGADTsGadtConDecl + >=> chkExplicitForAllGadtConDecl + +instance Checkable ConDecl where + check = chkConDeclForExistentials + >=> chkExplicitForAllConDecl + +instance Checkable Assertion where + check = chkTypeOperatorsAssertion + +instance Checkable InstanceHead where + check = chkTypeOperatorsInstHead diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/SupportedExtensions.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/SupportedExtensions.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/SupportedExtensions.hs @@ -0,0 +1,37 @@ +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.SupportedExtensions where + +import Language.Haskell.TH.LanguageExtensions (Extension(..)) + +isSupported :: Extension -> Bool +isSupported = flip elem fullyHandledExtensions + +fullyHandledExtensions :: [Extension] +fullyHandledExtensions = syntacticExtensions + ++ derivingExtensions + ++ typeClassExtensions + ++ typeSystemExtensions + +syntacticExtensions :: [Extension] +syntacticExtensions = [ RecordWildCards, TemplateHaskell, BangPatterns + , PatternSynonyms, TupleSections, LambdaCase, QuasiQuotes + , ViewPatterns, MagicHash, UnboxedTuples + , FunctionalDependencies, DefaultSignatures + , RecursiveDo, Arrows, ParallelListComp + , KindSignatures, ExplicitNamespaces + , GADTSyntax, ExplicitForAll, MultiWayIf + , TypeOperators ] + +derivingExtensions :: [Extension] +derivingExtensions = [ DeriveDataTypeable, DeriveGeneric, DeriveFunctor + , DeriveFoldable, DeriveTraversable, DeriveLift + , DeriveAnyClass, GeneralizedNewtypeDeriving + , StandaloneDeriving, DerivingStrategies ] + +typeClassExtensions :: [Extension] +typeClassExtensions = [ MultiParamTypeClasses, ConstrainedClassMethods + , FlexibleInstances, TypeSynonymInstances + ] + +typeSystemExtensions :: [Extension] +typeSystemExtensions = [ TypeFamilies, GADTs, ExistentialQuantification + , ConstraintKinds ] diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs @@ -1,592 +1,18 @@ -{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, MonoLocalBinds, RankNTypes, TypeApplications #-} + module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.TraverseAST ( module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.TraverseAST , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad ) where -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.Refactor as Refact - -import Control.Reference ((!~), (&), (&+&)) - -{- - NOTE: We need Decl level checking for deriving clausese - in order to gain extra information from the newtype and data keywords. - - We need Decl level checking for instance heads, in order to distinguish - class instances from data and type family instances. --} -chkDecl :: CheckNode Decl -chkDecl = chkFlexibleInstances >=> chkDerivings - -chkPattern :: CheckNode Pattern -chkPattern = chkBangPatterns - >=> chkViewPatterns - >=> chkUnboxedTuplesPat - -chkExpr :: CheckNode Expr -chkExpr = chkTupleSections - >=> chkUnboxedTuplesExpr - >=> chkLambdaCase - -chkType :: CheckNode Type -chkType = chkUnboxedTuplesType - -chkPatternField :: CheckNode PatternField -chkPatternField = chkRecordWildCardsPatField - -chkFieldUpdate :: CheckNode FieldUpdate -chkFieldUpdate = chkRecordWildCardsFieldUpdate - -chkPatternSynonym :: CheckNode PatternSynonym -chkPatternSynonym = chkPatternSynonymsSyn - -chkPatternSignature :: CheckNode PatternSignature -chkPatternSignature = chkPatternSynonymsTypeSig - -chkLiteral :: CheckNode Literal -chkLiteral = chkMagicHashLiteral - -chkNamePart :: CheckNode NamePart -chkNamePart = chkMagicHashNamePart - >=> chkTemplateHaskellhNamePart +import Data.Generics.ClassyPlate -chkKind :: CheckNode Kind -chkKind = chkMagicHashKind +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.Checkable() +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.AppSelector() traverseModule :: CheckNode UnnamedModule -traverseModule = (modDecl & annList !~ traverseDecl) - >=> (modHead & annJust !~ traverseModuleHead) - -- more - -traverseModuleHead :: CheckNode ModuleHead -traverseModuleHead = mhExports & annJust !~ traverseExportSpecs - -- more - -traverseExportSpecs :: CheckNode ExportSpecs -traverseExportSpecs = espExports & annList !~ traverseExportSpec - -traverseExportSpec :: CheckNode ExportSpec -traverseExportSpec = exportDecl !~ traverseIESpec - -traverseIESpec :: CheckNode IESpec -traverseIESpec = (ieName !~ traverseName) - >=> (ieSubspec & annJust !~ traverseSubSpec) - -traverseSubSpec :: CheckNode SubSpec -traverseSubSpec = essList & annList !~ traverseName - -traverseDecl :: CheckNode Decl -traverseDecl = chkDecl - >=> (declValBind !~ traverseValueBind) - >=> (declBody & annJust !~ traverseClassBody) - >=> (declSplice !~ traverseSplice) - >=> (innerType !~ traverseType) - >=> (declTypeSig !~ traverseTypeSignature) - >=> (declTypeFamily !~ traverseTypeFamily) -- - >=> (declSpec & annJust !~ traverseTypeFamilySpec) - >=> (declSafety & annJust !~ traverseSafety) - >=> (declRoles & annList !~ traverseRole) - >=> (declPragma !~ traverseTopLevelPragma) - >=> (declPatTypeSig !~ traversePatternSignature) - >=> (declPatSyn !~ traversePatternSynonym) - >=> (declOverlap & annJust !~ traverseOverlapPragma) - >=> (declKind & annJust !~ traverseKindContraint) - >=> (innerInstanceRule !~ traverseInstanceRule) - >=> (declInstDecl & annJust !~ traverseInstBody) - >=> (declHead !~ traverseDeclHead) - >=> (declGadt & annList !~ traverseGadtConDecl) - >=> (declFunDeps & annJust !~ traverseFunDeps) - >=> (declForeignType !~ traverseType) - >=> (declFixity !~ traverseFixitySignature) - >=> (declDeriving & annList !~ traverseDeriving) - >=> (declDecl & annList !~ traverseTypeEqn) - >=> (declCtx & annJust !~ traverseContext) - >=> (declCons & annList !~ traverseConDecl) - >=> (declCallConv !~ traverseCallConv) - >=> (declName !~ traverseName) - >=> (declRoleType !~ traverseQualifiedName) - - where innerType = (declTypes & annList) - &+& declType - &+& declAssignedType - - innerInstanceRule = declInstance &+& declInstRule - -traverseTypeFamily :: CheckNode TypeFamily -traverseTypeFamily = (tfHead !~ traverseDeclHead) - >=> (tfSpec & annJust !~ traverseTypeFamilySpec) - >=> (tfKind & annJust !~ traverseKindContraint) - --- tfTypeVar is from 0.9 -traverseTypeFamilySpec :: CheckNode TypeFamilySpec -traverseTypeFamilySpec = (tfSpecKind !~ traverseKindContraint) - -- >=> (tfTypeVar !~ traverseTyVar) - >=> (tfInjectivity !~ traverseInjectivityAnn) - -traverseInjectivityAnn :: CheckNode InjectivityAnn -traverseInjectivityAnn = (injAnnRes !~ traverseTyVar) - >=> (injAnnDeps & annList !~ traverseName) - --- DONE -traverseSafety :: CheckNode Safety -traverseSafety = return - --- DONE -traverseRole :: CheckNode Role -traverseRole = return - -traverseTopLevelPragma :: CheckNode TopLevelPragma -traverseTopLevelPragma = (pragmaRule & annList !~ traverseRule) - >=> (pragmaObjects & annList !~ traverseName) - >=> (annotationSubject !~ traverseAnnotationSubject) - >=> (pragmaInline !~ traverseInlinePragma) - >=> (specializePragma !~ traverseSpecializePragma) - --- no references for this -traverseSpecializePragma :: CheckUNode USpecializePragma -traverseSpecializePragma = return {- (specializeDef !~ traverseName) - >=> (specializeType & annList !~ traverseType) -} - -traverseAnnotationSubject :: CheckNode AnnotationSubject -traverseAnnotationSubject = annotateName !~ traverseName - -traverseRule :: CheckNode Rule -traverseRule = (ruleBounded & annList !~ traverseRuleVar) - >=> (innerExpr !~ traverseExpr) - -- some more - - where innerExpr = ruleLhs &+& ruleRhs - -traverseRuleVar :: CheckNode RuleVar -traverseRuleVar = (ruleVarName !~ traverseName) - >=> (ruleVarType !~ traverseType) - -traversePatternSignature :: CheckNode PatternSignature -traversePatternSignature = chkPatternSignature - >=> (patSigName & annList !~ traverseName) - >=> (patSigType !~ traverseType) - --- DONE -traverseOverlapPragma :: CheckNode OverlapPragma -traverseOverlapPragma = return - --- weird structure of nodes (Maybe (Ann AnnListG dom stage)) -traverseInstanceRule :: CheckNode InstanceRule -traverseInstanceRule = (irVars & annJust & element & annList !~ traverseTyVar) - >=> (irCtx & annJust !~ traverseContext) - >=> (irHead !~ traverseInstanceHead) - -traverseInstanceHead :: CheckNode InstanceHead -traverseInstanceHead = (ihConName !~ traverseName) - >=> (ihOperator !~ traverseOperator) - >=> (innerType !~ traverseType) - >=> (innerIHead !~ traverseInstanceHead) - - where innerType = ihLeftOp &+& ihType - innerIHead = ihHead &+& ihFun - -traverseDeclHead :: CheckNode DeclHead -traverseDeclHead = (dhName !~ traverseName) - >=> (dhOperator !~ traverseOperator) - >=> (innerDHead !~ traverseDeclHead) - >=> (innerTyVar !~ traverseTyVar) - - where innerDHead = dhBody &+& dhAppFun - innerTyVar = dhAppOperand &+& dhLeft &+& dhRight - -traverseGadtConDecl :: CheckNode GadtConDecl -traverseGadtConDecl = (gadtConNames & annList !~ traverseName) - >=> (gadtConTypeArgs & annList !~ traverseTyVar) - >=> (gadtConTypeCtx & annJust !~ traverseContext) - >=> (gadtConType !~ traverseGadtConType) - -traverseGadtConType :: CheckNode GadtConType -traverseGadtConType = (innerType !~ traverseType) - >=> (gadtConRecordFields & annList !~ traverseFieldDecl) - - where innerType = gadtConNormalType &+& gadtConResultType - -traverseFieldDecl :: CheckNode FieldDecl -traverseFieldDecl = (fieldNames & annList !~ traverseName) - >=> (fieldType !~ traverseType) - -traverseFunDeps :: CheckNode FunDeps -traverseFunDeps = funDeps & annList !~ traverseFunDep - -traverseFunDep :: CheckNode FunDep -traverseFunDep = innerName !~ traverseName - where innerName = (funDepLhs & annList) &+& (funDepRhs & annList) - -traverseDeriving :: CheckNode Deriving -traverseDeriving = innerIHead !~ traverseInstanceHead - where innerIHead = oneDerived &+& (allDerived & annList) - -traverseConDecl :: CheckNode ConDecl -traverseConDecl = (conTypeArgs & annList !~ traverseTyVar) - >=> (conTypeCtx & annJust !~ traverseContext) - >=> (conDeclName !~ traverseName) - >=> (innerType !~ traverseType) - >=> (conDeclFields & annList !~ traverseFieldDecl) - - where innerType = (conDeclArgs & annList) - &+& conDeclLhs - &+& conDeclRhs - --- DONE -traverseCallConv :: CheckNode CallConv -traverseCallConv = return - -traverseMinimalFormula :: CheckNode MinimalFormula -traverseMinimalFormula = (minimalName !~ traverseName) - >=> (innerFormula !~ traverseMinimalFormula) - - where innerFormula = minimalInner - &+& (minimalOrs & annList) - &+& (minimalAnds & annList) - --- there is no wrapper type for InlinePragma --- no references generated -traverseInlinePragma :: CheckUNode UInlinePragma -traverseInlinePragma = return {- nnerName !~ traverseName - where innerName = inlineDef &+& noInlineDef &+& inlinableDef -} - - - - -traversePatternSynonym :: CheckNode PatternSynonym -traversePatternSynonym = chkPatternSynonym - >=> (patRhs !~ traverseInnerRhs) - >=> (patLhs !~ traverseInnerLhs) - - where traverseInnerRhs = (patRhsPat !~ traversePattern) - >=> (patRhsOpposite & annJust & patOpposite & annList !~ traverseMatch) - - traverseInnerLhs = (innerName !~ traverseName) - >=> (patSynOp !~ traverseOperator) - - innerName = patName &+& (patArgs & annList) &+& patSynLhs &+& patSynRhs - - - -traverseMatch :: CheckNode Match -traverseMatch = (matchLhs !~ traverseMatchLhs) - >=> (matchRhs !~ traverseRhs) - >=> (matchBinds & annJust !~ traverseLocalBinds) - -traverseMatchLhs :: CheckNode MatchLhs -traverseMatchLhs = (matchLhsName !~ traverseName) - >=> (matchLhsOperator !~ traverseOperator) - >=> (innerPattern !~ traversePattern) - - where innerPattern = matchLhsArgs & annList - &+& matchLhsLhs - &+& matchLhsRhs - -traverseRhs :: CheckNode Rhs -traverseRhs = (rhsExpr !~ traverseExpr) - >=> (rhsGuards & annList !~ traverseGuardedRhs) - -traverseGuardedRhs :: CheckNode GuardedRhs -traverseGuardedRhs = (guardStmts & annList !~ traverseRhsGuard) - >=> (guardExpr !~ traverseExpr) - -traverseRhsGuard :: CheckNode RhsGuard -traverseRhsGuard = (guardPat !~ traversePattern) - >=> (guardRhs &+& guardCheck !~ traverseExpr) - >=> (guardBinds & annList !~ traverseLocalBind) - -traverseLocalBinds :: CheckNode LocalBinds -traverseLocalBinds = localBinds & annList !~ traverseLocalBind - -traverseLocalBind :: CheckNode LocalBind -traverseLocalBind = (localVal !~ traverseValueBind) - >=> (localSig !~ traverseTypeSignature) - >=> (localFixity !~ traverseFixitySignature) - -- >=> (localInline !~ ...) - - -traverseInstBody :: CheckNode InstBody -traverseInstBody = instBodyDecls & annList !~ traverseInstBodyDecl - -traverseInstBodyDecl :: CheckNode InstBodyDecl -traverseInstBodyDecl = (instBodyDeclFunbind !~ traverseValueBind) - >=> (instBodyTypeSig !~ traverseTypeSignature) - >=> (instBodyTypeEqn !~ traverseTypeEqn) - >=> (specializeInstanceType !~ traverseType) - -- and many more ... - -traverseTypeEqn :: CheckNode TypeEqn -traverseTypeEqn = teLhs &+& teRhs !~ traverseType - -traverseClassBody :: CheckNode ClassBody -traverseClassBody = cbElements & annList !~ traverseClassElem - -traverseClassElem :: CheckNode ClassElement -traverseClassElem = (ceTypeSig !~ traverseTypeSignature) - >=> (clsFixity !~ traverseFixitySignature) - >=> (ceBind !~ traverseValueBind) - >=> (ceName !~ traverseName) - >=> (ceKind &+& ceType !~ traverseType) - - -- some more, but are not important - - -traverseValueBind :: CheckNode ValueBind -traverseValueBind = (valBindPat !~ traversePattern) - >=> (valBindRhs !~ traverseRhs) - >=> (valBindLocals & annJust !~ traverseLocalBinds) - >=> (funBindMatches & annList !~ traverseMatch) - - -traversePattern :: CheckNode Pattern -traversePattern = chkPattern - >=> (innerPattern !~ traversePattern) - >=> (innerLiteral !~ traverseLiteral) - >=> (patternOperator !~ traverseOperator) - >=> (patternFields & annList !~ traversePatternField) - >=> (patternName !~ traverseName) - >=> (patternExpr !~ traverseExpr) - >=> (patternType !~ traverseType) - >=> (patternSplice !~ traverseSplice) - >=> (patQQ !~ traverseQuasiQuote) - - where - innerPattern = patternLhs - &+& patternRhs - &+& patternInner - &+& (patternElems & annList) - &+& (patternArgs & annList) - - innerLiteral = patternLiteral &+& patternLit - -traversePatternField :: CheckNode PatternField -traversePatternField = chkPatternField - >=> (fieldPatternName !~ traverseName) - >=> (fieldPattern !~ traversePattern) - --- TODO: TemplateHaskell? -traverseExpr :: CheckNode Expr -traverseExpr = chkExpr - >=> (innerExpressions !~ traverseExpr) - >=> (innerPatterns !~ traversePattern) - >=> (exprFunBind & annList !~ traverseLocalBind) - >=> (exprIfAlts & annList !~ traverseGuardedCaseRhs traverseExpr) - >=> (exprAlts & annList !~ traverseAlt traverseExpr) - >=> (exprOperator !~ traverseOperator) - >=> (exprLit !~ traverseLiteral) - >=> (innerNames !~ traverseName) - >=> (exprStmts & annList !~ traverseStmt traverseExpr) - >=> (tupleSectionElems & annList !~ traverseTupSecElem) - >=> (exprRecFields & annList !~ traverseFieldUpdate) - >=> (compBody & annList !~ traverseListCompBody) - >=> (innerTypes !~ traverseType) - >=> (exprSplice !~ traverseSplice) - >=> (exprBracket !~ traverseBracket) - >=> (exprQQ !~ traverseQuasiQuote) - - where innerExpressions = (tupleElems & annList) - &+& (listElems & annList) - &+& innerExpr - &+& exprCond - &+& exprThen - &+& exprElse - &+& exprRhs - &+& exprLhs - &+& exprInner - &+& exprFun - &+& exprCase - &+& exprArg - &+& enumToFix - &+& (enumTo & annJust) - &+& (enumThen & annJust) - &+& Refact.enumFrom - &+& compExpr - - innerPatterns = (exprBindings & annList) &+& procPattern - innerNames = exprName &+& exprRecName &+& quotedName - innerTypes = exprSig &+& exprType - --- These types are needed to generalize AST traversal for polymorphic nodes. --- These nodes are polymorphic in their inner nodes, which can be any "UNodes" --- (UType. UExpr, UDecl etc ...) -type AltG uexpr dom = Ann (UAlt' uexpr) dom SrcTemplateStage -type StmtG uexpr dom = Ann (UStmt' uexpr) dom SrcTemplateStage -type CaseRhsG uexpr dom = Ann (UCaseRhs' uexpr) dom SrcTemplateStage -type GuardedCaseRhsG uexpr dom = Ann (UGuardedCaseRhs' uexpr) dom SrcTemplateStage - -type PromotedG t dom = Ann (UPromoted t) dom SrcTemplateStage - -traverseAlt :: CheckUNode uexpr -> CheckNode (AltG uexpr IdDom) -traverseAlt f = (altPattern !~ traversePattern) - >=> (altRhs !~ traverseCaseRhs f) - >=> (altBinds & annJust !~ traverseLocalBinds) - -traverseCaseRhs :: CheckUNode uexpr -> CheckNode (CaseRhsG uexpr IdDom) -traverseCaseRhs f = (rhsCaseExpr !~ f) - >=> (rhsCaseGuards & annList !~ traverseGuardedCaseRhs f) - -traverseGuardedCaseRhs :: CheckUNode uexpr -> CheckNode (GuardedCaseRhsG uexpr IdDom) -traverseGuardedCaseRhs f = (caseGuardStmts & annList !~ traverseRhsGuard) - >=> (caseGuardExpr !~ f) - -traverseStmt :: CheckUNode uexpr -> CheckNode (StmtG uexpr IdDom) -traverseStmt f = (stmtPattern !~ traversePattern) - >=> (stmtExpr !~ f) - >=> (stmtBinds & annList !~ traverseLocalBind) - >=> (cmdStmtBinds & annList !~ traverseStmt f) - -traversePromoted :: CheckUNode t -> CheckNode (PromotedG t IdDom) -traversePromoted f = (promotedConName !~ traverseName) - >=> (promotedElements & annList !~ f) - -traverseTupSecElem :: CheckNode TupSecElem -traverseTupSecElem = tupSecExpr !~ traverseExpr - -traverseFieldUpdate :: CheckNode FieldUpdate -traverseFieldUpdate = chkFieldUpdate - >=> (fieldName &+& fieldUpdateName !~ traverseName) - >=> (fieldValue !~ traverseExpr) - -traverseListCompBody :: CheckNode ListCompBody -traverseListCompBody = compStmts & annList !~ traverseCompStmt - -traverseCompStmt :: CheckNode CompStmt -traverseCompStmt = (compStmt !~ traverseStmt traverseExpr) - >=> (innerExpressions !~ traverseExpr) - - where innerExpressions = thenExpr - &+& (byExpr & annJust) - &+& (usingExpr & annJust) - -traverseCmd :: CheckNode Cmd -traverseCmd = return -{- - -References are not generated for UCmd - -traverseCmd = (innerExpressions !~ traverseExpr) - >=> (innerCmds !~ traverseCmd) - >=> (cmdStmtBinds & annList !~ traversePattern) - >=> (cmdBinds & annList !~ traverseLocalBind) - >=> (cmdAlts & annList !~ traverseAlt traverseCmd) - >=> (cmdStmts & annList !~ traverseStmt traverseCmd) - where innerExpressions = cmdLhs &+& cmdRhs &+& cmdExpr &+& cmdApplied - - innerCmds = (cmdInnerCmds & annList) - &+& cmdInnerCmd - &+& cmdLeftCmd - &+& cmdRightCmd - &+& cmdInner - &+& cmdThen - &+& cmdElse --} - -traverseSplice :: CheckNode Splice -traverseSplice = chkTemplateHaskellSplice - >=> (spliceId !~ traverseName) - >=> (spliceExpr !~ traverseExpr) - -traverseBracket :: CheckNode Bracket -traverseBracket = chkTemplateHaskellBracket - >=> (bracketExpr !~ traverseExpr) - >=> (bracketPattern !~ traversePattern) - >=> (bracketType !~ traverseType) - >=> (bracketDecl & annList !~ traverseDecl) - -traverseQuasiQuote :: CheckNode QuasiQuote -traverseQuasiQuote = chkTemplateHaskellQuasiQuote - >=> (qqExprName !~ traverseName) - -traverseType :: CheckNode Type -traverseType = chkType - >=> (typeBounded & annList !~ traverseTyVar) - >=> (innerType !~ traverseType) - >=> (innerName !~ traverseName) - >=> (typeCtx !~ traverseContext) - >=> (typeOperator !~ traverseOperator) - >=> (typeKind !~ traverseKind) - >=> (tpPromoted !~ traversePromoted traverseType) - >=> (tsSplice !~ traverseSplice) - >=> (typeQQ !~ traverseQuasiQuote) - - where innerType = typeType - &+& typeParam - &+& typeResult - &+& (typeElements & annList) - &+& typeElement - &+& typeCon - &+& typeArg - &+& typeInner - &+& typeLeft - &+& typeRight - - innerName = typeName &+& typeWildcardName - -traverseTyVar :: CheckNode TyVar -traverseTyVar = (tyVarName !~ traverseName) - >=> (tyVarKind & annJust !~ traverseKindContraint) - -traverseKindContraint :: CheckNode KindConstraint -traverseKindContraint = kindConstr !~ traverseKind - -traverseKind :: CheckNode Kind -traverseKind = chkKind - >=> (innerKind !~ traverseKind) - >=> (kindVar !~ traverseName) - >=> (kindAppOp !~ traverseOperator) - >=> (kindPromoted !~ traversePromoted traverseKind) - - where innerKind = kindLeft - &+& kindRight - &+& kindParen - &+& kindAppFun - &+& kindAppArg - &+& kindLhs - &+& kindRhs - &+& kindElem - &+& (kindElems & annList) - -traverseContext :: CheckNode Context -traverseContext = contextAssertion !~ traverseAssertion - -traverseAssertion :: CheckNode Assertion -traverseAssertion = (innerType !~ traverseType) - >=> (innerName !~ traverseName) - >=> (assertOp !~ traverseOperator) - >=> (innerAsserts & annList !~ traverseAssertion) - - where innerType = (assertTypes & annList) - &+& assertLhs - &+& assertRhs - &+& assertImplType - - innerName = assertClsName &+& assertImplVar - -traverseName :: CheckNode Name -traverseName = simpleName !~ traverseQualifiedName - -traverseQualifiedName :: CheckNode QualifiedName -traverseQualifiedName = unqualifiedName !~ traverseNamePart - >=> qualifiers & annList !~ traverseNamePart - -traverseNamePart :: CheckNode NamePart -traverseNamePart = chkNamePart - -traverseLiteral :: CheckNode Literal -traverseLiteral = chkLiteral - -traverseOperator :: CheckNode Operator -traverseOperator = operatorName !~ traverseQualifiedName - -traverseTypeSignature :: CheckNode TypeSignature -traverseTypeSignature = (tsName & annList !~ traverseName) - >=> (tsType !~ traverseType) - -traverseFixitySignature :: CheckNode FixitySignature -traverseFixitySignature = fixityOperators & annList !~ traverseOperator +traverseModule = topDownM @Checkable check diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/Debug.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/Debug.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/Debug.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleInstances #-} + + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.Debug + ( module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.Debug + , module Debug.Trace + ) where + +import Data.Maybe (isJust) +import Control.Monad.Trans.Maybe +import Control.Reference ((^.), (&)) + +import Debug.Trace +import qualified Outputable as GHC + +import Language.Haskell.Tools.Refactor + + +debugM :: (Monad m, Show a) => m a -> m a +debugM m = do + x <- m + traceShow x m + +debug :: Show a => a -> a +debug x = traceShow x x + +-- | Displays True iff the wrapped value is a Just +debugMaybeT :: Monad m => MaybeT m a -> MaybeT m a +debugMaybeT m = MaybeT $ do + x <- runMaybeT m + traceShow (isJust x) (return x) + +showOutputable :: GHC.Outputable a => a -> String +showOutputable = GHC.showSDocUnsafe . GHC.ppr + +showName :: Name -> String +showName = (^. simpleName & unqualifiedName & simpleNameStr) + +showOp :: Operator -> String +showOp = (^. operatorName & unqualifiedName & simpleNameStr) diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs deleted file mode 100644 --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.SupportedExtensions where - -import Language.Haskell.TH.LanguageExtensions (Extension(..)) - -unregularExts :: String -> String -unregularExts "CPP" = "Cpp" -unregularExts "NamedFieldPuns" = "RecordPuns" -unregularExts "GeneralisedNewtypeDeriving" = "GeneralizedNewtypeDeriving" -unregularExts e = e - -isSupported :: Extension -> Bool -isSupported = flip elem fullyHandledExtensions - -fullyHandledExtensions :: [Extension] -fullyHandledExtensions = syntacticExtensions - ++ derivingExtensions - -- ++ [FlexibleInstances] - -syntacticExtensions :: [Extension] -syntacticExtensions = [ RecordWildCards, TemplateHaskell, BangPatterns - , PatternSynonyms, TupleSections, LambdaCase, QuasiQuotes - , ViewPatterns, MagicHash, UnboxedTuples] - -derivingExtensions :: [Extension] -derivingExtensions = [ DeriveDataTypeable, DeriveGeneric, DeriveFunctor - , DeriveFoldable, DeriveTraversable, DeriveLift - , DeriveAnyClass, GeneralizedNewtypeDeriving - , StandaloneDeriving, DerivingStrategies ] diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/TypeLookup.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/TypeLookup.hs deleted file mode 100644 --- a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/TypeLookup.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - -module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.TypeLookup where - - -import Language.Haskell.Tools.AST (simpleName) -import Language.Haskell.Tools.Refactor -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad - -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Reference ((^.)) - -import qualified GHC -import qualified TyCoRep as GHC (Type(..), TyThing(..)) - - -chkSynonym :: CheckNode Type -chkSynonym t = do - mtycon <- runMaybeT . lookupType $ t - case mtycon of - Nothing -> return t - Just tycon -> chkSynonym' tycon - where chkSynonym' x = case lookupSynDef x of - Nothing -> return t - Just _ -> addOccurence TypeSynonymInstances t - -lookupSynDefM :: Type -> MaybeT ExtMonad GHC.TyCon -lookupSynDefM t = do - tything <- lookupType t - liftMaybe $ lookupSynDef tything - where liftMaybe = MaybeT . return - --- NOTE: Returns Nothing if it is not a type synonym --- (or has some weird structure I didn't think of) -lookupSynDef :: GHC.TyThing -> Maybe GHC.TyCon -lookupSynDef syn = do - tycon <- tyconFromTyThing syn - rhs <- GHC.synTyConRhs_maybe tycon - tyconFromGHCType rhs - -tyconFromTyThing :: GHC.TyThing -> Maybe GHC.TyCon -tyconFromTyThing (GHC.ATyCon tycon) = Just tycon -tyconFromTyThing _ = Nothing - --- won't bother -tyconFromGHCType :: GHC.Type -> Maybe GHC.TyCon -tyconFromGHCType (GHC.AppTy t1 _) = tyconFromGHCType t1 -tyconFromGHCType (GHC.TyConApp tycon _) = Just tycon -tyconFromGHCType _ = Nothing - - --- NOTE: Return false if the type is certainly not a newtype --- Returns true if it is a newtype or it could not have been looked up -isNewtype :: Type -> ExtMonad Bool -isNewtype t = do - tycon <- runMaybeT . lookupType $ t - return $! maybe True isNewtypeTyCon tycon - - - -lookupType :: Type -> MaybeT ExtMonad GHC.TyThing -lookupType t = do - name <- liftMaybe . nameFromType $ t - sname <- liftMaybe . getSemName $ name - MaybeT . GHC.lookupName $ sname - where liftMaybe = MaybeT . return - --- NOTE: gives just name if the type being scrutinised can be newtype --- else it gives nothing -nameFromType :: Type -> Maybe Name -nameFromType (TypeApp f _) = nameFromType f -nameFromType (ParenType x) = nameFromType x -nameFromType (KindedType t _) = nameFromType t -nameFromType (VarType x) = Just x -nameFromType _ = Nothing - -isNewtypeTyCon :: GHC.TyThing -> Bool -isNewtypeTyCon (GHC.ATyCon tycon) = GHC.isNewTyCon tycon -isNewtypeTyCon _ = False - -getSemName :: Name -> Maybe GHC.Name -getSemName x = semanticsName (x ^. simpleName) diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtractBinding.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtractBinding.hs --- a/Language/Haskell/Tools/Refactor/Builtin/ExtractBinding.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtractBinding.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, MonoLocalBinds, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications, ViewPatterns #-} + module Language.Haskell.Tools.Refactor.Builtin.ExtractBinding (extractBinding', tryItOut, extractBindingRefactoring) where diff --git a/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs b/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs --- a/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, ScopedTypeVariables, TypeApplications #-} + module Language.Haskell.Tools.Refactor.Builtin.FloatOut (floatOut, floatOutRefactoring) where @@ -43,13 +44,13 @@ Extracted binds -> put Inserted >> (return $ annListElems .- (++ binds) $ locs) Inserted -> return locs where selected = locs ^? annList & filtered (isInside sp) - floated = normalizeElements $ selected ++ (locs ^? annList & filtered (nameIsSelected . (^? elementName))) - where nameIsSelected [n] = n `elem` concatMap (^? elementName) selected + floated = normalizeElements $ selected ++ (locs ^? annList & filtered (nameIsSelected . map semanticsName . (^? elementName))) + where nameIsSelected [n] = n `elem` concatMap (map semanticsName . (^? elementName)) selected nameIsSelected _ = False filteredLocs = filterList (\e -> not (getRange e `elem` floatedElemRanges)) locs where floatedElemRanges = map getRange floated - hasSharedSig = any (\e -> not $ null ((filteredLocs ^? annList & elementName) `intersect` (e ^? elementName))) selected + hasSharedSig = any (\e -> not $ null (map semanticsName (filteredLocs ^? annList & elementName) `intersect` map semanticsName (e ^? elementName))) selected conflicts = map checkConflict selected nameConflicts = concat $ map fst conflicts diff --git a/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs b/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs --- a/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, TupleSections, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, TupleSections #-} + module Language.Haskell.Tools.Refactor.Builtin.GenerateExports (generateExports, generateExportsRefactoring) where diff --git a/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs b/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs --- a/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables, TupleSections, TypeApplications, ViewPatterns #-} + module Language.Haskell.Tools.Refactor.Builtin.GenerateTypeSignature ( generateTypeSignature, generateTypeSignature', tryItOut , generateTypeSignatureRefactoring) where diff --git a/Language/Haskell/Tools/Refactor/Builtin/GetMatches.hs b/Language/Haskell/Tools/Refactor/Builtin/GetMatches.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/GetMatches.hs @@ -0,0 +1,45 @@ +module Language.Haskell.Tools.Refactor.Builtin.GetMatches where + +import Language.Haskell.Tools.Refactor + +import Control.Monad.Writer +import Control.Reference +import Data.Aeson + +import Outputable as GHC +import SrcLoc as GHC +import Id as GHC +import Type as GHC +import TyCon as GHC +import DataCon as GHC + +getMatchesQuery :: QueryChoice +getMatchesQuery = LocationQuery "GetMatches" getMatches + +getMatches :: RealSrcSpan -> ModuleDom -> [ModuleDom] -> QueryMonad Value +getMatches sp (_,mod) _ + = case selectedName of [n] -> do ctors <- getCtors $ idType $ semanticsId n + return $ toJSON ctors + [] -> queryError "No name is selected." + _ -> queryError "Multiple names are selected." + where + selectedName :: [QualifiedName] + selectedName = mod ^? nodesContaining sp + +getCtors :: GHC.Type -> QueryMonad [(String, [String])] +-- | TODO: unpack forall, context types +-- | TODO: care for infix constructors +getCtors t | Just (tc, _) <- splitTyConApp_maybe t + = maybe (queryError (noSuccessMsg t)) (return . map formatCtor) (tyConDataCons_maybe tc) +getCtors t = queryError (noSuccessMsg t) + +noSuccessMsg :: GHC.Type -> String +noSuccessMsg t = "Cannot find the constructors of type " ++ showSDocUnsafe (ppr t) + +formatCtor :: DataCon -> (String, [String]) +formatCtor dc = (showSDocUnsafe $ ppr $ dataConName dc, createArgNames (dataConOrigArgTys dc)) + +-- | TODO: Check for names in scope +-- | TODO: Create names based on the type +createArgNames :: [GHC.Type] -> [String] +createArgNames tys = map (\i -> "p" ++ show i) [1..length tys] diff --git a/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs b/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs --- a/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications #-} + -- | Defines the inline binding refactoring that removes a value binding and replaces all occurences -- with an expression equivalent to the body of the binding. module Language.Haskell.Tools.Refactor.Builtin.InlineBinding diff --git a/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs b/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs --- a/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, TupleSections, TypeFamilies, LambdaCase #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, RankNTypes, TupleSections #-} + module Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions ( module Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad @@ -7,18 +8,19 @@ import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.TraverseAST -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.SupportedExtensions (unregularExts, isSupported, fullyHandledExtensions) +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.SupportedExtensions (isSupported) import Language.Haskell.Tools.Refactor hiding (LambdaCase) -import Language.Haskell.Tools.Refactor.Utils.Extensions (expandExtension) +import Language.Haskell.Tools.Refactor.Utils.Extensions import GHC (Ghc(..)) import Control.Reference import Data.Char (isAlpha) import Data.Function (on) +import Data.Maybe (mapMaybe) import Data.List -import qualified Data.Map.Strict as SMap (keys, empty) +import qualified Data.Map.Strict as SMap (empty) -- NOTE: When working on the entire AST, we should build a monad, -- that will will avoid unnecessary checks. @@ -42,61 +44,55 @@ organizeExtensions :: LocalRefactoring organizeExtensions moduleAST = do exts <- liftGhc $ reduceExtensions moduleAST - let isRedundant e = extName `notElem` foundExts && extName `elem` handledExts - where extName = unregularExts (e ^. langExt) - handledExts = map show fullyHandledExtensions - foundExts = map show exts + let langExts = mkLanguagePragma . map show $ exts + ghcOpts = moduleAST ^? filePragmas & annList & opStr & stringNodeStr + ghcOpts' = map (mkOptionsGHC . unwords . filter (isPrefixOf "-") . words) ghcOpts - -- remove unused extensions (only those that are fully handled) - filePragmas & annList & lpPragmas !~ filterListSt (not . isRedundant) - -- remove empty {-# LANGUAGE #-} pragmas + newPragmas = mkFilePragmas $ langExts:ghcOpts' + + (filePragmas != newPragmas) + -- remove empty {-# LANGUAGE #-} pragmas >=> filePragmas !~ filterListSt (\case LanguagePragma (AnnList []) -> False; _ -> True) $ moduleAST -- | Reduces default extension list (keeps unsupported extensions) reduceExtensions :: UnnamedModule -> Ghc [Extension] -reduceExtensions = \moduleAST -> do - let expanded = expandDefaults moduleAST +reduceExtensions moduleAST = do + let defaults = map replaceDeprecated . collectDefaultExtensions $ moduleAST + expanded = expandExtensions defaults (xs, ys) = partition isSupported expanded - xs' <- flip execStateT SMap.empty . flip runReaderT xs . traverseModule $ moduleAST - return . sortBy (compare `on` show) . mergeInduced . nub $ (calcExts xs' ++ ys) - - where isLVar (LVar _) = True - isLVar _ = False - - calcExts :: ExtMap -> [Extension] - calcExts logRels - | ks <- SMap.keys logRels - , all isLVar ks - = map (\(LVar x) -> x) . SMap.keys $ logRels - | otherwise = [] - - rmInduced :: Extension -> [Extension] -> [Extension] - rmInduced e = flip (\\) induced - where induced = delete e $ expandExtension e - - mergeInduced :: [Extension] -> [Extension] - mergeInduced exts = foldl (flip rmInduced) exts exts - + -- we can't say anything about generated code + if TemplateHaskell `notElem` expanded + then do + xs' <- flip execStateT SMap.empty . flip runReaderT xs . traverseModule $ moduleAST + -- Merging is needed because there might be unsopported extensions + -- that are implied by supported extensions (TypeFamilies -> MonoLocalBinds) + return . sortBy (compare `on` show) . nub . mergeImplied $ (determineExtensions xs' ++ ys) + else + return . mergeImplied $ defaults -- | Collects extensions induced by the source code (with location info) collectExtensions :: UnnamedModule -> Ghc ExtMap -collectExtensions moduleAST = do - let expanded = expandDefaults moduleAST - flip execStateT SMap.empty . flip runReaderT expanded . traverseModule $ moduleAST +collectExtensions = collectExtensionsWith traverseModule --- | Collects default extension list, and expands each extension -expandDefaults :: UnnamedModule -> [Extension] -expandDefaults = nub . concatMap expandExtension . collectDefaultExtensions +collectExtensionsWith :: CheckNode UnnamedModule -> UnnamedModule -> Ghc ExtMap +collectExtensionsWith trvModule moduleAST = do + let expanded = expandExtensions . collectDefaultExtensions $ moduleAST + flip execStateT SMap.empty . flip runReaderT expanded . trvModule $ moduleAST + +-- | Expands every extension in a list, while not producing any duplicates. +expandExtensions :: [Extension] -> [Extension] +expandExtensions = nub . concatMap expandExtension + -- | Collects extensions enabled by default collectDefaultExtensions :: UnnamedModule -> [Extension] -collectDefaultExtensions = map toExt . getExtensions +collectDefaultExtensions = mapMaybe toExt . getExtensions where getExtensions :: UnnamedModule -> [String] getExtensions = flip (^?) (filePragmas & annList & lpPragmas & annList & langExt) -toExt :: String -> Extension -toExt str = case map fst . reads . unregularExts . takeWhile isAlpha $ str of - e:_ -> e - [] -> error $ "Extension '" ++ takeWhile isAlpha str ++ "' is not known." +toExt :: String -> Maybe Extension +toExt str = case map fst . reads . canonExt . takeWhile isAlpha $ str of + e:_ -> Just e + [] -> fail $ "Extension '" ++ takeWhile isAlpha str ++ "' is not known." diff --git a/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs b/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs --- a/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE ConstraintKinds - , FlexibleContexts - , LambdaCase - , ScopedTypeVariables - , TupleSections - , TypeApplications - , TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, ScopedTypeVariables, TupleSections, TypeApplications #-} + module Language.Haskell.Tools.Refactor.Builtin.OrganizeImports ( organizeImports, projectOrganizeImports , organizeImportsRefactoring, projectOrganizeImportsRefactoring @@ -26,6 +21,7 @@ import SrcLoc (SrcSpan(..), noSrcSpan) import TyCon (TyCon(..), tyConFamInst_maybe) import Unique (getUnique) +import CoreSyn as GHC (isOrphan) import Control.Applicative ((<$>), Alternative(..)) import Control.Monad @@ -64,9 +60,9 @@ if noNarrowingImports then -- we don't know what definitions the generated code will use return $ modImports .- sortImports $ mod - else modImports !~ narrowImports noNarrowingSubspecs exportedModules (addFromString dfs usedNames) exportedNames prelInstances prelFamInsts . sortImports $ mod - where prelInstances = semanticsPrelOrphanInsts mod - prelFamInsts = semanticsPrelFamInsts mod + else do (prelInstances, prelFamInsts) <- liftGhc $ getInstances preludeAccessible + modImports !~ fmap sortImports . narrowImports noNarrowingSubspecs exportedModules (addFromString dfs usedNames) exportedNames prelInstances prelFamInsts $ mod + where preludeAccessible = semanticsPrelTransMods mod addFromString dfs = if xopt OverloadedStrings dfs then (GHC.fromStringName :) else id usedNames = map getName $ (catMaybes $ map semanticsName -- obviously we don't want the names in the imports to be considered, but both from @@ -123,9 +119,9 @@ -- | Modify an import to only import names that are used. narrowImports :: Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> [ClsInst] -> [FamInst] -> ImportDeclList -> LocalRefactor ImportDeclList narrowImports noNarrowSubspecs exportedModules usedNames exportedNames prelInsts prelFamInsts imps - = (annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames exportedNames) - =<< filterListIndexedSt (\i _ -> impsNeeded !! i) imps - where impsNeeded = neededImports exportedModules (usedNames ++ map fst exportedNames) prelInsts prelFamInsts (imps ^. annListElems) + = do impsNeeded <- liftGhc $ neededImports exportedModules (usedNames ++ map fst exportedNames) prelInsts prelFamInsts (imps ^. annListElems) + (annListElems & traversal !~ narrowImport noNarrowSubspecs exportedModules usedNames exportedNames) + =<< filterListIndexedSt (\i _ -> impsNeeded !! i) imps -- | Reduces the number of definitions used from an import narrowImport :: Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> ImportDecl -> LocalRefactor ImportDecl @@ -187,22 +183,24 @@ createIESpec (n, True) = mkIESpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) -- | Check each import if it is actually needed -neededImports :: [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> [ImportDecl] -> [Bool] -neededImports exportedModules usedNames prelInsts prelFamInsts imps = neededImports' usedNames [] imps - where neededImports' _ _ [] = [] +neededImports :: [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> [ImportDecl] -> GHC.Ghc [Bool] +neededImports exportedModules usedNames prelInsts prelFamInsts imps = do + impsWithInsts <- mapM (\i -> (i,) <$> getInstances (semanticsTransMods i)) imps + return $ neededImports' usedNames [] prelInsts prelFamInsts impsWithInsts + where neededImports' _ _ _ _ [] = [] -- keep the import if any definition is needed from it - neededImports' usedNames kept (imp : rest) + neededImports' usedNames kept keptInsts keptFamInsts ((imp, (clsInsts, famInsts)) : rest) | not (null actuallyImported) || (imp ^. importModule & moduleNameString) `elem` exportedModules || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) - = True : neededImports' usedNames (imp : kept) rest + = True : neededImports' usedNames (imp : kept) (clsInsts ++ keptInsts) (famInsts ++ keptFamInsts) rest where actuallyImported = semanticsImported imp `intersect` usedNames - neededImports' usedNames kept (imp : rest) - = needed : neededImports' usedNames (if needed then imp : kept else kept) rest - where needed = any (`notElem` otherClsInstances) (map is_dfun $ semanticsOrphanInsts imp) - || any (`notElem` otherFamInstances) (map fi_axiom $ semanticsFamInsts imp) - otherClsInstances = map is_dfun (concatMap semanticsOrphanInsts kept ++ prelInsts) - otherFamInstances = map fi_axiom (concatMap semanticsFamInsts kept ++ prelFamInsts) + -- check if instances are needed from the import + neededImports' usedNames kept keptInsts keptFamInsts ((imp, (clsInsts, famInsts)) : rest) + = needed : if needed then neededImports' usedNames (imp : kept) (clsInsts ++ keptInsts) (famInsts ++ keptFamInsts) rest + else neededImports' usedNames kept keptInsts keptFamInsts rest + where needed = any (`notElem` map is_dfun keptInsts) (map is_dfun $ filter (isOrphan . is_orphan) clsInsts) + || any (`notElem` map fi_axiom keptFamInsts) (map fi_axiom famInsts) -- | Narrows the import specification (explicitly imported elements) narrowImportSpecs :: Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> IESpecList -> LocalRefactor IESpecList diff --git a/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs b/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs --- a/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs +++ b/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiWayIf, ScopedTypeVariables, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-} +{-# LANGUAGE FlexibleContexts, MonoLocalBinds, MultiWayIf, ScopedTypeVariables, TupleSections, TypeApplications, ViewPatterns #-} + module Language.Haskell.Tools.Refactor.Builtin.RenameDefinition (renameDefinition, renameDefinition', renameDefinitionRefactoring) where diff --git a/examples/CPP/A.hs b/examples/CPP/A.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/A.hs @@ -0,0 +1,3 @@ +module CPP.A where + +a = () diff --git a/examples/CPP/B.hs b/examples/CPP/B.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/B.hs @@ -0,0 +1,3 @@ +module CPP.B where + +b = () diff --git a/examples/CPP/BetweenImports.hs b/examples/CPP/BetweenImports.hs --- a/examples/CPP/BetweenImports.hs +++ b/examples/CPP/BetweenImports.hs @@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} module CPP.BetweenImports where -import Data.List +import CPP.A(a) #if !(MIN_VERSION_text(1,2,1)) #endif -import Data.Maybe +import CPP.B(b) -x = Just +x = a diff --git a/examples/CPP/BetweenImports_res.hs b/examples/CPP/BetweenImports_res.hs --- a/examples/CPP/BetweenImports_res.hs +++ b/examples/CPP/BetweenImports_res.hs @@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} module CPP.BetweenImports where -import Data.Maybe (Maybe(..)) +import CPP.A(a) #if !(MIN_VERSION_text(1,2,1)) #endif -x = Just +x = a diff --git a/examples/CPP/C.hs b/examples/CPP/C.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/C.hs @@ -0,0 +1,3 @@ +module CPP.C where + +c = () diff --git a/examples/CPP/ConditionalCode.hs b/examples/CPP/ConditionalCode.hs deleted file mode 100644 --- a/examples/CPP/ConditionalCode.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -module CPP.ConditionalCode where - -#if __GLASGOW_HASKELL__ >= 800 -version = "GHC 8" -#else -version = "not GHC 8" -#endif diff --git a/examples/CPP/ConditionalImport.hs b/examples/CPP/ConditionalImport.hs --- a/examples/CPP/ConditionalImport.hs +++ b/examples/CPP/ConditionalImport.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImport where -import Data.List +import CPP.A(a) #ifndef USE_DATA_LIST -import Control.Monad (Monad(..)) +import CPP.B(b) #endif -import Data.List +import CPP.A(a) -a = Nothing >> Nothing +x = b diff --git a/examples/CPP/ConditionalImportBegin.hs b/examples/CPP/ConditionalImportBegin.hs --- a/examples/CPP/ConditionalImportBegin.hs +++ b/examples/CPP/ConditionalImportBegin.hs @@ -2,9 +2,9 @@ module CPP.ConditionalImportBegin where #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.A(a) #endif -import Data.List -import Data.List +import CPP.B(b) +import CPP.B(b) -a = Nothing >> Nothing +x = a diff --git a/examples/CPP/ConditionalImportBegin_res.hs b/examples/CPP/ConditionalImportBegin_res.hs --- a/examples/CPP/ConditionalImportBegin_res.hs +++ b/examples/CPP/ConditionalImportBegin_res.hs @@ -2,8 +2,8 @@ module CPP.ConditionalImportBegin where #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.A(a) #endif -a = Nothing >> Nothing +x = a diff --git a/examples/CPP/ConditionalImportEnd.hs b/examples/CPP/ConditionalImportEnd.hs --- a/examples/CPP/ConditionalImportEnd.hs +++ b/examples/CPP/ConditionalImportEnd.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImportEnd where -import Data.List -import Data.List +import CPP.B(b) +import CPP.B(b) #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.A(a) #endif -a = Nothing >> Nothing +x = a diff --git a/examples/CPP/ConditionalImportEnd_res.hs b/examples/CPP/ConditionalImportEnd_res.hs --- a/examples/CPP/ConditionalImportEnd_res.hs +++ b/examples/CPP/ConditionalImportEnd_res.hs @@ -3,7 +3,7 @@ #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.A(a) #endif -a = Nothing >> Nothing +x = a diff --git a/examples/CPP/ConditionalImportHalfRemoved.hs b/examples/CPP/ConditionalImportHalfRemoved.hs --- a/examples/CPP/ConditionalImportHalfRemoved.hs +++ b/examples/CPP/ConditionalImportHalfRemoved.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImportHalfRemoved where -import Data.List +import CPP.A(a) #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.B(b) #endif -import Control.Applicative ((<$>)) +import CPP.C(c) -a = id <$> (Nothing >> Nothing) +x = (b,c) diff --git a/examples/CPP/ConditionalImportHalfRemoved_res.hs b/examples/CPP/ConditionalImportHalfRemoved_res.hs --- a/examples/CPP/ConditionalImportHalfRemoved_res.hs +++ b/examples/CPP/ConditionalImportHalfRemoved_res.hs @@ -3,8 +3,8 @@ #ifndef USE_DATA_LIST -import Control.Monad ((>>)) +import CPP.B(b) #endif -import Control.Applicative ((<$>)) +import CPP.C(c) -a = id <$> (Nothing >> Nothing) +x = (b,c) diff --git a/examples/CPP/ConditionalImportMulti.hs b/examples/CPP/ConditionalImportMulti.hs --- a/examples/CPP/ConditionalImportMulti.hs +++ b/examples/CPP/ConditionalImportMulti.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImportMulti where -import Data.List +import CPP.A #ifndef USE_DATA_LIST -import Control.Applicative ((<$>)) -import Control.Monad ((>>)) +import CPP.B(b) +import CPP.C(c) #endif -import Data.List +import CPP.A -a = id <$> (Nothing >> Nothing) +x = (b,c) diff --git a/examples/CPP/ConditionalImportMulti_res.hs b/examples/CPP/ConditionalImportMulti_res.hs --- a/examples/CPP/ConditionalImportMulti_res.hs +++ b/examples/CPP/ConditionalImportMulti_res.hs @@ -3,9 +3,9 @@ #ifndef USE_DATA_LIST -import Control.Applicative ((<$>)) -import Control.Monad ((>>)) +import CPP.B(b) +import CPP.C(c) #endif -a = id <$> (Nothing >> Nothing) +x = (b,c) diff --git a/examples/CPP/ConditionalImportOrder.hs b/examples/CPP/ConditionalImportOrder.hs --- a/examples/CPP/ConditionalImportOrder.hs +++ b/examples/CPP/ConditionalImportOrder.hs @@ -1,13 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImportOrder where -import Data.List (intersperse) +import CPP.C(c) #ifndef USE_DATA_LIST -import Control.Monad (Monad(..)) +import CPP.B(b) #endif -import Control.Applicative ((<$>)) - -a = Nothing >> Nothing +import CPP.A(a) -b = id <$> Nothing -c = intersperse "," ["a","b"] +x = (a,b,c) diff --git a/examples/CPP/ConditionalImportOrder_res.hs b/examples/CPP/ConditionalImportOrder_res.hs --- a/examples/CPP/ConditionalImportOrder_res.hs +++ b/examples/CPP/ConditionalImportOrder_res.hs @@ -1,13 +1,10 @@ {-# LANGUAGE CPP #-} module CPP.ConditionalImportOrder where -import Data.List (intersperse) +import CPP.C(c) #ifndef USE_DATA_LIST -import Control.Monad (Monad(..)) +import CPP.B(b) #endif -import Control.Applicative ((<$>)) - -a = Nothing >> Nothing +import CPP.A(a) -b = id <$> Nothing -c = intersperse "," ["a","b"] +x = (a,b,c) diff --git a/examples/CPP/ConditionalImport_res.hs b/examples/CPP/ConditionalImport_res.hs --- a/examples/CPP/ConditionalImport_res.hs +++ b/examples/CPP/ConditionalImport_res.hs @@ -3,8 +3,8 @@ #ifndef USE_DATA_LIST -import Control.Monad (Monad(..)) +import CPP.B(b) #endif -a = Nothing >> Nothing +x = b diff --git a/examples/CPP/JustEnabled.hs b/examples/CPP/JustEnabled.hs deleted file mode 100644 --- a/examples/CPP/JustEnabled.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# LANGUAGE CPP #-} -module CPP.JustEnabled where diff --git a/examples/CppHs/Language/Preprocessor/Cpphs.hs b/examples/CppHs/Language/Preprocessor/Cpphs.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.Preprocessor.Cpphs --- Copyright : 2000-2006 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- Include the interface that is exported ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs - ( runCpphs, runCpphsPass1, runCpphsPass2, runCpphsReturningSymTab - , cppIfdef, tokenise, WordStyle(..) - , macroPass, macroPassReturningSymTab - , CpphsOptions(..), BoolOptions(..) - , parseOptions, defaultCpphsOptions, defaultBoolOptions - , module Language.Preprocessor.Cpphs.Position - ) where - -import Language.Preprocessor.Cpphs.CppIfdef(cppIfdef) -import Language.Preprocessor.Cpphs.MacroPass(macroPass - ,macroPassReturningSymTab) -import Language.Preprocessor.Cpphs.RunCpphs(runCpphs - ,runCpphsPass1 - ,runCpphsPass2 - ,runCpphsReturningSymTab) -import Language.Preprocessor.Cpphs.Options - (CpphsOptions(..), BoolOptions(..), parseOptions - ,defaultCpphsOptions,defaultBoolOptions) -import Language.Preprocessor.Cpphs.Position -import Language.Preprocessor.Cpphs.Tokenise diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs b/examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs +++ /dev/null @@ -1,416 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : CppIfdef --- Copyright : 1999-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All - --- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's. --- and \#include's. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.CppIfdef - ( cppIfdef -- :: FilePath -> [(String,String)] -> [String] -> Options - -- -> String -> IO [(Posn,String)] - ) where - - -import Text.Parse -import Language.Preprocessor.Cpphs.SymTab -import Language.Preprocessor.Cpphs.Position (Posn,newfile,newline,newlines - ,cppline,cpp2hask,newpos) -import Language.Preprocessor.Cpphs.ReadFirst (readFirst) -import Language.Preprocessor.Cpphs.Tokenise (linesCpp,reslash) -import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) -import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine - ,expandMacro) -import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro) -import Data.Char (isDigit,isSpace,isAlphaNum) -import Data.List (intercalate,isPrefixOf) -import Numeric (readHex,readOct,readDec) -import System.IO.Unsafe (unsafeInterleaveIO) -import System.IO (hPutStrLn,stderr) -import Control.Monad (when) - --- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's, --- whilst taking account of \#define's and \#undef's as we encounter them. -cppIfdef :: FilePath -- ^ File for error reports - -> [(String,String)] -- ^ Pre-defined symbols and their values - -> [String] -- ^ Search path for \#includes - -> BoolOptions -- ^ Options controlling output style - -> String -- ^ The input file content - -> IO [(Posn,String)] -- ^ The file after processing (in lines) -cppIfdef fp syms search options = - cpp posn defs search options (Keep []) . initial . linesCpp - where - posn = newfile fp - defs = preDefine options syms - initial = if literate options then id else (cppline posn:) --- Previous versions had a very simple symbol table mapping strings --- to strings. Now the #ifdef pass uses a more elaborate table, in --- particular to deal with parameterised macros in conditionals. - - --- | Internal state for whether lines are being kept or dropped. --- In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether --- we have already succeeded in keeping some lines in a chain of --- @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts, --- used for error messages in case EOF is reached too soon. -data KeepState = Keep [Posn] | Drop Int Bool [Posn] - --- | Return just the list of lines that the real cpp would decide to keep. -cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState - -> [String] -> IO [(Posn,String)] - -cpp _ _ _ _ (Keep ps) [] | not (null ps) = do - hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++ - unlines (map show ps) - return [] -cpp _ _ _ _ _ [] = return [] - -cpp p syms path options (Keep ps) (l@('#':x):xs) = - let ws = words x - cmd = if null ws then "" else head ws - line = tail ws - sym = head (tail ws) - rest = tail (tail ws) - def = defineMacro options (sym++" "++ maybe "1" id (un rest)) - un v = if null v then Nothing else Just (unwords v) - keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps) - skipn syms' retain ud xs' = - let n = 1 + length (filter (=='\n') l) in - (if macros options && retain then emitOne (p,reslash l) - else emitMany (replicate n (p,""))) $ - cpp (newlines n p) syms' path options ud xs' - in case cmd of - "define" -> skipn (insertST def syms) True (Keep ps) xs - "undef" -> skipn (deleteST sym syms) True (Keep ps) xs - "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs - "ifdef" -> skipn syms False (keepIf (definedST sym syms)) xs - "if" -> do b <- gatherDefined p syms (unwords line) - skipn syms False (keepIf b) xs - "else" -> skipn syms False (Drop 1 False ps) xs - "elif" -> skipn syms False (Drop 1 True ps) xs - "endif" | null ps -> - do hPutStrLn stderr $ "Unmatched #endif at "++show p - return [] - "endif" -> skipn syms False (Keep (tail ps)) xs - "pragma" -> skipn syms True (Keep ps) xs - ('!':_) -> skipn syms False (Keep ps) xs -- \#!runhs scripts - "include"-> do (inc,content) <- readFirst (file syms (unwords line)) - p path - (warnings options) - cpp p syms path options (Keep ps) - (("#line 1 "++show inc): linesCpp content - ++ cppline (newline p): xs) - "warning"-> if warnings options then - do hPutStrLn stderr (l++"\nin "++show p) - skipn syms False (Keep ps) xs - else skipn syms False (Keep ps) xs - "error" -> error (l++"\nin "++show p) - "line" | all isDigit sym - -> (if locations options && hashline options then emitOne (p,l) - else if locations options then emitOne (p,cpp2hask l) - else id) $ - cpp (newpos (read sym) (un rest) p) - syms path options (Keep ps) xs - n | all isDigit n && not (null n) - -> (if locations options && hashline options then emitOne (p,l) - else if locations options then emitOne (p,cpp2hask l) - else id) $ - cpp (newpos (read n) (un (tail ws)) p) - syms path options (Keep ps) xs - | otherwise - -> do when (warnings options) $ - hPutStrLn stderr ("Warning: unknown directive #"++n - ++"\nin "++show p) - emitOne (p,l) $ - cpp (newline p) syms path options (Keep ps) xs - -cpp p syms path options (Drop n b ps) (('#':x):xs) = - let ws = words x - cmd = if null ws then "" else head ws - delse | n==1 && b = Drop 1 b ps - | n==1 = Keep ps - | otherwise = Drop n b ps - dend | n==1 = Keep (tail ps) - | otherwise = Drop (n-1) b (tail ps) - delif v | n==1 && not b && v - = Keep ps - | otherwise = Drop n b ps - skipn ud xs' = - let n' = 1 + length (filter (=='\n') x) in - emitMany (replicate n' (p,"")) $ - cpp (newlines n' p) syms path options ud xs' - in - if cmd == "ifndef" || - cmd == "if" || - cmd == "ifdef" then skipn (Drop (n+1) b (p:ps)) xs - else if cmd == "elif" then do v <- gatherDefined p syms (unwords (tail ws)) - skipn (delif v) xs - else if cmd == "else" then skipn delse xs - else if cmd == "endif" then - if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p - return [] - else skipn dend xs - else skipn (Drop n b ps) xs - -- define, undef, include, error, warning, pragma, line - -cpp p syms path options (Keep ps) (x:xs) = - let p' = newline p in seq p' $ - emitOne (p,x) $ cpp p' syms path options (Keep ps) xs -cpp p syms path options d@(Drop _ _ _) (_:xs) = - let p' = newline p in seq p' $ - emitOne (p,"") $ cpp p' syms path options d xs - - --- | Auxiliary IO functions -emitOne :: a -> IO [a] -> IO [a] -emitMany :: [a] -> IO [a] -> IO [a] -emitOne x io = do ys <- unsafeInterleaveIO io - return (x:ys) -emitMany xs io = do ys <- unsafeInterleaveIO io - return (xs++ys) - - ----- -gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool -gatherDefined p st inp = - case runParser (preExpand st) inp of - (Left msg, _) -> error ("Cannot expand #if directive in file "++show p - ++":\n "++msg) - (Right s, xs) -> do --- hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n "++s - when (any (not . isSpace) xs) $ - hPutStrLn stderr ("Warning: trailing characters after #if" - ++" macro expansion in file "++show p++": "++xs) - - case runParser parseBoolExp s of - (Left msg, _) -> error ("Cannot parse #if directive in file "++show p - ++":\n "++msg) - (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $ - hPutStrLn stderr - ("Warning: trailing characters after #if" - ++" directive in file "++show p++": "++xs) - return b - -notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace - - --- | The preprocessor must expand all macros (recursively) before evaluating --- the conditional. -preExpand :: SymTab HashDefine -> TextParser String -preExpand st = - do eof - return "" - <|> - do a <- many1 (satisfy notIdent) - commit $ pure (a++) `apply` preExpand st - <|> - do b <- expandSymOrCall st - commit $ pure (b++) `apply` preExpand st - --- | Expansion of symbols. -expandSymOrCall :: SymTab HashDefine -> TextParser String -expandSymOrCall st = - do sym <- parseSym - if sym=="defined" then do arg <- skip parseSym; convert sym [arg] - <|> - do arg <- skip $ parenthesis (do x <- skip parseSym; - skip (return x)) - convert sym [arg] - <|> convert sym [] - else - ( do args <- parenthesis (commit $ fragment `sepBy` skip (isWord ",")) - args' <- flip mapM args $ \arg-> - case runParser (preExpand st) arg of - (Left msg, _) -> fail msg - (Right s, _) -> return s - convert sym args' - <|> convert sym [] - ) - where - fragment = many1 (satisfy (`notElem`",)")) - convert "defined" [arg] = - case lookupST arg st of - Nothing | all isDigit arg -> return arg - Nothing -> return "0" - Just (a@AntiDefined{}) -> return "0" - Just (a@SymbolReplacement{}) -> return "1" - Just (a@MacroExpansion{}) -> return "1" - convert sym args = - case lookupST sym st of - Nothing -> if null args then return sym - else return "0" - -- else fail (disp sym args++" is not a defined macro") - Just (a@SymbolReplacement{}) -> do reparse (replacement a) - return "" - Just (a@MacroExpansion{}) -> do reparse (expandMacro a args False) - return "" - Just (a@AntiDefined{}) -> - if null args then return sym - else return "0" - -- else fail (disp sym args++" explicitly undefined with -U") - disp sym args = let len = length args - chars = map (:[]) ['a'..'z'] - in sym ++ if null args then "" - else "("++intercalate "," (take len chars)++")" - -parseBoolExp :: TextParser Bool -parseBoolExp = - do a <- parseExp1 - bs <- many (do skip (isWord "||") - commit $ skip parseBoolExp) - return $ foldr (||) a bs - -parseExp1 :: TextParser Bool -parseExp1 = - do a <- parseExp0 - bs <- many (do skip (isWord "&&") - commit $ skip parseExp1) - return $ foldr (&&) a bs - -parseExp0 :: TextParser Bool -parseExp0 = - do skip (isWord "!") - a <- commit $ parseExp0 - return (not a) - <|> - do val1 <- parseArithExp1 - op <- parseCmpOp - val2 <- parseArithExp1 - return (val1 `op` val2) - <|> - do sym <- parseArithExp1 - case sym of - 0 -> return False - _ -> return True - <|> - do parenthesis (commit parseBoolExp) - -parseArithExp1 :: TextParser Integer -parseArithExp1 = - do val1 <- parseArithExp0 - ( do op <- parseArithOp1 - val2 <- parseArithExp1 - return (val1 `op` val2) - <|> return val1 ) - <|> - do parenthesis parseArithExp1 - -parseArithExp0 :: TextParser Integer -parseArithExp0 = - do val1 <- parseNumber - ( do op <- parseArithOp0 - val2 <- parseArithExp0 - return (val1 `op` val2) - <|> return val1 ) - <|> - do parenthesis parseArithExp0 - -parseNumber :: TextParser Integer -parseNumber = fmap safeRead $ skip parseSym - where - safeRead s = - case s of - '0':'x':s' -> number readHex s' - '0':'o':s' -> number readOct s' - _ -> number readDec s - number rd s = - case rd s of - [] -> 0 :: Integer - ((n,_):_) -> n :: Integer - -parseCmpOp :: TextParser (Integer -> Integer -> Bool) -parseCmpOp = - do skip (isWord ">=") - return (>=) - <|> - do skip (isWord ">") - return (>) - <|> - do skip (isWord "<=") - return (<=) - <|> - do skip (isWord "<") - return (<) - <|> - do skip (isWord "==") - return (==) - <|> - do skip (isWord "!=") - return (/=) - -parseArithOp1 :: TextParser (Integer -> Integer -> Integer) -parseArithOp1 = - do skip (isWord "+") - return (+) - <|> - do skip (isWord "-") - return (-) - -parseArithOp0 :: TextParser (Integer -> Integer -> Integer) -parseArithOp0 = - do skip (isWord "*") - return (*) - <|> - do skip (isWord "/") - return (div) - <|> - do skip (isWord "%") - return (rem) - --- | Return the expansion of the symbol (if there is one). -parseSymOrCall :: SymTab HashDefine -> TextParser String -parseSymOrCall st = - do sym <- skip parseSym - args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ",")) - return $ convert sym args - <|> - do sym <- skip parseSym - return $ convert sym [] - where - convert sym args = - case lookupST sym st of - Nothing -> sym - Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a) - Just (a@MacroExpansion{}) -> recursivelyExpand st (expandMacro a args False) - Just (a@AntiDefined{}) -> name a - -recursivelyExpand :: SymTab HashDefine -> String -> String -recursivelyExpand st inp = - case runParser (parseSymOrCall st) inp of - (Left msg, _) -> inp - (Right s, _) -> s - -parseSym :: TextParser String -parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_")) - `onFail` - do xs <- allAsString - fail $ "Expected an identifier, got \""++xs++"\"" - -notIdent :: Char -> Bool -notIdent c = not (isAlphaNum c || c`elem`"'`_") - -skip :: TextParser a -> TextParser a -skip p = many (satisfy isSpace) >> p - --- | The standard "parens" parser does not work for us here. Define our own. -parenthesis :: TextParser a -> TextParser a -parenthesis p = do isWord "(" - x <- p - isWord ")" - return x - --- | Determine filename in \#include -file :: SymTab HashDefine -> String -> String -file st name = - case name of - ('"':ns) -> init ns - ('<':ns) -> init ns - _ -> let ex = recursivelyExpand st name in - if ex == name then name else file st ex - diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs b/examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : HashDefine --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- What structures are declared in a \#define. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.HashDefine - ( HashDefine(..) - , ArgOrText(..) - , expandMacro - , parseHashDefine - , simplifyHashDefines - ) where - -import Data.Char (isSpace) -import Data.List (intercalate) - -data HashDefine - = LineDrop - { name :: String } - | Pragma - { name :: String } - | AntiDefined - { name :: String - , linebreaks :: Int - } - | SymbolReplacement - { name :: String - , replacement :: String - , linebreaks :: Int - } - | MacroExpansion - { name :: String - , arguments :: [String] - , expansion :: [(ArgOrText,String)] - , linebreaks :: Int - } - deriving (Eq,Show) - --- | 'smart' constructor to avoid warnings from ghc (undefined fields) -symbolReplacement :: HashDefine -symbolReplacement = - SymbolReplacement - { name=undefined, replacement=undefined, linebreaks=undefined } - --- | Macro expansion text is divided into sections, each of which is classified --- as one of three kinds: a formal argument (Arg), plain text (Text), --- or a stringised formal argument (Str). -data ArgOrText = Arg | Text | Str deriving (Eq,Show) - --- | Expand an instance of a macro. --- Precondition: got a match on the macro name. -expandMacro :: HashDefine -> [String] -> Bool -> String -expandMacro macro parameters layout = - let env = zip (arguments macro) parameters - replace (Arg,s) = maybe ("") id (lookup s env) - replace (Str,s) = maybe (str "") str (lookup s env) - replace (Text,s) = if layout then s else filter (/='\n') s - str s = '"':s++"\"" - checkArity | length (arguments macro) == 1 && length parameters <= 1 - || length (arguments macro) == length parameters = id - | otherwise = error ("macro "++name macro++" expected "++ - show (length (arguments macro))++ - " arguments, but was given "++ - show (length parameters)) - in - checkArity $ concatMap replace (expansion macro) - --- | Parse a \#define, or \#undef, ignoring other \# directives -parseHashDefine :: Bool -> [String] -> Maybe HashDefine -parseHashDefine ansi def = (command . skip) def - where - skip xss@(x:xs) | all isSpace x = skip xs - | otherwise = xss - skip [] = [] - command ("line":xs) = Just (LineDrop ("#line"++concat xs)) - command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs)) - command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def }) - command ("undef":xs) = Just (((undef . skip) xs)) - command _ = Nothing - undef (sym:_) = AntiDefined { name=sym, linebreaks=0 } - define (sym:xs) = case {-skip-} xs of - ("(":ys) -> (macroHead sym [] . skip) ys - ys -> symbolReplacement - { name=sym - , replacement = concatMap snd - (classifyRhs [] (chop (skip ys))) } - macroHead sym args (",":xs) = (macroHead sym args . skip) xs - macroHead sym args (")":xs) = MacroExpansion - { name =sym , arguments = reverse args - , expansion = classifyRhs args (skip xs) - , linebreaks = undefined } - macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs - macroHead sym args [] = error ("incomplete macro definition:\n" - ++" #define "++sym++"(" - ++intercalate "," args) - classifyRhs args ("#":x:xs) - | ansi && - x `elem` args = (Str,x): classifyRhs args xs - classifyRhs args ("##":xs) - | ansi = classifyRhs args xs - classifyRhs args (s:"##":s':xs) - | ansi && all isSpace s && all isSpace s' - = classifyRhs args xs - classifyRhs args (word:xs) - | word `elem` args = (Arg,word): classifyRhs args xs - | otherwise = (Text,word): classifyRhs args xs - classifyRhs _ [] = [] - count = length . filter (=='\n') . concat - chop = reverse . dropWhile (all isSpace) . reverse - --- | Pretty-print hash defines to a simpler format, as key-value pairs. -simplifyHashDefines :: [HashDefine] -> [(String,String)] -simplifyHashDefines = concatMap simp - where - simp hd@LineDrop{} = [] - simp hd@Pragma{} = [] - simp hd@AntiDefined{} = [] - simp hd@SymbolReplacement{} = [(name hd, replacement hd)] - simp hd@MacroExpansion{} = [(name hd++"("++intercalate "," (arguments hd) - ++")" - ,concatMap snd (expansion hd))] diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs b/examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : MacroPass --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- Perform a cpp.second-pass, accumulating \#define's and \#undef's, --- whilst doing symbol replacement and macro expansion. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.MacroPass - ( macroPass - , preDefine - , defineMacro - , macroPassReturningSymTab - ) where - -import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro - , simplifyHashDefines) -import Language.Preprocessor.Cpphs.Tokenise (tokenise, WordStyle(..) - , parseMacroCall) -import Language.Preprocessor.Cpphs.SymTab (SymTab, lookupST, insertST - , emptyST, flattenST) -import Language.Preprocessor.Cpphs.Position (Posn, newfile, filename, lineno) -import Language.Preprocessor.Cpphs.Options (BoolOptions(..)) -import System.IO.Unsafe (unsafeInterleaveIO) -import Control.Monad ((=<<)) -import System.Time (getClockTime, toCalendarTime, formatCalendarTime) -import System.Locale (defaultTimeLocale) - -noPos :: Posn -noPos = newfile "preDefined" - --- | Walk through the document, replacing calls of macros with the expanded RHS. -macroPass :: [(String,String)] -- ^ Pre-defined symbols and their values - -> BoolOptions -- ^ Options that alter processing style - -> [(Posn,String)] -- ^ The input file content - -> IO String -- ^ The file after processing -macroPass syms options = - fmap (safetail -- to remove extra "\n" inserted below - . concat - . onlyRights) - . macroProcess (pragma options) (layout options) (lang options) - (preDefine options syms) - . tokenise (stripEol options) (stripC89 options) - (ansi options) (lang options) - . ((noPos,""):) -- ensure recognition of "\n#" at start of file - where - safetail [] = [] - safetail (_:xs) = xs - --- | auxiliary -onlyRights :: [Either a b] -> [b] -onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];) - --- | Walk through the document, replacing calls of macros with the expanded RHS. --- Additionally returns the active symbol table after processing. -macroPassReturningSymTab - :: [(String,String)] -- ^ Pre-defined symbols and their values - -> BoolOptions -- ^ Options that alter processing style - -> [(Posn,String)] -- ^ The input file content - -> IO (String,[(String,String)]) - -- ^ The file and symbol table after processing -macroPassReturningSymTab syms options = - fmap (mapFst (safetail -- to remove extra "\n" inserted below - . concat) - . walk) - . macroProcess (pragma options) (layout options) (lang options) - (preDefine options syms) - . tokenise (stripEol options) (stripC89 options) - (ansi options) (lang options) - . ((noPos,""):) -- ensure recognition of "\n#" at start of file - where - safetail [] = [] - safetail (_:xs) = xs - walk (Right x: rest) = let (xs, foo) = walk rest - in (x:xs, foo) - walk (Left x: []) = ( [] , simplifyHashDefines (flattenST x) ) - walk (Left x: rest) = walk rest - mapFst f (a,b) = (f a, b) - - --- | Turn command-line definitions (from @-D@) into 'HashDefine's. -preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine -preDefine options defines = - foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d)) - emptyST defines - --- | Turn a string representing a macro definition into a 'HashDefine'. -defineMacro :: BoolOptions -> String -> (String,HashDefine) -defineMacro opts s = - let (Cmd (Just hd):_) = tokenise True True (ansi opts) (lang opts) - [(noPos,"\n#define "++s++"\n")] - in (name hd, hd) - - --- | Trundle through the document, one word at a time, using the WordStyle --- classification introduced by 'tokenise' to decide whether to expand a --- word or macro. Encountering a \#define or \#undef causes that symbol to --- be overwritten in the symbol table. Any other remaining cpp directives --- are discarded and replaced with blanks, except for \#line markers. --- All valid identifiers are checked for the presence of a definition --- of that name in the symbol table, and if so, expanded appropriately. --- (Bool arguments are: keep pragmas? retain layout? haskell language?) --- The result lazily intersperses output text with symbol tables. Lines --- are emitted as they are encountered. A symbol table is emitted after --- each change to the defined symbols, and always at the end of processing. -macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle] - -> IO [Either (SymTab HashDefine) String] -macroProcess _ _ _ st [] = return [Left st] -macroProcess p y l st (Other x: ws) = emit x $ macroProcess p y l st ws -macroProcess p y l st (Cmd Nothing: ws) = emit "\n" $ macroProcess p y l st ws -macroProcess p y l st (Cmd (Just (LineDrop x)): ws) - = emit "\n" $ - emit x $ macroProcess p y l st ws -macroProcess pragma y l st (Cmd (Just (Pragma x)): ws) - | pragma = emit "\n" $ emit x $ macroProcess pragma y l st ws - | otherwise = emit "\n" $ macroProcess pragma y l st ws -macroProcess p layout lang st (Cmd (Just hd): ws) = - let n = 1 + linebreaks hd - newST = insertST (name hd, hd) st - in - emit (replicate n '\n') $ - emitSymTab newST $ - macroProcess p layout lang newST ws -macroProcess pr layout lang st (Ident p x: ws) = - case x of - "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws - "__LINE__" -> emit (show (lineno p)) $ macroProcess pr layout lang st ws - "__DATE__" -> do w <- return . - formatCalendarTime defaultTimeLocale "\"%d %b %Y\"" - =<< toCalendarTime =<< getClockTime - emit w $ macroProcess pr layout lang st ws - "__TIME__" -> do w <- return . - formatCalendarTime defaultTimeLocale "\"%H:%M:%S\"" - =<< toCalendarTime =<< getClockTime - emit w $ macroProcess pr layout lang st ws - _ -> - case lookupST x st of - Nothing -> emit x $ macroProcess pr layout lang st ws - Just hd -> - case hd of - AntiDefined {name=n} -> emit n $ - macroProcess pr layout lang st ws - SymbolReplacement {replacement=r} -> - let r' = if layout then r else filter (/='\n') r in - -- one-level expansion only: - -- emit r' $ macroProcess layout st ws - -- multi-level expansion: - macroProcess pr layout lang st - (tokenise True True False lang [(p,r')] - ++ ws) - MacroExpansion {} -> - case parseMacroCall p ws of - Nothing -> emit x $ - macroProcess pr layout lang st ws - Just (args,ws') -> - if length args /= length (arguments hd) then - emit x $ macroProcess pr layout lang st ws - else do args' <- mapM (fmap (concat.onlyRights) - . macroProcess pr layout - lang st) - args - -- one-level expansion only: - -- emit (expandMacro hd args' layout) $ - -- macroProcess layout st ws' - -- multi-level expansion: - macroProcess pr layout lang st - (tokenise True True False lang - [(p,expandMacro hd args' layout)] - ++ ws') - --- | Useful helper function. -emit :: a -> IO [Either b a] -> IO [Either b a] -emit x io = do xs <- unsafeInterleaveIO io - return (Right x:xs) --- | Useful helper function. -emitSymTab :: b -> IO [Either b a] -> IO [Either b a] -emitSymTab x io = do xs <- unsafeInterleaveIO io - return (Left x:xs) diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/Options.hs b/examples/CppHs/Language/Preprocessor/Cpphs/Options.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/Options.hs +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Options --- Copyright : 2006 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- This module deals with Cpphs options and parsing them ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Options - ( CpphsOptions(..) - , BoolOptions(..) - , parseOptions - , defaultCpphsOptions - , defaultBoolOptions - , trailing - ) where - -import Data.Maybe -import Data.List (isPrefixOf) - --- | Cpphs options structure. -data CpphsOptions = CpphsOptions - { infiles :: [FilePath] - , outfiles :: [FilePath] - , defines :: [(String,String)] - , includes :: [String] - , preInclude:: [FilePath] -- ^ Files to \#include before anything else - , boolopts :: BoolOptions - } deriving (Show) - --- | Default options. -defaultCpphsOptions :: CpphsOptions -defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = [] - , defines = [], includes = [] - , preInclude = [] - , boolopts = defaultBoolOptions } - --- | Options representable as Booleans. -data BoolOptions = BoolOptions - { macros :: Bool -- ^ Leave \#define and \#undef in output of ifdef? - , locations :: Bool -- ^ Place \#line droppings in output? - , hashline :: Bool -- ^ Write \#line or {-\# LINE \#-} ? - , pragma :: Bool -- ^ Keep \#pragma in final output? - , stripEol :: Bool -- ^ Remove C eol (\/\/) comments everywhere? - , stripC89 :: Bool -- ^ Remove C inline (\/**\/) comments everywhere? - , lang :: Bool -- ^ Lex input as Haskell code? - , ansi :: Bool -- ^ Permit stringise \# and catenate \#\# operators? - , layout :: Bool -- ^ Retain newlines in macro expansions? - , literate :: Bool -- ^ Remove literate markup? - , warnings :: Bool -- ^ Issue warnings? - } deriving (Show) - --- | Default settings of boolean options. -defaultBoolOptions :: BoolOptions -defaultBoolOptions = BoolOptions { macros = True, locations = True - , hashline = True, pragma = False - , stripEol = False, stripC89 = False - , lang = True, ansi = False - , layout = False, literate = False - , warnings = True } - --- | Raw command-line options. This is an internal intermediate data --- structure, used during option parsing only. -data RawOption - = NoMacro - | NoLine - | LinePragma - | Pragma - | Text - | Strip - | StripEol - | Ansi - | Layout - | Unlit - | SuppressWarnings - | Macro (String,String) - | Path String - | PreInclude FilePath - | IgnoredForCompatibility - deriving (Eq, Show) - -flags :: [(String, RawOption)] -flags = [ ("--nomacro", NoMacro) - , ("--noline", NoLine) - , ("--linepragma", LinePragma) - , ("--pragma", Pragma) - , ("--text", Text) - , ("--strip", Strip) - , ("--strip-eol", StripEol) - , ("--hashes", Ansi) - , ("--layout", Layout) - , ("--unlit", Unlit) - , ("--nowarn", SuppressWarnings) - ] - --- | Parse a single raw command-line option. Parse failure is indicated by --- result Nothing. -rawOption :: String -> Maybe RawOption -rawOption x | isJust a = a - where a = lookup x flags -rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d) - where (s,d) = break (=='=') xs -rawOption ('-':'U':xs) = Just $ IgnoredForCompatibility -rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs -rawOption xs | "--include="`isPrefixOf`xs - = Just $ PreInclude (drop 10 xs) -rawOption _ = Nothing - --- | Trim trailing elements of the second list that match any from --- the first list. Typically used to remove trailing forward\/back --- slashes from a directory path. -trailing :: (Eq a) => [a] -> [a] -> [a] -trailing xs = reverse . dropWhile (`elem`xs) . reverse - --- | Convert a list of RawOption to a BoolOptions structure. -boolOpts :: [RawOption] -> BoolOptions -boolOpts opts = - BoolOptions - { macros = not (NoMacro `elem` opts) - , locations = not (NoLine `elem` opts) - , hashline = not (LinePragma `elem` opts) - , pragma = Pragma `elem` opts - , stripEol = StripEol`elem` opts - , stripC89 = StripEol`elem` opts || Strip `elem` opts - , lang = not (Text `elem` opts) - , ansi = Ansi `elem` opts - , layout = Layout `elem` opts - , literate = Unlit `elem` opts - , warnings = not (SuppressWarnings `elem` opts) - } - --- | Parse all command-line options. -parseOptions :: [String] -> Either String CpphsOptions -parseOptions xs = f ([], [], []) xs - where - f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs - f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of - Nothing -> Left x - Just a -> f (a:opts, ins, outs) xs - f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs - f (opts, ins, outs) [] = - Right CpphsOptions { infiles = reverse ins - , outfiles = reverse outs - , defines = [ x | Macro x <- reverse opts ] - , includes = [ x | Path x <- reverse opts ] - , preInclude=[ x | PreInclude x <- reverse opts ] - , boolopts = boolOpts opts - } - normalise ('/':'/':filepath) = normalise ('/':filepath) - normalise (x:filepath) = x:normalise filepath - normalise [] = [] diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/Position.hs b/examples/CppHs/Language/Preprocessor/Cpphs/Position.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/Position.hs +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Position --- Copyright : 2000-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- Simple file position information, with recursive inclusion points. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Position - ( Posn(..) - , newfile - , addcol, newline, tab, newlines, newpos - , cppline, haskline, cpp2hask - , filename, lineno, directory - , cleanPath - ) where - -import Data.List (isPrefixOf) - --- | Source positions contain a filename, line, column, and an --- inclusion point, which is itself another source position, --- recursively. -data Posn = Pn String !Int !Int (Maybe Posn) - deriving (Eq) - -instance Show Posn where - showsPrec _ (Pn f l c i) = showString f . - showString " at line " . shows l . - showString " col " . shows c . - ( case i of - Nothing -> id - Just p -> showString "\n used by " . - shows p ) - --- | Constructor. Argument is filename. -newfile :: String -> Posn -newfile name = Pn (cleanPath name) 1 1 Nothing - --- | Increment column number by given quantity. -addcol :: Int -> Posn -> Posn -addcol n (Pn f r c i) = Pn f r (c+n) i - --- | Increment row number, reset column to 1. -newline :: Posn -> Posn ---newline (Pn f r _ i) = Pn f (r+1) 1 i -newline (Pn f r _ i) = let r' = r+1 in r' `seq` Pn f r' 1 i - --- | Increment column number, tab stops are every 8 chars. -tab :: Posn -> Posn -tab (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i - --- | Increment row number by given quantity. -newlines :: Int -> Posn -> Posn -newlines n (Pn f r _ i) = Pn f (r+n) 1 i - --- | Update position with a new row, and possible filename. -newpos :: Int -> Maybe String -> Posn -> Posn -newpos r Nothing (Pn f _ c i) = Pn f r c i -newpos r (Just ('"':f)) (Pn _ _ c i) = Pn (init f) r c i -newpos r (Just f) (Pn _ _ c i) = Pn f r c i - --- | Project the line number. -lineno :: Posn -> Int --- | Project the filename. -filename :: Posn -> String --- | Project the directory of the filename. -directory :: Posn -> FilePath - -lineno (Pn _ r _ _) = r -filename (Pn f _ _ _) = f -directory (Pn f _ _ _) = dirname f - - --- | cpp-style printing of file position -cppline :: Posn -> String -cppline (Pn f r _ _) = "#line "++show r++" "++show f - --- | haskell-style printing of file position -haskline :: Posn -> String -haskline (Pn f r _ _) = "{-# LINE "++show r++" "++show f++" #-}" - --- | Conversion from a cpp-style "#line" to haskell-style pragma. -cpp2hask :: String -> String -cpp2hask line | "#line" `isPrefixOf` line = "{-# LINE " - ++unwords (tail (words line)) - ++" #-}" - | otherwise = line - --- | Strip non-directory suffix from file name (analogous to the shell --- command of the same name). -dirname :: String -> String -dirname = reverse . safetail . dropWhile (not.(`elem`"\\/")) . reverse - where safetail [] = [] - safetail (_:x) = x - --- | Sigh. Mixing Windows filepaths with unix is bad. Make sure there is a --- canonical path separator. -cleanPath :: FilePath -> FilePath -cleanPath [] = [] -cleanPath ('\\':cs) = '/': cleanPath cs -cleanPath (c:cs) = c: cleanPath cs diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs b/examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : ReadFirst --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- Read the first file that matches in a list of search paths. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.ReadFirst - ( readFirst - ) where - -import System.IO (hPutStrLn, stderr) -import System.Directory (doesFileExist) -import Data.List (intersperse) -import Control.Monad (when) -import Language.Preprocessor.Cpphs.Position (Posn,directory,cleanPath) - --- | Attempt to read the given file from any location within the search path. --- The first location found is returned, together with the file content. --- (The directory of the calling file is always searched first, then --- the current directory, finally any specified search path.) -readFirst :: String -- ^ filename - -> Posn -- ^ inclusion point - -> [String] -- ^ search path - -> Bool -- ^ report warnings? - -> IO ( FilePath - , String - ) -- ^ discovered filepath, and file contents - -readFirst name demand path warn = - case name of - '/':nm -> try nm [""] - _ -> try name (cons dd (".":path)) - where - dd = directory demand - cons x xs = if null x then xs else x:xs - try name [] = do - when warn $ - hPutStrLn stderr ("Warning: Can't find file \""++name - ++"\" in directories\n\t" - ++concat (intersperse "\n\t" (cons dd (".":path))) - ++"\n Asked for by: "++show demand) - return ("missing file: "++name,"") - try name (p:ps) = do - let file = cleanPath p++'/':cleanPath name - ok <- doesFileExist file - if not ok then try name ps - else do content <- readFile file - return (file,content) diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs b/examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- --- The main program for cpphs, a simple C pre-processor written in Haskell. - --- Copyright (c) 2004 Malcolm Wallace --- This file is LGPL (relicensed from the GPL by Malcolm Wallace, October 2011). --} -module Language.Preprocessor.Cpphs.RunCpphs ( runCpphs - , runCpphsPass1 - , runCpphsPass2 - , runCpphsReturningSymTab - ) where - -import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef) -import Language.Preprocessor.Cpphs.MacroPass(macroPass,macroPassReturningSymTab) -import Language.Preprocessor.Cpphs.Options (CpphsOptions(..), BoolOptions(..) - ,trailing) -import Language.Preprocessor.Cpphs.Tokenise (deWordStyle, tokenise) -import Language.Preprocessor.Cpphs.Position (cleanPath, Posn) -import Language.Preprocessor.Unlit as Unlit (unlit) - - -runCpphs :: CpphsOptions -> FilePath -> String -> IO String -runCpphs options filename input = do - pass1 <- runCpphsPass1 options filename input - runCpphsPass2 (boolopts options) (defines options) filename pass1 - -runCpphsPass1 :: CpphsOptions -> FilePath -> String -> IO [(Posn,String)] -runCpphsPass1 options' filename input = do - let options= options'{ includes= map (trailing "\\/") (includes options') } - let bools = boolopts options - preInc = case preInclude options of - [] -> "" - is -> concatMap (\f->"#include \""++f++"\"\n") is - ++ "#line 1 \""++cleanPath filename++"\"\n" - - pass1 <- cppIfdef filename (defines options) (includes options) bools - (preInc++input) - return pass1 - -runCpphsPass2 :: BoolOptions -> [(String,String)] -> FilePath -> [(Posn,String)] -> IO String -runCpphsPass2 bools defines filename pass1 = do - pass2 <- macroPass defines bools pass1 - let result= if not (macros bools) - then if stripC89 bools || stripEol bools - then concatMap deWordStyle $ - tokenise (stripEol bools) (stripC89 bools) - (ansi bools) (lang bools) pass1 - else unlines (map snd pass1) - else pass2 - pass3 = if literate bools then Unlit.unlit filename else id - return (pass3 result) - -runCpphsReturningSymTab :: CpphsOptions -> FilePath -> String - -> IO (String,[(String,String)]) -runCpphsReturningSymTab options' filename input = do - let options= options'{ includes= map (trailing "\\/") (includes options') } - let bools = boolopts options - preInc = case preInclude options of - [] -> "" - is -> concatMap (\f->"#include \""++f++"\"\n") is - ++ "#line 1 \""++cleanPath filename++"\"\n" - (pass2,syms) <- - if macros bools then do - pass1 <- cppIfdef filename (defines options) (includes options) - bools (preInc++input) - macroPassReturningSymTab (defines options) bools pass1 - else do - pass1 <- cppIfdef filename (defines options) (includes options) - bools{macros=True} (preInc++input) - (_,syms) <- macroPassReturningSymTab (defines options) bools pass1 - pass1 <- cppIfdef filename (defines options) (includes options) - bools (preInc++input) - let result = if stripC89 bools || stripEol bools - then concatMap deWordStyle $ - tokenise (stripEol bools) (stripC89 bools) - (ansi bools) (lang bools) pass1 - else init $ unlines (map snd pass1) - return (result,syms) - - let pass3 = if literate bools then Unlit.unlit filename else id - return (pass3 pass2, syms) - diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs b/examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs +++ /dev/null @@ -1,92 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : SymTab --- Copyright : 2000-2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : Stable --- Portability : All --- --- Symbol Table, based on index trees using a hash on the key. --- Keys are always Strings. Stored values can be any type. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.SymTab - ( SymTab - , emptyST - , insertST - , deleteST - , lookupST - , definedST - , flattenST - , IndTree - ) where - --- | Symbol Table. Stored values are polymorphic, but the keys are --- always strings. -type SymTab v = IndTree [(String,v)] - -emptyST :: SymTab v -insertST :: (String,v) -> SymTab v -> SymTab v -deleteST :: String -> SymTab v -> SymTab v -lookupST :: String -> SymTab v -> Maybe v -definedST :: String -> SymTab v -> Bool -flattenST :: SymTab v -> [v] - -emptyST = itgen maxHash [] -insertST (s,v) ss = itiap (hash s) ((s,v):) ss id -deleteST s ss = itiap (hash s) (filter ((/=s).fst)) ss id -lookupST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss) - in if null vs then Nothing - else (Just . snd . head) vs -definedST s ss = let vs = filter ((==s).fst) ((itind (hash s)) ss) - in (not . null) vs -flattenST ss = itfold (map snd) (++) ss - - ----- --- | Index Trees (storing indexes at nodes). - -data IndTree t = Leaf t | Fork Int (IndTree t) (IndTree t) - deriving Show - -itgen :: Int -> a -> IndTree a -itgen 1 x = Leaf x -itgen n x = - let n' = n `div` 2 - in Fork n' (itgen n' x) (itgen (n-n') x) - -itiap :: --Eval a => - Int -> (a->a) -> IndTree a -> (IndTree a -> b) -> b -itiap _ f (Leaf x) k = let fx = f x in {-seq fx-} (k (Leaf fx)) -itiap i f (Fork n lt rt) k = - if i k (Fork n lt' rt) - else itiap (i-n) f rt $ \rt' -> k (Fork n lt rt') - -itind :: Int -> IndTree a -> a -itind _ (Leaf x) = x -itind i (Fork n lt rt) = if ib) -> (b->b->b) -> IndTree a -> b -itfold leaf _fork (Leaf x) = leaf x -itfold leaf fork (Fork _ l r) = fork (itfold leaf fork l) (itfold leaf fork r) - ----- --- Hash values - -maxHash :: Int -- should be prime -maxHash = 101 - -class Hashable a where - hashWithMax :: Int -> a -> Int - hash :: a -> Int - hash = hashWithMax maxHash - -instance Enum a => Hashable [a] where - hashWithMax m = h 0 - where h a [] = a - h a (c:cs) = h ((17*(fromEnum c)+19*a)`rem`m) cs - ----- diff --git a/examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs b/examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs +++ /dev/null @@ -1,281 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Tokenise --- Copyright : 2004 Malcolm Wallace --- Licence : LGPL --- --- Maintainer : Malcolm Wallace --- Stability : experimental --- Portability : All --- --- The purpose of this module is to lex a source file (language --- unspecified) into tokens such that cpp can recognise a replaceable --- symbol or macro-use, and do the right thing. ------------------------------------------------------------------------------ - -module Language.Preprocessor.Cpphs.Tokenise - ( linesCpp - , reslash - , tokenise - , WordStyle(..) - , deWordStyle - , parseMacroCall - ) where - -import Data.Char -import Language.Preprocessor.Cpphs.HashDefine -import Language.Preprocessor.Cpphs.Position - --- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp. --- The main difference is that in Cpp mode we should recognise line --- continuation characters. -data Mode = Haskell | Cpp - --- | linesCpp is, broadly speaking, Prelude.lines, except that --- on a line beginning with a \#, line continuation characters are --- recognised. In a line continuation, the newline character is --- preserved, but the backslash is not. -linesCpp :: String -> [String] -linesCpp [] = [] -linesCpp (x:xs) | x=='#' = tok Cpp ['#'] xs - | otherwise = tok Haskell [] (x:xs) - where - tok Cpp acc ('\\':'\n':ys) = tok Cpp ('\n':acc) ys - tok _ acc ('\n':'#':ys) = reverse acc: tok Cpp ['#'] ys - tok _ acc ('\n':ys) = reverse acc: tok Haskell [] ys - tok _ acc [] = reverse acc: [] - tok mode acc (y:ys) = tok mode (y:acc) ys - --- | Put back the line-continuation characters. -reslash :: String -> String -reslash ('\n':xs) = '\\':'\n':reslash xs -reslash (x:xs) = x: reslash xs -reslash [] = [] - ----- --- | Submodes are required to deal correctly with nesting of lexical --- structures. -data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle) - | String Char | LineComment | NestComment Int - | CComment | CLineComment - --- | Each token is classified as one of Ident, Other, or Cmd: --- * Ident is a word that could potentially match a macro name. --- * Cmd is a complete cpp directive (\#define etc). --- * Other is anything else. -data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine) - deriving (Eq,Show) -other :: Posn -> String -> WordStyle -other _ s = Other s - -deWordStyle :: WordStyle -> String -deWordStyle (Ident _ i) = i -deWordStyle (Other i) = i -deWordStyle (Cmd _) = "\n" - --- | tokenise is, broadly-speaking, Prelude.words, except that: --- * the input is already divided into lines --- * each word-like "token" is categorised as one of {Ident,Other,Cmd} --- * \#define's are parsed and returned out-of-band using the Cmd variant --- * All whitespace is preserved intact as tokens. --- * C-comments are converted to white-space (depending on first param) --- * Parens and commas are tokens in their own right. --- * Any cpp line continuations are respected. --- No errors can be raised. --- The inverse of tokenise is (concatMap deWordStyle). -tokenise :: Bool -> Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle] -tokenise _ _ _ _ [] = [] -tokenise stripEol stripComments ansi lang ((pos,str):pos_strs) = - (if lang then haskell else plaintext) Any [] pos pos_strs str - where - -- rules to lex Haskell - haskell :: SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - haskell Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $ - cpp Any haskell [] [] p ls xs - -- warning: non-maximal munch on comment - haskell Any acc p ls ('-':'-':xs) = emit acc $ - haskell LineComment "--" p ls xs - haskell Any acc p ls ('{':'-':xs) = emit acc $ - haskell (NestComment 0) "-{" p ls xs - haskell Any acc p ls ('/':'*':xs) - | stripComments = emit acc $ - haskell CComment " " p ls xs - haskell Any acc p ls ('/':'/':xs) - | stripEol = emit acc $ - haskell CLineComment " " p ls xs - haskell Any acc p ls ('"':xs) = emit acc $ - haskell (String '"') ['"'] p ls xs - haskell Any acc p ls ('\'':'\'':xs) = emit acc $ -- TH type quote - haskell Any "''" p ls xs - haskell Any acc p ls ('\'':xs@('\\':_)) = emit acc $ -- escaped char literal - haskell (String '\'') "'" p ls xs - haskell Any acc p ls ('\'':x:'\'':xs) = emit acc $ -- character literal - emit ['\'', x, '\''] $ - haskell Any [] p ls xs - haskell Any acc p ls ('\'':xs) = emit acc $ -- TH name quote - haskell Any "'" p ls xs - haskell Any acc p ls (x:xs) | single x = emit acc $ emit [x] $ - haskell Any [] p ls xs - haskell Any acc p ls (x:xs) | space x = emit acc $ - haskell (Pred space other) [x] - p ls xs - haskell Any acc p ls (x:xs) | symbol x = emit acc $ - haskell (Pred symbol other) [x] - p ls xs - -- haskell Any [] p ls (x:xs) | ident0 x = id $ - haskell Any acc p ls (x:xs) | ident0 x = emit acc $ - haskell (Pred ident1 Ident) [x] - p ls xs - haskell Any acc p ls (x:xs) = haskell Any (x:acc) p ls xs - - haskell pre@(Pred pred ws) acc p ls (x:xs) - | pred x = haskell pre (x:acc) p ls xs - haskell (Pred _ ws) acc p ls xs = ws p (reverse acc): - haskell Any [] p ls xs - haskell (String c) acc p ls ('\\':x:xs) - | x=='\\' = haskell (String c) ('\\':'\\':acc) p ls xs - | x==c = haskell (String c) (c:'\\':acc) p ls xs - haskell (String c) acc p ls (x:xs) - | x==c = emit (c:acc) $ haskell Any [] p ls xs - | otherwise = haskell (String c) (x:acc) p ls xs - haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs - haskell LineComment acc p ls (x:xs) = haskell LineComment (x:acc) p ls xs - haskell (NestComment n) acc p ls ('{':'-':xs) - = haskell (NestComment (n+1)) - ("-{"++acc) p ls xs - haskell (NestComment 0) acc p ls ('-':'}':xs) - = emit ("}-"++acc) $ haskell Any [] p ls xs - haskell (NestComment n) acc p ls ('-':'}':xs) - = haskell (NestComment (n-1)) - ("}-"++acc) p ls xs - haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc) - p ls xs - haskell CComment acc p ls ('*':'/':xs) = emit (" "++acc) $ - haskell Any [] p ls xs - haskell CComment acc p ls (x:xs) = haskell CComment (white x:acc) p ls xs - haskell CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs - haskell CLineComment acc p ls (_:xs) = haskell CLineComment (' ':acc) - p ls xs - haskell mode acc _ ((p,l):ls) [] = haskell mode acc p ls ('\n':l) - haskell _ acc _ [] [] = emit acc $ [] - - -- rules to lex Cpp - cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle]) - -> String -> [String] -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - cpp mode next word line pos remaining input = - lexcpp mode word line remaining input - where - lexcpp Any w l ls ('/':'*':xs) = lexcpp (NestComment 0) "" (w*/*l) ls xs - lexcpp Any w l ls ('/':'/':xs) = lexcpp LineComment " " (w*/*l) ls xs - lexcpp Any w l ((p,l'):ls) ('\\':[]) = cpp Any next [] ("\n":w*/*l) p ls l' - lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs - lexcpp Any w l ls xs@('\n':_) = Cmd (parseHashDefine ansi - (reverse (w*/*l))): - next Any [] pos ls xs - -- lexcpp Any w l ls ('"':xs) = lexcpp (String '"') ['"'] (w*/*l) ls xs - -- lexcpp Any w l ls ('\'':xs) = lexcpp (String '\'') "'" (w*/*l) ls xs - lexcpp Any w l ls ('"':xs) = lexcpp Any [] ("\"":(w*/*l)) ls xs - lexcpp Any w l ls ('\'':xs) = lexcpp Any [] ("'": (w*/*l)) ls xs - lexcpp Any [] l ls (x:xs) - | ident0 x = lexcpp (Pred ident1 Ident) [x] l ls xs - -- lexcpp Any w l ls (x:xs) | ident0 x = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs - lexcpp Any w l ls (x:xs) - | single x = lexcpp Any [] ([x]:w*/*l) ls xs - | space x = lexcpp (Pred space other) [x] (w*/*l) ls xs - | symbol x = lexcpp (Pred symbol other) [x] (w*/*l) ls xs - | otherwise = lexcpp Any (x:w) l ls xs - lexcpp pre@(Pred pred _) w l ls (x:xs) - | pred x = lexcpp pre (x:w) l ls xs - lexcpp (Pred _ _) w l ls xs = lexcpp Any [] (w*/*l) ls xs - lexcpp (String c) w l ls ('\\':x:xs) - | x=='\\' = lexcpp (String c) ('\\':'\\':w) l ls xs - | x==c = lexcpp (String c) (c:'\\':w) l ls xs - lexcpp (String c) w l ls (x:xs) - | x==c = lexcpp Any [] ((c:w)*/*l) ls xs - | otherwise = lexcpp (String c) (x:w) l ls xs - lexcpp LineComment w l ((p,l'):ls) ('\\':[]) - = cpp LineComment next [] (('\n':w)*/*l) pos ls l' - lexcpp LineComment w l ls ('\\':'\n':xs) - = lexcpp LineComment [] (('\n':w)*/*l) ls xs - lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs - lexcpp LineComment w l ls (_:xs) = lexcpp LineComment (' ':w) l ls xs - lexcpp (NestComment _) w l ls ('*':'/':xs) - = lexcpp Any [] (w*/*l) ls xs - lexcpp (NestComment n) w l ls (x:xs) = lexcpp (NestComment n) (white x:w) l - ls xs - lexcpp mode w l ((p,l'):ls) [] = cpp mode next w l p ls ('\n':l') - lexcpp _ _ _ [] [] = [] - - -- rules to lex non-Haskell, non-cpp text - plaintext :: SubMode -> String -> Posn -> [(Posn,String)] - -> String -> [WordStyle] - plaintext Any acc p ls ('\n':'#':xs) = emit acc $ -- emit "\n" $ - cpp Any plaintext [] [] p ls xs - plaintext Any acc p ls ('/':'*':xs) - | stripComments = emit acc $ - plaintext CComment " " p ls xs - plaintext Any acc p ls ('/':'/':xs) - | stripEol = emit acc $ - plaintext CLineComment " " p ls xs - plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $ - plaintext Any [] p ls xs - plaintext Any acc p ls (x:xs) | space x = emit acc $ - plaintext (Pred space other) [x] - p ls xs - plaintext Any acc p ls (x:xs) | ident0 x = emit acc $ - plaintext (Pred ident1 Ident) [x] - p ls xs - plaintext Any acc p ls (x:xs) = plaintext Any (x:acc) p ls xs - plaintext pre@(Pred pred ws) acc p ls (x:xs) - | pred x = plaintext pre (x:acc) p ls xs - plaintext (Pred _ ws) acc p ls xs = ws p (reverse acc): - plaintext Any [] p ls xs - plaintext CComment acc p ls ('*':'/':xs) = emit (" "++acc) $ - plaintext Any [] p ls xs - plaintext CComment acc p ls (x:xs) = plaintext CComment (white x:acc) p ls xs - plaintext CLineComment acc p ls xs@('\n':_) - = emit acc $ plaintext Any [] p ls xs - plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':acc) - p ls xs - plaintext mode acc _ ((p,l):ls) [] = plaintext mode acc p ls ('\n':l) - plaintext _ acc _ [] [] = emit acc $ [] - - -- predicates for lexing Haskell. - ident0 x = isAlpha x || x `elem` "_`" - ident1 x = isAlphaNum x || x `elem` "'_`" - symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~" - single x = x `elem` "(),[];{}" - space x = x `elem` " \t" - -- conversion of comment text to whitespace - white '\n' = '\n' - white '\r' = '\r' - white _ = ' ' - -- emit a token (if there is one) from the accumulator - emit "" = id - emit xs = (Other (reverse xs):) - -- add a reversed word to the accumulator - "" */* l = l - w */* l = reverse w : l - -- help out broken Haskell compilers which need balanced numbers of C - -- comments in order to do import chasing :-) -----> */* - - --- | Parse a possible macro call, returning argument list and remaining input -parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle]) -parseMacroCall p = call . skip - where - skip (Other x:xs) | all isSpace x = skip xs - skip xss = xss - call (Other "(":xs) = (args (0::Int) [] [] . skip) xs - call _ = Nothing - args 0 w acc ( Other ")" :xs) = Just (reverse (addone w acc), xs) - args 0 w acc ( Other "," :xs) = args 0 [] (addone w acc) (skip xs) - args n w acc (x@(Other "("):xs) = args (n+1) (x:w) acc xs - args n w acc (x@(Other ")"):xs) = args (n-1) (x:w) acc xs - args n w acc ( Ident _ v :xs) = args n (Ident p v:w) acc xs - args n w acc (x@(Other _) :xs) = args n (x:w) acc xs - args _ _ _ _ = Nothing - addone w acc = reverse (skip w): acc diff --git a/examples/CppHs/Language/Preprocessor/Unlit.hs b/examples/CppHs/Language/Preprocessor/Unlit.hs deleted file mode 100644 --- a/examples/CppHs/Language/Preprocessor/Unlit.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Part of this code is from "Report on the Programming Language Haskell", --- version 1.2, appendix C. -module Language.Preprocessor.Unlit (unlit) where - -import Data.Char -import Data.List (isPrefixOf) - -data Classified = Program String | Blank | Comment - | Include Int String | Pre String - -classify :: [String] -> [Classified] -classify [] = [] -classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs - where allProg [] = [] -- Should give an error message, - -- but I have no good position information. - allProg (('\\':x):xs) | "end{code}"`isPrefixOf`x = Blank : classify xs - allProg (x:xs) = Program x:allProg xs -classify (('>':x):xs) = Program (' ':x) : classify xs -classify (('#':x):xs) = (case words x of - (line:rest) | all isDigit line - -> Include (read line) (unwords rest) - _ -> Pre x - ) : classify xs ---classify (x:xs) | "{-# LINE" `isPrefixOf` x = Program x: classify xs -classify (x:xs) | all isSpace x = Blank:classify xs -classify (x:xs) = Comment:classify xs - -unclassify :: Classified -> String -unclassify (Program s) = s -unclassify (Pre s) = '#':s -unclassify (Include i f) = '#':' ':show i ++ ' ':f -unclassify Blank = "" -unclassify Comment = "" - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> String -unlit file lhs = (unlines - . map unclassify - . adjacent file (0::Int) Blank - . classify) (inlines lhs) - -adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified] -adjacent file 0 _ (x :xs) = x : adjacent file 1 x xs -- force evaluation of line number -adjacent file n y@(Program _) (x@Comment :xs) = error (message file n "program" "comment") -adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@(Program _) (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n y@Comment (x@(Program _) :xs) = error (message file n "comment" "program") -adjacent file n y@Comment (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Comment (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n y@Blank (x@(Include i f):xs) = x: adjacent f i y xs -adjacent file n y@Blank (x@(Pre _) :xs) = x: adjacent file (n+1) y xs -adjacent file n _ (x@next :xs) = x: adjacent file (n+1) x xs -adjacent file n _ [] = [] - -message :: String -> Int -> String -> String -> String -message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" -message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n" -message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n" - - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines s = lines' s id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - diff --git a/examples/Decl/AmbiguousFields.hs b/examples/Decl/AmbiguousFields.hs deleted file mode 100644 --- a/examples/Decl/AmbiguousFields.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module Decl.AmbiguousFields where - -data A = A { x, y :: Int } -data B = B { x, y :: Int } - -f :: A -> Int -f = x - diff --git a/examples/Decl/AnnPragma.hs b/examples/Decl/AnnPragma.hs deleted file mode 100644 --- a/examples/Decl/AnnPragma.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Decl.AnnPragma where -{-# ANN module (Just "Hello") #-} -{-# ANN f (Just "Hello") #-} -f :: Int -> Int -f a = a + 1 - -{-# ANN type A (Just "Hello") #-} -data A = A diff --git a/examples/Decl/ClassInfix.hs b/examples/Decl/ClassInfix.hs deleted file mode 100644 --- a/examples/Decl/ClassInfix.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Decl.ClassInfix where - -import Control.Applicative - -class Applicative f => MonoidApplicative f where - infixl 4 +<*> - (+<*>) :: f (a -> a) -> f a -> f a - - infixl 5 >< - (><) :: Monoid a => f a -> f a -> f a diff --git a/examples/Decl/ClosedTypeFamily.hs b/examples/Decl/ClosedTypeFamily.hs deleted file mode 100644 --- a/examples/Decl/ClosedTypeFamily.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Decl.ClosedTypeFamily where - -type family F a where - F Int = Bool - F Bool = Char - F a = Bool - -type family ClosedEmpty t where diff --git a/examples/Decl/CompletePragma.hs b/examples/Decl/CompletePragma.hs deleted file mode 100644 --- a/examples/Decl/CompletePragma.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Decl.CompletePragma where - -data Choice a = Choice Bool a - -pattern LeftChoice :: a -> Choice a -pattern LeftChoice a = Choice False a - -pattern RightChoice :: a -> Choice a -pattern RightChoice a = Choice True a - -{-# COMPLETE LeftChoice, RightChoice #-} - -foo :: Choice Int -> Int -foo (LeftChoice n) = n * 2 -foo (RightChoice n) = n - 2 diff --git a/examples/Decl/CtorOp.hs b/examples/Decl/CtorOp.hs deleted file mode 100644 --- a/examples/Decl/CtorOp.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Decl.CtorOp where - -data a :+: b = a :+: b - -data (a :!: b) c = a c :!: b c - -data ((:-:) a) b = a :-: b - -data (:*:) a b = a :*: b diff --git a/examples/Decl/DataFamily.hs b/examples/Decl/DataFamily.hs deleted file mode 100644 --- a/examples/Decl/DataFamily.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Decl.DataFamily where - -data family Array :: * -> * - -data instance Array () = UnitArray Int deriving Show diff --git a/examples/Decl/DataInstanceGADT.hs b/examples/Decl/DataInstanceGADT.hs deleted file mode 100644 --- a/examples/Decl/DataInstanceGADT.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE GADTs, KindSignatures, TypeFamilies #-} -module Decl.DataInstanceGADT where - -data family GadtFam (a :: *) (b :: *) -data instance GadtFam c d where - MkGadtFam1 :: x -> y -> GadtFam y x diff --git a/examples/Decl/DataType.hs b/examples/Decl/DataType.hs deleted file mode 100644 --- a/examples/Decl/DataType.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.DataType where - -data EmptyData - -data A = B Int | C diff --git a/examples/Decl/DataTypeDerivings.hs b/examples/Decl/DataTypeDerivings.hs deleted file mode 100644 --- a/examples/Decl/DataTypeDerivings.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.DataTypeDerivings where - -data A = A deriving (Eq, Show) -data B = B deriving (Eq) -data C = C deriving Eq diff --git a/examples/Decl/DefaultDecl.hs b/examples/Decl/DefaultDecl.hs deleted file mode 100644 --- a/examples/Decl/DefaultDecl.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.DefaultDecl where - -default () diff --git a/examples/Decl/FunBind.hs b/examples/Decl/FunBind.hs deleted file mode 100644 --- a/examples/Decl/FunBind.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Decl.FunBind where - -f 0 = 1 -f x = x diff --git a/examples/Decl/FunFixity.hs b/examples/Decl/FunFixity.hs deleted file mode 100644 --- a/examples/Decl/FunFixity.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.FunFixity where - -infixl `snoc` -snoc :: [a] -> a -> [a] -snoc xs x = xs ++ [x] diff --git a/examples/Decl/FunGuards.hs b/examples/Decl/FunGuards.hs deleted file mode 100644 --- a/examples/Decl/FunGuards.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.FunGuards where - -f 0 = 1 -f x | even x = 0 - | otherwise = 2 diff --git a/examples/Decl/FunctionalDeps.hs b/examples/Decl/FunctionalDeps.hs deleted file mode 100644 --- a/examples/Decl/FunctionalDeps.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} -module Decl.FunctionalDeps where - -class C a b | a -> b, b -> a where - trf :: a -> b - diff --git a/examples/Decl/GADT.hs b/examples/Decl/GADT.hs deleted file mode 100644 --- a/examples/Decl/GADT.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs, KindSignatures, DeriveDataTypeable #-} -module Decl.GADT where - -import Data.Typeable - -data DMap k f where - Tip :: DMap k f - Bin :: !Int -> !(k v) -> f v -> !(DMap k f) -> !(DMap k f) -> DMap k f - deriving Typeable diff --git a/examples/Decl/GadtConWithCtx.hs b/examples/Decl/GadtConWithCtx.hs deleted file mode 100644 --- a/examples/Decl/GadtConWithCtx.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Decl.GadtConWithCtx where - -data Concurrently m a where - Concurrently :: Monad m => { runConcurrently :: m a } -> Concurrently m a diff --git a/examples/Decl/InfixAssertion.hs b/examples/Decl/InfixAssertion.hs deleted file mode 100644 --- a/examples/Decl/InfixAssertion.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, TypeFamilies #-} -module Decl.InfixAssertion where - -import GHC.TypeLits - -data Proxy (n :: Nat) = Proxy - -divSNat :: (1 <= b) => Proxy b -> Proxy b -divSNat n = n diff --git a/examples/Decl/InfixInstances.hs b/examples/Decl/InfixInstances.hs deleted file mode 100644 --- a/examples/Decl/InfixInstances.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeOperators, TypeFamilies #-} -module Decl.InfixInstances where - -data Zipper h i a = Zipper -data (:@) a i -infixl 8 :> -type family (:>) h p -type instance h :> (a :@ i) = Zipper h i a diff --git a/examples/Decl/InfixPatSyn.hs b/examples/Decl/InfixPatSyn.hs deleted file mode 100644 --- a/examples/Decl/InfixPatSyn.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Decl.InfixPatSyn where - -pattern x :. xs <- (uncons -> Just (x,xs)) where - x:.xs = cons x xs -infixr 5 :. - -cons x xs = x:xs -uncons (x:xs) = Just (x,xs) -uncons [] = Nothing diff --git a/examples/Decl/InjectiveTypeFamily.hs b/examples/Decl/InjectiveTypeFamily.hs deleted file mode 100644 --- a/examples/Decl/InjectiveTypeFamily.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-} -module Decl.InjectiveTypeFamily where - -type family Array a = r | r -> a - -type instance Array () = Int diff --git a/examples/Decl/InlinePragma.hs b/examples/Decl/InlinePragma.hs deleted file mode 100644 --- a/examples/Decl/InlinePragma.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.InlinePragma where - -comp :: (b -> c) -> (a -> b) -> a -> c -{-# INLINE CONLIKE [~1] comp #-} -comp f g = \x -> f (g x) diff --git a/examples/Decl/InstanceFamily.hs b/examples/Decl/InstanceFamily.hs deleted file mode 100644 --- a/examples/Decl/InstanceFamily.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeOperators, TypeFamilies #-} -module Decl.InstanceFamily where - -import GHC.Generics - -class HasTrie a where - data (:->:) a :: * -> * - -instance (HasTrie (f x)) => HasTrie (M1 i t f x) where - data (M1 i t f x :->: b) = M1Trie (f x :->: b) diff --git a/examples/Decl/InstanceOverlaps.hs b/examples/Decl/InstanceOverlaps.hs deleted file mode 100644 --- a/examples/Decl/InstanceOverlaps.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Decl.InstanceOverlaps where - -data A a = A a - -instance {-# OVERLAPPING #-} Show (A String) where - show (A a) = a -instance {-# OVERLAPS #-} Show a => Show (A [a]) where - show (A a) = show a -instance {-# OVERLAPPABLE #-} Show (A a) where - show (A _) = "A" diff --git a/examples/Decl/InstanceSpec.hs b/examples/Decl/InstanceSpec.hs deleted file mode 100644 --- a/examples/Decl/InstanceSpec.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Decl.InstanceSpec where - -data Foo a = Foo a - -instance (Eq a) => Eq (Foo a) where - {-# SPECIALIZE instance Eq (Foo Char) #-} - Foo a == Foo b = a == b diff --git a/examples/Decl/LocalBindingInDo.hs b/examples/Decl/LocalBindingInDo.hs deleted file mode 100644 --- a/examples/Decl/LocalBindingInDo.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Decl.LocalBindingInDo where - -x :: Maybe () -x = do let y = f a - where a = () - return y - where f = id diff --git a/examples/Decl/LocalBindings.hs b/examples/Decl/LocalBindings.hs deleted file mode 100644 --- a/examples/Decl/LocalBindings.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Decl.LocalBindings where - -f x = g x - where g :: Int -> Int - g = id - -f' x | even x = g x - where g :: Int -> Int - g = id diff --git a/examples/Decl/LocalFixity.hs b/examples/Decl/LocalFixity.hs deleted file mode 100644 --- a/examples/Decl/LocalFixity.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Decl.LocalFixity where - -x = 1 `f` 2 - where f :: Int -> Int -> Int - f a b = a + b - infixl 6 `f` diff --git a/examples/Decl/MinimalPragma.hs b/examples/Decl/MinimalPragma.hs deleted file mode 100644 --- a/examples/Decl/MinimalPragma.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Decl.MinimalPragma where - -class A x where - f, g :: x -> () - {-# MINIMAL f,g #-} - -class B x where - fb, gb :: x -> () - fb = gb - gb = fb - {-# MINIMAL fb | gb #-} - -class C x where - fc, gc, hc :: x -> x - gc = fc - hc = fc - fc = gc . hc - {-# MINIMAL fc | (gc, hc) #-} - -class D x where - fd :: x -> x - fd = id - {-# MINIMAL #-} diff --git a/examples/Decl/MixedInstance.hs b/examples/Decl/MixedInstance.hs deleted file mode 100644 --- a/examples/Decl/MixedInstance.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-} -module Decl.MixedInstance where - -data Canvas = Canvas -data V2 = V2 - -class Backend c v e where - data Options c v e :: * - -instance Backend Canvas V2 Double where - data Options Canvas V2 Double = CanvasOptions diff --git a/examples/Decl/MultipleFixity.hs b/examples/Decl/MultipleFixity.hs deleted file mode 100644 --- a/examples/Decl/MultipleFixity.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Decl.MultipleFixity where - -f :: Int -> Int -> Int -f a b = a + b - -g = f - -infixl 6 `f`, `g` - -h = f - -infixl 5 `h` diff --git a/examples/Decl/MultipleSigs.hs b/examples/Decl/MultipleSigs.hs deleted file mode 100644 --- a/examples/Decl/MultipleSigs.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Decl.MultipleSigs where - -f, g :: Int -> Int -> Int -f a b = a + b - -g = f diff --git a/examples/Decl/OperatorBind.hs b/examples/Decl/OperatorBind.hs deleted file mode 100644 --- a/examples/Decl/OperatorBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Decl.OperatorBind where - -a >< b = a ++ b - -(<+>) :: Int -> Int -> Int -> Int -(a <+> b) c = a + b + c diff --git a/examples/Decl/OperatorDecl.hs b/examples/Decl/OperatorDecl.hs deleted file mode 100644 --- a/examples/Decl/OperatorDecl.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Decl.OperatorDecl where - -(-!-) :: Int -> Int -> Int -(-!-) a b = a + b - -test = (-!-) (1 -!- 2) 3 diff --git a/examples/Decl/ParamDataType.hs b/examples/Decl/ParamDataType.hs deleted file mode 100644 --- a/examples/Decl/ParamDataType.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.ParamDataType where - -data A a = B Int | C a - -data X a = X a diff --git a/examples/Decl/PatternBind.hs b/examples/Decl/PatternBind.hs deleted file mode 100644 --- a/examples/Decl/PatternBind.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.PatternBind where - -(x,y) | 1 == 1 = (1,2) diff --git a/examples/Decl/PatternSynonym.hs b/examples/Decl/PatternSynonym.hs deleted file mode 100644 --- a/examples/Decl/PatternSynonym.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Decl.PatternSynonym where - -data Type = App String [Type] - -pattern Arrow :: Type -> Type -> Type -pattern Arrow t1 t2 = App "->" [t1, t2] - - -pattern Int <- App "Int" [] - -pattern Maybe t <- App "Maybe" [t] - where Maybe (App "()" []) = App "Bool" [] - Maybe t = App "Maybe" [t] - -pattern (:<) :: [a] -> a -> [a] -pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x)) - where - (:<) xs x = xs ++ [x] - ------- this is not supported yet --- class ListLike a where --- pattern Head :: e -> a e0 --- pattern Tail :: a e -> a e - --- instance ListLike [] where --- pattern Head h = h:_ --- pattern Tail t = _:t diff --git a/examples/Decl/RecordPatternSynonyms.hs b/examples/Decl/RecordPatternSynonyms.hs deleted file mode 100644 --- a/examples/Decl/RecordPatternSynonyms.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Decl.RecordPatternSynonyms where - -pattern XPoint {xp} <- (xp, 0) where XPoint xp = (xp, 0) - -pattern Point {x, y} = (x, y) - -r = (0, 0) { x = 1 } diff --git a/examples/Decl/RecordType.hs b/examples/Decl/RecordType.hs deleted file mode 100644 --- a/examples/Decl/RecordType.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.RecordType where - -data A = B { valB, extra :: Int, qq :: Double } | C diff --git a/examples/Decl/RewriteRule.hs b/examples/Decl/RewriteRule.hs deleted file mode 100644 --- a/examples/Decl/RewriteRule.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.RewriteRule where - -{-# RULES "map/map" forall f g xs . map f (map g xs) = map (f . g) xs #-} diff --git a/examples/Decl/SpecializePragma.hs b/examples/Decl/SpecializePragma.hs deleted file mode 100644 --- a/examples/Decl/SpecializePragma.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Decl.SpecializePragma where - -hammeredLookup :: Ord key => [(key, value)] -> key -> value -{-# SPECIALIZE hammeredLookup :: [(String, value)] -> String -> value, [(Char, value)] -> Char -> value #-} -hammeredLookup = undefined diff --git a/examples/Decl/StandaloneDeriving.hs b/examples/Decl/StandaloneDeriving.hs deleted file mode 100644 --- a/examples/Decl/StandaloneDeriving.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -module Decl.StandaloneDeriving where - -data WrapStr = WrapStr String - -deriving instance Eq WrapStr diff --git a/examples/Decl/TypeClass.hs b/examples/Decl/TypeClass.hs deleted file mode 100644 --- a/examples/Decl/TypeClass.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Decl.TypeClass where - -class EmptyClass a - -class Show a => C a where - type X a :: * - type X a = Int - data Q a :: * - - f :: a -> String - f = show - diff --git a/examples/Decl/TypeClassMinimal.hs b/examples/Decl/TypeClassMinimal.hs deleted file mode 100644 --- a/examples/Decl/TypeClassMinimal.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Decl.TypeClassMinimal where - -class Eq' a where - (=.=) :: a -> a -> Bool - (/.=) :: a -> a -> Bool - x =.= y = not (x /.= y) - x /.= y = not (x =.= y) - {-# MINIMAL (=.=) | (/.=) #-} diff --git a/examples/Decl/TypeFamily.hs b/examples/Decl/TypeFamily.hs deleted file mode 100644 --- a/examples/Decl/TypeFamily.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Decl.TypeFamily where - -type family Array a :: * - -type instance Array () = Int diff --git a/examples/Decl/TypeFamilyKindSig.hs b/examples/Decl/TypeFamilyKindSig.hs deleted file mode 100644 --- a/examples/Decl/TypeFamilyKindSig.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Decl.TypeFamilyKindSig where - -type family Array (a :: *) :: * - -type instance Array () = Int diff --git a/examples/Decl/TypeInstance.hs b/examples/Decl/TypeInstance.hs deleted file mode 100644 --- a/examples/Decl/TypeInstance.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeFamilies, InstanceSigs #-} -module Decl.TypeInstance where - -import Decl.TypeClass - -data A = A deriving Show - -instance C A where - type X A = Int - data Q A = Bool - - f :: A -> String - f A = "XXX" - diff --git a/examples/Decl/TypeRole.hs b/examples/Decl/TypeRole.hs deleted file mode 100644 --- a/examples/Decl/TypeRole.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -module Decl.TypeRole where - -type role Foo representational representational -data Foo a b = Foo Int diff --git a/examples/Decl/TypeSynonym.hs b/examples/Decl/TypeSynonym.hs deleted file mode 100644 --- a/examples/Decl/TypeSynonym.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.TypeSynonym where - -type List = Int diff --git a/examples/Decl/ValBind.hs b/examples/Decl/ValBind.hs deleted file mode 100644 --- a/examples/Decl/ValBind.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Decl.ValBind where - -x = 1 diff --git a/examples/Decl/ViewPatternSynonym.hs b/examples/Decl/ViewPatternSynonym.hs deleted file mode 100644 --- a/examples/Decl/ViewPatternSynonym.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Decl.ViewPatternSynonym where - -data Uncert a = Un a a - -pattern x :+/- dx <- Un x (sqrt->dx) - where - x :+/- dx = Un x (dx*dx) diff --git a/examples/Expr/ArrowNotation.hs b/examples/Expr/ArrowNotation.hs deleted file mode 100644 --- a/examples/Expr/ArrowNotation.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE Arrows #-} -module Expr.ArrowNotation where - -import Control.Arrow - -addA :: Arrow a => a b Int -> a b Int -> a b Int -addA f g = proc x -> do - y <- f -< x - z <- g -< x - returnA -< y + z diff --git a/examples/Expr/Case.hs b/examples/Expr/Case.hs deleted file mode 100644 --- a/examples/Expr/Case.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Expr.Case where - -x = 12 - -a = case x of 1 -> 0 - _ -> 1 - -b = case x of { 1 -> 0; _ -> 1 } diff --git a/examples/Expr/DoNotation.hs b/examples/Expr/DoNotation.hs deleted file mode 100644 --- a/examples/Expr/DoNotation.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Expr.DoNotation where - -import Control.Monad.Identity - -x1 :: Identity () -x1 = return () - -x2 :: Identity () -x2 = do return () - -x3 :: Identity () -x3 = do { return () } - -x4 :: Identity Int -x4 = do { one <- Identity 1; return (one + 1) } diff --git a/examples/Expr/EmptyCase.hs b/examples/Expr/EmptyCase.hs deleted file mode 100644 --- a/examples/Expr/EmptyCase.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE EmptyCase #-} -module Expr.EmptyCase where - -x = 12 - -a = case x of - -b = case x of {} diff --git a/examples/Expr/EmptyLet.hs b/examples/Expr/EmptyLet.hs deleted file mode 100644 --- a/examples/Expr/EmptyLet.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Expr.EmptyLet where - -a = let in () - -m = do let - putStrLn "hello" diff --git a/examples/Expr/FunSection.hs b/examples/Expr/FunSection.hs deleted file mode 100644 --- a/examples/Expr/FunSection.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Expr.FunSection where - -data Rule = Rule { - rulePath :: String -> Bool } - -f r = filter (`rulePath` r) diff --git a/examples/Expr/GeneralizedListComp.hs b/examples/Expr/GeneralizedListComp.hs deleted file mode 100644 --- a/examples/Expr/GeneralizedListComp.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - MonadComprehensions, - RecordWildCards #-} -module Expr.GeneralizedListComp where - -import GHC.Exts -import qualified Data.Map as M -import Data.Ord (comparing) - -data Character = Character - { firstName :: String - , lastName :: String - , birthYear :: Int - } deriving (Show, Eq) - -friends :: [Character] -friends = [ Character "Phoebe" "Buffay" 1963 - , Character "Chandler" "Bing" 1969 - , Character "Rachel" "Green" 1969 - , Character "Joey" "Tribbiani" 1967 - , Character "Monica" "Geller" 1964 - , Character "Ross" "Geller" 1966 - ] - -oldest :: Int -> [Character] -> [String] -oldest k tbl = [ firstName ++ " " ++ lastName - | Character{..} <- tbl - , then sortWith by birthYear - , then take k - ] diff --git a/examples/Expr/If.hs b/examples/Expr/If.hs deleted file mode 100644 --- a/examples/Expr/If.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Expr.If where - -b = 12 -a = if b > 3 then 1 else 0 diff --git a/examples/Expr/LambdaCase.hs b/examples/Expr/LambdaCase.hs deleted file mode 100644 --- a/examples/Expr/LambdaCase.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE LambdaCase, EmptyCase #-} -module Expr.LambdaCase where - -a = \case 1 -> 0 - _ -> 1 - -b = \case { 1 -> 0; _ -> 1 } - -c = \case {} - -d = \case diff --git a/examples/Expr/ListComp.hs b/examples/Expr/ListComp.hs deleted file mode 100644 --- a/examples/Expr/ListComp.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Expr.ListComp where - -ls = [ x+y | x <- [1..5], y <- [1..5]] diff --git a/examples/Expr/MultiwayIf.hs b/examples/Expr/MultiwayIf.hs deleted file mode 100644 --- a/examples/Expr/MultiwayIf.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module Expr.MultiwayIf where - -b = 12 -a = if | b > 3 -> 1 - | b < -5 -> 2 - | otherwise -> 3 diff --git a/examples/Expr/Negate.hs b/examples/Expr/Negate.hs deleted file mode 100644 --- a/examples/Expr/Negate.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Expr.Negate where - -y = 1 -x = -y diff --git a/examples/Expr/Operator.hs b/examples/Expr/Operator.hs deleted file mode 100644 --- a/examples/Expr/Operator.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Expr.Operator where - -x = 1 + 2 -y = (+) 1 2 -z = 1 `mod` 2 diff --git a/examples/Expr/ParListComp.hs b/examples/Expr/ParListComp.hs deleted file mode 100644 --- a/examples/Expr/ParListComp.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module Expr.ParListComp where - -ls = [ x+y | x <- [1..5] | y <- [1..5]] diff --git a/examples/Expr/ParenName.hs b/examples/Expr/ParenName.hs deleted file mode 100644 --- a/examples/Expr/ParenName.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Expr.ParenName where - -a x y = (mod) x y diff --git a/examples/Expr/PatternAndDo.hs b/examples/Expr/PatternAndDo.hs deleted file mode 100644 --- a/examples/Expr/PatternAndDo.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Expr.PatternAndDo where - -import Control.Monad -import Control.Monad.Identity - -data A = A { x :: Int } - -a = forM_ [] $ \A {..} -> do - Identity "Hello" diff --git a/examples/Expr/RecordPuns.hs b/examples/Expr/RecordPuns.hs deleted file mode 100644 --- a/examples/Expr/RecordPuns.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module Expr.RecordPuns where - -data Point = Point { x :: Int, y :: Int } - -f (Point {y}) = y diff --git a/examples/Expr/RecordWildcards.hs b/examples/Expr/RecordWildcards.hs deleted file mode 100644 --- a/examples/Expr/RecordWildcards.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Expr.RecordWildcards where - -data Point = Point { x :: Int, y :: Int } - -p1 = let x = 3; y = 4 in Point { x = 1, .. } diff --git a/examples/Expr/RecursiveDo.hs b/examples/Expr/RecursiveDo.hs deleted file mode 100644 --- a/examples/Expr/RecursiveDo.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -module Expr.RecursiveDo where - -justOnes = mdo xs <- Just (1:xs) - return (map negate xs) - -justOnes' = do rec xs <- Just (1:xs) - return (map negate xs) - return xs diff --git a/examples/Expr/SccPragma.hs b/examples/Expr/SccPragma.hs deleted file mode 100644 --- a/examples/Expr/SccPragma.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Expr.SccPragma where - -f x = {-# SCC "drawComponent" #-} - case x of () -> () diff --git a/examples/Expr/Sections.hs b/examples/Expr/Sections.hs deleted file mode 100644 --- a/examples/Expr/Sections.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Expr.Sections where - -x = (1+) -y = (+1) diff --git a/examples/Expr/SemicolonDo.hs b/examples/Expr/SemicolonDo.hs deleted file mode 100644 --- a/examples/Expr/SemicolonDo.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Expr.SemicolonDo where - -import Control.Monad.Identity - -a = do { n <- Identity () - ; return () - } diff --git a/examples/Expr/StaticPtr.hs b/examples/Expr/StaticPtr.hs deleted file mode 100644 --- a/examples/Expr/StaticPtr.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE StaticPointers #-} -module Expr.StaticPtr where - -import GHC.StaticPtr - -inc :: Int -> Int -inc x = x + 1 - -ref1, ref3, ref4 :: StaticPtr Int -ref2 :: StaticPtr (Int -> Int) -ref5 :: Int -> StaticPtr Int -ref1 = static 1 -ref2 = static inc -ref3 = static (inc 1) -ref4 = static ((\x -> x + 1) (1 :: Int)) -ref5 y = static (let x = 1 in x) diff --git a/examples/Expr/TupleSections.hs b/examples/Expr/TupleSections.hs deleted file mode 100644 --- a/examples/Expr/TupleSections.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Expr.TupleSections where - -f1 = (1,,) -f2 = (,1) - -x = (,("x", [])) diff --git a/examples/Expr/UnboxedSum.hs b/examples/Expr/UnboxedSum.hs deleted file mode 100644 --- a/examples/Expr/UnboxedSum.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE UnboxedSums #-} -module Expr.UnboxedSum where - -f = () - where - expr :: (# Int | Bool #) - expr = (# | True #) - - expr2 :: (# Int | Bool #) - expr2 = (# 3 | #) - - expr3 :: (# Int | String | Bool #) - expr3 = (# | "aaa" | #) diff --git a/examples/Expr/UnicodeSyntax.hs b/examples/Expr/UnicodeSyntax.hs deleted file mode 100644 --- a/examples/Expr/UnicodeSyntax.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} -module Expr.UnicodeSyntax where - -import Data.List.Unicode ((∪)) - -main ∷ IO () -main = print $ [1, 2, 3] ∪ [1, 3, 5] diff --git a/examples/InstanceControl/Control/Instances/Morph.hs b/examples/InstanceControl/Control/Instances/Morph.hs deleted file mode 100644 --- a/examples/InstanceControl/Control/Instances/Morph.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-} - -module Control.Instances.Morph (GenMorph(..), Morph(..)) where - -import Control.Instances.ShortestPath - -import Control.Monad.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.List -import Control.Monad.State -import Data.Maybe -import Data.Proxy -import GHC.TypeLits -import Control.Instances.TypeLevelPrelude - --- | States that 'm1' can be represented with 'm2'. --- That is because 'm2' contains more infromation than 'm1'. --- --- The 'MMorph' relation defines a natural transformation from 'm1' to 'm2' --- that keeps the following laws: --- --- > morph (return x) = return x --- > morph (m >>= f) = morph m >>= morph . f --- --- It is a reflexive and transitive relation. --- -class Morph (m1 :: * -> *) (m2 :: * -> *) where - -- | Lifts the first monad into the second. - morph :: m1 a -> m2 a - -instance GenMorph DB m1 m2 => Morph m1 m2 where - morph = genMorph db - --- | A generalized version of 'Morph'. Can work on different --- rulesets, so this should be used if the ruleset is to be extended. -class GenMorph db (m1 :: * -> *) (m2 :: * -> *) where - -- | Lifts the first monad into the second. - genMorph :: db -> m1 a -> m2 a - -instance ( fl ~ (TransformPath (PathFromList (ShortestPath (ToMorphRepo DB) x y))) - , CorrectPath x y fl - , GeneratableMorph DB fl - , Morph' fl x y - ) => GenMorph DB x y where - genMorph db = repr (generateMorph db :: fl) - -class Morph' fl x y where - repr :: fl -> x a -> y a - -instance Morph' r y z => Morph' (ConnectMorph x y :+: r) x z where - repr (ConnectMorph m :+: r) = repr r . m - -instance (Morph' r m x, Monad m) => Morph' (IdentityMorph m :+: r) Identity x where - repr (IdentityMorph :+: r) = (repr r :: forall a . m a -> x a) . return . runIdentity - -instance Morph' (MUMorph m :+: r) m Proxy where - repr (MUMorph :+: _) = const Proxy - -instance Morph' NoMorph x x where - repr fl = id - -infixr 6 :+: -data a :+: r = a :+: r - -data NoMorph = NoMorph - -type family ToMorphRepo db where - ToMorphRepo (cm :+: r) = TranslateConn cm ': ToMorphRepo r - ToMorphRepo NoMorph = '[] - -type DB = ConnectMorph_2m Maybe MaybeT - :+: ConnectMorph_mt MaybeT - :+: ConnectMorph Maybe [] - :+: ConnectMorph_2m [] ListT - :+: ConnectMorph (MaybeT IO) (ListT IO) - :+: NoMorph - -db :: DB -db = ConnectMorph_2m (MaybeT . return) - :+: ConnectMorph_mt (MaybeT . liftM Just) - :+: ConnectMorph (maybeToList) - :+: ConnectMorph_2m (ListT . return) - :+: ConnectMorph (ListT . liftM maybeToList . runMaybeT) - :+: NoMorph - --- | This class provides a way to construct the value-level transformations --- from the type-level path and a rulebase. -class GeneratableMorph db ch where - generateMorph :: db -> ch - -instance GeneratableMorph db NoMorph where - generateMorph _ = NoMorph - -instance GeneratableMorph db r - => GeneratableMorph db ((IdentityMorph m) :+: r) where - generateMorph db = IdentityMorph :+: generateMorph db - -instance GeneratableMorph db r - => GeneratableMorph db (MUMorph m :+: r) where - generateMorph db = MUMorph :+: generateMorph db - -instance (HasMorph db (ConnectMorph a b), GeneratableMorph db r) - => GeneratableMorph db (ConnectMorph a b :+: r) where - generateMorph db = getMorph db :+: generateMorph db - --- | This class extracts a given morph from the set of rules -class HasMorph r m where - getMorph :: r -> m -instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_2m a b :+: r) (ConnectMorph a (b k)) where - getMorph (ConnectMorph_2m f :+: r) = ConnectMorph f -instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_mt t :+: r) (ConnectMorph k (t k)) where - getMorph (ConnectMorph_mt f :+: r) = ConnectMorph f -instance {-# OVERLAPS #-} HasMorph r m => HasMorph (c :+: r) m where - getMorph (c :+: r) = getMorph r -instance {-# OVERLAPPABLE #-} HasMorph (m :+: r) m where - getMorph (c :+: r) = c - --- | Checks if the path is found to provide usable error messages -class CorrectPath from to path - -instance CorrectPath from to (a :+: b) -instance CorrectPath from to NoMorph - -data ConnectMorph m1 m2 = ConnectMorph { fromConnectMorph :: forall a . m1 a -> m2 a } -data ConnectMorph_2m m1 m2 = ConnectMorph_2m { fromConnectMorph_2m :: forall a k . Monad k => m1 a -> m2 k a } -data ConnectMorph_mt mt = ConnectMorph_mt { fromConnectMorph_mt :: forall a k . Monad k => k a -> mt k a } -data IdentityMorph (m :: * -> *) = IdentityMorph -data MUMorph m = MUMorph - --- | Transforms a path element from the generic format to the specific one -type family TranslateConn m where - TranslateConn (ConnectMorph m1 m2) = Connect m1 m2 - TranslateConn (ConnectMorph_2m m1 m2) = Connect_2m m1 m2 - TranslateConn (ConnectMorph_mt mt) = Connect_mt mt - --- | Transforms the path from the generic format to the specific one -type family TransformPath m where - TransformPath (Connect m1 m2 :+: r) = ConnectMorph m1 m2 :+: TransformPath r - TransformPath (Connect_id m :+: r) = IdentityMorph m :+: TransformPath r - TransformPath (Connect_MU m :+: r) = MUMorph m :+: TransformPath r - TransformPath NoMorph = NoMorph - TransformPath NoPathFound = NoPathFound - -type family PathFromList ls where - PathFromList '[] = NoMorph - PathFromList '[ NoPathFound ] = NoPathFound - PathFromList (c ': ls) = c :+: PathFromList ls - - diff --git a/examples/InstanceControl/Control/Instances/ShortestPath.hs b/examples/InstanceControl/Control/Instances/ShortestPath.hs deleted file mode 100644 --- a/examples/InstanceControl/Control/Instances/ShortestPath.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-} - -module Control.Instances.ShortestPath where - -import Control.Monad.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.List -import Control.Monad.State -import Data.Maybe -import Data.Proxy -import GHC.TypeLits -import Control.Instances.TypeLevelPrelude - --- * Generic datatypes to store connections - -data Connect m1 m2 -data Connect_2m m1 m2 -data Connect_mt mt -data Connect_id m -data Connect_MU m - --- | Marks that there is no legal path between the two types according --- to the rulebase. -data NoPathFound - -type family ShortestPath (e :: [*]) (s :: * -> *) (t :: * -> *) :: [*] where - ShortestPath e t t = '[] - ShortestPath e Identity t = '[ Connect_id t ] - ShortestPath e s Proxy = '[ Connect_MU s ] - ShortestPath e s t = ShortestPath' e s (InitCurrent e t) - -type family ShortestPath' (e :: [*]) (s :: * -> *) (c :: [[*]]) :: [*] where - ShortestPath' e s '[] = '[ NoPathFound ] - ShortestPath' e s c = FromMaybe (ShortestPath' e s (ApplyEdges e c c)) - (GetFinished s c) - - -type family GetFinished s c where - GetFinished s ((Connect s b ': p) ': lls) - = Just (Connect s b ': p) - GetFinished s (p ': lls) = GetFinished s lls - GetFinished s '[] = Nothing - -type family InitCurrent (e :: [*]) (t :: * -> *) :: [[*]] where - InitCurrent '[] t = '[] - InitCurrent (e ': es) t = IfJust (ApplyEdge e t) - ('[ MonomorphEnd e t ] ': InitCurrent es t) - (InitCurrent es t) - -type family ApplyEdges (e :: [*]) (co :: [[*]]) (c :: [[*]]) :: [[*]] where - ApplyEdges (e ': es) co ((Connect s b ': p) ': cs) - = AppendJust (IfThenJust (IsJust (ApplyEdge e s)) - (MonomorphEnd e s ': Connect s b ': p)) - (ApplyEdges (e ': es) co cs) - ApplyEdges (e ': es) co '[] = ApplyEdges es co co - ApplyEdges '[] co cr = '[] - -type family ApplyEdge e t :: Maybe (* -> *) where - ApplyEdge (Connect ms mr) mr = Just ms - ApplyEdge (Connect_2m ms mt) (mt m) = Just ms - ApplyEdge (Connect_mt mt) (mt m) = Just m - ApplyEdge e t = Nothing - -type family MonomorphEnd c v :: * where - MonomorphEnd (Connect_2m m m') v = Connect m v - MonomorphEnd (Connect_mt t) (t m) = Connect m (t m) - MonomorphEnd c v = c - - diff --git a/examples/InstanceControl/Control/Instances/Test.hs b/examples/InstanceControl/Control/Instances/Test.hs deleted file mode 100644 --- a/examples/InstanceControl/Control/Instances/Test.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Control.Instances.Test where - -import Control.Instances.Morph - -import Control.Monad.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.List -import Control.Monad.State - -test1 :: Identity a -> IO a -test1 = morph - -test2 :: Maybe a -> [a] -test2 = morph - -test3 :: Maybe a -> ListT IO a -test3 = morph - -test4 :: Maybe a -> MaybeT IO a -test4 = morph - -test5 :: Monad m => Maybe a -> ListT (StateT s m) a -test5 = morph diff --git a/examples/InstanceControl/Control/Instances/TypeLevelPrelude.hs b/examples/InstanceControl/Control/Instances/TypeLevelPrelude.hs deleted file mode 100644 --- a/examples/InstanceControl/Control/Instances/TypeLevelPrelude.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-} - -module Control.Instances.TypeLevelPrelude where - -import GHC.TypeLits - -type family Const a b where - Const a b = a - -type family Seq a b where - Seq a b = b - -type family LazyIfThenElse p a b where - LazyIfThenElse True a b = a - LazyIfThenElse False a b = b - -type family Iterate a where - Iterate a = a ': Iterate a - -type family l1 :++: l2 where - '[] :++: l2 = l2 - (e ': r1) :++: l2 = e ': (r1 :++: l2) - -type family Elem e ls where - Elem e '[] = False - Elem e (e ': ls) = True - Elem e (x ': ls) = Elem e ls - -type family IfThenElse (b :: Bool) (th :: x) (el :: x) :: x where - IfThenElse True th el = th - IfThenElse False th el = el - -type family Length ls :: Nat where - Length '[] = 0 - Length (e ': ls) = 1 + Length ls - -type family Head (ls :: [k]) :: k where - Head (e ': ls) = e - -type family HeadMaybe (ls :: [k]) :: Maybe k where - HeadMaybe (e ': ls) = Just e - HeadMaybe '[] = Nothing - -type family FromMaybe d m where - FromMaybe d (Just x) = x - FromMaybe d Nothing = d - -type family Same a b where - Same a a = True - Same a b = False - -type family Null (ls :: [k]) :: Bool where - Null '[] = True - Null ls = False - -type family MapAppend e lls where - MapAppend e (ls ': lls) = (e ': ls) ': MapAppend e lls - MapAppend e '[] = '[] - -type family AppendJust m ls where - AppendJust (Just x) ls = x ': ls - AppendJust Nothing ls = ls - -type family Revert ls where - Revert '[] = '[] - Revert (e ': ls) = Revert ls :++: '[ e ] - -type family IfThenJust (p :: Bool) (v :: k) :: Maybe k where - IfThenJust True v = Just v - IfThenJust False v = Nothing - -type family IfJust (p :: Maybe k) (t :: kr) (e :: kr) :: kr where - IfJust (Just x) t e = t - IfJust Nothing t e = e - -type family IsJust (p :: Maybe k) :: Bool where - IsJust (Just x) = True - IsJust Nothing = False - -type family FromJust (p :: Maybe k) :: k where - FromJust (Just x) = x - -type family Cat (f2 :: k2 -> k3) (f1 :: k1 -> k2) (a :: k1) :: k3 where - Cat f2 f1 a = f2 (f1 a) - - - - diff --git a/examples/Module/DeprecatedPragma.hs b/examples/Module/DeprecatedPragma.hs deleted file mode 100644 --- a/examples/Module/DeprecatedPragma.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Module.DeprecatedPragma {-# DEPRECATED "this module is deprecated" #-} where diff --git a/examples/Module/Export.hs b/examples/Module/Export.hs deleted file mode 100644 --- a/examples/Module/Export.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Module.Export (maybe, Maybe(..), Either(Left)) where --- this module reexports Maybe from Prelude diff --git a/examples/Module/ExportModifiers.hs b/examples/Module/ExportModifiers.hs deleted file mode 100644 --- a/examples/Module/ExportModifiers.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces, PatternSynonyms #-} -module Module.ExportModifiers (type Maybe, pattern Maybe) where - -pattern Maybe = 42 diff --git a/examples/Module/ExportSubs.hs b/examples/Module/ExportSubs.hs deleted file mode 100644 --- a/examples/Module/ExportSubs.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Module.ExportSubs (T(Cons, name)) where - -data T = Cons { name :: String } diff --git a/examples/Module/GhcOptionsPragma.hs b/examples/Module/GhcOptionsPragma.hs deleted file mode 100644 --- a/examples/Module/GhcOptionsPragma.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Module.GhcOptionsPragma where diff --git a/examples/Module/Import.hs b/examples/Module/Import.hs deleted file mode 100644 --- a/examples/Module/Import.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PackageImports, Safe #-} -module Module.Import where - -import Data.List -import "base" Data.List -import {-# SOURCE #-} Data.List -import qualified Data.List -import Data.List as List -import Data.List(map,(++)) -import Data.Function hiding ((&)) -import safe Control.Monad.Writer hiding (Alt, Writer()) diff --git a/examples/Module/ImportOp.hs b/examples/Module/ImportOp.hs deleted file mode 100644 --- a/examples/Module/ImportOp.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Module.ImportOp where - -import Module.Imported ((:-)(..)) diff --git a/examples/Module/Imported.hs b/examples/Module/Imported.hs deleted file mode 100644 --- a/examples/Module/Imported.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Module.Imported where - -infixr 8 :- --- | A stack datatype. Just a better looking tuple. -data a :- b = a :- b deriving (Eq, Show) diff --git a/examples/Module/LangPragmas.hs b/examples/Module/LangPragmas.hs deleted file mode 100644 --- a/examples/Module/LangPragmas.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-#LANGUAGE LambdaCase #-} -{-# LANGUAGE LambdaCase#-} -module Module.LangPragmas where diff --git a/examples/Module/NamespaceExport.hs b/examples/Module/NamespaceExport.hs deleted file mode 100644 --- a/examples/Module/NamespaceExport.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Module.NamespaceExport (type (++)) where - -data a ++ b = Ctor diff --git a/examples/Module/PatternImport.hs b/examples/Module/PatternImport.hs deleted file mode 100644 --- a/examples/Module/PatternImport.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Module.PatternImport where - -import Decl.PatternSynonym (pattern Arrow) diff --git a/examples/Module/Simple.hs b/examples/Module/Simple.hs deleted file mode 100644 --- a/examples/Module/Simple.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Module.Simple where diff --git a/examples/Module/WarningPragma.hs b/examples/Module/WarningPragma.hs deleted file mode 100644 --- a/examples/Module/WarningPragma.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Module.WarningPragma {-# WARNING "this module is dangerous" #-} where diff --git a/examples/Pattern/Backtick.hs b/examples/Pattern/Backtick.hs deleted file mode 100644 --- a/examples/Pattern/Backtick.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Pattern.Backtick where - -data Point = Point { x :: Prelude.Int, y :: Int } - -f (x `Point` y) = 0 diff --git a/examples/Pattern/Constructor.hs b/examples/Pattern/Constructor.hs deleted file mode 100644 --- a/examples/Pattern/Constructor.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Pattern.Constructor where - -Just x = Just 1 diff --git a/examples/Pattern/ImplicitParams.hs b/examples/Pattern/ImplicitParams.hs deleted file mode 100644 --- a/examples/Pattern/ImplicitParams.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -module Pattern.ImplicitParams where - -import Data.List (sortBy) - -sort :: (?cmp :: a -> a -> Ordering) => [a] -> [a] -sort = sortBy ?cmp - -main = let ?cmp = compare in putStrLn (show (sort [3,1,2])) diff --git a/examples/Pattern/Infix.hs b/examples/Pattern/Infix.hs deleted file mode 100644 --- a/examples/Pattern/Infix.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Pattern.Infix where - ---(a:b:c:d) = ["1","2","3","4"] - -Nothing:_ = undefined diff --git a/examples/Pattern/NPlusK.hs b/examples/Pattern/NPlusK.hs deleted file mode 100644 --- a/examples/Pattern/NPlusK.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE NPlusKPatterns #-} -module Pattern.NPlusK where - -factorial :: Integer -> Integer -factorial 0 = 1 -factorial (n+1) = (*) (n+1) (factorial n) diff --git a/examples/Pattern/NestedWildcard.hs b/examples/Pattern/NestedWildcard.hs deleted file mode 100644 --- a/examples/Pattern/NestedWildcard.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -module Pattern.NestedWildcard where - -data A = A { b :: B, ai :: Int } -data B = B { bi :: Int } - -h A { b = B {..}, .. } = bi + ai diff --git a/examples/Pattern/OperatorPattern.hs b/examples/Pattern/OperatorPattern.hs deleted file mode 100644 --- a/examples/Pattern/OperatorPattern.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Pattern.OperatorPattern where - -child r (_:ps) = r ps diff --git a/examples/Pattern/Record.hs b/examples/Pattern/Record.hs deleted file mode 100644 --- a/examples/Pattern/Record.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -module Pattern.Record where - -data Point = Point { x :: Int, y :: Int } - -f Point { x = 3, y = 1 } = 0 -f Point {} = 1 - -g Point { x } = x - -h Point { x = 1, .. } = y diff --git a/examples/Pattern/UnboxedSum.hs b/examples/Pattern/UnboxedSum.hs deleted file mode 100644 --- a/examples/Pattern/UnboxedSum.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE UnboxedSums #-} -module Pattern.UnboxedSum where - -f :: (# Int | Bool #) -> () -f (# i | #) = () -f (# | b #) = () diff --git a/examples/Refactor/AutoCorrect/ComplexExprReOrder.hs b/examples/Refactor/AutoCorrect/ComplexExprReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ComplexExprReOrder where + +x = f (B 1 2) (A "A") + +f :: A -> B -> () +f _ _ = () + +data A = A String +data B = B Int Int diff --git a/examples/Refactor/AutoCorrect/ComplexExprReOrder2.hs b/examples/Refactor/AutoCorrect/ComplexExprReOrder2.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReOrder2.hs @@ -0,0 +1,11 @@ +module Refactor.AutoCorrect.ComplexExprReOrder2 where + +x = f (b { b1 = 0 }) (A { a = "fdf" }) + +b = B 1 2 + +f :: A -> B -> () +f _ _ = () + +data A = A { a :: String } +data B = B { b1 :: Int, b2 :: Int } diff --git a/examples/Refactor/AutoCorrect/ComplexExprReOrder2_res.hs b/examples/Refactor/AutoCorrect/ComplexExprReOrder2_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReOrder2_res.hs @@ -0,0 +1,11 @@ +module Refactor.AutoCorrect.ComplexExprReOrder2 where + +x = f (A { a = "fdf" }) (b { b1 = 0 }) + +b = B 1 2 + +f :: A -> B -> () +f _ _ = () + +data A = A { a :: String } +data B = B { b1 :: Int, b2 :: Int } diff --git a/examples/Refactor/AutoCorrect/ComplexExprReOrder_res.hs b/examples/Refactor/AutoCorrect/ComplexExprReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ComplexExprReOrder where + +x = f (A "A") (B 1 2) + +f :: A -> B -> () +f _ _ = () + +data A = A String +data B = B Int Int diff --git a/examples/Refactor/AutoCorrect/ComplexExprReParen.hs b/examples/Refactor/AutoCorrect/ComplexExprReParen.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReParen.hs @@ -0,0 +1,6 @@ +module Refactor.AutoCorrect.ComplexExprReParen where + +x = f f (show ()) + +f :: String -> String +f = id diff --git a/examples/Refactor/AutoCorrect/ComplexExprReParen_res.hs b/examples/Refactor/AutoCorrect/ComplexExprReParen_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ComplexExprReParen_res.hs @@ -0,0 +1,6 @@ +module Refactor.AutoCorrect.ComplexExprReParen where + +x = (f (f (show ()))) + +f :: String -> String +f = id diff --git a/examples/Refactor/AutoCorrect/ExternalInstanceReOrder.hs b/examples/Refactor/AutoCorrect/ExternalInstanceReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ExternalInstanceReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ExternalInstanceReOrder where + +x = f 3 () + +f :: (Show a, Num b) => a -> b -> () +f _ _ = () + +a :: Integer +a = 3 diff --git a/examples/Refactor/AutoCorrect/ExternalInstanceReOrder_res.hs b/examples/Refactor/AutoCorrect/ExternalInstanceReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ExternalInstanceReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ExternalInstanceReOrder where + +x = f () 3 + +f :: (Show a, Num b) => a -> b -> () +f _ _ = () + +a :: Integer +a = 3 diff --git a/examples/Refactor/AutoCorrect/ExternalInstanceReParen.hs b/examples/Refactor/AutoCorrect/ExternalInstanceReParen.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ExternalInstanceReParen.hs @@ -0,0 +1,4 @@ +module Refactor.AutoCorrect.ExternalInstanceReParen where + +-- The only reason why ((show 1) + 2) is not a good result is that there are no Num instance for String +x = show 1 + 2 diff --git a/examples/Refactor/AutoCorrect/ExternalInstanceReParen_res.hs b/examples/Refactor/AutoCorrect/ExternalInstanceReParen_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ExternalInstanceReParen_res.hs @@ -0,0 +1,4 @@ +module Refactor.AutoCorrect.ExternalInstanceReParen where + +-- The only reason why ((show 1) + 2) is not a good result is that there are no Num instance for String +x = (show (1 + 2)) diff --git a/examples/Refactor/AutoCorrect/Instance.hs b/examples/Refactor/AutoCorrect/Instance.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/Instance.hs @@ -0,0 +1,4 @@ +module Refactor.AutoCorrect.Instance where + +data A = A deriving Show +data B = B diff --git a/examples/Refactor/AutoCorrect/OwnInstanceReOrder.hs b/examples/Refactor/AutoCorrect/OwnInstanceReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/OwnInstanceReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.OwnInstanceReOrder where + +import Refactor.AutoCorrect.Instance + +x = f B A + +f :: Show a => a -> b -> () +f _ _ = () + diff --git a/examples/Refactor/AutoCorrect/OwnInstanceReOrder_res.hs b/examples/Refactor/AutoCorrect/OwnInstanceReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/OwnInstanceReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.OwnInstanceReOrder where + +import Refactor.AutoCorrect.Instance + +x = f A B + +f :: Show a => a -> b -> () +f _ _ = () + diff --git a/examples/Refactor/AutoCorrect/SectionReOrder.hs b/examples/Refactor/AutoCorrect/SectionReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SectionReOrder.hs @@ -0,0 +1,3 @@ +module Refactor.AutoCorrect.SectionReOrder where + +x = "x" $ (++"y") diff --git a/examples/Refactor/AutoCorrect/SectionReOrder_res.hs b/examples/Refactor/AutoCorrect/SectionReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SectionReOrder_res.hs @@ -0,0 +1,3 @@ +module Refactor.AutoCorrect.SectionReOrder where + +x = (++"y") $ "x" diff --git a/examples/Refactor/AutoCorrect/SimpleReOrder.hs b/examples/Refactor/AutoCorrect/SimpleReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SimpleReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.SimpleReOrder where + +x = f B A + +f :: A -> B -> () +f _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/SimpleReOrder_res.hs b/examples/Refactor/AutoCorrect/SimpleReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SimpleReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.SimpleReOrder where + +x = f A B + +f :: A -> B -> () +f _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/SimpleReParen.hs b/examples/Refactor/AutoCorrect/SimpleReParen.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SimpleReParen.hs @@ -0,0 +1,6 @@ +module Refactor.AutoCorrect.SimpleReParen where + +x = f f "a" + +f :: String -> String +f = id diff --git a/examples/Refactor/AutoCorrect/SimpleReParen_res.hs b/examples/Refactor/AutoCorrect/SimpleReParen_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/SimpleReParen_res.hs @@ -0,0 +1,6 @@ +module Refactor.AutoCorrect.SimpleReParen where + +x = (f (f "a")) + +f :: String -> String +f = id diff --git a/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder.hs b/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ThreeArgFirstReOrder where + +x = f B A B + +f :: A -> B -> B -> () +f _ _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder_res.hs b/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ThreeArgFirstReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ThreeArgFirstReOrder where + +x = f A B B + +f :: A -> B -> B -> () +f _ _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/ThreeArgReOrder.hs b/examples/Refactor/AutoCorrect/ThreeArgReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ThreeArgReOrder.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ThreeArgReOrder where + +x = f B A B + +f :: B -> B -> A -> () +f _ _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/ThreeArgReOrder_res.hs b/examples/Refactor/AutoCorrect/ThreeArgReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/ThreeArgReOrder_res.hs @@ -0,0 +1,9 @@ +module Refactor.AutoCorrect.ThreeArgReOrder where + +x = f B B A + +f :: B -> B -> A -> () +f _ _ _ = () + +data A = A +data B = B diff --git a/examples/Refactor/AutoCorrect/TupleSectionReOrder.hs b/examples/Refactor/AutoCorrect/TupleSectionReOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/TupleSectionReOrder.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Refactor.AutoCorrect.TupleSectionReOrder where + +x = "x" $ (,3) diff --git a/examples/Refactor/AutoCorrect/TupleSectionReOrder_res.hs b/examples/Refactor/AutoCorrect/TupleSectionReOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/AutoCorrect/TupleSectionReOrder_res.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Refactor.AutoCorrect.TupleSectionReOrder where + +x = (,3) $ "x" diff --git a/examples/Refactor/CommentHandling/BlockComments.hs b/examples/Refactor/CommentHandling/BlockComments.hs deleted file mode 100644 --- a/examples/Refactor/CommentHandling/BlockComments.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Refactor.CommentHandling.BlockComments where - -{-| 1 -} -{- 2 -} -import Control.Monad {- 3 -} -{-^ 4 -} -{-| 5 -} -{- 6 -} -import Control.Monad as Monad {- 7 -} -{-^ 8 -} diff --git a/examples/Refactor/CommentHandling/CommentTypes.hs b/examples/Refactor/CommentHandling/CommentTypes.hs deleted file mode 100644 --- a/examples/Refactor/CommentHandling/CommentTypes.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Refactor.CommentHandling.CommentTypes where - --- | 1 --- 2 -import Control.Monad -- 3 --- ^ 4 --- | 5 --- 6 -import Control.Monad as Monad -- 7 --- ^ 8 diff --git a/examples/Refactor/CommentHandling/Crosslinking.hs b/examples/Refactor/CommentHandling/Crosslinking.hs deleted file mode 100644 --- a/examples/Refactor/CommentHandling/Crosslinking.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Refactor.CommentHandling.Crosslinking where - -import Control.Monad --- | forward --- ^ back -import Control.Monad as Monad diff --git a/examples/Refactor/CommentHandling/FunctionArgs.hs b/examples/Refactor/CommentHandling/FunctionArgs.hs deleted file mode 100644 --- a/examples/Refactor/CommentHandling/FunctionArgs.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Refactor.CommentHandling.FunctionArgs where - -f :: Int -- something - -> {-| result -} Int - -> Int -- ^ other thing -f = undefined diff --git a/examples/Refactor/OrganizeImports/Class.hs b/examples/Refactor/OrganizeImports/Class.hs --- a/examples/Refactor/OrganizeImports/Class.hs +++ b/examples/Refactor/OrganizeImports/Class.hs @@ -1,6 +1,6 @@ module Refactor.OrganizeImports.Class where -import Decl.TypeClass (C(f)) -import Decl.TypeInstance +import Refactor.OrganizeImports.TypeClass (C(f)) +import Refactor.OrganizeImports.TypeInstance test = f A diff --git a/examples/Refactor/OrganizeImports/Class_res.hs b/examples/Refactor/OrganizeImports/Class_res.hs --- a/examples/Refactor/OrganizeImports/Class_res.hs +++ b/examples/Refactor/OrganizeImports/Class_res.hs @@ -1,6 +1,6 @@ module Refactor.OrganizeImports.Class where -import Decl.TypeClass (C(f)) -import Decl.TypeInstance (A(..)) +import Refactor.OrganizeImports.TypeClass (C(f)) +import Refactor.OrganizeImports.TypeInstance (A(..)) test = f A diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate.hs b/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.OrganizeImports.InstanceCarry.Duplicate where + +import Data.List () +import Data.List () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate_res.hs b/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/Duplicate_res.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.OrganizeImports.InstanceCarry.Duplicate where + +import Data.List () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/Transitive.hs b/examples/Refactor/OrganizeImports/InstanceCarry/Transitive.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/Transitive.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.OrganizeImports.InstanceCarry.Transitive where + +import Data.List () +import Data.Foldable () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/Transitive_res.hs b/examples/Refactor/OrganizeImports/InstanceCarry/Transitive_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/Transitive_res.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.OrganizeImports.InstanceCarry.Transitive where + +import Data.List () diff --git a/examples/Refactor/OrganizeImports/TypeClass.hs b/examples/Refactor/OrganizeImports/TypeClass.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/TypeClass.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +module Refactor.OrganizeImports.TypeClass where + +class EmptyClass a + +class Show a => C a where + type X a :: * + type X a = Int + data Q a :: * + + f :: a -> String + f = show + diff --git a/examples/Refactor/OrganizeImports/TypeInstance.hs b/examples/Refactor/OrganizeImports/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/TypeInstance.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies, InstanceSigs #-} +module Refactor.OrganizeImports.TypeInstance where + +import Refactor.OrganizeImports.TypeClass + +data A = A deriving Show + +instance C A where + type X A = Int + data Q A = Bool + + f :: A -> String + f A = "XXX" + diff --git a/examples/Refactor/RenameDefinition/ThHelper.hs b/examples/Refactor/RenameDefinition/ThHelper.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ThHelper.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.ThHelper where + +import Language.Haskell.TH + +nameOf :: Name -> Q [Dec] +nameOf n = return [] diff --git a/examples/Refactor/RenameDefinition/TypeBracket.hs b/examples/Refactor/RenameDefinition/TypeBracket.hs --- a/examples/Refactor/RenameDefinition/TypeBracket.hs +++ b/examples/Refactor/RenameDefinition/TypeBracket.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Refactor.RenameDefinition.TypeBracket where -import TH.Splice.Define +import Refactor.RenameDefinition.ThHelper data A = A diff --git a/examples/Refactor/RenameDefinition/TypeBracket_res.hs b/examples/Refactor/RenameDefinition/TypeBracket_res.hs --- a/examples/Refactor/RenameDefinition/TypeBracket_res.hs +++ b/examples/Refactor/RenameDefinition/TypeBracket_res.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Refactor.RenameDefinition.TypeBracket where -import TH.Splice.Define +import Refactor.RenameDefinition.ThHelper data B = A diff --git a/examples/Refactor/RenameDefinition/ValBracket.hs b/examples/Refactor/RenameDefinition/ValBracket.hs --- a/examples/Refactor/RenameDefinition/ValBracket.hs +++ b/examples/Refactor/RenameDefinition/ValBracket.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Refactor.RenameDefinition.ValBracket where -import TH.Splice.Define +import Refactor.RenameDefinition.ThHelper data A = A diff --git a/examples/Refactor/RenameDefinition/ValBracket_res.hs b/examples/Refactor/RenameDefinition/ValBracket_res.hs --- a/examples/Refactor/RenameDefinition/ValBracket_res.hs +++ b/examples/Refactor/RenameDefinition/ValBracket_res.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Refactor.RenameDefinition.ValBracket where -import TH.Splice.Define +import Refactor.RenameDefinition.ThHelper data A = B diff --git a/examples/TH/Brackets.hs b/examples/TH/Brackets.hs deleted file mode 100644 --- a/examples/TH/Brackets.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Brackets where - -import Language.Haskell.TH - -decls :: Q [Dec] -decls = [d| w = 3 |] - -exp :: Q Exp -exp = [| 3 |] - -exp' :: Q Exp -exp' = [e| 3 |] - -pat :: Q Pat -pat = [p| x |] - -typ :: Q Type -typ = [t| Int |] diff --git a/examples/TH/ClassUse.hs b/examples/TH/ClassUse.hs deleted file mode 100644 --- a/examples/TH/ClassUse.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances #-} -module TH.ClassUse where - -class C a where - f :: a -> a - -$([d| - instance C a where - f = id - |]) diff --git a/examples/TH/CrossDef.hs b/examples/TH/CrossDef.hs deleted file mode 100644 --- a/examples/TH/CrossDef.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.CrossDef where - -$([d| x = 3 |]) diff --git a/examples/TH/DoubleSplice.hs b/examples/TH/DoubleSplice.hs deleted file mode 100644 --- a/examples/TH/DoubleSplice.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.DoubleSplice where - -$($(id [| return [] |])) diff --git a/examples/TH/GADTFields.hs b/examples/TH/GADTFields.hs deleted file mode 100644 --- a/examples/TH/GADTFields.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs, KindSignatures, TypeFamilies, TemplateHaskell #-} -module TH.GADTFields where - -data Gadtrec1 a where - Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b) - -$( let a = ['gadtrec1a, 'gadtrec1b] in return [] ) diff --git a/examples/TH/LocalDefinition.hs b/examples/TH/LocalDefinition.hs deleted file mode 100644 --- a/examples/TH/LocalDefinition.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.LocalDefinition where - -import Language.Haskell.TH - -decls :: Q [Dec] -decls = [d| w = 3 |] - -exp :: Q Exp -exp = [| 3 |] - -exp' :: Q Exp -exp' = [e| 3 |] - -pat :: Q Pat -pat = [p| x |] - -typ :: Q Type -typ = [t| Int |] diff --git a/examples/TH/MultiImport.hs b/examples/TH/MultiImport.hs deleted file mode 100644 --- a/examples/TH/MultiImport.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.MultiImport where - -import Prelude (last,return) -import qualified Data.Text (last) - -$(let f = last in return []) diff --git a/examples/TH/NestedSplices.hs b/examples/TH/NestedSplices.hs deleted file mode 100644 --- a/examples/TH/NestedSplices.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.NestedSplices where - -import Language.Haskell.TH - -f = [t| $(parensT [t| $(return ListT) |]) |] diff --git a/examples/TH/QuasiQuote/Define.hs b/examples/TH/QuasiQuote/Define.hs deleted file mode 100644 --- a/examples/TH/QuasiQuote/Define.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -module TH.QuasiQuote.Define where - -import Language.Haskell.TH.Quote -import Language.Haskell.TH - -expr :: QuasiQuoter -expr = QuasiQuoter { quoteExp = const (return $ VarE $ mkName "hello") } diff --git a/examples/TH/QuasiQuote/Use.hs b/examples/TH/QuasiQuote/Use.hs deleted file mode 100644 --- a/examples/TH/QuasiQuote/Use.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE QuasiQuotes #-} -module TH.QuasiQuote.Use where - -import TH.QuasiQuote.Define - -hello :: Int -hello = 3 - -main :: IO () -main = print [expr| 1 + 2 + 4|] diff --git a/examples/TH/Quoted.hs b/examples/TH/Quoted.hs deleted file mode 100644 --- a/examples/TH/Quoted.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Quoted where - -import qualified Text.Read.Lex (Lexeme) - -$(let x = ''Text.Read.Lex.Lexeme in return []) diff --git a/examples/TH/Splice/Define.hs b/examples/TH/Splice/Define.hs deleted file mode 100644 --- a/examples/TH/Splice/Define.hs +++ /dev/null @@ -1,24 +0,0 @@ -module TH.Splice.Define where - -import Language.Haskell.TH - -def :: String -> Q [Dec] -def name = return [ ValD (VarP (mkName name)) (NormalB $ LitE $ IntegerL 3) [] ] - -defHello :: Q [Dec] -defHello = def "hello" - -defHello2 :: Q [Dec] -defHello2 = def "hello2" - -defHello3 :: Q [Dec] -defHello3 = def "hello3" - -expr :: Q Exp -expr = return $ LitE $ IntegerL 3 - -typ :: Q Type -typ = return $ TupleT 0 - -nameOf :: Name -> Q [Dec] -nameOf n = return [] diff --git a/examples/TH/Splice/Names.hs b/examples/TH/Splice/Names.hs deleted file mode 100644 --- a/examples/TH/Splice/Names.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Splice.Names where - -import TH.Splice.Define - -data A = A - -$(nameOf ''A) -nameOf ''A - -$(nameOf 'A) -nameOf 'A diff --git a/examples/TH/Splice/Use.hs b/examples/TH/Splice/Use.hs deleted file mode 100644 --- a/examples/TH/Splice/Use.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Splice.Use where - -import TH.Splice.Define - -$(return []) - -$(let x = return [] in x) - -$(def "x") - -$(defHello) - -$defHello2 - -defHello3 - -a :: $typ -a = () - -e :: Int -e = $expr diff --git a/examples/TH/Splice/UseImported.hs b/examples/TH/Splice/UseImported.hs deleted file mode 100644 --- a/examples/TH/Splice/UseImported.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Splice.UseImported where - -data T a = T a - -$([d| - instance Show a => Show (T a) where show = undefined - instance (Eq a, Show a) => Eq (T a) where (==) = undefined - |]) diff --git a/examples/TH/Splice/UseQual.hs b/examples/TH/Splice/UseQual.hs deleted file mode 100644 --- a/examples/TH/Splice/UseQual.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Splice.UseQual where - -import qualified TH.Splice.Define as Def - -$(Def.def "x") diff --git a/examples/TH/Splice/UseQualMulti.hs b/examples/TH/Splice/UseQualMulti.hs deleted file mode 100644 --- a/examples/TH/Splice/UseQualMulti.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH.Splice.UseQualMulti where - -import qualified TH.Splice.Define as Def -import qualified TH.Splice.Define as Def2 - -$(Def.def "x") -$(Def2.def "y") diff --git a/examples/TH/WithWildcards.hs b/examples/TH/WithWildcards.hs deleted file mode 100644 --- a/examples/TH/WithWildcards.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards #-} -module TH.WithWildcards where - -import Language.Haskell.TH.Syntax - -data A = A { x :: Q Exp } - -g A{..} = [| $(x) |] diff --git a/examples/Type/Bang.hs b/examples/Type/Bang.hs deleted file mode 100644 --- a/examples/Type/Bang.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Type.Bang where - -data X = X !Int - diff --git a/examples/Type/Builtin.hs b/examples/Type/Builtin.hs deleted file mode 100644 --- a/examples/Type/Builtin.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Type.Builtin where - -import GHC.Prim -import GHC.Base - -x1 :: IO () -x1 = undefined - -x2 :: IO Int -x2 = return 2 - -x3 :: Int -x3 = I# x3' - where x3' :: Int# - x3' = 3# - -x4 :: (Int, Bool) -x4 = (3,True) - diff --git a/examples/Type/Ctx.hs b/examples/Type/Ctx.hs deleted file mode 100644 --- a/examples/Type/Ctx.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Type.Ctx where - -sh :: Show a => a -> String -sh = show - -sh' :: (Show a) => a -> String -sh' = show - -sh'' :: (Show a, Eq a) => a -> String -sh'' = show diff --git a/examples/Type/ExplicitTypeApplication.hs b/examples/Type/ExplicitTypeApplication.hs deleted file mode 100644 --- a/examples/Type/ExplicitTypeApplication.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module Type.ExplicitTypeApplication where - -quad :: a -> b -> c -> d -> (a, b, c, d) -quad w x y z = (w, x, y, z) - -foo = quad @Bool @_ @Int False 'c' 17 "Hello!" diff --git a/examples/Type/Forall.hs b/examples/Type/Forall.hs deleted file mode 100644 --- a/examples/Type/Forall.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Type.Forall where - -id :: forall a . a -> a -id x = x - -id' :: a -> a -id' x = x - -id'' :: forall a . Monoid a => a -> a -id'' x = x diff --git a/examples/Type/Primitives.hs b/examples/Type/Primitives.hs deleted file mode 100644 --- a/examples/Type/Primitives.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Type.Primitives where -import GHC.Prim - -data MyInt = MyInt Int# - -my3 = MyInt 3# - -myPlus :: MyInt -> MyInt -> MyInt -myPlus (MyInt i) (MyInt j) = MyInt (i +# j) diff --git a/examples/Type/TupleAssert.hs b/examples/Type/TupleAssert.hs deleted file mode 100644 --- a/examples/Type/TupleAssert.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -module Type.TupleAssert where - -f :: (Ord a, (Show a, Eq a)) => a -> String -f = show diff --git a/examples/Type/TypeOperators.hs b/examples/Type/TypeOperators.hs deleted file mode 100644 --- a/examples/Type/TypeOperators.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Type.TypeOperators where - -infixr 6 :+: -data a :+: r = a :+: r - -type X = Int :+: Char :+: String - -type (:&:) = (,) -infixr :&: diff --git a/examples/Type/Unpack.hs b/examples/Type/Unpack.hs deleted file mode 100644 --- a/examples/Type/Unpack.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Type.Unpack where - -data X = X {-# UNPACK #-} !Int {-# NOUNPACK #-} !Int - diff --git a/examples/Type/Wildcard.hs b/examples/Type/Wildcard.hs deleted file mode 100644 --- a/examples/Type/Wildcard.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} -{-# LANGUAGE PartialTypeSignatures #-} -module Type.Wildcard where - -not' :: Bool -> _ -not' x = not x --- Inferred: Bool -> Bool diff --git a/haskell-tools-builtin-refactorings.cabal b/haskell-tools-builtin-refactorings.cabal --- a/haskell-tools-builtin-refactorings.cabal +++ b/haskell-tools-builtin-refactorings.cabal @@ -1,5 +1,5 @@ name: haskell-tools-builtin-refactorings -version: 1.0.0.4 +version: 1.0.1.1 synopsis: Refactoring Tool for Haskell description: Contains a set of refactorings based on the Haskell-Tools framework to easily transform a Haskell program. For the descriptions of the implemented refactorings, see the homepage. homepage: https://github.com/haskell-tools/haskell-tools @@ -12,16 +12,8 @@ cabal-version: >=1.10 extra-source-files: examples/CPP/*.hs - , examples/CppHs/Language/Preprocessor/*.hs - , examples/CppHs/Language/Preprocessor/Cpphs/*.hs - , examples/CppHs/Language/Preprocessor/Cpphs/*.hs - , examples/Decl/*.hs - , examples/Expr/*.hs - , examples/InstanceControl/Control/Instances/*.hs - , examples/Module/*.hs - , examples/Pattern/*.hs - , examples/Refactor/CommentHandling/*.hs , examples/Refactor/ExtractBinding/*.hs + , examples/Refactor/FloatOut/*.hs , examples/Refactor/GenerateExports/*.hs , examples/Refactor/GenerateTypeSignature/*.hs , examples/Refactor/GenerateTypeSignature/BringToScope/*.hs @@ -41,24 +33,40 @@ , examples/Refactor/RenameDefinition/SpliceExpr_res/*.hs , examples/Refactor/RenameDefinition/SpliceType/*.hs , examples/Refactor/RenameDefinition/SpliceType_res/*.hs - , examples/Refactor/FloatOut/*.hs - , examples/TH/*.hs - , examples/TH/QuasiQuote/*.hs - , examples/TH/Splice/*.hs - , examples/Type/*.hs - , test/ExtensionOrganizerTest/RecordWildCardsTest/*.hs - , test/ExtensionOrganizerTest/FlexibleInstancesTest/*.hs - , test/ExtensionOrganizerTest/DerivingsTest/*.hs + , examples/Refactor/AutoCorrect/*.hs + + , test/ExtensionOrganizerTest/ArrowsTest/*.hs , test/ExtensionOrganizerTest/BangPatternsTest/*.hs - , test/ExtensionOrganizerTest/PatternSynonymsTest/*.hs - , test/ExtensionOrganizerTest/ViewPatternsTest/*.hs + , test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/*.hs + , test/ExtensionOrganizerTest/ConstraintKindsTest/*.hs + , test/ExtensionOrganizerTest/DefaultSignaturesTest/*.hs + , test/ExtensionOrganizerTest/DerivingsTest/*.hs + , test/ExtensionOrganizerTest/ExistentialQuantificationTest/*.hs + , test/ExtensionOrganizerTest/ExplicitNamespacesTest/*.hs + , test/ExtensionOrganizerTest/FlexibleInstancesTest/*.hs + , test/ExtensionOrganizerTest/FunctionalDependenciesTest/*.hs + , test/ExtensionOrganizerTest/GADTsTest/*.hs + , test/ExtensionOrganizerTest/KindSignaturesTest/*.hs , test/ExtensionOrganizerTest/LambdaCaseTest/*.hs + , test/ExtensionOrganizerTest/MagicHashTest/Literal/*.hs + , test/ExtensionOrganizerTest/MagicHashTest/Name/*.hs + , test/ExtensionOrganizerTest/MultiParamTypeClassesTest/*.hs + , test/ExtensionOrganizerTest/MultiWayIfTest/*.hs + , test/ExtensionOrganizerTest/OverloadedStringsTest/*.hs + , test/ExtensionOrganizerTest/ParallelListCompTest/*.hs + , test/ExtensionOrganizerTest/PatternSynonymsTest/*.hs + , test/ExtensionOrganizerTest/RecordWildCardsTest/*.hs + , test/ExtensionOrganizerTest/RecursiveDoTest/*.hs + , test/ExtensionOrganizerTest/TemplateHaskellTest/*.hs , test/ExtensionOrganizerTest/TupleSectionsTest/*.hs - --, test/ExtensionOrganizerTest/UnboxedTuplesTest/*.hs + , test/ExtensionOrganizerTest/TypeFamiliesTest/*.hs + , test/ExtensionOrganizerTest/TypeOperatorsTest/*.hs + , test/ExtensionOrganizerTest/ViewPatternsTest/*.hs library ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Refactor.Builtin + , Language.Haskell.Tools.Refactor.Builtin.AutoCorrect , Language.Haskell.Tools.Refactor.Builtin.GenerateTypeSignature , Language.Haskell.Tools.Refactor.Builtin.OrganizeImports , Language.Haskell.Tools.Refactor.Builtin.GenerateExports @@ -66,32 +74,53 @@ , Language.Haskell.Tools.Refactor.Builtin.ExtractBinding , Language.Haskell.Tools.Refactor.Builtin.InlineBinding , Language.Haskell.Tools.Refactor.Builtin.FloatOut + , Language.Haskell.Tools.Refactor.Builtin.GetMatches , Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.SupportedExtensions , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.TraverseAST - + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.Checkable + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Instances.AppSelector - other-modules: Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers + other-modules: Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ArrowsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstrainedClassMethodsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ConstraintKindsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DefaultSignaturesChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitForAllChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ExplicitNamespacesChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FlexibleInstancesChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.BangPatternsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.FunctionalDependenciesChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.GADTsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.KindSignaturesChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiParamTypeClassesChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MultiWayIfChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.OverloadedStringsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ParallelListCompChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecursiveDoChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeFamiliesChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeOperatorsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TypeSynonymInstancesChecker , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.TypeLookup - , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.SupportedExtensions - + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.Debug build-depends: base >= 4.10 && < 4.11 , mtl >= 2.2 && < 2.3 + , aeson >= 1.0 && < 1.4 , uniplate >= 1.6 && < 1.7 + , classyplate >= 0.3 && < 0.4 + , deepseq >= 1.4 && < 1.5 , ghc-paths >= 0.1 && < 0.2 , containers >= 0.5 && < 0.6 , directory >= 1.2 && < 1.4 @@ -100,8 +129,9 @@ , split >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 , template-haskell >= 2.12 && < 2.13 + , minisat-solver >= 0.1 && < 0.2 , ghc >= 8.2 && < 8.3 - , Cabal >= 2.0 && < 2.1 + , Cabal >= 2.0 && < 2.3 , haskell-tools-ast >= 1.0 && < 1.1 , haskell-tools-backend-ghc >= 1.0 && < 1.1 , haskell-tools-rewrite >= 1.0 && < 1.1 @@ -114,9 +144,9 @@ ghc-options: -with-rtsopts=-M2g hs-source-dirs: test main-is: Main.hs - build-depends: base >= 4.10 && < 4.11 + build-depends: base >= 4.10 && < 4.11 , tasty >= 0.11 && < 1.1 - , tasty-hunit >= 0.9 && < 0.11 + , tasty-hunit >= 0.9 && < 0.11 , transformers >= 0.5 && < 0.6 , either >= 4.4 && < 5.1 , filepath >= 1.4 && < 1.5 @@ -130,16 +160,13 @@ , template-haskell >= 2.12 && < 2.13 , ghc >= 8.2 && < 8.3 , ghc-paths >= 0.1 && < 0.2 - , Cabal >= 2.0 && < 2.1 + , Cabal >= 2.0 && < 2.3 , haskell-tools-ast >= 1.0 && < 1.1 , haskell-tools-backend-ghc >= 1.0 && < 1.1 , haskell-tools-rewrite >= 1.0 && < 1.1 , haskell-tools-prettyprint >= 1.0 && < 1.1 , haskell-tools-refactor >= 1.0 && < 1.1 , haskell-tools-builtin-refactorings - -- libraries used by the examples - , old-time >= 1.1 && < 1.2 - , polyparse >= 1.12 && < 1.13 default-language: Haskell2010 test-suite ht-extension-organizer-test @@ -147,11 +174,12 @@ type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g other-modules: ExtensionOrganizerTest.AnnotationParser + , ExtensionOrganizerTest.Parser hs-source-dirs: test main-is: ExtensionOrganizerTest/Main.hs build-depends: base >= 4.10 && < 4.11 , tasty >= 0.11 && < 1.1 - , tasty-hunit >= 0.9 && < 0.11 + , tasty-hunit >= 0.9 && < 0.11 , transformers >= 0.5 && < 0.6 , either >= 4.4 && < 5.1 , filepath >= 1.4 && < 1.5 @@ -165,7 +193,7 @@ , template-haskell >= 2.12 && < 2.13 , ghc >= 8.2 && < 8.3 , ghc-paths >= 0.1 && < 0.2 - , Cabal >= 2.0 && < 2.1 + , Cabal >= 2.0 && < 2.3 , haskell-tools-ast >= 1.0 && < 1.1 , haskell-tools-backend-ghc >= 1.0 && < 1.1 , haskell-tools-rewrite >= 1.0 && < 1.1 @@ -174,3 +202,36 @@ , haskell-tools-builtin-refactorings default-language: Haskell2010 + +-- benchmark ht-extension-organizer-benchmark +-- type: exitcode-stdio-1.0 +-- ghc-options: -with-rtsopts=-M2g +-- other-modules: ExtensionOrganizerBenchmark.ManualTraversal +-- , ExtensionOrganizerBenchmark.UniPlateTraversal +-- hs-source-dirs: benchmark +-- main-is: ExtensionOrganizerBenchmark/Main.hs +-- build-depends: base >= 4.10 && < 4.11 +-- , criterion >= 1.2 && < 1.3 +-- , silently >= 1.2 && < 1.3 +-- , transformers >= 0.5 && < 0.6 +-- , either >= 4.4 && < 4.6 +-- , filepath >= 1.4 && < 1.5 +-- , mtl >= 2.2 && < 2.3 +-- , uniplate >= 1.6 && < 1.7 +-- , containers >= 0.5 && < 0.6 +-- , directory >= 1.2 && < 1.4 +-- , references >= 0.3 && < 0.4 +-- , split >= 0.2 && < 0.3 +-- , time >= 1.8 && < 1.9 +-- , template-haskell >= 2.12 && < 2.13 +-- , ghc >= 8.2 && < 8.3 +-- , ghc-paths >= 0.1 && < 0.2 +-- , Cabal >= 2.0 && < 2.3 +-- , haskell-tools-ast >= 1.0 && < 1.1 +-- , haskell-tools-backend-ghc >= 1.0 && < 1.1 +-- , haskell-tools-rewrite >= 1.0 && < 1.1 +-- , haskell-tools-prettyprint >= 1.0 && < 1.1 +-- , haskell-tools-refactor >= 1.0 && < 1.1 +-- , haskell-tools-builtin-refactorings +-- +-- default-language: Haskell2010 diff --git a/test/ExtensionOrganizerTest/AnnotationParser.hs b/test/ExtensionOrganizerTest/AnnotationParser.hs --- a/test/ExtensionOrganizerTest/AnnotationParser.hs +++ b/test/ExtensionOrganizerTest/AnnotationParser.hs @@ -1,28 +1,51 @@ -module ExtensionOrganizerTest.AnnotationParser where +module ExtensionOrganizerTest.AnnotationParser + -- (getLocalExtensionAnnotations, getGlobalExtensionAnnotations) + where +import ExtensionOrganizerTest.Parser + import Data.List import qualified Data.Map.Strict as SMap (Map, empty, insertWith) -import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad (Extension, LogicalRelation(..)) -- for Ord Extension +import Language.Haskell.Tools.Refactor.Utils.Extensions (canonExt) +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + {-# ANN module "HLint: ignore Use zipWith" #-} -getExtensionAnnotations :: String -> SMap.Map (LogicalRelation Extension) [Int] -getExtensionAnnotations s = foldl f SMap.empty (parseFile s) +getGlobalExtensionAnnotations :: String -> [Extension] +getGlobalExtensionAnnotations s + | [] <- getGlobalAnnot s = [] + | otherwise = parseGlobalAnnot . getGlobalAnnot $ s + +getLocalExtensionAnnotations :: String -> SMap.Map (LogicalRelation Extension) [Int] +getLocalExtensionAnnotations s = foldl f SMap.empty (parseFile s) where f m (num, exts) = foldl (g num) m exts - g num m' ext = SMap.insertWith (++) (LVar ext) [num] m' + g num m' ext = SMap.insertWith (++) ext [num] m' -parseFile :: String -> [(Int, [Extension])] -- SMap.Map Extension [Int] +parseFile :: String -> [(Int, [LogicalRelation Extension])] -- SMap.Map Extension [Int] parseFile = map parseLine . zip [1..] . lines -parseLine :: (Int, String) -> (Int, [Extension]) -parseLine (num, line) = (num, parseAnnot line) +parseLine :: (Int, String) -> (Int, [LogicalRelation Extension]) +parseLine (num, line) = (num, parseLocalAnnot . getLocalAnnot $ line) -parseAnnot :: String -> [Extension] -parseAnnot = map read . delimit (== ',') . getAnnot +parseLocalAnnot :: String -> [LogicalRelation Extension] +parseLocalAnnot = map parseRelation . prepareAnnot -getAnnot :: String -> String -getAnnot = concat . takeWhile (not . isPrefixOf "*-}") . tail' . dropWhile (not . isPrefixOf "{-*" ) . words +parseRelation :: String -> LogicalRelation Extension +parseRelation = execParser relation + +parseGlobalAnnot :: String -> [Extension] +parseGlobalAnnot = map read . delimit (== ',') + +getGlobalAnnot :: String -> String +getGlobalAnnot = getAnnot "{-@" "@-}" + +getLocalAnnot :: String -> String +getLocalAnnot = getAnnot "{-*" "*-}" + +getAnnot :: String -> String -> String -> String +getAnnot start end = concat . takeWhile (not . isPrefixOf end) . tail' . dropWhile (not . isPrefixOf start ) . words where tail' [] = [] tail' xs = tail xs @@ -34,8 +57,34 @@ delimit' pred xs acc = delimit' pred l2 (acc ++ [l1]) where (l1, l2) = break' pred xs --- exludes the elemnt for which the predicate is true +-- exludes the element for which the predicate is true break' _ xs@[] = (xs, xs) break' p (x:xs') | p x = ([],xs') | otherwise = let (ys,zs) = break' p xs' in (x:ys,zs) + +--------- + +prepareAnnot :: String -> [String] +prepareAnnot = map (filter (not . isSpace)) . delimit (== ',') + +crop :: String -> String +crop = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +-- | A relation parser that tries to reduce the left-hand side of operators, +-- before applíing the left-recursive rules. +-- Also the rules are a bit convoluted in order to respect the precedence +-- of the operators +relation :: Parser (LogicalRelation Extension) +relation = primRel + <|> (:&&:) <$> primRel <*> (token "*" *> primRel) + <|> (:||:) <$> primRel <*> (token "+" *> relation) + <|> (:||:) <$> relation <*> (token "+" *> relation) + <|> (:&&:) <$> relation <*> (token "*" *> relation) + <|> Not <$> (token "~" *> relation) + + where primRel = (lVar . readExt) <$> word + <|> Not <$> (token "~" *> primRel) + + readExt :: String -> Extension + readExt = read . canonExt diff --git a/test/ExtensionOrganizerTest/ArrowsTest/Basic.hs b/test/ExtensionOrganizerTest/ArrowsTest/Basic.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ArrowsTest/Basic.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Arrows #-} + +module Basic where + +import Control.Arrow (returnA) + +idA :: a -> a +idA = proc a -> returnA -< a {-* Arrows *-} + +plusOne :: Int -> Int +plusOne = proc a -> returnA -< (a+1) {-* Arrows *-} + +plusFive = + proc a -> do b <- plusOne -< a {-* Arrows *-} + c <- plusOne -< b {-* Arrows *-} + d <- plusOne -< c {-* Arrows *-} + e <- plusOne -< d {-* Arrows *-} + plusOne -< e {-* Arrows, Arrows *-} diff --git a/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/Definitions.hs b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/Definitions.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Definitions where + +class C0 where + f :: () + +class D a where + g :: a -> () diff --git a/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/MixedTyVars.hs b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/MixedTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/MixedTyVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleContexts, ConstrainedClassMethods #-} + +module MixedTyVars where + +import Definitions + +class C a where + op1 :: D (a, b) => a -> b + op2 :: D b => b -> a diff --git a/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/NullaryConstraint.hs b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/NullaryConstraint.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/NullaryConstraint.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ConstrainedClassMethods #-} + +module NullaryConstraint where + +import Definitions + +class C a where + op :: C0 => a -> a diff --git a/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/OnlyClassTyVars.hs b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/OnlyClassTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstrainedClassMethodsTest/OnlyClassTyVars.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ConstrainedClassMethods #-} + +module OnlyClassTyVars where + +import Definitions + +class C a where {-* ConstrainedClassMethods *-} + op :: D a => a -> b diff --git a/test/ExtensionOrganizerTest/ConstraintKindsTest/ClassConstraints.hs b/test/ExtensionOrganizerTest/ConstraintKindsTest/ClassConstraints.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstraintKindsTest/ClassConstraints.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} + +module ClassConstraints where + +type Bar1 a = Eq a {-* ConstraintKinds *-} +type Bar2 a = (Eq a, Show a) {-* ConstraintKinds *-} diff --git a/test/ExtensionOrganizerTest/ConstraintKindsTest/ComplexConstraints.hs b/test/ExtensionOrganizerTest/ConstraintKindsTest/ComplexConstraints.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstraintKindsTest/ComplexConstraints.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, KindSignatures, ConstraintKinds #-} + +module ComplexConstraints where + +import GHC.Exts + +type Foo1 (f :: * -> Constraint) b = (Eq b, f b) => b -> b {-* ConstraintKinds, KindSignatures, KindSignatures, KindSignatures *-} +type Foo2 (f :: * -> Constraint) = forall b . (Eq b, f b) => b {-* ConstraintKinds, KindSignatures, KindSignatures, KindSignatures, ExplicitForAll *-} diff --git a/test/ExtensionOrganizerTest/ConstraintKindsTest/NotClassConstraints.hs b/test/ExtensionOrganizerTest/ConstraintKindsTest/NotClassConstraints.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ConstraintKindsTest/NotClassConstraints.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RankNTypes, KindSignatures, ConstraintKinds #-} + +module NotClassConstraints where + +import GHC.Exts + +type Foo0 (f :: Constraint) = f {-* ConstraintKinds, KindSignatures *-} +type Foo1 (f :: * -> Constraint) b = f b {-* ConstraintKinds, KindSignatures, KindSignatures, KindSignatures *-} +type Foo2 (f :: * -> Constraint) b = f b => b -> b {-* ConstraintKinds, KindSignatures, KindSignatures, KindSignatures *-} +type Foo3 (f :: * -> Constraint) = forall b . f b => b {-* ConstraintKinds, KindSignatures, KindSignatures, KindSignatures, ExplicitForAll *-} diff --git a/test/ExtensionOrganizerTest/DefaultSignaturesTest/Basic.hs b/test/ExtensionOrganizerTest/DefaultSignaturesTest/Basic.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DefaultSignaturesTest/Basic.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DefaultSignatures #-} + +module Basic where + +class DefaultClass a where + f :: a -> () + f = const () + +class C a where + g :: a -> () + default g :: DefaultClass a => a -> () {-* DefaultSignatures *-} + g = f diff --git a/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADT.hs b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADT.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADT.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExistentialQuantification, GADTSyntax #-} + +module WithGADT where + +{-@ ExistentialQuantification, GADTSyntax @-} + +data T a = forall c . T a c {-* ExplicitForAll, GADTs + ExistentialQuantification *-} + +data GT a where + GT1 :: forall a . a -> GT [a] {-* GADTSyntax, GADTs + ExistentialQuantification, ExplicitForAll *-} diff --git a/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADTSyntax.hs b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADTSyntax.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithGADTSyntax.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExistentialQuantification, GADTSyntax #-} + +module WithGADTSyntax where + +{-@ ExistentialQuantification, GADTSyntax @-} + +data T a = forall c . T a c {-* ExplicitForAll, GADTs + ExistentialQuantification *-} + +data GT a where + GT1 :: a -> GT a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithoutGADTSyntax.hs b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithoutGADTSyntax.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExistentialQuantificationTest/WithoutGADTSyntax.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module WithoutGADTSyntax where + +{-@ ExistentialQuantification @-} + +data T1 a = forall c . T1 a c {-* ExplicitForAll, GADTs + ExistentialQuantification *-} +data T2 a = Eq a => T2 a {-* GADTs + ExistentialQuantification *-} diff --git a/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Definitions.hs b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Definitions.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + +module Definitions where + +data (:+:) a b = Plus a b diff --git a/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Export.hs b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Export.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Export.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module Export + ( module Export + , type (:+:) {-* ExplicitNamespaces *-} + ) where + +import Definitions diff --git a/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Import.hs b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Import.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ExplicitNamespacesTest/Import.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +module Import where + +import Definitions (type (:+:)) {-* ExplicitNamespaces *-} diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs --- a/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs @@ -23,6 +23,21 @@ data T1 a = T1 a data T0 = T0 -data a :+: b = Plus a b +type TS4 a b c d = T4 a b c d +type TS3 a b c = T3 a b c +type TS2 a b = T2 a b +type TS1 a = T1 a +type TS0 = T0 + +data a :-: b = Minus a b +data a :+: b = Plus a b data (a :++: b) c = PPlus a b c -data a :-: b = Minus a b + +type MinusSyn a b = a :-: b +type PlusSyn a b = a :+: b +type PPlusSyn a b c = (a :++: b) c + + +type Phantom a b = [a] +type HomoTuple a = (a,a) +type DoubleList a = [[a]] diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs --- a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs @@ -9,7 +9,7 @@ {-# ANN module "HLint: ignore Redundant bracket" #-} -instance C1 (T1 a) where +instance C1 (T1 a) where f1 _ = True instance C1 (T1 (T1 a)) where {-* FlexibleInstances *-} diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurence.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurence.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurence.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE KindSignatures, + TypeOperators, + MultiParamTypeClasses, + FlexibleInstances + #-} + +module NoOccurence where + +import Definitions + +{-# ANN module "HLint: ignore Redundant bracket" #-} + +-- NOTE: The FlexibleInstancesChecker should find some extensions, +-- because FlexibleInstances is turned on. +-- (However it shouldn't find FlexibleInstances) +-- Same test-cases as in NoOccurenceOFF. + + +instance (C1 (((T4) (a)) b c d)) where + f1 _ = True + +instance C1 (T2 a b) where + f1 _ = True + +instance C1 (T1 a) where + f1 _ = True + +-- (because T0 is a type ctor here) +instance C1 T0 where + f1 _ = True + +instance C1 (a :+: b) where {-* TypeOperators *-} + f1 _ = True + +instance C1 ((:-:) a b) where + f1 _ = True + +instance (:?:) T0 T0 where {-* MultiParamTypeClasses *-} + h _ _ = True + +instance T0 :!: T0 where {-* MultiParamTypeClasses, TypeOperators *-} + j _ _ = True {-* *-} + +instance T0 :!: (T1 a) where {-* MultiParamTypeClasses, TypeOperators *-} + j _ _ = True + +instance (T2 a b) :!: (T1 a) where {-* MultiParamTypeClasses, TypeOperators *-} + j _ _ = True + +instance (a :+: b) :!: (T1 a) where {-* MultiParamTypeClasses, TypeOperators, TypeOperators *-} + j _ _ = True + +instance C1 [(a :: *)] where {-* KindSignatures *-} + f1 _ = True + +instance C2 (T1 a) (T1 a) where {-* MultiParamTypeClasses *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs deleted file mode 100644 --- a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE KindSignatures, - TypeOperators, - MultiParamTypeClasses - #-} - -module NoOccurenceOFF where - -import Definitions - -{-# ANN module "HLint: ignore Redundant bracket" #-} - --- NOTE: The FlexibleInstancesChecker shouldn't even run, --- since the FlexibleInstances isn't even turned on. --- Same test-cases as in NoOccurenceON. - -instance (C1 (((T4) (a)) b c d)) where - f1 _ = True - -instance C1 (T2 a b) where - f1 _ = True - -instance C1 (T1 a) where - f1 _ = True - --- (because T0 is a type ctor here) -instance C1 T0 where - f1 _ = True - -instance C1 (a :+: b) where - f1 _ = True - -instance C1 ((:-:) a b) where - f1 _ = True - -instance (:?:) T0 T0 where - h _ _ = True - -instance T0 :!: T0 where - j _ _ = True - -instance T0 :!: (T1 a) where - j _ _ = True - -instance (T2 a b) :!: (T1 a) where - j _ _ = True - -instance (a :+: b) :!: (T1 a) where - j _ _ = True - -instance C1 [(a :: *)] where - f1 _ = True - -instance C2 (T1 a) (T1 a) where - f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceON.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceON.hs deleted file mode 100644 --- a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceON.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE KindSignatures, - TypeOperators, - MultiParamTypeClasses, - FlexibleInstances - #-} - -module NoOccurenceON where - -import Definitions - -{-# ANN module "HLint: ignore Redundant bracket" #-} - --- NOTE: The FlexibleInstancesChecker should find some extensions, --- because FlexibleInstances is turned on. --- (However it shouldn't find FlexibleInstances) --- Same test-cases as in NoOccurenceOFF. - - -instance (C1 (((T4) (a)) b c d)) where - f1 _ = True - -instance C1 (T2 a b) where - f1 _ = True - -instance C1 (T1 a) where - f1 _ = True - --- (because T0 is a type ctor here) -instance C1 T0 where - f1 _ = True - -instance C1 (a :+: b) where {-* TypeOperators *-} - f1 _ = True - -instance C1 ((:-:) a b) where - f1 _ = True - -instance (:?:) T0 T0 where {-* MultiParamTypeClasses *-} - h _ _ = True - -instance T0 :!: T0 where {-* TypeOperators, MultiParamTypeClasses *-} - j _ _ = True - -instance T0 :!: (T1 a) where {-* TypeOperators, MultiParamTypeClasses *-} - j _ _ = True - -instance (T2 a b) :!: (T1 a) where {-* TypeOperators, MultiParamTypeClasses *-} - j _ _ = True - -instance (a :+: b) :!: (T1 a) where {-* TypeOperators, TypeOperators, MultiParamTypeClasses *-} - j _ _ = True - -instance C1 [(a :: *)] where {-* KindSignatures *-} - f1 _ = True - -instance C2 (T1 a) (T1 a) where {-* MultiParamTypeClasses *-} - f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymCombined.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymCombined.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymCombined.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleInstances, + MultiParamTypeClasses + #-} + +module SynonymCombined where + +import Definitions + +-- NOTE: runs really slowly + +-- same TyVars and TopLevelTyVar + +instance C2 a (TS2 c c) where {-* FlexibleInstances, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedTypes.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedTypes.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedTypes.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeOperators, + FlexibleInstances + #-} + +module SynonymNestedTypes where + +import Definitions + +{-# ANN module "HLint: ignore Redundant bracket" #-} + + +instance C1 (TS1 a) where {-* TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS1 (TS1 a)) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS2 a (TS1 b)) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS2 (TS1 a) b) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (PlusSyn (TS1 a) b) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (DoubleList a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (Phantom (T1 a) a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +-- False positive +instance C1 (Phantom a (T1 a)) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedUnitTyCon.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedUnitTyCon.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedUnitTyCon.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleInstances + #-} + +module SynonymNestedUnitTyCon where + +import Definitions + + +instance C1 (TS3 a b TS0) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS3 a TS0 c) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS3 TS0 b c) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (DoubleList T0) where {-* FlexibleInstances, FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (HomoTuple T0) where {-* FlexibleInstances, FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (Phantom T0 a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +-- False positive +instance C1 (Phantom a T0) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedWiredInType.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedWiredInType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNestedWiredInType.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleInstances #-} + +module SynonymNestedWiredInType where + +import Definitions + + +instance C1 (TS3 a b Int) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS3 a Int c) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS3 Int b c) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (Phantom Int a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +-- False positive +instance C1 (Phantom a Int) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNoOccurence.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNoOccurence.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymNoOccurence.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE KindSignatures, + TypeOperators, + MultiParamTypeClasses, + FlexibleInstances + #-} + +module SynonymNoOccurence where + +import Definitions + +{-# ANN module "HLint: ignore Redundant bracket" #-} + +instance (C1 (((TS4) (a)) b c d)) where {-* TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS2 a b) where {-* TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS1 a) where {-* TypeSynonymInstances *-} + f1 _ = True + +-- (because TS0 is a type ctor here) +instance C1 TS0 where {-* TypeSynonymInstances *-} + f1 _ = True + +instance C1 (PlusSyn a b) where {-* TypeSynonymInstances *-} + f1 _ = True + +instance C1 ((:-:) a b) where + f1 _ = True + +instance (:?:) TS0 TS0 where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeSynonymInstances *-} + h _ _ = True + +instance TS0 :!: TS0 where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeSynonymInstances, TypeOperators *-} + j _ _ = True + +instance TS0 :!: (TS1 a) where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeSynonymInstances, TypeOperators *-} + j _ _ = True + +instance (TS2 a b) :!: (TS1 a) where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeSynonymInstances, TypeOperators *-} + j _ _ = True + +instance (a :+: b) :!: (TS1 a) where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeOperators, TypeOperators *-} + j _ _ = True + +instance C1 [(a :: *)] where {-* KindSignatures *-} + f1 _ = True + +instance C2 (TS1 a) (TS1 a) where {-* MultiParamTypeClasses, TypeSynonymInstances, TypeSynonymInstances *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymSameTyVars.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymSameTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymSameTyVars.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances + #-} + +module SynonymSameTyVars where + +import Definitions + + +instance C1 (TS2 a a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (TS4 a b d d) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +instance C1 (HomoTuple a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True + +-- False positive +instance C1 (Phantom a a) where {-* FlexibleInstances, TypeSynonymInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymTopLevelTyVar.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymTopLevelTyVar.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SynonymTopLevelTyVar.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses, + TypeOperators, + FlexibleInstances + #-} + +module SynonymTopLevelTyVar where + +import Definitions + +{-# ANN module "HLint: ignore Redundant bracket" #-} + +-- There are two matches, because there are two top-level tyvars + +instance C2 a a where {-* FlexibleInstances, FlexibleInstances, MultiParamTypeClasses *-} + f2 _ _ = True + +-- extra check for the brackets around "d" +instance C2 ((PPlusSyn a b) c) (d) where {-* FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FunctionalDependenciesTest/Basic.hs b/test/ExtensionOrganizerTest/FunctionalDependenciesTest/Basic.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FunctionalDependenciesTest/Basic.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Basic where + +class C a b where {-* MultiParamTypeClasses *-} + f :: a -> b -> () + +class FDC a b | a -> b where {-* FunctionalDependencies, MultiParamTypeClasses *-} + g :: a -> b -> () diff --git a/test/ExtensionOrganizerTest/GADTsTest/AssocGDataFamily.hs b/test/ExtensionOrganizerTest/GADTsTest/AssocGDataFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/AssocGDataFamily.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, GADTs #-} + +module AssocGDataFamily where + +class GC a where + data GD a :: * -> * {-* TypeFamilies, KindSignatures, KindSignatures, KindSignatures *-} + +instance GC Int where + data GD Int a where + G1 :: Int -> a -> GD Int a {-* TypeFamilies, GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/GDataFamilyDecl.hs b/test/ExtensionOrganizerTest/GADTsTest/GDataFamilyDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/GDataFamilyDecl.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies + , GADTs + #-} + +module GDataFamilyDecl where + +data family G a b {-* TypeFamilies *-} + +data instance G [a] b where + G1 :: c -> G [Int] b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + G2 :: G [a] Bool {-* GADTSyntax, GADTs + ExistentialQuantification, TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/GDataInstDecl.hs b/test/ExtensionOrganizerTest/GADTsTest/GDataInstDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/GDataInstDecl.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GADTs, TypeFamilies #-} + +module GDataInstDecl where + +data family G a b {-* TypeFamilies *-} +data instance G [a] b where + GExistential :: c -> G [a] b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + GSpecResTy :: G [Int] b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + GContext :: Eq a => G [a] b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + GRegular :: G [a] b {-* GADTSyntax, TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/NormalContext.hs b/test/ExtensionOrganizerTest/GADTsTest/NormalContext.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/NormalContext.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module NormalContext where + +{-@ GADTs @-} + +data T a where + T1 :: Eq a => a -> T a {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: a -> a -> T a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/NormalExistential.hs b/test/ExtensionOrganizerTest/GADTsTest/NormalExistential.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/NormalExistential.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module NormalExistential where + +{-@ GADTs @-} + +data T a where + T1 :: b -> T a {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: a -> a -> T a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/NormalOnlySyntax.hs b/test/ExtensionOrganizerTest/GADTsTest/NormalOnlySyntax.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/NormalOnlySyntax.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTSyntax #-} + +module NormalOnlySyntax where + +data T a where + T1 :: a -> T a {-* GADTSyntax *-} + T2 :: a -> a -> T a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/NormalSpecResultType.hs b/test/ExtensionOrganizerTest/GADTsTest/NormalSpecResultType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/NormalSpecResultType.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module NormalSpecResultType where + +{-@ GADTs @-} + +data T a where + T1 :: a -> T [a] {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: a -> a -> T a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/RecordContext.hs b/test/ExtensionOrganizerTest/GADTsTest/RecordContext.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/RecordContext.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module RecordContext where + +{-@ GADTs @-} + +data T a b where + T1 :: Eq a => { f1::a, f2::b } -> T a b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: { f1::a, f2::b } -> T a b {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/RecordExistential.hs b/test/ExtensionOrganizerTest/GADTsTest/RecordExistential.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/RecordExistential.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module RecordExistential where + +{-@ GADTs @-} + +data T a b where + T1 :: { f1::a, f2::c } -> T a b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: { g1::a, g2::b } -> T a b {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/RecordOnlySyntax.hs b/test/ExtensionOrganizerTest/GADTsTest/RecordOnlySyntax.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/RecordOnlySyntax.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTSyntax #-} + +module RecordOnlySyntax where + +data T a b where + T1 :: { f1::a, f2::b } -> T a b {-* GADTSyntax *-} + T2 :: { f1::a, f2::b } -> T a b {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/RecordSpecResultType.hs b/test/ExtensionOrganizerTest/GADTsTest/RecordSpecResultType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/RecordSpecResultType.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +module RecordSpecResultType where + +{-@ GADTs @-} + +data T a b where + T1 :: { f1::a, f2::b } -> T [a] [b] {-* GADTSyntax, GADTs + ExistentialQuantification *-} + T2 :: { g1::a, g2::b } -> T a b {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/TypeEquality.hs b/test/ExtensionOrganizerTest/GADTsTest/TypeEquality.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/TypeEquality.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GADTs, ConstraintKinds #-} + +module TypeEquality where + +{-@ GADTs, ConstraintKinds @-} + +type EqRel a b = a ~ b {-* TypeFamilies + GADTs, TypeFamilies + GADTs, ConstraintKinds *-} + +data T a where + T1 :: b -> T a {-* GADTSyntax, GADTs + ExistentialQuantification *-} diff --git a/test/ExtensionOrganizerTest/GADTsTest/TypeEqualityWithOnlySyntax.hs b/test/ExtensionOrganizerTest/GADTsTest/TypeEqualityWithOnlySyntax.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/GADTsTest/TypeEqualityWithOnlySyntax.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GADTs, ConstraintKinds #-} + +module TypeEqualityWithOnlySyntax where + +{-@ GADTs, ConstraintKinds @-} + +type EqRel a b = a ~ b {-* TypeFamilies + GADTs, TypeFamilies + GADTs, ConstraintKinds *-} + +data T a where + T1 :: a -> T a {-* GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/KindSignaturesTest/InClassDecl.hs b/test/ExtensionOrganizerTest/KindSignaturesTest/InClassDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/KindSignaturesTest/InClassDecl.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE KindSignatures #-} + +module InClassDecl where + +class C (a :: *) where {-* KindSignatures *-} + f :: a -> () diff --git a/test/ExtensionOrganizerTest/KindSignaturesTest/InDataDecl.hs b/test/ExtensionOrganizerTest/KindSignaturesTest/InDataDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/KindSignaturesTest/InDataDecl.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE KindSignatures #-} + +module InDataDecl where + +data Foo (f :: * -> *) a = Foo (f a) {-* KindSignatures, KindSignatures, KindSignatures *-} diff --git a/test/ExtensionOrganizerTest/KindSignaturesTest/InForAll.hs b/test/ExtensionOrganizerTest/KindSignaturesTest/InForAll.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/KindSignaturesTest/InForAll.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE KindSignatures, ExplicitForAll #-} + +module InForAll where + +f :: forall (a :: *) . a -> a {-* KindSignatures, ExplicitForAll *-} +f = id diff --git a/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeFamily.hs b/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeFamily.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module InTypeFamily where + +type family F a :: * where {-* KindSignatures *-} + F () = () + F _ = () {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeSynonym.hs b/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/KindSignaturesTest/InTypeSynonym.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE KindSignatures #-} + +module InTypeSynonym where + +type Foo (f :: * -> *) a = f a {-* KindSignatures, KindSignatures, KindSignatures *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs --- a/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs @@ -28,7 +28,7 @@ x5 = if | (\case {_ -> False}) 5 -> 20 {-* LambdaCase *-} | (\case {_ -> True}) 5 -> (\case {_ -> 10}) () {-* LambdaCase, LambdaCase *-} - | otherwise -> (\case {_ -> 10}) () {-* LambdaCase *-} --MultiWayIf + | otherwise -> (\case {_ -> 10}) () {-* LambdaCase, MultiWayIf *-} x6 = case (\case {_ -> [1..10]}) () of {-* LambdaCase *-} [] -> \case {_ -> 5} {-* LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Literal/InExpr.hs b/test/ExtensionOrganizerTest/MagicHashTest/Literal/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Literal/InExpr.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} + +module InExpr where + +-- non-exhaustive check for Expr node location in AST + +f :: () +f = () + where + x1 = 1# {-* MagicHash *-} + x2 = 1## {-* MagicHash *-} + x3 = 3.14# {-* MagicHash *-} + x4 = 3.14## {-* MagicHash *-} + x5 = 'c'# {-* MagicHash *-} + x6 = "xxx"# {-* MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InAssertion.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InAssertion.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InAssertion.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MagicHash, + TypeOperators, + MultiParamTypeClasses + #-} + +module InAssertion where + +-- TODO: implicit assert + +class C# a where {-* MagicHash *-} + f1 :: a -> a + +class a :!: b where {-* MultiParamTypeClasses *-} + f2 :: a -> b {-* TypeOperators *-} + + +g1 :: C# a# => a# -> a# {-* MagicHash, MagicHash, MagicHash, MagicHash *-} +g1 = id + +g2 :: (a :!: b#) => a -> b# -> () {-* MagicHash, MagicHash, TypeOperators *-} +g2 _ _ = () + +g3 :: (C# a, (a :!: b#)) => a -> b# -> () {-* MagicHash, MagicHash, MagicHash, TypeOperators *-} +g3 _ _ = () diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InClassElement.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InClassElement.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InClassElement.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash, + DefaultSignatures + #-} + +module InClassElement where + +class C a where + f# :: a -> a {-* MagicHash *-} + default f# :: a -> a {-* MagicHash, DefaultSignatures *-} + f# = id {-* MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InDecl.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InDecl.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MagicHash #-} + +module InDecl where + +-- non-exhaustive check for Decl node location in AST + +-- TODO: Foreign Import/Export diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InDeclHead.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InDeclHead.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InDeclHead.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MagicHash, + GADTSyntax + #-} + +module InDeclHead where + +type T1# = () {-* MagicHash *-} +newtype T2# = T2# T1# {-* MagicHash, MagicHash, MagicHash *-} +data T3# = T31# | T32# {-* MagicHash, MagicHash, MagicHash *-} + +data Expr# a where {-* MagicHash *-} + I :: Int -> Expr# a {-* GADTSyntax, MagicHash *-} + B :: Bool -> Expr# a {-* GADTSyntax, MagicHash *-} + Add :: Expr# Int -> Expr# Int -> Expr# a {-* GADTSyntax, MagicHash, MagicHash, MagicHash *-} + Mul :: Expr# Int -> Expr# Int -> Expr# a {-* GADTSyntax, MagicHash, MagicHash, MagicHash *-} + Eq :: Expr# Int -> Expr# Int -> Expr# a {-* GADTSyntax, MagicHash, MagicHash, MagicHash *-} + +class C1# a where {-* MagicHash *-} + f :: a -> a diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InExpr.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InExpr.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MagicHash #-} + +module InExpr where + +-- TODO: non-exhaustive + +data Rec = Rec# { x :: Int } {-* MagicHash *-} + +f :: Int -> Int +f x# = x# + x# {-* MagicHash, MagicHash, MagicHash *-} + +g :: Rec -> Rec +g Rec#{x = x} = Rec# {x = 2} {-* MagicHash, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldDecl.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldDecl.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} + +module InFieldDecl where + +import GHC.Prim + +data Rec a# = R {-* MagicHash *-} + { f1# :: Int# {-* MagicHash, MagicHash *-} + , f2# :: a# {-* MagicHash, MagicHash *-} + } diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldUpdate.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldUpdate.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFieldUpdate.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} + +module InFieldUpdate where + +-- TODO: non-exhaustive + +data Rec = Rec { x# :: Int } {-* MagicHash *-} + +g :: Rec -> Rec +g Rec{x# = x} = Rec {x# = 2} {-* MagicHash, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InFunDeps.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFunDeps.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InFunDeps.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash, + FunctionalDependencies + #-} + +module InFunDeps where + +class C a# b# | a# -> b# where {-* MagicHash, MagicHash, MagicHash, MagicHash, FunctionalDependencies, MultiParamTypeClasses *-} + f :: a# -> b# {-* MagicHash, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InInstanceHead.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InInstanceHead.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InInstanceHead.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} + +module InInstanceHead where + +class C# a where {-* MagicHash *-} + f :: a -> a + +instance (C#) Int where {-* MagicHash *-} + f = id diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InKind.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InKind.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InKind.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash, + PolyKinds, + MultiParamTypeClasses + #-} + +module InKind where + +-- TODO: unboxed kinds + +class C (f :: k# -> *) (a :: k#) (b :: *) where {-* Magichash, Magichash *-} --PolyKinds, MultiParamTypeClasses + g :: f a -> b diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InMatchLhs.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InMatchLhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InMatchLhs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MagicHash #-} + +module InMatchLhs where + +f :: [a] -> [a] +f (a# : as#) = as# {-* MagicHash, MagicHash, MagicHash *-} +f [a#] = [a#] {-* MagicHash, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatSynLhs.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatSynLhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatSynLhs.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash, + PatternSynonyms + #-} + +module InPatSynLhs where + +pattern Uni# :: a -> b -> c -> (a,b,c) {-* PatternSynonyms, MagicHash *-} +pattern Uni# a b c <- (a,b,c) {-* PatternSynonyms, MagicHash *-} + +pattern Bi# :: a -> [a] {-* PatternSynonyms, MagicHash *-} +pattern Bi# a = [a] {-* PatternSynonyms, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InPattern.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPattern.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash, + BangPatterns, + ScopedTypeVariables, + ViewPatterns + #-} + +module InPattern where + +-- NOTE: non-exhaustive + +data Rec = Rec# { x :: Int } {-* MagicHash *-} + +f1 :: a -> () +f1 x# = () {-* MagicHash *-} + +f2 :: [a] -> () +f2 (a# : as#) = () {-* MagicHash, MagicHash *-} +f2 [x#] = () {-* MagicHash *-} +f2 _ = () + +f3 :: Maybe a -> () +f3 (Just x#) = () {-* MagicHash *-} +f3 _ = () + +f4 :: (a,a) -> () +f4 (x#, y#) = () {-* MagicHash, MagicHash *-} + +f5 :: Rec -> () +f5 Rec#{x = x} = () {-* MagicHash *-} + +f6 :: a -> () +f6 x#@y# = () {-* MagicHash, MagicHash *-} + +f7 :: a -> () +f7 !x# = () {-* MagicHash, BangPatterns *-} + +f8 :: a -> () +f8 (x# :: a) = () {-* MagicHash *-} -- ScopedTypeVariables + +f9 :: a -> () +f9 (id -> x#) = () {-* MagicHash, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatternField.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatternField.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InPatternField.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MagicHash, + NamedFieldPuns + #-} + +module InPatternField where + +-- NOTE: non-exhaustive + +data Rec = Rec { x# :: Int } {-* MagicHash *-} + +f5 :: Rec -> () +f5 Rec{x# = 0} = () {-* MagicHash *-} +f5 Rec{x#} = () {-* MagicHash *-} --RecordPuns diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InType.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InType.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE MagicHash, + ExplicitForAll, + KindSignatures, + TypeOperators + #-} + +module InType where + +{-# ANN module "HLint: ignore Redundant bracket" #-} + + +-- TODO: unboxed tuples, template haskell, etc ... + + + +newtype T a b = T (a,b) + +data a :+: b = Plus a b {-* TypeOperators *-} + + +f1 :: forall a# . a# -> () {-* MagicHash, MagicHash, ExplicitForAll *-} +f1 x = () + +f2 :: Show a# => a# -> () {-* MagicHash, MagicHash *-} +f2 x = () + +f3 :: a# -> b# -> () {-* MagicHash, MagicHash *-} +f3 x y = () + +f4 :: (a#, b#) -> () {-* MagicHash, MagicHash *-} +f4 x = () + +f5 :: [a#] -> () {-* MagicHash *-} +f5 xs = () + +f6 :: T a# b# -> T a# b# {-* MagicHash, MagicHash, MagicHash, MagicHash *-} +f6 = id + +f7 :: (a#) -> () {-* MagicHash *-} +f7 x = () + +f8 :: a# :+: b# -> () {-* MagicHash, MagicHash, TypeOperators *-} +f8 x = () + +f9 :: (a# :: *) -> () {-* MagicHash, KindSignatures *-} +f9 x = () diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeFamily.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeFamily.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash, + TypeFamilyDependencies + #-} + +module InTypeFamily where + +-- DeclHead, TypeEqn, InjectivityAnn + +-- a function on types: gets a type 'a' and return a type with kind * +type family Id# a# = r# | r# -> a# where {-* MagicHash, MagicHash, MagicHash, MagicHash, MagicHash*-} --TypeFamilies, TypeFamilyDependencies + Id# a# = a# {-* MagicHash, MagicHash *-} diff --git a/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeSig.hs b/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeSig.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MagicHashTest/Name/InTypeSig.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MagicHash #-} + +module InTypeSig where + +-- non-exhaustive + +f# :: a -> a {-* MagicHash *-} +f# = id {-* MagicHash *-} + where asd# :: b -> b {-* MagicHash *-} + asd# = id {-* MagicHash *-} + +class C a where + g# :: a -> a {-* MagicHash *-} diff --git a/test/ExtensionOrganizerTest/Main.hs b/test/ExtensionOrganizerTest/Main.hs --- a/test/ExtensionOrganizerTest/Main.hs +++ b/test/ExtensionOrganizerTest/Main.hs @@ -9,10 +9,11 @@ import SrcLoc (SrcSpan(..), srcSpanEndLine) import Data.List (sort) +import Control.Monad (unless) import qualified Data.Map.Strict as SMap (Map, map) import System.FilePath (FilePath, addExtension, ()) -import ExtensionOrganizerTest.AnnotationParser (getExtensionAnnotations) +import ExtensionOrganizerTest.AnnotationParser import Language.Haskell.Tools.Refactor hiding (ModuleName) import Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions @@ -38,6 +39,22 @@ , mkTests lambdaCaseTest , mkTests tupleSectionsTest , mkNestedTests magicHashTest + , mkTests functionalDependenciesTest + , mkTests defaultSignaturesTest + , mkTests recursiveDoTest + , mkTests arrowsTest + , mkTests parallelListCompTest + , mkTests typeFamiliesTest + , mkTests multiParamTypeClassesTest + , mkTests constraintKindsTest + , mkTests kindSignaturesTest + , mkTests explicitNamespacesTest + , mkTests overloadedStringsTest + , mkTests gadtsTest + , mkTests existentialQuantificationTest + , mkTests constrainedClassMethodsTest + , mkTests multiWayIfTest + , mkTests typeOperatorsTest ] testRoot = "test/ExtensionOrganizerTest" @@ -58,34 +75,38 @@ simplifyExtMap :: ExtMap -> SimpleMap simplifyExtMap = SMap.map (map spanToLine) -loadModuleAST :: FilePath -> ModuleName -> Ghc TypedModule -loadModuleAST dir moduleName = do - useFlags ["-w"] - modSummary <- loadModule (testRoot dir) moduleName - parseTyped modSummary - getExtensionsFrom :: FilePath -> ModuleName -> IO SimpleMap getExtensionsFrom dir moduleName = runGhc (Just libdir) $ do - modAST <- loadModuleAST dir moduleName + modAST <- loadModuleAST (testRoot dir) moduleName exts <- collectExtensions modAST return $! simplifyExtMap exts -getExtAnnotsFrom :: FilePath -> ModuleName -> IO SimpleMap -getExtAnnotsFrom dir moduleName = do +getLclExtAnnotsFrom :: FilePath -> ModuleName -> IO SimpleMap +getLclExtAnnotsFrom dir moduleName = do s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs" - return $! getExtensionAnnotations s + return $! getLocalExtensionAnnotations s +getGlbExtAnnotsFrom :: FilePath -> ModuleName -> IO [Extension] +getGlbExtAnnotsFrom dir moduleName = do + s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs" + return $! getGlobalExtensionAnnotations s mkTest :: FilePath -> ModuleName -> TestTree mkTest dir moduleName = testCase moduleName $ mkAssertion dir moduleName +-- | Compares the local annotations with the result of the checker. +-- Also compares the global expected result with minimized extension set. mkAssertion :: FilePath -> ModuleName -> IO () mkAssertion dir moduleName = do - expected <- getExtAnnotsFrom dir moduleName - result <- getExtensionsFrom dir moduleName - assertEqual "Failure" (mapSort expected) (mapSort result) - where mapSort = SMap.map sort + global <- getGlbExtAnnotsFrom dir moduleName + local <- getLclExtAnnotsFrom dir moduleName + result <- getExtensionsFrom dir moduleName + let minimalExts = determineExtensions result + mapSort = SMap.map sort + assertEqual "Failure" (mapSort local) (mapSort result) + unless (null global) $ assertEqual "Failure" (sort global) (sort minimalExts) + mkTests :: TestSuite -> TestTree mkTests (testDir, tests) = testGroup testDir (map (mkTest testDir) tests) @@ -111,11 +132,17 @@ , "NestedTypes" , "NestedUnitTyCon" , "NestedWiredInType" - , "NoOccurenceON" - , "NoOccurenceOFF" + , "NoOccurence" , "SameTyVars" , "TopLevelTyVar" , "TopLevelWiredInType" + , "SynonymCombined" + , "SynonymNestedTypes" + , "SynonymNestedUnitTyCon" + , "SynonymNestedWiredInType" + , "SynonymNoOccurence" + , "SynonymSameTyVars" + , "SynonymTopLevelTyVar" ] derivingsTest :: TestSuite @@ -235,3 +262,164 @@ magicHashLiteralTest = (mhLiteralRoot, mhLiteralModules) mhLiteralRoot = "Literal" mhLiteralModules = [ "InExpr" ] + + +functionalDependenciesTest :: TestSuite +functionalDependenciesTest = (fdRoot, fdModules) +fdRoot = "FunctionalDependenciesTest" +fdModules = [ "Basic" ] + + +defaultSignaturesTest :: TestSuite +defaultSignaturesTest = (dsRoot, dsModules) +dsRoot = "DefaultSignaturesTest" +dsModules = [ "Basic" ] + + +recursiveDoTest :: TestSuite +recursiveDoTest = (rdRoot, rdModules) +rdRoot = "RecursiveDoTest" +rdModules = [ "MDo" + , "RecStmt" + ] + + +arrowsTest :: TestSuite +arrowsTest = (arrRoot, arrModules) +arrRoot = "ArrowsTest" +arrModules = [ "Basic" ] + + +parallelListCompTest :: TestSuite +parallelListCompTest = (pcRoot, pcModules) +pcRoot = "ParallelListCompTest" +pcModules = [ "InCaseRhs" + , "InCompStmt" + , "InExpr" + , "InFieldUpdate" + , "InPattern" + , "InRhs" + , "InRhsGuard" + , "InStmt" + , "InTupSecElem" + ] + +typeFamiliesTest :: TestSuite +typeFamiliesTest = (tfRoot, tfModules) +tfRoot = "TypeFamiliesTest" +tfModules = [ "AssocDataFamily" + , "AssocGDataFamily" + , "AssocTypeFamily" + , "ClosedTypeFamilyDecl" + , "DataFamilyDecl" + , "GDataFamilyDecl" + , "NestedTypeEqualityContextSynonyms" + , "NestedTypeEqualitySynonyms" + , "TypeEqualityContext" + , "TypeEqualityContextSynonyms" + , "TypeEquality" + , "TypeEqualitySynonyms" + , "TypeEqualityInName" + , "TypeFamilyDecl" + ] + +multiParamTypeClassesTest :: TestSuite +multiParamTypeClassesTest = (mptcRoot, mptcModules) +mptcRoot = "MultiParamTypeClassesTest" +mptcModules = [ "MultipleTyVars" + , "ZeroTyVars" + ] + +constraintKindsTest :: TestSuite +constraintKindsTest = (ckRoot, ckModules) +ckRoot = "ConstraintKindsTest" +ckModules = [ "ClassConstraints" + , "ComplexConstraints" + , "NotClassConstraints" + ] + +kindSignaturesTest :: TestSuite +kindSignaturesTest = (ksRoot, ksModules) +ksRoot = "KindSignaturesTest" +ksModules = [ "InClassDecl" + , "InDataDecl" + , "InForAll" + , "InTypeFamily" + , "InTypeSynonym" + ] + +explicitNamespacesTest :: TestSuite +explicitNamespacesTest = (esRoot, esModules) +esRoot = "ExplicitNamespacesTest" +esModules = [ "Import" + , "Export" + ] + +overloadedStringsTest :: TestSuite +overloadedStringsTest = (osRoot, osModules) +osRoot = "OverloadedStringsTest" +osModules = [ "Synonym" + , "Newtype" + , "Other" + ] + +gadtsTest :: TestSuite +gadtsTest = (gadtRoot, gadtModules) +gadtRoot = "GADTsTest" +gadtModules = [ "AssocGDataFamily" + , "GDataFamilyDecl" + , "GDataInstDecl" + , "NormalContext" + , "NormalExistential" + , "NormalOnlySyntax" + , "NormalSpecResultType" + , "RecordContext" + , "RecordExistential" + , "RecordOnlySyntax" + , "RecordSpecResultType" + , "TypeEquality" + , "TypeEqualityWithOnlySyntax" + ] + +existentialQuantificationTest :: TestSuite +existentialQuantificationTest = (eqRoot, eqModules) +eqRoot = "ExistentialQuantificationTest" +eqModules = [ "WithGADT" + , "WithGADTSyntax" + , "WithoutGADTSyntax" + ] + +constrainedClassMethodsTest :: TestSuite +constrainedClassMethodsTest = (ccmRoot, ccmModules) +ccmRoot = "ConstrainedClassMethodsTest" +ccmModules = [ "MixedTyVars" + , "NullaryConstraint" + , "OnlyClassTyVars" + ] + +multiWayIfTest :: TestSuite +multiWayIfTest = (mwiRoot, mwiModules) +mwiRoot = "MultiWayIfTest" +mwiModules = [ "InCaseRhs" + , "InCompStmt" + , "InExpr" + , "InFieldUpdate" + , "InPattern" + , "InRhs" + , "InRhsGuard" + , "InStmt" + , "InTupSecElem" + ] + +typeOperatorsTest :: TestSuite +typeOperatorsTest = (toRoot, toModules) +toRoot = "TypeOperatorsTest" +toModules = [ "InfixClassDecl" + , "InfixDataDecl" + , "InfixInstance" + , "InfixTypeAnnot" + , "InfixTypeSig" + , "NormalClassDecl" + , "NormalDataDecl" + , "NormalInstance" + ] diff --git a/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/MultipleTyVars.hs b/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/MultipleTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/MultipleTyVars.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module MultipleTyVars where + +class C2 a b where {-* MultiParamTypeClasses *-} + f :: a -> b -> () + +class C3 a b c where {-* MultiParamTypeClasses *-} + g :: a -> b -> c -> () + +instance C2 Int Int where {-* MultiParamTypeClasses *-} + f _ _ = () + +instance C3 Int Int Int where {-* MultiParamTypeClasses *-} + g _ _ _ = () diff --git a/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/ZeroTyVars.hs b/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/ZeroTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiParamTypeClassesTest/ZeroTyVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module ZeroTyVars where + +class C0 where {-* MultiParamTypeClasses *-} + f :: () + +instance C0 where {-* MultiParamTypeClasses *-} + f = () diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/Definitions.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/Definitions.hs @@ -0,0 +1,3 @@ +module Definitions where + +data Rec = Rec { num :: Int } diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InCaseRhs.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InCaseRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InCaseRhs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiWayIf #-} + +module InCaseRhs where + +f x = case x of + [] -> if | True -> 0 | False -> 1 {-* MultiWayIf *-} + xs -> if | True -> 0 | False -> 1 {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InCompStmt.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InCompStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InCompStmt.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiWayIf #-} + +module InCompStmt where + +xs = [ (if | x == 0 -> 0 | x == 1 -> 1) | x <- [1..10] ] {-* MultiWayIf *-} + +ys = [ 2*y | y <- (if | 0 == 0 -> [] | 1 == 1 -> []) ] {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InExpr.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InExpr.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MultiWayIf, + TupleSections + #-} + +module InExpr where + +import Definitions + +{-# ANN module "HLint: ignore Redundant lambda" #-} +{-# ANN module "HLint: ignore Redundant bracket" #-} + +x1 = (if | True -> 0 | False -> 1) : [if | True -> 0 | False -> 1] {-* MultiWayIf, MultiWayIf *-} + +x2 = - ((if | True -> id | False -> id) 6) {-* MultiWayIf *-} + +f1 g = g (if | True -> 0 | False -> 1) {-* MultiWayIf *-} + +f2 g h = h g (if | True -> 0 | False -> 1) {-* MultiWayIf *-} + +f3 = \x -> if | True -> 0 | False -> 1 {-* MultiWayIf *-} + +x3 = let x = (if | True -> id | False -> id) 5 in x {-* MultiWayIf *-} + +x4 = if (if | True -> id | False -> id) True {-* MultiWayIf *-} + then (if | True -> 0 | False -> 1) {-* MultiWayIf *-} + else (if | True -> 0 | False -> 2) {-* MultiWayIf *-} + +x6 = case (if | True -> [] | False -> []) of {-* MultiWayIf *-} + [] -> () + xs -> () + +x7 = (if | True -> 0 | False -> 1, 5) {-* MultiWayIf *-} + +x8 = (if | True -> 0 | False -> 1,) {-* MultiWayIf, TupleSections *-} + +x9 = ([(if | True -> 0 | False -> 1)]) {-* MultiWayIf *-} + +f4 = ((if | True -> 0 | False -> 1) +) {-* MultiWayIf *-} + +f5 = (+ (if | True -> 0 | False -> 1)) {-* MultiWayIf *-} + +x10 = Rec { num = (if | True -> 0 | False -> 1) } {-* MultiWayIf *-} + +x11 r = r { num = (if | True -> 0 | False -> 1) } {-* MultiWayIf *-} + +x12 = [(if | True -> 0 | False -> 1), (if | True -> 0 | False -> 1) .. (if | True -> 0 | False -> 1) ] {-* MultiWayIf, MultiWayIf, MultiWayIf *-} + +x13 = (if | True -> 0 | False -> 1) :: Int {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InFieldUpdate.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InFieldUpdate.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InFieldUpdate.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiWayIf #-} + +module InFieldUpdate where + +import Definitions + +f Rec { num = num } = Rec {num = if | True -> 0 | False -> 1} {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InPattern.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InPattern.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultiWayIf, + ViewPatterns + #-} + +module InPattern where + +f ((if | True -> id | False -> id) -> []) = () {-* MultiWayIf, ViewPatterns *-} +f ((if | True -> id | False -> id) -> ys) = () {-* MultiWayIf, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InRhs.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InRhs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiWayIf #-} + +module InRhs where + +f [] = if | True -> 0 | False -> 1 {-* MultiWayIf *-} +f x = if | True -> 0 | False -> 1 {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InRhsGuard.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InRhsGuard.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InRhsGuard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiWayIf #-} + +module InRhsGuard where + +f x + | y1 <- if | True -> 0 | False -> 1, {-* MultiWayIf *-} + y2 <- if | True -> 0 | False -> 1 {-* MultiWayIf *-} + = () + | z1 <- if | True -> 0 | False -> 1 {-* MultiWayIf *-} + = () diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InStmt.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InStmt.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiWayIf #-} + +module InStmt where + +f x = do + let k = if | True -> 0 | False -> 1 {-* MultiWayIf *-} + if | True -> Just 0 | False -> Just 1 {-* MultiWayIf *-} + y <- if | True -> Just 0 | False -> Just 1 {-* MultiWayIf *-} + z <- if | True -> Just 0 | False -> Just 1 {-* MultiWayIf *-} + return $ if | True -> 0 | False -> 1 {-* MultiWayIf *-} diff --git a/test/ExtensionOrganizerTest/MultiWayIfTest/InTupSecElem.hs b/test/ExtensionOrganizerTest/MultiWayIfTest/InTupSecElem.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/MultiWayIfTest/InTupSecElem.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiWayIf, + TupleSections + #-} + +module InTupSecElem where + +f = (,if | True -> 0 | False -> 1) {-* MultiWayIf, TupleSections *-} diff --git a/test/ExtensionOrganizerTest/OverloadedStringsTest/Newtype.hs b/test/ExtensionOrganizerTest/OverloadedStringsTest/Newtype.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/OverloadedStringsTest/Newtype.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Newtype where + +import GHC.Exts (IsString(..)) + +newtype MyString = MyString String + deriving Eq + +instance IsString MyString where + fromString = MyString + +f :: MyString -> MyString +f "asd" = "qwe" {-* OverloadedStrings, OverloadedStrings *-} +f x = x diff --git a/test/ExtensionOrganizerTest/OverloadedStringsTest/Other.hs b/test/ExtensionOrganizerTest/OverloadedStringsTest/Other.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/OverloadedStringsTest/Other.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Other where + +import GHC.Exts (IsString(..)) +import Data.Text + +f :: Text -> Text +f "asd" = "qwe" {-* OverloadedStrings, OverloadedStrings *-} +f x = x diff --git a/test/ExtensionOrganizerTest/OverloadedStringsTest/Synonym.hs b/test/ExtensionOrganizerTest/OverloadedStringsTest/Synonym.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/OverloadedStringsTest/Synonym.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- the pragma is only enabled so that the OverloadedStrings checker runs +module Synonym where + +import GHC.Exts (IsString(..)) + +type MyString1 = [Char] +type MyString2 = String + +f :: MyString1 -> MyString1 +f "asd" = "qwe" +f x = x + +g :: MyString2 -> MyString2 +g "asd" = "qwe" +g x = x diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/Definitions.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/Definitions.hs @@ -0,0 +1,3 @@ +module Definitions where + +data Rec = Rec { num :: Int } diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InCaseRhs.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InCaseRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InCaseRhs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ParallelListComp #-} + +module InCaseRhs where + +f x = case x of + [] -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + xs -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InCompStmt.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InCompStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InCompStmt.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ParallelListComp #-} + +module InCompStmt where + +{-# ANN module "HLint: ignore Redundant list comprehension" #-} + +xs = [ [ (x,y) | x <- [1..10] | y <- [1..10] ] | z <- [1..10] ] {-* ParallelListComp *-} + +ys = [ z | z <- [ (x,y) | x <- [1..10] | y <- [1..10] ] ] {-* ParallelListComp *-} + +zs = [ [ (x,y) | x <- [1..10] | y <- [1..10] ] | z <- [ (x,y) | x <- [1..10] | y <- [1..10] ] ] {-* ParallelListComp, ParallelListComp *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InExpr.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InExpr.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ParallelListComp, + MultiWayIf, + TupleSections + #-} + +module InExpr where + +import Definitions + +{-# ANN module "HLint: ignore Redundant lambda" #-} +{-# ANN module "HLint: ignore Redundant bracket" #-} +{-# ANN module "HLint: ignore Redundant if" #-} + +x1 = [ (x,y) | x <- [1..10] | y <- [1..10] ] : [[ (x,y) | x <- [1..10] | y <- [1..10] ]] {-* ParallelListComp, ParallelListComp *-} + +x2 = length ([ (x,y) | x <- [1..10] | y <- [1..10] ]) {-* ParallelListComp *-} + +f1 g = g [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + +f2 g h = h g ([ (x,y) | x <- [1..10] | y <- [1..10] ]) {-* ParallelListComp *-} + +f3 = \z -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + +x3 = let z = [ (x,y) | x <- [1..10] | y <- [1..10] ] in z {-* ParallelListComp *-} + +x4 = if null [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + then ([ (x,y) | x <- [1..10] | y <- [1..10] ]) {-* ParallelListComp *-} + else ([ (x,y) | x <- [1..10] | y <- [1..10] ]) {-* ParallelListComp *-} + +x5 = if | null [ (x,y) | x <- [1..10] | y <- [1..10] ] -> [] {-* ParallelListComp *-} + | null [ (x,y) | x <- [1..10] | y <- [1..10] ] -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp, ParallelListComp *-} + | otherwise -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp, MultiWayIf *-} + +x6 = case [ (x,y) | x <- [1..10] | y <- [1..10] ] of {-* ParallelListComp *-} + [] -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + xs -> [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + +x7 = ([ (x,y) | x <- [1..10] | y <- [1..10] ], 5) {-* ParallelListComp *-} + +x8 = ([ (x,y) | x <- [1..10] | y <- [1..10] ],) {-* ParallelListComp, TupleSections *-} + +x9 = ([[ (x,y) | x <- [1..10] | y <- [1..10] ]]) {-* ParallelListComp *-} + +f4 = (([ (x,y) | x <- [1..10] | y <- [1..10] ]) ++) {-* ParallelListComp *-} + +f5 = (++ ([ (x,y) | x <- [1..10] | y <- [1..10] ])) {-* ParallelListComp *-} + +x10 = Rec { num = length [ (x,y) | x <- [1..10] | y <- [1..10] ] } {-* ParallelListComp *-} + +x11 r = r { num = length [ (x,y) | x <- [1..10] | y <- [1..10] ] } {-* ParallelListComp *-} + +x12 = [(length [ (x,y) | x <- [1..10] | y <- [1..10] ]) .. (length [ (x,y) | x <- [1..10] | y <- [1..10] ]) ] {-* ParallelListComp, ParallelListComp *-} + +x13 = (length [ (x,y) | x <- [1..10] | y <- [1..10] ]) :: Int {-* ParallelListComp *-} + +-- x14 = (\case {_ -> 5}) @Int ((\case {_ -> 5}) 5) diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InFieldUpdate.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InFieldUpdate.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InFieldUpdate.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ParallelListComp #-} + +module InFieldUpdate where + +import Definitions + +f Rec { num = num } = Rec {num = length ([ (x,y) | x <- [1..10] | y <- [1..10] ])} {-* ParallelListComp *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InPattern.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InPattern.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ParallelListComp, + ViewPatterns + #-} + +module InPattern where + +f (const [ (x,y) | x <- [1..10] | y <- [1..10] ] -> []) = () {-* ParallelListComp, ViewPatterns *-} +f (const [ (x,y) | x <- [1..10] | y <- [1..10] ] -> ys) = () {-* ParallelListComp, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InRhs.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InRhs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ParallelListComp #-} + +module InRhs where + +f [] = [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} +f x = [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InRhsGuard.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InRhsGuard.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InRhsGuard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ParallelListComp #-} + +module InRhsGuard where + +f x + | y1 <- [ (x,y) | x <- [1..10] | y <- [1..10] ], {-* ParallelListComp *-} + y2 <- [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + = () + | z1 <- [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + = () diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InStmt.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InStmt.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ParallelListComp #-} + +module InStmt where + +f x = do + let k = [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + Just [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + y <- Just [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + z <- Just [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} + return $ [ (x,y) | x <- [1..10] | y <- [1..10] ] {-* ParallelListComp *-} diff --git a/test/ExtensionOrganizerTest/ParallelListCompTest/InTupSecElem.hs b/test/ExtensionOrganizerTest/ParallelListCompTest/InTupSecElem.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ParallelListCompTest/InTupSecElem.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ParallelListComp, + TupleSections + #-} + +module InTupSecElem where + +f = (,[ (x,y) | x <- [1..10] | y <- [1..10] ]) {-* ParallelListComp, TupleSections *-} diff --git a/test/ExtensionOrganizerTest/Parser.hs b/test/ExtensionOrganizerTest/Parser.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/Parser.hs @@ -0,0 +1,111 @@ +module ExtensionOrganizerTest.Parser + ( module ExtensionOrganizerTest.Parser + , module Control.Applicative + , module Data.Char + ) where + +import Control.Applicative +import Data.Char +import Data.List (foldl') +import Data.Maybe + +{-# ANN module "HLint: ignore Use mappend" #-} + +newtype Parser a = P (String -> [(a, String)]) + +char :: Char -> Parser Char +char c = matches (== c) + +matches :: (Char -> Bool) -> Parser Char +matches p = P $ \s -> + case s of + (x:xs) | p x -> [(x, xs)] + _ -> [] + +instance Functor Parser where + fmap f (P p) = P $ \s -> [ (f x, s') | (x, s') <- p s ] + +instance Applicative Parser where + pure x = P $ \s -> [(x, s)] + (P pf) <*> (P q) = P $ \s -> [ (f x, s'') | (f, s') <- pf s, (x, s'') <- q s' ] + +instance Alternative Parser where + empty = P $ const [] + (P p) <|> (P q) = P $ \s -> p s ++ q s + +instance Monad Parser where + return = pure + --(>>=) :: Parser a -> (a -> Parser b) -> Parser b + --qs :: Parser (Parser b) ~ P ( String -> [(Parser b, Strng)] + p >>= f = P (\s -> case f <$> p of + P qs -> concat [ qs' s' | (P qs', s') <- qs s ] ) + + +times :: Int -> Parser a -> Parser [a] +times 0 _ = pure [] +times n p = (:) <$> p <*> times (n-1) p + +--parseNInts :: Parser [Int] +--parseNInts = (decimal <* whitespace) >>= (\n -> times n (decimal <* whitespace)) + +token :: String -> Parser String +token "" = pure "" +token (x:xs) = (:) <$> char x <*> token xs + +digit :: Parser Int +digit = digitToInt <$> matches isDigit + +decimal :: Parser Int +decimal = foldl' (\n x -> 10 * n + fromIntegral x) 0 <$> some digit + +string :: Parser String +string = char '"' *> many (matches (/= '"')) <* char '"' + +word :: Parser String +word = many $ matches isAlpha + +whitespace :: Parser String +whitespace = many (matches isSpace) + +endParsing :: Parser () +endParsing = P $ const [((), "")] + +parserResult :: Parser a -> String -> [(a, String)] +parserResult (P p) = p + +runParser :: Parser a -> String -> Maybe a +runParser (P p) s = + case dropWhile (not . null . snd) $ p s of + ((x,""):_) -> Just x + _ -> Nothing + +execParser :: Parser a -> String -> a +execParser p s = fromMaybe (error $ "execParser: Couldn't parse: " ++ s) + (runParser p s) + + +-- Examples for the monad instance +{- +parseNInts :: Parser [Int] +parseNInts = do +{ + n <- (decimal <* whitespace); + res <- times n (decimal <* whitespace); + return res; +} + +parseNTests :: Parser [[Int]] +parseNTests = do +{ + numOfTests <- decimal'; + tests <- times numOfTests (do + { + n <- decimal'; + ints <- times n decimal'; + return ints; + }); + + return tests; +} + where decimal' = decimal <* whitespace +-} diff --git a/test/ExtensionOrganizerTest/RecursiveDoTest/MDo.hs b/test/ExtensionOrganizerTest/RecursiveDoTest/MDo.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/RecursiveDoTest/MDo.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecursiveDo #-} + +module MDo where + +justOnes = mdo { xs <- Just (1:xs) + ; return (map negate xs) } {-* RecursiveDo *-} diff --git a/test/ExtensionOrganizerTest/RecursiveDoTest/RecStmt.hs b/test/ExtensionOrganizerTest/RecursiveDoTest/RecStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/RecursiveDoTest/RecStmt.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecursiveDo #-} + +module RecStmt where + +justOnes = do { rec { xs <- Just (1:xs) } {-* RecursiveDo *-} + ; return (map negate xs) } diff --git a/test/ExtensionOrganizerTest/TemplateHaskellTest/Quote.hs b/test/ExtensionOrganizerTest/TemplateHaskellTest/Quote.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TemplateHaskellTest/Quote.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Quote where + +import Language.Haskell.TH + +add1 :: Int -> Q Exp +add1 x = [| x + 1 |] {-* TemplateHaskellQuotes *-} diff --git a/test/ExtensionOrganizerTest/TemplateHaskellTest/Splice.hs b/test/ExtensionOrganizerTest/TemplateHaskellTest/Splice.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TemplateHaskellTest/Splice.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Splice where + +import Quote + +two :: Int +two = $(add1 1) {-* TemplateHaskell *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs --- a/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs @@ -27,7 +27,7 @@ x5 = if | fst $ (True,) 0 -> 20 {-* TupleSections *-} | snd $ (,True) 0 -> fst $ (0,) 5 {-* TupleSections, TupleSections *-} - | otherwise -> fst $ (0,) 5 {-* TupleSections *-} --MultiWayIf + | otherwise -> fst $ (0,) 5 {-* TupleSections, MultiWayIf *-} x6 = case fst $ ([],) () of {-* TupleSections *-} [] -> (0,) {-* TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocDataFamily.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocDataFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocDataFamily.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module AssocDataFamily where + +class GMapKey k where + data GMap k :: * -> * {-* TypeFamilies, KindSignatures, KindSignatures, KindSignatures *-} + +instance GMapKey Int where + data GMap Int [v] = G1 v {-* TypeFamilies *-} + data GMap Int (a,a) = G2 a {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocGDataFamily.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocGDataFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocGDataFamily.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, GADTSyntax #-} + +module AssocGDataFamily where + +class GC a where + data GD a :: * -> * {-* TypeFamilies, KindSignatures, KindSignatures, KindSignatures *-} + +instance GC Int where + data GD Int a where + G1 :: Int -> a -> GD Int a {-* TypeFamilies, GADTSyntax *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocTypeFamily.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocTypeFamily.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/AssocTypeFamily.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module AssocTypeFamily where + +class Collects ce where + type Elem ce :: * {-* TypeFamilies, KindSignatures *-} + type instance Elem ce = () {-* TypeFamilies *-} + +instance Collects [a] where + type Elem [a] = a {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/ClosedTypeFamilyDecl.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/ClosedTypeFamilyDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/ClosedTypeFamilyDecl.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module ClosedTypeFamilyDecl where + +type family F a :: * where {-* KindSignatures *-} + F Int = Integer + F Char = String {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/DataFamilyDecl.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/DataFamilyDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/DataFamilyDecl.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module DataFamilyDecl where + +data family F a :: * {-* TypeFamilies, KindSignatures *-} + +data instance F Int = F1 {-* TypeFamilies *-} +data instance F Char = F2 {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/Definitions.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/Definitions.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies + , ConstraintKinds + , RankNTypes + #-} + +module Definitions where + +type EqRel a b = a ~ b + +type TrfAB a b = a ~ b => a -> b + +type family F a :: * where + F Int = Integer + F Char = String + F a = a + +type HiddenEqRel a b = EqRel a b + +type ComplexEqRelType a = + Eq a => a -> a -> (forall c . HiddenEqRel a c => c -> c -> Bool) -> Bool + + +eqRelName :: EqRel a b => a -> b +eqRelName = id diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/GDataFamilyDecl.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/GDataFamilyDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/GDataFamilyDecl.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies + , GADTs + #-} + +module GDataFamilyDecl where + +{-@ TypeFamilies, GADTs @-} + +data family G a b {-* TypeFamilies *-} + +data instance G [a] b where + G1 :: c -> G [Int] b {-* GADTSyntax, GADTs + ExistentialQuantification *-} + G2 :: G [a] Bool {-* TypeFamilies, GADTSyntax, GADTs + ExistentialQuantification *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualityContextSynonyms.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualityContextSynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualityContextSynonyms.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies, RankNTypes #-} + +module NestedTypeEqualityContextSynonyms where + +import Definitions + +{-@ GADTs @-} + +f :: HiddenEqRel a b => a -> b {-* TypeFamilies + GADTs, TypeFamilies + GADTs *-} +f = id + +g :: ComplexEqRelType a {-* TypeFamilies + GADTs, TypeFamilies + GADTs *-} +g x y h = h x y {-* TypeFamilies + GADTs *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualitySynonyms.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualitySynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/NestedTypeEqualitySynonyms.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds #-} + +module NestedTypeEqualitySynonyms where + +import Definitions + +{-@ GADTs, ConstraintKinds @-} + +type TripleEq a b c = (HiddenEqRel a b, HiddenEqRel b c) {-* TypeFamilies + GADTs, TypeFamilies + GADTs, ConstraintKinds *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEquality.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEquality.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEquality.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds #-} + +module TypeEquality where + +{-@ GADTs, ConstraintKinds @-} + +type DoubleEq a b c = (a ~ b, b ~ c) {-* TypeFamilies + GADTs, TypeFamilies + GADTs, TypeFamilies + GADTs, ConstraintKinds *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContext.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContext.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContext.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeEqualityContext where + +{-@ GADTs @-} + +f :: a ~ b => a -> b {-* TypeFamilies + GADTs, TypeFamilies + GADTs *-} +f = id diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContextSynonyms.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContextSynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityContextSynonyms.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeEqualityContextSynonyms where + +import Definitions + +{-@ GADTs @-} + +f :: EqRel a b => a -> b {-* TypeFamilies + GADTs, TypeFamilies + GADTs *-} +f = id + +g :: TrfAB a b {-* TypeFamilies + GADTs, TypeFamilies + GADTs *-} +g = id diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityInName.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityInName.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualityInName.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeEqualityInName where + +import Definitions + +{-@ GADTs @-} + +g = eqRelName {-* TypeFamilies + GADTs *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualitySynonyms.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualitySynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeEqualitySynonyms.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds #-} + +module TypeEqualitySynonyms where + +import Definitions + +{-@ GADTs, ConstraintKinds @-} + +type DoubleEq a b c = (EqRel a b, EqRel b c) {-* TypeFamilies + GADTs, TypeFamilies + GADTs, ConstraintKinds *-} diff --git a/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeFamilyDecl.hs b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeFamilyDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeFamiliesTest/TypeFamilyDecl.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module TypeFamilyDecl where + +type family F a :: * {-* TypeFamilies, KindSignatures *-} + +type instance F Int = Integer {-* TypeFamilies *-} +type instance F Char = String {-* TypeFamilies *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixClassDecl.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixClassDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixClassDecl.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses #-} + +module InfixClassDecl where + +class a :?: b where {-* MultiParamTypeClasses *-} + f :: a -> b -> () {-* TypeOperators *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixDataDecl.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixDataDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixDataDecl.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + +module InfixDataDecl where + +data a :+: b = Plus a b {-* TypeOperators *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixInstance.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixInstance.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixInstance.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses #-} + +module InfixInstance where + +import InfixClassDecl + +instance [a] :?: [b] where {-* TypeOperators, MultiParamTypeClasses *-} + f _ _ = () diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeAnnot.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeAnnot.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeAnnot.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeOperators, ScopedTypeVariables #-} + +module InfixTypeAnnot where + +import InfixDataDecl +import NormalDataDecl + +h :: forall a b . (:+:) a b -> (:-:) a b {-* ExplicitForAll *-} +h (Plus x y) = Minus x y :: a :-: b {-* TypeOperators *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeSig.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeSig.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/InfixTypeSig.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators #-} + +module InfixTypeSig where + +import InfixDataDecl + +h :: a :+: b -> () {-* TypeOperators *-} +h _ = () diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalClassDecl.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalClassDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalClassDecl.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses #-} + +module NormalClassDecl where + +class (:!:) a b where {-* MultiParamTypeClasses *-} + g :: a -> b -> () {-* TypeOperators *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalDataDecl.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalDataDecl.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalDataDecl.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + +module NormalDataDecl where + +data (:-:) a b = Minus a b {-* TypeOperators *-} diff --git a/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalInstance.hs b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalInstance.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TypeOperatorsTest/NormalInstance.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses #-} + +module NormalInstance where + +import NormalClassDecl + +instance (:!:) [a] [b] where {-* MultiParamTypeClasses *-} + g _ _ = () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase, TypeFamilies #-} +{-# LANGUAGE LambdaCase, MonoLocalBinds #-} + module Main where @@ -33,194 +34,25 @@ --import ExtensionOrganizerTest.Main (extensionOrganizerTestGroup) main :: IO () -main = defaultMain nightlyTests - -nightlyTests :: TestTree -nightlyTests - = testGroup "all tests" [ testGroup "functional tests" functionalTests - , testGroup "CppHs tests" $ map makeCpphsTest cppHsTests - , testGroup "instance-control tests" $ map makeInstanceControlTest instanceControlTests - ] - -functionalTests :: [TestTree] -functionalTests - = [ testGroup "reprint tests" (map makeReprintTest checkTestCases) - , testGroup "refactor tests" - $ map makeOrganizeImportsTest organizeImportTests - ++ map makeGenerateSignatureTest generateSignatureTests - ++ map makeWrongGenerateSigTest wrongGenerateSigTests - ++ map makeGenerateExportsTest generateExportsTests - ++ map makeRenameDefinitionTest renameDefinitionTests - ++ map makeWrongRenameDefinitionTest wrongRenameDefinitionTests - ++ map makeExtractBindingTest extractBindingTests - ++ map makeWrongExtractBindingTest wrongExtractBindingTests - ++ map makeInlineBindingTest inlineBindingTests - ++ map makeWrongInlineBindingTest wrongInlineBindingTests - ++ map makeFloatOutTest floatOutTests - ++ map makeWrongFloatOutTest wrongFloatOutTests - ++ map (makeMultiModuleTest checkMultiResults) multiModuleTests - ++ map (makeMultiModuleTest checkMultiFail) wrongMultiModuleTests - ] - where checkTestCases = languageTests - ++ organizeImportTests - ++ map fst generateSignatureTests - ++ generateExportsTests - ++ map (\(mod,_,_) -> mod) renameDefinitionTests - ++ map (\(mod,_,_) -> mod) wrongRenameDefinitionTests - ++ map (\(mod,_,_) -> mod) extractBindingTests - ++ map (\(mod,_,_) -> mod) wrongExtractBindingTests - ++ map (\(mod,_) -> mod) inlineBindingTests +main = defaultMain $ testGroup "refactor tests" + $ map makeOrganizeImportsTest organizeImportTests + ++ map makeGenerateSignatureTest generateSignatureTests + ++ map makeWrongGenerateSigTest wrongGenerateSigTests + ++ map makeGenerateExportsTest generateExportsTests + ++ map makeRenameDefinitionTest renameDefinitionTests + ++ map makeWrongRenameDefinitionTest wrongRenameDefinitionTests + ++ map makeExtractBindingTest extractBindingTests + ++ map makeWrongExtractBindingTest wrongExtractBindingTests + ++ map makeInlineBindingTest inlineBindingTests + ++ map makeWrongInlineBindingTest wrongInlineBindingTests + ++ map makeFloatOutTest floatOutTests + ++ map makeAutoCorrectTest autoCorrectTests + ++ map makeWrongFloatOutTest wrongFloatOutTests + ++ map (makeMultiModuleTest checkMultiResults) multiModuleTests + ++ map (makeMultiModuleTest checkMultiFail) wrongMultiModuleTests rootDir = "examples" -languageTests = - [ "CPP.JustEnabled" - , "CPP.ConditionalCode" - , "Decl.AmbiguousFields" - , "Decl.AnnPragma" - , "Decl.ClassInfix" - , "Decl.ClosedTypeFamily" - , "Decl.CompletePragma" - , "Decl.CtorOp" - , "Decl.DataFamily" - , "Decl.DataType" - , "Decl.DataInstanceGADT" - , "Decl.DataTypeDerivings" - , "Decl.DefaultDecl" - , "Decl.FunBind" - , "Decl.FunctionalDeps" - , "Decl.FunGuards" - , "Decl.GADT" - , "Decl.GadtConWithCtx" - , "Decl.InfixAssertion" - , "Decl.InfixInstances" - , "Decl.InfixPatSyn" - , "Decl.InjectiveTypeFamily" - , "Decl.InlinePragma" - , "Decl.InstanceFamily" - , "Decl.InstanceOverlaps" - , "Decl.InstanceSpec" - , "Decl.LocalBindings" - , "Decl.LocalBindingInDo" - , "Decl.LocalFixity" - , "Decl.MinimalPragma" - , "Decl.MultipleFixity" - , "Decl.MultipleSigs" - , "Decl.OperatorBind" - , "Decl.OperatorDecl" - , "Decl.ParamDataType" - , "Decl.PatternBind" - , "Decl.PatternSynonym" - , "Decl.RecordPatternSynonyms" - , "Decl.RecordType" - , "Decl.RewriteRule" - , "Decl.SpecializePragma" - , "Decl.StandaloneDeriving" - , "Decl.TypeClass" - , "Decl.TypeClassMinimal" - , "Decl.TypeFamily" - , "Decl.TypeFamilyKindSig" - , "Decl.TypeInstance" - , "Decl.TypeRole" - , "Decl.TypeSynonym" - , "Decl.ValBind" - , "Decl.ViewPatternSynonym" - , "Expr.ArrowNotation" - , "Expr.Case" - , "Expr.DoNotation" - , "Expr.GeneralizedListComp" - , "Expr.EmptyCase" - , "Expr.FunSection" - , "Expr.If" - , "Expr.LambdaCase" - , "Expr.ListComp" - , "Expr.MultiwayIf" - , "Expr.Negate" - , "Expr.Operator" - , "Expr.ParenName" - , "Expr.ParListComp" - , "Expr.PatternAndDo" - , "Expr.RecordPuns" - , "Expr.RecordWildcards" - , "Expr.RecursiveDo" - , "Expr.Sections" - , "Expr.SemicolonDo" - , "Expr.StaticPtr" - , "Expr.TupleSections" - , "Expr.UnboxedSum" - , "Module.Simple" - , "Module.GhcOptionsPragma" - , "Module.Export" - , "Module.ExportSubs" - , "Module.ExportModifiers" - , "Module.NamespaceExport" - , "Module.Import" - , "Module.ImportOp" - , "Module.LangPragmas" - , "Module.PatternImport" - , "Pattern.Backtick" - , "Pattern.Constructor" - -- , "Pattern.ImplicitParams" - , "Pattern.Infix" - , "Pattern.NestedWildcard" - , "Pattern.NPlusK" - , "Pattern.OperatorPattern" - , "Pattern.Record" - , "Pattern.UnboxedSum" - , "Type.Bang" - , "Type.Builtin" - , "Type.Ctx" - , "Type.ExplicitTypeApplication" - , "Type.Forall" - , "Type.Primitives" - , "Type.TupleAssert" - , "Type.TypeOperators" - , "Type.Unpack" - , "Type.Wildcard" - , "TH.Brackets" - , "TH.QuasiQuote.Define" - , "TH.QuasiQuote.Use" - , "TH.Splice.Define" - , "TH.Splice.Use" - , "TH.CrossDef" - , "TH.ClassUse" - , "TH.Splice.UseImported" - , "TH.Splice.UseQual" - , "TH.Splice.UseQualMulti" - , "TH.LocalDefinition" - , "TH.MultiImport" - , "TH.NestedSplices" - , "TH.Quoted" - , "TH.WithWildcards" - , "TH.DoubleSplice" - , "TH.GADTFields" - , "Refactor.CommentHandling.CommentTypes" - , "Refactor.CommentHandling.BlockComments" - , "Refactor.CommentHandling.Crosslinking" - , "Refactor.CommentHandling.FunctionArgs" - ] - -cppHsTests = - [ "Language.Preprocessor.Cpphs" - , "Language.Preprocessor.Unlit" - , "Language.Preprocessor.Cpphs.CppIfdef" - , "Language.Preprocessor.Cpphs.HashDefine" - , "Language.Preprocessor.Cpphs.MacroPass" - , "Language.Preprocessor.Cpphs.Options" - , "Language.Preprocessor.Cpphs.Position" - , "Language.Preprocessor.Cpphs.ReadFirst" - , "Language.Preprocessor.Cpphs.RunCpphs" - , "Language.Preprocessor.Cpphs.SymTab" - , "Language.Preprocessor.Cpphs.Tokenise" - ] - -instanceControlTests = - [ "Control.Instances.Test" - , "Control.Instances.Morph" - , "Control.Instances.ShortestPath" - , "Control.Instances.TypeLevelPrelude" - ] - organizeImportTests = [ "Refactor.OrganizeImports.Narrow" , "Refactor.OrganizeImports.Reorder" @@ -252,6 +84,8 @@ , "Refactor.OrganizeImports.MakeExplicit.Renamed" , "Refactor.OrganizeImports.InstanceCarry.ImportOrphan" , "Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan" + , "Refactor.OrganizeImports.InstanceCarry.Duplicate" + , "Refactor.OrganizeImports.InstanceCarry.Transitive" , "Refactor.OrganizeImports.NarrowQual" , "Refactor.OrganizeImports.NarrowSpec" , "Refactor.OrganizeImports.StandaloneDeriving" @@ -443,6 +277,21 @@ wrongMultiModuleTests = [ ("InlineBinding 3:1-3:2", "A", "Refactor" "InlineBinding" "AppearsInAnother", []) ] + +autoCorrectTests = + [ ("Refactor.AutoCorrect.SimpleReParen", "3:5-3:12") + , ("Refactor.AutoCorrect.ExternalInstanceReParen", "4:5-4:15") + , ("Refactor.AutoCorrect.ComplexExprReParen", "3:5-3:29") + , ("Refactor.AutoCorrect.SimpleReOrder", "3:5-3:10") + , ("Refactor.AutoCorrect.ThreeArgReOrder", "3:5-3:12") + , ("Refactor.AutoCorrect.ThreeArgFirstReOrder", "3:5-3:10") + , ("Refactor.AutoCorrect.ExternalInstanceReOrder", "3:5-3:11") + , ("Refactor.AutoCorrect.ComplexExprReOrder", "3:5-3:22") + , ("Refactor.AutoCorrect.OwnInstanceReOrder", "5:5-5:10") + , ("Refactor.AutoCorrect.ComplexExprReOrder2", "3:5-3:39") + , ("Refactor.AutoCorrect.SectionReOrder", "3:5-3:18") + , ("Refactor.AutoCorrect.TupleSectionReOrder", "4:5-4:15") + ] makeMultiModuleTest :: ((String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO ()) -> (String, String, String, [String]) -> TestTree @@ -469,8 +318,12 @@ createTest :: String -> [String] -> String -> TestTree createTest refactoring args mod - = testCase mod $ checkCorrectlyTransformed (refactoring ++ (concatMap (" "++) args)) rootDir mod + = testCase mod $ checkCorrectlyTransformed False (refactoring ++ (concatMap (" "++) args)) rootDir mod +createResilientTest :: String -> [String] -> String -> TestTree +createResilientTest refactoring args mod + = testCase mod $ checkCorrectlyTransformed True (refactoring ++ (concatMap (" "++) args)) rootDir mod + createFailTest :: String -> [String] -> String -> TestTree createFailTest refactoring args mod = testCase mod $ checkTransformFails (refactoring ++ (concatMap (" "++) args)) rootDir mod @@ -511,12 +364,17 @@ makeWrongFloatOutTest :: (String, String) -> TestTree makeWrongFloatOutTest (mod, rng) = createFailTest "FloatOut" [rng] mod -checkCorrectlyTransformed :: String -> String -> String -> IO () -checkCorrectlyTransformed command workingDir moduleName +makeAutoCorrectTest :: (String, String) -> TestTree +makeAutoCorrectTest (mod, rng) = createResilientTest "AutoCorrect" [rng] mod + + +checkCorrectlyTransformed :: Bool -> String -> String -> String -> IO () +checkCorrectlyTransformed suppressErrors command workingDir moduleName = do expected <- loadExpected True workingDir moduleName - res <- performRefactor command workingDir [] moduleName + res <- performRefactor command workingDir (if suppressErrors then deferFlags else []) moduleName assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) (mapRight standardizeLineEndings res) + where deferFlags = ["-fdefer-type-errors","-fdefer-typed-holes","-fdefer-out-of-scope-variables", "-w"] testRefactor :: (UnnamedModule -> LocalRefactoring) -> String -> IO (Either String String) testRefactor refact moduleName @@ -541,30 +399,6 @@ hGetContents expectedHandle standardizeLineEndings = filter (/= '\r') - -makeReprintTest :: String -> TestTree -makeReprintTest mod = testCase mod (checkCorrectlyPrinted rootDir mod) - -makeCpphsTest :: String -> TestTree -makeCpphsTest mod = testCase mod (checkCorrectlyPrinted (rootDir "CppHs") mod) - -makeInstanceControlTest :: String -> TestTree -makeInstanceControlTest mod = testCase mod (checkCorrectlyPrinted (rootDir "InstanceControl") mod) - -checkCorrectlyPrinted :: String -> String -> IO () -checkCorrectlyPrinted workingDir moduleName - = do -- need to use binary or line endings will be translated - expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ ".hs") ReadMode - expected <- hGetContents expectedHandle - (actual, actual', actual'') <- runGhc (Just libdir) $ do - parsed <- loadModule workingDir moduleName - actual <- prettyPrint <$> parseAST parsed - actual' <- prettyPrint <$> parseRenamed parsed - actual'' <- prettyPrint <$> parseTyped parsed - return (actual, actual', actual'') - assertEqual "Parsed: The original and the transformed source differ" expected actual - assertEqual "Renamed: The original and the transformed source differ" expected actual' - assertEqual "Typechecked: The original and the transformed source differ" expected actual'' performRefactors :: String -> String -> [String] -> String -> IO (Either String [(String, Maybe String)]) performRefactors command workingDir flags target = do