diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/Tools/Refactor/Builtin.hs b/Language/Haskell/Tools/Refactor/Builtin.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} +module Language.Haskell.Tools.Refactor.Builtin ( builtinRefactorings ) where + +import Language.Haskell.Tools.Refactor (RefactoringChoice) +import Language.Haskell.Tools.Refactor.Builtin.ExtractBinding (ExtractBindingDomain, extractBindingRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.FloatOut (floatOutRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.GenerateExports (DomGenerateExports, generateExportsRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.GenerateTypeSignature (GenerateSignatureDomain, generateTypeSignatureRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.InlineBinding (inlineBindingRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions (OrganizeExtensionsDomain, organizeExtensionsRefactoring, projectOrganizeExtensionsRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.OrganizeImports (OrganizeImportsDomain, organizeImportsRefactoring, projectOrganizeImportsRefactoring) +import Language.Haskell.Tools.Refactor.Builtin.RenameDefinition (DomainRenameDefinition, renameDefinitionRefactoring) + +builtinRefactorings :: ( DomGenerateExports dom, OrganizeImportsDomain dom + , DomainRenameDefinition dom, ExtractBindingDomain dom + , GenerateSignatureDomain dom, OrganizeExtensionsDomain dom + ) => [RefactoringChoice dom] +builtinRefactorings + = [ organizeImportsRefactoring + , projectOrganizeImportsRefactoring + , inlineBindingRefactoring + , generateTypeSignatureRefactoring + , renameDefinitionRefactoring + , generateExportsRefactoring + , floatOutRefactoring + , extractBindingRefactoring + , organizeExtensionsRefactoring + , projectOrganizeExtensionsRefactoring + ] diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers.hs @@ -0,0 +1,25 @@ +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 + ) 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 diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/BangPatternsChecker.hs @@ -0,0 +1,28 @@ +{-# 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 + +chkBangPatterns' :: CheckNode Pattern +chkBangPatterns' p@(BangPat _) = addOccurence BangPatterns p +chkBangPatterns' x = return x + +{- + RhsGuard DONE + MatchLhs DONE + ValueBind DONE + Expr DONE + Alt DONE + Stmt DONE + Pattern MORE TESTS + Bracket ASK + PatSynRhs DONE +-} diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/DerivingsChecker.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE FlexibleContexts, MultiWayIf, RankNTypes, TypeFamilies, ViewPatterns #-} + +{- + NOTE: We need Decl level checking in order to gain extra information + from the newtype and data keywords. + NOTE: Here we implicitly constrained the type with ExtDomain. + but we only really need HasNameInfo. + + When a strategy is not explicitly given, every single extension + is analysied individually, so every occurence induces a separate + extension. However, when a strategy is specified, we only add + GND and DeriveAnyClass once, since no further examination is needed. + + For examples see the test files. + + SEE: https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies#Thederivingstrategyresolutionalgorithm + + TODO: + - write tests for GADTs, data instances + - correct DerivingStrategies behaviour with StandaloneDeriving +-} + + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker where + +import Control.Reference ((^.), (!~), (&)) +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) + +-- can be derived +isStockClass = flip elem stockClasses +stockClasses = [ eqClassName + , ordClassName + , ixClassName + , showClassName + , readClassName + , enumClassName + , boundedClassName + , dataClassName + , typeableClassName + , genClassName + , gen1ClassName + , functorClassName + , foldableClassName + , traversableClassName + , liftClassName + ] + +-- can be derived for newtypes even without GND +gndNotNeeded :: GHC.Name -> Bool +gndNotNeeded = flip elem gndNotNeededClasses +gndNotNeededClasses = + [ eqClassName + , ordClassName + , ixClassName + , boundedClassName + ] + +-- can be derived for newtypes with GND +gndNeeded :: GHC.Name -> Bool +gndNeeded = flip elem gndNeededClasses +gndNeededClasses = + [ functorClassName + , foldableClassName + , enumClassName + ] + +-- never selected by default for newtypes (even with GND) +gndNotAllowed :: GHC.Name -> Bool +gndNotAllowed = flip elem gndNotAllowedClasses +gndNotAllowedClasses = + [ dataClassName + , typeableClassName + , showClassName + , readClassName + , traversableClassName + , genClassName + , gen1ClassName + , liftClassName + ] + +whichExtension :: GHC.Name -> Maybe Extension +whichExtension = flip Map.lookup nameExtensionMap + +nameExtensionMap = Map.fromList nameExtensions + where nameExtensions = [ (dataClassName, DeriveDataTypeable) + , (typeableClassName, DeriveDataTypeable) + , (genClassName, DeriveGeneric) + , (gen1ClassName, DeriveGeneric) + , (functorClassName, DeriveFunctor) + , (foldableClassName, DeriveFoldable) + , (traversableClassName, DeriveTraversable) + , (liftClassName, DeriveLift) + ] + +chkDerivings :: CheckNode Decl +chkDerivings = conditionalAny chkDerivings' derivingExts + >=> conditional chkStandaloneDeriving Ext.StandaloneDeriving + + where chkDerivings' = chkDataDecl + >=> chkGADTDataDecl + >=> chkDataInstance + + derivingExts = [ DeriveDataTypeable + , DeriveGeneric + , DeriveFunctor + , DeriveFoldable + , DeriveTraversable + , DeriveLift + , DeriveAnyClass + , GeneralizedNewtypeDeriving + , DerivingStrategies + ] + + +chkDataDecl :: CheckNode Decl +chkDataDecl d@(DataDecl keyw _ _ _ derivs) = do + annList !~ separateByKeyword keyw $ derivs + return d +chkDataDecl d = return d + +chkGADTDataDecl :: CheckNode Decl +chkGADTDataDecl d@(GADTDataDecl keyw _ _ _ _ derivs) = do + addOccurence_ GADTs d + annList !~ separateByKeyword keyw $ derivs + return d +chkGADTDataDecl d = return d + +chkDataInstance :: CheckNode Decl +chkDataInstance d@(DataInstance keyw _ _ derivs) = do + addOccurence_ TypeFamilies d + annList !~ separateByKeyword keyw $ derivs + return d +chkDataInstance d = return d + + +separateByKeyword :: DataOrNewtypeKeyword dom -> CheckNode Deriving +separateByKeyword keyw derivs + | isNewtypeDecl keyw = chkByStrat chkClassForNewtype derivs + | otherwise = chkByStrat chkClassForData derivs + where isNewtypeDecl keyw = case keyw ^. element of + UNewtypeKeyword -> True + _ -> False + + +getStrategy :: Deriving dom -> Maybe (DeriveStrategy dom) +getStrategy d = d ^. (deriveStrategy & annMaybe) + +addExtension :: (MonadState ExtMap m, HasRange node) => + GHC.Name -> node -> m node +addExtension sname + | Just ext <- whichExtension sname = addOccurence ext + | otherwise = return + +addStockExtension :: CheckNode InstanceHead +addStockExtension x + | Just sname <- nameFromStock x = addExtension sname x + | otherwise = return x + +chkByStrat :: CheckNode' InstanceHead dom -> CheckNode' Deriving dom +chkByStrat checker d + | Just strat <- getStrategy d = do + addOccurence DerivingStrategies d + chkDerivingClause (chkStrat strat) d + | otherwise = + chkDerivingClause checker d + +chkStrat :: DeriveStrategy dom -> CheckNode' InstanceHead dom +chkStrat (_element -> UStockStrategy) = addStockExtension +chkStrat (_element -> UNewtypeStrategy) = addOccurence GeneralizedNewtypeDeriving +chkStrat (_element -> UAnyClassStrategy) = addOccurence DeriveAnyClass + +chkDerivingClause :: CheckNode' InstanceHead dom -> CheckNode' Deriving dom +chkDerivingClause checker d@(DerivingOne x) = checker x >> return d +chkDerivingClause checker d@(DerivingMulti xs) = (annList !~ checker) xs >> return d + +-- checks whether the class is stock, and if it is, returns its name +nameFromStock :: HasNameInfo dom => InstanceHead dom -> Maybe GHC.Name +nameFromStock x + | InstanceHead name <- skipParens x, + Just sname <- getSemName name, + isStockClass sname + = Just sname + | otherwise = Nothing + +chkClassForData :: CheckNode InstanceHead +chkClassForData x + | Just sname <- nameFromStock x = addExtension sname x + | otherwise = addOccurence DeriveAnyClass x + +-- performs check in case no explicit strategy is given +chkClassForNewtype :: CheckNode InstanceHead +chkClassForNewtype x + | Just sname <- nameFromStock x + = if | gndNotNeeded sname -> return x + | gndNeeded sname -> addOccurence GeneralizedNewtypeDeriving x + | gndNotAllowed sname -> addExtension sname x + | otherwise = do + gndOn <- isTurnedOn GeneralizedNewtypeDeriving + deriveAnyOn <- isTurnedOn DeriveAnyClass + if | gndOn && deriveAnyOn -> addOccurence_ DeriveAnyClass x + | deriveAnyOn -> addOccurence_ DeriveAnyClass x + | gndOn -> addOccurence_ GeneralizedNewtypeDeriving x + | otherwise -> return () + return x + +skipParens :: InstanceHead dom -> InstanceHead dom +skipParens (ParenInstanceHead x) = skipParens x +skipParens x = x + +chkStandaloneDeriving :: CheckNode Decl +chkStandaloneDeriving d@(Refact.StandaloneDeriving strat _ (decompRule -> (cls,ty))) + | Just strat' <- strat = do + addOccurence_ Ext.DerivingStrategies d + addOccurence_ Ext.StandaloneDeriving d + chkSynonym ty + chkStrat strat' cls + return d + | otherwise = do + addOccurence_ Ext.StandaloneDeriving d + itIsNewType <- isNewtype ty + itIsSynNewType <- isSynNewType ty + if itIsNewType || itIsSynNewType + then chkClassForNewtype cls + else chkClassForData cls + return d +chkStandaloneDeriving d = return d + +decompRule :: InstanceRule dom -> (InstanceHead dom, Type dom) +decompRule instRule = (cls, ty) + where ihead = instRule ^. irHead + cls = getClassCon ihead + ty = rightmostType ihead + +getClassCon :: InstanceHead dom -> InstanceHead dom +getClassCon (AppInstanceHead f _) = getClassCon f +getClassCon (ParenInstanceHead x) = getClassCon x +getClassCon x = x + +rightmostType :: InstanceHead dom -> Type dom +rightmostType ihead + | AppInstanceHead _ tyvar <- skipParens ihead = tyvar + +{- + 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 + in which case GeneralizedNewtypeDeriving might be necessary. +-} +isSynNewType :: HasNameInfo dom => Type dom -> ExtMonad Bool +isSynNewType t = do + mtycon <- runMaybeT . lookupType $ t + case mtycon of + Nothing -> return True + Just tycon -> isSynNewType' tycon + where isSynNewType' x = case lookupSynDef x of + Nothing -> return False + Just def -> do + addOccurence_ TypeSynonymInstances t + return (GHC.isNewTyCon def) diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/FlexibleInstancesChecker.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleContexts, MultiWayIf, TypeFamilies #-} + +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 Control.Monad.Trans.Maybe (MaybeT(..)) +import Data.Data (Data(..)) +import Data.List (nub) + +import Name as GHC (isTyVarName, isTyConName, isWiredInName) + +{-# 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 :: ExtDomain dom => InstanceRule dom -> a -> ExtMonad a +checkedReturn rule x = chkInstanceRule rule >> return x + +-- 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 + +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 + + +-- 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) +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 + +-- 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 + + 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 + (addOccurence_ FlexibleInstances vars) + Nothing -> error "chkTyVars: Couldn't look up something" + return vars + + chkAll x = + ifM (chkTopLevel x) $ + chkOnlyApp x + + chkTopLevel x = -- NOTE: this resembles a monadic bind ... (Cont?) + ifM (chkListType x) . + ifM (chkTupleType x) . + ifM (chkUnitTyCon x) $ + return False + + ifM cond f = do b <- cond; if b then (return b) else f + + chkUnitTyCon (VarType x) = do + sname <- tyVarSemNameM x + -- standalone top-level type variables are not accepted + -- 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 + chkUnitTyCon _ = return False + + + chkSingleTyVar (VarType x) = do + sname <- tyVarSemNameM x + if (isTyVarName sname) + then addTyVarM x >> return True + else addTyConM x >> return False + chkSingleTyVar _ = return False + + + chkTupleType (TupleType args) = do + let xs = args ^. annListElems + bs <- mapM chkSingleTyVar xs + return $! and bs + chkTupleType _ = return False + + chkListType (ListType v) = chkSingleTyVar v + chkListType _ = return False + + chkOnlyApp :: (MonadState ([Name dom],[Name dom]) (m1 m2), + MonadTrans m1, + MonadState ExtMap m2, + ExtDomain dom) => + Type dom -> MaybeT (m1 m2) Bool + chkOnlyApp (TypeApp f v@(VarType _)) = do + isTyVar <- chkSingleTyVar v + if isTyVar + then case f of + (VarType c) -> addTyConM c >> return True + _ -> chkOnlyApp f + else return False + chkOnlyApp x@(InfixTypeApp lhs op rhs) = do + lift . lift $ addOccurence_ TypeOperators x + addTyConM . mkNormalName $ (op ^. operatorName) + lOK <- chkSingleTyVar lhs + rOK <- chkSingleTyVar rhs + return $! lOK && rOK + chkOnlyApp _ = return False + + addTyCon n (ctors, vars) = (n:ctors, vars) + addTyVar n (ctors, vars) = (ctors, n:vars) + addTyConM n = modify $ addTyCon n + addTyVarM n = modify $ addTyVar n + + tyVarSemNameM x = MaybeT . return . semanticsName $ x ^. simpleName + +rmTypeMisc :: Type dom -> ExtMonad (Type dom) +rmTypeMisc = rmTParens >=> rmTKinded + +rmTKinded :: Type dom -> ExtMonad (Type dom) +rmTKinded kt@(KindedType t _) = addOccurence_ KindSignatures kt >> return t +rmTKinded x = return x + +-- removes Parentheses from the AST +-- the structure is reserved +rmTParens :: Type dom -> ExtMonad (Type dom) +rmTParens (ParenType x) = return x +rmTParens x = return x diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/LambdaCaseChecker.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.LambdaCaseChecker where + +import Language.Haskell.Tools.Refactor as Refact +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad as Ext + +chkLambdaCase :: CheckNode Expr +chkLambdaCase = conditional chkLambdaCase' Ext.LambdaCase + +chkLambdaCase' :: CheckNode Expr +chkLambdaCase' e@(Refact.LambdaCase _) = addOccurence Ext.LambdaCase e +chkLambdaCase' e = return e + + +{- + TopLevelPragma, + Rule, + + Splice, + Bracket, + + Cmd, + + Rhs DONE + RhsGuard DONE + Expr DONE + FieldUpdate DONE + TupSecElem DONE + CaseRhs DONE + Stmt DONE + CompStmt DONE + Pattern DONE +-} diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/MagicHashChecker.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.MagicHashChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +{-# ANN module "HLint: ignore Redundant bracket" #-} + +chkMagicHashLiteral :: CheckNode Literal +chkMagicHashLiteral = conditional chkMagicHashLiteral' MagicHash + +chkMagicHashNamePart :: CheckNode NamePart +chkMagicHashNamePart = conditional chkMagicHashNamePart' MagicHash + +chkMagicHashKind :: CheckNode Kind +chkMagicHashKind = conditional chkMagicHashKind' MagicHash + + + + +chkMagicHashLiteral' :: CheckNode Literal +chkMagicHashLiteral' l@(PrimIntLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l@(PrimWordLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l@(PrimFloatLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l@(PrimDoubleLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l@(PrimCharLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l@(PrimStringLit _) = addOccurence MagicHash l +chkMagicHashLiteral' l = return l + + +chkMagicHashNamePart' :: CheckNode NamePart +chkMagicHashNamePart' n@(NamePart name) = + if (last name == '#') then addOccurence MagicHash n + else return n + +-- NOTE: is this really needed? +chkMagicHashKind' :: CheckNode Kind +chkMagicHashKind' k@UnboxKind = addOccurence MagicHash k +chkMagicHashKind' k = return k + +{- Name can be reached from: + UIESpec + USubSpec + UInjectivityAnn + URuleVar + UTopLevelPragma + UAnnotationSubject + UMinimalFormula + + UDecl DONE + UClassElement DONE + UDeclHead DONE + UGadtConDecl DONE + UPatSynLhs DONE + UPatternTypeSignature DONE + UFunDep DONE + UConDecl DONE + UFieldDecl DONE + UInstanceHead DONE + UTypeSignature DONE + UMatchLhs DONE + UTyVar DONE + UType DONE + UKind DONE + UAssertion DONE + UExpr DONE + UFieldUpdate DONE + UPattern DONE + UPatternField DONE + USplice + UQuasiQuote + + UPromoted t +-} + +{- QualifiedName can be reached from: + UDecl DONE + UOperator DONE + UName (obviously) DONE +-} diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/PatternSynonymsChecker.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.PatternSynonymsChecker where + +import Language.Haskell.Tools.Refactor (PatternSignature, PatternSynonym) +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +-- NOTE: Here we implicitly constrained the type with ExtDomain. +-- but we don't really need any. + +chkPatternSynonymsSyn :: CheckNode PatternSynonym +chkPatternSynonymsSyn = conditional chkPatternSynonymsSyn' PatternSynonyms + +chkPatternSynonymsSyn' :: CheckNode PatternSynonym +chkPatternSynonymsSyn' = addOccurence PatternSynonyms + +chkPatternSynonymsTypeSig :: CheckNode PatternSignature +chkPatternSynonymsTypeSig = conditional (addOccurence PatternSynonyms) PatternSynonyms diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/RecordWildCardsChecker.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.RecordWildCardsChecker 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 contraint. + +chkRecordWildCardsPatField :: CheckNode PatternField +chkRecordWildCardsPatField p@(FieldWildcardPattern {}) = addOccurence RecordWildCards p +chkRecordWildCardsPatField p = return p + +chkRecordWildCardsFieldUpdate :: CheckNode FieldUpdate +chkRecordWildCardsFieldUpdate e@(FieldWildcard {}) = addOccurence RecordWildCards e +chkRecordWildCardsFieldUpdate e = return e diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TemplateHaskellChecker.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TemplateHaskellChecker 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. + +-- can be reached from: Decl, Type, Expr, Pattern +chkTemplateHaskellSplice :: CheckNode Splice +chkTemplateHaskellSplice = addOccurence TemplateHaskell + +-- can be reached from: Type, Expr, Pattern +chkTemplateHaskellQuasiQuote :: CheckNode QuasiQuote +chkTemplateHaskellQuasiQuote = addOccurence QuasiQuotes + +-- can be reached from: Expr +chkTemplateHaskellBracket :: CheckNode Bracket +chkTemplateHaskellBracket = addOccurence TemplateHaskellQuotes + +chkTemplateHaskellhNamePart :: CheckNode NamePart +chkTemplateHaskellhNamePart = conditional chkTemplateHaskellNamePart' TemplateHaskellQuotes + + +-- should be THQuotes OR DataKinds +chkTemplateHaskellNamePart' :: CheckNode NamePart +chkTemplateHaskellNamePart' n@(NamePart name) = + if (head name == '\'') then addOccurence TemplateHaskellQuotes n + else return n diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/TupleSectionsChecker.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.TupleSectionsChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkTupleSections :: CheckNode Expr +chkTupleSections = conditional chkTupleSections' TupleSections + +chkTupleSections' :: CheckNode Expr +chkTupleSections' e@(TupleSection _) = addOccurence TupleSections e +chkTupleSections' e@(UnboxedTupleSection _) = addOccurence TupleSections e + >> addOccurence UnboxedTuples e +chkTupleSections' e = return e diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/UnboxedTuplesChecker.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.UnboxedTuplesChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkUnboxedTuplesExpr :: CheckNode Expr +chkUnboxedTuplesExpr = conditional chkUnboxedTuplesExpr' UnboxedTuples + +chkUnboxedTuplesPat :: CheckNode Pattern +chkUnboxedTuplesPat = conditional chkUnboxedTuplesPat' UnboxedTuples + +chkUnboxedTuplesType :: CheckNode Type +chkUnboxedTuplesType = conditional chkUnboxedTuplesType' UnboxedTuples + + +chkUnboxedTuplesExpr' :: CheckNode Expr +chkUnboxedTuplesExpr' e@(UnboxedTuple _) = addOccurence UnboxedTuples e +chkUnboxedTuplesExpr' e@(UnboxedTupleSection _) = addOccurence UnboxedTuples e +chkUnboxedTuplesExpr' e = return e + +chkUnboxedTuplesPat' :: CheckNode Pattern +chkUnboxedTuplesPat' p@(UnboxTuplePat _) = addOccurence UnboxedTuples p +chkUnboxedTuplesPat' p = return p + +chkUnboxedTuplesType' :: CheckNode Type +chkUnboxedTuplesType' t@(UnboxedTupleType _) = addOccurence UnboxedTuples t +chkUnboxedTuplesType' t = return t diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Checkers/ViewPatternsChecker.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.ViewPatternsChecker where + +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + +chkViewPatterns :: CheckNode Pattern +chkViewPatterns = conditional chkViewPatterns' ViewPatterns + +chkViewPatterns' :: CheckNode Pattern +chkViewPatterns' p@(ViewPat _ _) = addOccurence ViewPatterns p +chkViewPatterns' p = return p diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMap.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap where + +import Language.Haskell.TH.LanguageExtensions (Extension) +import SrcLoc (SrcSpan) + +import qualified Data.Map.Strict as SMap (Map) + + +infix 6 :||: +infix 7 :&&: + +data LogicalRelation a = LVar a + | Not (LogicalRelation a) + | LogicalRelation a :&&: LogicalRelation a + | LogicalRelation a :||: LogicalRelation a + deriving (Eq, Show, Functor, Ord) + +type ExtMap = SMap.Map (LogicalRelation Extension) [SrcSpan] diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/ExtMonad.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, StandaloneDeriving, TypeFamilies, TypeSynonymInstances #-} + +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.TH.LanguageExtensions + , module Control.Monad.State + , module Control.Monad.Reader + ) where + +import Language.Haskell.Tools.Refactor +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 +import qualified Data.Map.Strict as SMap (Map(..), empty, insertWith) + + +{-# 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 ExtDomain dom = (HasNameInfo dom) + +type CheckNode elem = forall dom . CheckNode' elem dom +type CheckNode' elem dom = ExtDomain dom => elem dom -> ExtMonad (elem dom) + +type CheckUNode uelem = forall dom . CheckUNode' uelem dom +type CheckUNode' uelem dom = ExtDomain dom => Ann uelem dom SrcTemplateStage -> ExtMonad (Ann uelem dom SrcTemplateStage) + +addOccurence' :: (Ord k, HasRange a) => + k -> a -> SMap.Map k [SrcSpan] -> SMap.Map k [SrcSpan] +addOccurence' key node = SMap.insertWith (++) key [getRange node] + +-- TODO: add isTurnedOn check +addOccurence_ :: (MonadState ExtMap m, HasRange node) => + Extension -> node -> m () +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 + +isTurnedOn :: Extension -> ExtMonad Bool +isTurnedOn ext = do + defaults <- ask + return $! ext `elem` defaults + +conditional :: (node -> ExtMonad node) -> + Extension -> + node -> + ExtMonad node +conditional checker ext = conditionalAny checker [ext] + +conditionalNot :: (node -> ExtMonad node) -> + Extension -> + node -> + ExtMonad node +conditionalNot checker ext node = do + b <-isTurnedOn ext + if b then return node else checker node + +conditionalAny :: (node -> ExtMonad node) -> + [Extension] -> + node -> + ExtMonad node +conditionalAny checker exts node = do + bs <- mapM isTurnedOn exts + if or bs then checker node else return node + +conditionalAdd :: HasRange node => Extension -> node -> ExtMonad node +conditionalAdd ext = conditional (addOccurence ext) ext + + +runExtMonadIO :: ExtMonad a -> IO a +runExtMonadIO = runGhc (Just libdir) . runExtMonadGHC + +runExtMonadGHC :: ExtMonad a -> Ghc a +runExtMonadGHC = liftM fst . flip runStateT SMap.empty . flip runReaderT [] diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/TraverseAST.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-} + +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 + +chkKind :: CheckNode Kind +chkKind = chkMagicHashKind + + +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) +traverseAlt f = (altPattern !~ traversePattern) + >=> (altRhs !~ traverseCaseRhs f) + >=> (altBinds & annJust !~ traverseLocalBinds) + +traverseCaseRhs :: CheckUNode uexpr -> CheckNode (CaseRhsG uexpr) +traverseCaseRhs f = (rhsCaseExpr !~ f) + >=> (rhsCaseGuards & annList !~ traverseGuardedCaseRhs f) + +traverseGuardedCaseRhs :: CheckUNode uexpr -> CheckNode (GuardedCaseRhsG uexpr) +traverseGuardedCaseRhs f = (caseGuardStmts & annList !~ traverseRhsGuard) + >=> (caseGuardExpr !~ f) + +traverseStmt :: CheckUNode uexpr -> CheckNode (StmtG uexpr) +traverseStmt f = (stmtPattern !~ traversePattern) + >=> (stmtExpr !~ f) + >=> (stmtBinds & annList !~ traverseLocalBind) + >=> (cmdStmtBinds & annList !~ traverseStmt f) + +traversePromoted :: CheckUNode t -> CheckNode (PromotedG t) +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 diff --git a/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/SupportedExtensions.hs @@ -0,0 +1,28 @@ +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 new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtensionOrganizer/Utils/TypeLookup.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Utils.TypeLookup where + + +import Language.Haskell.Tools.AST (HasNameInfo'(..), HasNameInfo(..), 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 :: HasNameInfo dom => Type dom -> 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 :: HasNameInfo dom => Type dom -> ExtMonad Bool +isNewtype t = do + tycon <- runMaybeT . lookupType $ t + return $! maybe True isNewtypeTyCon tycon + + + +lookupType :: HasNameInfo dom => Type dom -> 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 dom -> Maybe (Name dom) +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 :: HasNameInfo dom => Name dom -> 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 new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/ExtractBinding.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications, TypeFamilies, ViewPatterns #-} +module Language.Haskell.Tools.Refactor.Builtin.ExtractBinding + (extractBinding', ExtractBindingDomain, tryItOut, extractBindingRefactoring) where + +import qualified GHC +import Name (nameModule_maybe) +import qualified OccName as GHC (occNameString) +import OccName (HasOccName(..)) +import PrelNames +import RdrName (isOrig_maybe) +import SrcLoc + +import Control.Monad.State +import Control.Reference +import Data.Generics.Uniplate.Data () +import Data.List (find, intersperse) +import Data.Maybe + +import Language.Haskell.Tools.Refactor + + +extractBindingRefactoring :: (ExtractBindingDomain dom, HasModuleInfo dom) => RefactoringChoice dom +extractBindingRefactoring = NamingRefactoring "ExtractBinding" (\loc s -> localRefactoring (extractBinding' loc s)) + +-- | We need name information to identify bindings, and scope information to check which +-- entities must be directly passed as parameters. +type ExtractBindingDomain dom = ( HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom ) + +tryItOut :: String -> String -> String -> IO () +tryItOut mod sp name = tryRefactor (localRefactoring . flip extractBinding' name) mod sp + +extractBinding' :: ExtractBindingDomain dom => RealSrcSpan -> String -> LocalRefactoring dom +extractBinding' sp name mod + = if isNothing (isValidBindingName name) + then extractBinding sp (nodesContaining sp) (nodesContaining sp) name mod + else refactError $ "The given name is not a valid for the extracted binding: " ++ fromJust (isValidBindingName name) + +-- | Safely performs the transformation to introduce the local binding and replace the expression with the call. +-- Checks if the introduction of the name causes a name conflict. +extractBinding :: forall dom . ExtractBindingDomain dom + => RealSrcSpan -> Simple Traversal (Module dom) (ValueBind dom) + -> Simple Traversal (ValueBind dom) (Expr dom) + -> String -> LocalRefactoring dom +extractBinding sp selectDecl selectExpr name mod + = let conflicting = filter (isConflicting name) ((take 1 $ reverse $ mod ^? selectDecl) ^? biplateRef :: [QualifiedName dom]) + exprRanges = map getRange (mod ^? selectDecl & selectExpr) + decl = last (mod ^? selectDecl) + declPats = decl ^? valBindPat &+& funBindMatches & annList & matchLhs + & (matchLhsArgs & annList &+& matchLhsLhs &+& matchLhsRhs &+& matchLhsArgs & annList) + in case exprRanges of + (reverse -> exprRange:_) -> + if | not (null conflicting) + -> refactError $ "The given name causes name conflict with the definition(s) at: " ++ concat (intersperse "," (map (shortShowSpanWithFile . getRange) conflicting)) + | any (`containsRange` exprRange) $ map getRange declPats + -> refactError "Extract binding cannot be applied to view pattern expressions." + | otherwise + -> case decl ^? actualContainingExpr exprRange of + expr:_ -> do (res, st) <- runStateT (selectDecl&selectExpr !~ extractThatBind sp name expr $ mod) Nothing + case st of Just def -> return $ evalState (selectDecl !~ addLocalBinding exprRange def $ res) False + Nothing -> refactError "There is no applicable expression to extract." + [] -> refactError $ "There is no applicable expression to extract." + [] -> refactError "There is no applicable expression to extract." + where RealSrcSpan sp1 `containsRange` RealSrcSpan sp2 = sp1 `containsSpan` sp2 + _ `containsRange` _ = False + +-- | Decides if a new name defined to be the given string will conflict with the given AST element +isConflicting :: ExtractBindingDomain dom => String -> QualifiedName dom -> Bool +isConflicting name used + = semanticsDefining used + && (GHC.occNameString . GHC.getOccName <$> semanticsName used) == Just name + +-- Replaces the selected expression with a call and generates the called binding. +extractThatBind :: ExtractBindingDomain dom + => RealSrcSpan -> String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) +extractThatBind sp name cont e + = do ret <- get -- being in a state monad to only apply the + if (isJust ret) then return e + else case e of + -- only the expression inside the parameters should be extracted + Paren {} | hasParameter -> exprInner !~ doExtract name cont $ e + | otherwise -> doExtract name cont (fromJust $ e ^? exprInner) + -- a single variable cannot be extracted (would lead to precedence problems) + Var {} -> lift $ refactError "The selected expression is too simple to be extracted." + -- extract operator sections + InfixApp lhs op rhs + | (lhs `outside` sp) && (sp `encloses` op) && (sp `encloses` rhs) + -> do let params = getExternalBinds cont rhs ++ opName op + put (Just (generateBind name (map mkVarPat params) (mkRightSection op (parenIfInfix rhs)))) + return (mkApp (generateCall name params) (parenIfInfix lhs)) + | (sp `encloses` lhs) && (sp `encloses` op) && (rhs `outside` sp) + -> do let params = getExternalBinds cont lhs ++ opName op + put (Just (generateBind name (map mkVarPat params) (mkLeftSection (parenIfInfix lhs) op))) + return (mkApp (generateCall name params) (parenIfInfix rhs)) + where parenIfInfix e@(InfixApp {}) = mkParen e + parenIfInfix e = e + -- extract parts of known associative infix operators + InfixApp (InfixApp lhs lop mid) rop rhs -- correction for left-associative operators + | (Just lName, Just rName) <- (semanticsName (lop ^. operatorName), semanticsName (rop ^. operatorName)) + , (lop `outside` sp) && (sp `encloses` mid) && (sp `encloses` rhs) + && lName == rName && isKnownCommutativeOp lName + -> do let params = getExternalBinds cont mid ++ opName rop ++ getExternalBinds cont rhs + put (Just (generateBind name (map mkVarPat params) (mkInfixApp mid rop rhs))) + return (mkInfixApp lhs lop (generateCall name params)) + InfixApp lhs lop (InfixApp mid rop rhs) -- correction for right-associative operators + | (Just lName, Just rName) <- (semanticsName (lop ^. operatorName), semanticsName (rop ^. operatorName)) + , (sp `encloses` lhs) && (sp `encloses` mid) && (rop `outside` sp) + && lName == rName && isKnownCommutativeOp lName + -> do let params = getExternalBinds cont lhs ++ opName lop ++ getExternalBinds cont mid + put (Just (generateBind name (map mkVarPat params) (mkInfixApp lhs lop mid))) + return (mkInfixApp (generateCall name params) rop rhs) + -- normal case + el | isParenLikeExpr el && hasParameter -> mkParen <$> doExtract name cont e + | otherwise -> doExtract name cont e + where hasParameter = not (null (getExternalBinds cont e)) + -- True if the elem is completely inside the given source range + sp `encloses` elem = case getRange elem of RealSrcSpan enc -> sp `containsSpan` enc + _ -> False + -- True if the elem is completely outside the given range (no overlapping) + elem `outside` sp = case getRange elem of RealSrcSpan out -> realSrcSpanStart sp > realSrcSpanEnd out + || realSrcSpanEnd sp < realSrcSpanStart out + _ -> False + opName op = case semanticsName (op ^. operatorName) of + Nothing -> [] + Just n -> [mkUnqualName' n | not $ n `inScope` semanticsScope cont] + isKnownCommutativeOp :: GHC.Name -> Bool + isKnownCommutativeOp n = isJust $ find (maybe False (\(mn, occ) -> (nameModule_maybe n) == Just mn && occName n == occ) . isOrig_maybe) ops + where ops = [plus_RDR, times_RDR, append_RDR, and_RDR, {- or_RDR, -} compose_RDR] -- somehow or is missing... WHY? + +-- | Adds a local binding to the where clause of the enclosing binding +addLocalBinding :: SrcSpan -> ValueBind dom -> ValueBind dom -> State Bool (ValueBind dom) +-- this uses the state monad to only add the local binding to the first selected element +addLocalBinding exprRange local bind + = do done <- get + if not done then do put True + return $ indentBody $ doAddBinding exprRange local bind + else return bind + where + doAddBinding _ local sb@(SimpleBind {}) = valBindLocals .- insertLocalBind local $ sb + doAddBinding (RealSrcSpan rng) local fb@(FunctionBind {}) + = funBindMatches & annList & filtered (isInside rng) & matchBinds + .- insertLocalBind local $ fb + doAddBinding _ _ _ = error "doAddBinding: invalid expression range" + + indentBody = (valBindRhs .- updIndent) . (funBindMatches & annList & matchLhs .- updIndent) . (funBindMatches & annList & matchRhs .- updIndent) + + updIndent :: SourceInfoTraversal elem => elem dom SrcTemplateStage -> elem dom SrcTemplateStage + updIndent = setMinimalIndent 4 + +-- | Puts a value definition into a list of local binds +insertLocalBind :: ValueBind dom -> MaybeLocalBinds dom -> MaybeLocalBinds dom +insertLocalBind toInsert locals + | isAnnNothing locals = mkLocalBinds [mkLocalValBind toInsert] + | otherwise = annJust & localBinds .- insertWhere True (mkLocalValBind toInsert) (const True) isNothing $ locals + +-- | All expressions that are bound stronger than function application. +isParenLikeExpr :: Expr dom -> Bool +isParenLikeExpr (If {}) = True +isParenLikeExpr (Paren {}) = True +isParenLikeExpr (List {}) = True +isParenLikeExpr (ParArray {}) = True +isParenLikeExpr (LeftSection {}) = True +isParenLikeExpr (RightSection {}) = True +isParenLikeExpr (RecCon {}) = True +isParenLikeExpr (RecUpdate {}) = True +isParenLikeExpr (Enum {}) = True +isParenLikeExpr (ParArrayEnum {}) = True +isParenLikeExpr (ListComp {}) = True +isParenLikeExpr (ParArrayComp {}) = True +isParenLikeExpr (BracketExpr {}) = True +isParenLikeExpr (SpliceExpr {}) = True +isParenLikeExpr (QuasiQuoteExpr {}) = True +isParenLikeExpr _ = False + +-- | Replaces the expression with the call and stores the binding of the call in its state +doExtract :: ExtractBindingDomain dom + => String -> Expr dom -> Expr dom -> StateT (Maybe (ValueBind dom)) (LocalRefactor dom) (Expr dom) +doExtract name cont e@(Lambda (AnnList bindings) inner) + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params ++ bindings) inner)) + return (generateCall name params) +doExtract name cont e + = do let params = getExternalBinds cont e + put (Just (generateBind name (map mkVarPat params) e)) + return (generateCall name params) + +-- | Gets the values that have to be passed to the extracted definition +getExternalBinds :: ExtractBindingDomain dom => Expr dom -> Expr dom -> [Name dom] +getExternalBinds cont expr = map exprToName $ keepFirsts $ filter isApplicableName (expr ^? uniplateRef) + where isApplicableName (getExprNameInfo -> Just nm) = inScopeForOriginal nm && notInScopeForExtracted nm + isApplicableName _ = False + + getExprNameInfo :: ExtractBindingDomain dom => Expr dom -> Maybe GHC.Name + getExprNameInfo expr = semanticsName =<< (listToMaybe $ expr ^? (exprName&simpleName &+& exprOperator&operatorName)) + + -- | Creates the parameter value to pass the name (operators are passed in parentheses) + exprToName :: Expr dom -> Name dom + exprToName e | Just n <- e ^? exprName = n + | Just op <- e ^? exprOperator & operatorName = mkParenName op + | otherwise = error "exprToName: name not found" + + notInScopeForExtracted :: GHC.Name -> Bool + notInScopeForExtracted n = not $ n `inScope` semanticsScope cont + + inScopeForOriginal :: GHC.Name -> Bool + inScopeForOriginal n = n `inScope` semanticsScope expr + + keepFirsts (e:rest) = e : keepFirsts (filter (/= e) rest) + keepFirsts [] = [] + +actualContainingExpr :: SrcSpan -> Simple Traversal (ValueBind dom) (Expr dom) +actualContainingExpr (RealSrcSpan rng) = accessRhs & accessExpr + where accessRhs :: Simple Traversal (ValueBind dom) (Rhs dom) + accessRhs = valBindRhs &+& funBindMatches & annList & filtered (rng `isInside`) & matchRhs + accessExpr :: Simple Traversal (Rhs dom) (Expr dom) + accessExpr = rhsExpr &+& rhsGuards & annList & filtered (rng `isInside`) & guardExpr +actualContainingExpr _ = error "actualContainingExpr: not a real range" + +-- | Generates the expression that calls the local binding +generateCall :: String -> [Name dom] -> Expr dom +generateCall name args = foldl (\e a -> mkApp e (mkVar a)) (mkVar $ mkNormalName $ mkSimpleName name) args + +-- | Generates the local binding for the selected expression +generateBind :: String -> [Pattern dom] -> Expr dom -> ValueBind dom +generateBind name [] e = mkSimpleBind (mkVarPat $ mkNormalName $ mkSimpleName name) (mkUnguardedRhs e) Nothing +generateBind name args e = mkFunctionBind [mkMatch (mkMatchLhs (mkNormalName $ mkSimpleName name) args) (mkUnguardedRhs e) Nothing] + +isValidBindingName :: String -> Maybe String +isValidBindingName = nameValid Variable diff --git a/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs b/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/FloatOut.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +module Language.Haskell.Tools.Refactor.Builtin.FloatOut + (floatOut, FloatOutDefinition, floatOutRefactoring) where + +import Control.Monad.State +import Control.Reference +import Data.List +import Data.Maybe (Maybe(..), catMaybes) + +import Language.Haskell.Tools.Refactor + +import Name as GHC (Name, NamedThing(..), occNameString) +import SrcLoc (RealSrcSpan) + +floatOutRefactoring :: (FloatOutDefinition dom, HasModuleInfo dom) => RefactoringChoice dom +floatOutRefactoring = SelectionRefactoring "FloatOut" (localRefactoring . floatOut) + +type FloatOutDefinition dom = (HasNameInfo dom, HasScopeInfo dom) + +floatOut :: FloatOutDefinition dom => RealSrcSpan -> LocalRefactoring dom +floatOut sp mod + = do (mod', st) <- runStateT (nodesContaining sp !~ extractAndInsert sp $ mod) NotEncountered + case st of NotEncountered -> refactError "No definition is selected. The selection range must be inside the definition." + Extracted bnds -> -- insert it to the global definition list + return $ modDecl & annListElems .- (++ map toTopLevel bnds) $ removeEmpties mod' + Inserted -> -- already inserted to a local scope + return (removeEmpties mod') + where toTopLevel :: LocalBind dom -> Decl dom + toTopLevel (LocalValBind vb) = mkValueBinding vb + toTopLevel (LocalTypeSig sg) = mkTypeSigDecl sg + toTopLevel (LocalFixity fx) = mkFixityDecl fx + + removeEmpties = removeEmptyBnds (nodesContaining sp) (nodesContaining sp) + +data FloatState dom = NotEncountered | Extracted [LocalBind dom] | Inserted + +extractAndInsert :: FloatOutDefinition dom => RealSrcSpan -> LocalBindList dom -> StateT (FloatState dom) (LocalRefactor dom) (LocalBindList dom) +extractAndInsert sp locs + | hasSharedSig = refactError "Cannot float out a definition, since it has a signature shared with other bindings that stay in the scope." + | not (null nameConflicts) = refactError $ "Cannot float out a definition, since it would cause a name conflicts in the target scope: " + ++ concat (intersperse ", " nameConflicts) + | not (null implicitConflicts) = refactError $ "Cannot float out a definition, since it uses the implicit parameters: " + ++ concat (intersperse ", " implicitConflicts) + | otherwise = get >>= \case NotEncountered -> put (Extracted floated) >> return filteredLocs + 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 + 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 + conflicts = map checkConflict selected + + nameConflicts = concat $ map fst conflicts + implicitConflicts = concat $ map snd conflicts + +checkConflict :: forall dom . FloatOutDefinition dom => LocalBind dom -> ([String], [String]) +checkConflict bnd = (concatMap @[] getConflict bndNames, implicits) + where bndNames = bnd ^? elementName + getConflict bndName = filter ((== nameStr) . Just) $ map (occNameString . getOccName) outerScope + where outerScope = map (^. _1) $ concat $ take 1 $ drop 2 $ semanticsScope bndName + nameStr = fmap (occNameString . getOccName) $ semanticsName bndName + implicits = map (occNameString . getOccName) + (concatMap getPossibleImplicits bndNames `intersect` getQNames (bnd ^? biplateRef)) + + getQNames :: [QualifiedName dom] -> [GHC.Name] + getQNames = catMaybes . map semanticsName + + getPossibleImplicits :: QualifiedName dom -> [GHC.Name] + getPossibleImplicits qn = concat (map (map (^. _1)) $ take 2 $ semanticsScope qn) \\ catMaybes (map semanticsName bndNames) diff --git a/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs b/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/GenerateExports.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, TupleSections, TypeFamilies #-} +module Language.Haskell.Tools.Refactor.Builtin.GenerateExports + (generateExports, DomGenerateExports, generateExportsRefactoring) where + +import Control.Reference ((^?), (.=), (&)) +import Language.Haskell.Tools.Refactor + +import qualified GHC (NamedThing(..), Name) + +import Control.Applicative ((<|>)) +import Data.Maybe (Maybe(..), catMaybes) + +generateExportsRefactoring :: (DomGenerateExports dom, HasModuleInfo dom) => RefactoringChoice dom +generateExportsRefactoring = ModuleRefactoring "GenerateExports" (localRefactoring generateExports) + +-- | We need name information to generate exports +type DomGenerateExports dom = (Domain dom, HasNameInfo dom) + +-- | Creates an export list that imports standalone top-level definitions with all of their contained definitions +generateExports :: DomGenerateExports dom => LocalRefactoring dom +generateExports mod = return (modHead & annJust & mhExports & annMaybe + .= Just (createExports (getTopLevels mod)) $ mod) + +-- | Get all the top-level definitions with flags that mark if they can contain other top-level definitions +-- (classes and data declarations). +getTopLevels :: DomGenerateExports dom => Module dom -> [(GHC.Name, Bool)] +getTopLevels mod = catMaybes $ map (\d -> fmap (,exportContainOthers d) + (foldl (<|>) Nothing $ map semanticsName $ d ^? elementName)) + (filter (\case TypeSigDecl{} -> False; _ -> True) + $ mod ^? modDecl & annList) + where exportContainOthers :: Decl dom -> Bool + exportContainOthers (DataDecl {}) = True + exportContainOthers (ClassDecl {}) = True + exportContainOthers _ = False + +-- | Create the export for a give name. +createExports :: [(GHC.Name, Bool)] -> ExportSpecs dom +createExports elems = mkExportSpecs $ map (mkExportSpec . createExport) elems + where createExport (n, False) = mkIESpec (mkUnqualName' (GHC.getName n)) Nothing + createExport (n, True) = mkIESpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) diff --git a/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs b/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/GenerateTypeSignature.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, ScopedTypeVariables, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-} +module Language.Haskell.Tools.Refactor.Builtin.GenerateTypeSignature + ( generateTypeSignature, generateTypeSignature', GenerateSignatureDomain, tryItOut + , generateTypeSignatureRefactoring) where + +import GHC hiding (Module) +import Id as GHC +import OccName as GHC (isSymOcc) +import Outputable as GHC (Outputable(..), showSDocUnsafe) +import TyCon as GHC (TyCon(..), isTupleTyCon) +import Type as GHC +import TysWiredIn as GHC (listTyCon, charTyCon) + +import Control.Monad +import Control.Monad.State +import Control.Reference +import Data.Generics.Uniplate.Data (universeBi) +import Data.List +import Data.Maybe (Maybe(..), catMaybes) + +import Language.Haskell.Tools.Refactor as AST + +type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom, HasScopeInfo dom ) + +generateTypeSignatureRefactoring :: GenerateSignatureDomain dom => RefactoringChoice dom +generateTypeSignatureRefactoring = SelectionRefactoring "GenerateSignature" (localRefactoring . generateTypeSignature') + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor (localRefactoring . generateTypeSignature') + +generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom +generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp) + +-- | Perform the refactoring on either local or top-level definition +generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom) + -- ^ Access for a top-level definition if it is the selected definition + -> Simple Traversal (Module dom) (LocalBindList dom) + -- ^ Access for a definition list if it contains the selected definition + -> (forall d . (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom)) + -- ^ Selector for either local or top-level declaration in the definition list + -> LocalRefactoring dom +generateTypeSignature topLevelRef localRef vbAccess mod + = let typeSigs = universeBi mod + bindings = universeBi mod + findTypeSigFor id = find (\ts -> any (id ==) $ map semanticsId (ts ^? tsName & annList & simpleName)) + bindsWithSigs = catMaybes $ concatMap (\b -> map (\n -> let id = semanticsId n in fmap (id,,b) (findTypeSigFor id typeSigs)) (b ^? bindingName)) bindings + scopedSigs = hasScopedTypeSignatures mod + in do (mod', done) <- flip runStateT False . + (topLevelRef !~ genTypeSig scopedSigs bindsWithSigs vbAccess + <=< localRef !~ genTypeSig scopedSigs bindsWithSigs vbAccess) $ mod + if done + then return mod' + else refactError "No binding without type signature is found at the selection." + + +hasScopedTypeSignatures :: Module dom -> Bool +hasScopedTypeSignatures mod = "ScopedTypeVariables" `elem` (mod ^? filePragmas & annList & lpPragmas & annList & langExt :: [String]) + +genTypeSig :: forall dom d . (GenerateSignatureDomain dom, BindingElem d) => Bool -> [(GHC.Var, TypeSignature dom, ValueBind dom)] -> (AnnList d dom -> Maybe (ValueBind dom)) + -> AnnList d dom -> StateT Bool (LocalRefactor dom) (AnnList d dom) +genTypeSig scopedSigs sigBinds vbAccess ls + | Just vb <- vbAccess ls + , not (typeSignatureAlreadyExist ls vb) + = if isSimpleBinding vb + then + do let id = getBindingName vb + isTheBind (Just decl) + = isBinding decl && map semanticsId (decl ^? elementName) == map semanticsId (vb ^? bindingName) + isTheBind _ = False + + alreadyGenerated <- get + if alreadyGenerated + then return ls + else do put True + -- checking for possible situations when we cannot generate signature because of + -- an implicitly passed value + let dangerousTypeVars = dangerousTVs scopedSigs sigBinds + myTvs = concatMap @[] (getExternalTVs . idType . semanticsId) (vb ^? bindingName) + if not $ null @[] $ myTvs `intersect` dangerousTypeVars + then refactError $ "Could not generate type signature: the type variable(s) " + ++ concat (intersperse ", " $ map (showSDocUnsafe . ppr) (myTvs `intersect` dangerousTypeVars)) + ++ " cannot be captured. (Use ScopedTypeVariables and forall-ed type signatures)" + else do + typeSig <- lift $ generateTSFor (getName id) (idType id) + return $ insertWhere True (createTypeSig typeSig) (const True) isTheBind ls + else refactError "Signature can only be generated for simple value bindings." + | otherwise = return ls + where isSimpleBinding vb = case vb of SimpleBind (AST.VarPat {}) _ _ -> True + SimpleBind _ _ _ -> False + _ -> True + dangerousTVs scopedSigs sigBinds + = let dangerousDecls = if scopedSigs then filter (\(_,ts,_) -> not $ isForalledTS ts) sigBinds else sigBinds + dangerousNames = map (\(_,_,bn) -> bn ^? (valBindPats & biplateRef &+& bindingName)) dangerousDecls + in concatMap (concatMap @[] (getExternalTVs . idType . semanticsId @(QualifiedName dom))) dangerousNames + +generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> LocalRefactor dom (TypeSignature dom) +generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (-1) (dropForAlls t) + +-- | Generates the source-level type for a GHC internal type +generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (AST.Type dom) +generateTypeFor prec t + -- context + | (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t + , not (null preds) + = do ctx <- case preds of [pred] -> mkContext <$> generateAssertionFor pred + _ -> mkContext <$> (mkTupleAssertion <$> mapM generateAssertionFor preds) + wrapParen 0 <$> (mkCtxType ctx <$> generateTypeFor 0 (mkFunTys other rt)) + -- function + | Just (at, rt) <- splitFunTy_maybe t + = wrapParen 0 <$> (mkFunctionType <$> generateTypeFor 10 at <*> generateTypeFor 0 rt) + -- type operator (we don't know the precedences, so always use parentheses) + | (op, [at,rt]) <- splitAppTys t + , Just tc <- tyConAppTyCon_maybe op + , isSymOcc (getOccName (getName tc)) + = wrapParen 0 <$> (mkInfixTypeApp <$> generateTypeFor 10 at <*> referenceOperator (idName $ getTCId tc) <*> generateTypeFor 10 rt) + -- tuple types + | Just (tc, tas) <- splitTyConApp_maybe t + , isTupleTyCon tc + = mkTupleType <$> mapM (generateTypeFor (-1)) tas + -- string type + | Just (ls, [et]) <- splitTyConApp_maybe t + , Just ch <- tyConAppTyCon_maybe et + , listTyCon == ls + , charTyCon == ch + = return $ mkVarType (mkNormalName $ mkSimpleName "String") + -- list types + | Just (tc, [et]) <- splitTyConApp_maybe t + , listTyCon == tc + = mkListType <$> generateTypeFor (-1) et + -- type application + | Just (tf, ta) <- splitAppTy_maybe t + = wrapParen 10 <$> (mkTypeApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta) + -- type constructor + | Just tc <- tyConAppTyCon_maybe t + = mkVarType <$> referenceName (idName $ getTCId tc) + -- type variable + | Just tv <- getTyVar_maybe t + = mkVarType <$> referenceName (idName tv) + -- forall type + | (tvs@(_:_), t') <- splitForAllTys t + = wrapParen (-1) <$> (mkForallType (map (mkTypeVar' . getName) tvs) <$> generateTypeFor 0 t') + | otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t)) + where wrapParen :: Int -> AST.Type dom -> AST.Type dom + wrapParen prec' node = if prec' < prec then mkParenType node else node + + getTCId :: GHC.TyCon -> GHC.Id + getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc) + + generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Assertion dom) + generateAssertionFor t + | Just (tc, types) <- splitTyConApp_maybe t + = mkClassAssert <$> referenceName (idName $ getTCId tc) <*> mapM (generateTypeFor 0) types + | otherwise = error "generateAssertionFor: type not supported yet." + +-- | Check whether the definition already has a type signature +typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList d dom -> ValueBind dom -> Bool +typeSignatureAlreadyExist ls vb = + getBindingName vb `elem` (map semanticsId $ concatMap (^? elementName) (filter isTypeSig $ ls ^? annList)) + +getBindingName :: GenerateSignatureDomain dom => ValueBind dom -> GHC.Id +getBindingName vb = case nub $ map semanticsId $ vb ^? bindingName of + [n] -> n + [] -> error "Trying to generate a signature for a binding with no name" + _ -> error "Trying to generate a signature for a binding with multiple names" + +-- * Checking for type variable constraints + +getExternalTVs :: GHC.Type -> [GHC.Var] +getExternalTVs t + | Just tv <- getTyVar_maybe t = [tv] + | Just (op, arg) <- splitAppTy_maybe t = getExternalTVs op `union` getExternalTVs arg + | Just (tv, t') <- splitForAllTy_maybe t = delete tv $ getExternalTVs t' + | otherwise = [] + +isForalledTS :: TypeSignature dom -> Bool +isForalledTS ts = not $ null @[] $ ts ^? tsType & typeBounded & annList diff --git a/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs b/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/InlineBinding.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, MultiWayIf, RankNTypes, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +-- | 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 + (inlineBinding, InlineBindingDomain, tryItOut, inlineBindingRefactoring) where + +import Control.Monad.State +import Control.Reference +import Data.Generics.Uniplate.Data () +import Data.Generics.Uniplate.Operations (Uniplate(..), Biplate(..)) +import Data.List (nub) +import Data.Maybe (Maybe(..), catMaybes) + +import Name as GHC (NamedThing(..), Name, occNameString) +import SrcLoc as GHC (SrcSpan(..), RealSrcSpan) + +import Language.Haskell.Tools.Refactor as AST + +inlineBindingRefactoring :: InlineBindingDomain dom => RefactoringChoice dom +inlineBindingRefactoring = SelectionRefactoring "InlineBinding" inlineBinding + +tryItOut :: String -> String -> IO () +tryItOut = tryRefactor inlineBinding + +type InlineBindingDomain dom = ( HasNameInfo dom, HasDefiningInfo dom, HasScopeInfo dom, HasModuleInfo dom ) + +inlineBinding :: forall dom . InlineBindingDomain dom => RealSrcSpan -> Refactoring dom +inlineBinding span namedMod@(_,mod) mods + = let topLevel :: Simple Traversal (Module dom) (DeclList dom) + topLevel = nodesContaining span + local :: Simple Traversal (Module dom) (LocalBindList dom) + local = nodesContaining span + exprs :: Simple Traversal (Module dom) (Expr dom) + exprs = nodesContaining span + elemAccess :: (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom) + elemAccess = getValBindInList span + removed = catMaybes $ map elemAccess (mod ^? topLevel) ++ map elemAccess (mod ^? local) + in case reverse removed of + [] -> refactError "No binding is selected." + removedBinding:_ -> + let [removedBindingName] = nub $ catMaybes $ map semanticsName (removedBinding ^? bindingName) + in if | any (containInlined removedBindingName) mods + -> refactError "Cannot inline the definition, it is used in other modules." + | _:_ <- mod ^? modHead & annJust & mhExports & annJust & biplateRef + & filtered (\n -> semanticsName (n :: QualifiedName dom) == Just removedBindingName) + -> refactError "Cannot inline the definition, it is present in the export list." + | otherwise -> localRefactoring (inlineBinding' topLevel local exprs removedBinding removedBindingName) namedMod mods + +-- | Performs the inline binding on a single module. +inlineBinding' :: InlineBindingDomain dom + => Simple Traversal (Module dom) (DeclList dom) + -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) + -> ValueBind dom -> GHC.Name + -> LocalRefactoring dom +inlineBinding' topLevelRef localRef exprRef removedBinding removedBindingName mod + = do replacement <- createReplacement removedBinding + let RealSrcSpan bindingSpan = getRange removedBinding + mod' <- removeBindingAndSig topLevelRef localRef exprRef removedBindingName mod + (mod'', used) <- runStateT (descendBiM (replaceInvocations bindingSpan removedBindingName replacement) mod') False + if not used + then refactError "The selected definition is not used, it can be safely deleted." + else return mod'' + +-- | True if the given module contains the name of the inlined definition. +containInlined :: forall dom . InlineBindingDomain dom => GHC.Name -> ModuleDom dom -> Bool +containInlined name (_,mod) + = any (\qn -> semanticsName qn == Just name) $ (mod ^? biplateRef :: [QualifiedName dom]) + +-- | Removes the inlined binding and the accompanying type and fixity signatures. +removeBindingAndSig :: InlineBindingDomain dom + => Simple Traversal (Module dom) (DeclList dom) + -> Simple Traversal (Module dom) (LocalBindList dom) + -> Simple Traversal (Module dom) (Expr dom) + -> GHC.Name + -> LocalRefactoring dom +removeBindingAndSig topLevelRef localRef exprRef name + = (return . removeEmptyBnds (topLevelRef & annList & declValBind &+& localRef & annList & localVal) exprRef) + <=< (topLevelRef !~ removeBindingAndSig' name) + <=< (localRef !~ removeBindingAndSig' name) + +removeBindingAndSig' :: (SourceInfoTraversal d, InlineBindingDomain dom, BindingElem d) + => GHC.Name -> AnnList d dom -> LocalRefactor dom (AnnList d dom) +removeBindingAndSig' name ls = do + bnds <- mapM notThatBindOrSig (ls ^? annList) + return $ (annList .- removeNameFromSigBind) (filterListIndexed (\i _ -> bnds !! i) ls) + where notThatBindOrSig e + | Just sb <- e ^? sigBind = return $ nub (map semanticsName (sb ^? tsName & annList & simpleName)) /= [Just name] + | Just vb <- e ^? valBind = do + let isThat = nub (map semanticsName (vb ^? bindingName)) == [Just name] + when isThat (void $ accessRhs !| checkForRecursion name $ vb) + return $ not isThat + | Just fs <- e ^? fixitySig = return $ nub (map semanticsName (fs ^? fixityOperators & annList & operatorName)) /= [Just name] + | otherwise = return True + + removeNameFromSigBind + = (sigBind & tsName .- filterList (\n -> semanticsName (n ^. simpleName) /= Just name)) + . (fixitySig & fixityOperators .- filterList (\n -> semanticsName (n ^. operatorName) /= Just name)) + + accessRhs = valBindRhs + &+& valBindLocals & accessLocalRhs + &+& funBindMatches & annList & matchRhs + &+& funBindMatches & annList & (matchRhs &+& matchBinds & accessLocalRhs) + accessLocalRhs = annJust & localBinds & annList & localVal & accessRhs + +-- | Check the extracted bindings right-hand-side for possible recursion +checkForRecursion :: InlineBindingDomain dom + => GHC.Name -> Rhs dom -> LocalRefactor dom () +checkForRecursion n = void . (biplateRef !| checkNameForRecursion n) + +checkNameForRecursion :: InlineBindingDomain dom + => GHC.Name -> AST.Name dom -> LocalRefactor dom () +checkNameForRecursion name n + | semanticsName (n ^. simpleName) == Just name + = refactError $ "Cannot inline definitions containing direct recursion. Recursive call at: " + ++ shortShowSpanWithFile (getRange n) + | otherwise = return () + +-- | As a top-down transformation, replaces the occurrences of the binding with generated expressions. This method passes +-- the captured arguments of the function call to generate simpler results. +replaceInvocations :: InlineBindingDomain dom + => RealSrcSpan -> GHC.Name -> ([[GHC.Name]] -> [Expr dom] -> Expr dom) -> Expr dom -> StateT Bool (LocalRefactor dom) (Expr dom) +replaceInvocations bindingRange name replacement expr + | (Var n, args) <- splitApps expr + , semanticsName (n ^. simpleName) == Just name + = do put True + replacement (map (map (^. _1)) $ semanticsScope expr) + <$> mapM (descendM (replaceInvocations bindingRange name replacement)) args + | otherwise + = descendM (replaceInvocations bindingRange name replacement) expr + +-- | Splits an application into function and arguments. Works also for operators. +splitApps :: Expr dom -> (Expr dom, [Expr dom]) +splitApps (App f a) = case splitApps f of (fun, args) -> (fun, args ++ [a]) +splitApps (InfixApp l (NormalOp qn) r) = (mkVar (mkParenName qn), [l,r]) +splitApps (InfixApp l (BacktickOp qn) r) = (mkVar (mkNormalName qn), [l,r]) +splitApps (Paren expr) = splitApps expr +splitApps expr = (expr, []) + +-- | Rejoins the function and the arguments as an expression. +joinApps :: Expr dom -> [Expr dom] -> Expr dom +joinApps f [] = f +joinApps f args = parenIfNeeded (foldl mkApp f args) + +-- | Create an expression that is equivalent to calling the given bind. +createReplacement :: InlineBindingDomain dom => ValueBind dom -> LocalRefactor dom ([[GHC.Name]] -> [Expr dom] -> Expr dom) +createReplacement (SimpleBind (VarPat _) (UnguardedRhs e) locals) + = return $ \_ args -> joinApps (parenIfNeeded $ wrapLocals locals e) args +createReplacement (SimpleBind _ _ _) + = refactError "Cannot inline, illegal simple bind. Only variable left-hand sides and unguarded right-hand sides are accepted." +createReplacement (FunctionBind (AnnList [Match lhs (UnguardedRhs expr) locals])) + = return $ \_ args -> let (argReplacement, matchedPats, appliedArgs) = matchArguments (getArgsOf lhs) args + in joinApps (parenIfNeeded (createLambda matchedPats (wrapLocals locals (replaceExprs argReplacement expr)))) appliedArgs + where getArgsOf (MatchLhs _ (AnnList args)) = args + getArgsOf (InfixLhs lhs _ rhs (AnnList more)) = lhs:rhs:more +createReplacement (FunctionBind matches) + -- function bind has at least one match + = return $ \sc args -> let numArgs = getArgNum (head (matches ^? annList & matchLhs)) - length args + newArgs = take numArgs $ map mkName $ filter notInScope $ map (("x" ++ ) . show @Int) [1..] + notInScope str = not $ any (any ((== str) . occNameString . getOccName)) sc + in parenIfNeeded $ createLambda (map mkVarPat newArgs) + $ mkCase (mkTuple $ map mkVar newArgs ++ args) + $ map replaceMatch (matches ^? annList) + where getArgNum (MatchLhs _ (AnnList args)) = length args + getArgNum (InfixLhs _ _ _ (AnnList more)) = length more + 2 + +-- | Replaces names with expressions according to a mapping. +replaceExprs :: InlineBindingDomain dom => [(GHC.Name, Expr dom)] -> Expr dom -> Expr dom +replaceExprs [] = id +replaceExprs replaces = (uniplateRef .-) $ \case + Var n | Just name <- semanticsName (n ^. simpleName) + , Just replace <- lookup name replaces + -> replace + e -> e + +-- | Matches a pattern list with an expression list and generates bindings. Matches until an argument cannot be matched. +matchArguments :: InlineBindingDomain dom => [Pattern dom] -> [Expr dom] -> ([(GHC.Name, Expr dom)], [Pattern dom], [Expr dom]) +matchArguments (ParenPat p : pats) exprs = matchArguments (p:pats) exprs +matchArguments (p:pats) (e:exprs) + | Just replacement <- staticPatternMatch p e + = case matchArguments pats exprs of (replacements, patterns, expressions) -> (replacement ++ replacements, patterns, expressions) + | otherwise + = ([], p:pats, e:exprs) +matchArguments pats [] = ([], pats, []) +matchArguments [] exprs = ([], [], exprs) + +-- | Matches a pattern with an expression. Generates a mapping of names to expressions. +staticPatternMatch :: InlineBindingDomain dom => Pattern dom -> Expr dom -> Maybe [(GHC.Name, Expr dom)] +staticPatternMatch (VarPat n) e + | Just name <- semanticsName $ n ^. simpleName + = Just [(name, e)] +staticPatternMatch (AppPat n (AnnList args)) e + | (Var n', exprs) <- splitApps e + , length args == length exprs + && semanticsName (n ^. simpleName) == semanticsName (n' ^. simpleName) + , Just subs <- sequence $ zipWith staticPatternMatch args exprs + = Just $ concat subs +staticPatternMatch (TuplePat (AnnList pats)) (Tuple (AnnList args)) + | length pats == length args + , Just subs <- sequence $ zipWith staticPatternMatch pats args + = Just $ concat subs +staticPatternMatch _ _ = Nothing + +replaceMatch :: Match dom -> Alt dom +replaceMatch (Match lhs rhs locals) = mkAlt (toPattern lhs) (toAltRhs rhs) (locals ^? annJust) + where toPattern (MatchLhs _ (AnnList pats)) = mkTuplePat pats + toPattern (InfixLhs lhs _ rhs (AnnList more)) = mkTuplePat (lhs:rhs:more) + + toAltRhs (UnguardedRhs expr) = mkCaseRhs expr + toAltRhs (GuardedRhss (AnnList rhss)) = mkGuardedCaseRhss (map toAltGuardedRhs rhss) + + toAltGuardedRhs (GuardedRhs (AnnList guards) expr) = mkGuardedCaseRhs guards expr + +wrapLocals :: MaybeLocalBinds dom -> Expr dom -> Expr dom +wrapLocals bnds = case bnds ^? annJust & localBinds & annList of + [] -> id + localBinds -> mkLet localBinds + +-- | True for patterns that need to be parenthesized if in a lambda +compositePat :: Pattern dom -> Bool +compositePat (AppPat {}) = True +compositePat (InfixAppPat {}) = True +compositePat (TypeSigPat {}) = True +compositePat (ViewPat {}) = True +compositePat _ = False + +parenIfNeeded :: Expr dom -> Expr dom +parenIfNeeded e = if compositeExprs e then mkParen e else e + +-- | True for expresssions that need to be parenthesized if in application +compositeExprs :: Expr dom -> Bool +compositeExprs (App {}) = True +compositeExprs (InfixApp {}) = True +compositeExprs (Lambda {}) = True +compositeExprs (Let {}) = True +compositeExprs (If {}) = True +compositeExprs (Case {}) = True +compositeExprs (Do {}) = True +compositeExprs _ = False + +createLambda :: [Pattern dom] -> Expr dom -> Expr dom +createLambda [] = id +createLambda pats = mkLambda (map (\p -> if compositePat p then mkParenPat p else p) pats) diff --git a/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs b/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/OrganizeExtensions.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, RankNTypes, TupleSections, TypeFamilies, LambdaCase #-} + +module Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions + ( module Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions + , module Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + ) where + +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 hiding (LambdaCase) +import Language.Haskell.Tools.Refactor.Utils.Extensions (expandExtension) + +import GHC (Ghc(..)) + +import Control.Reference +import Data.Char (isAlpha) +import Data.Function (on) +import Data.List +import qualified Data.Map.Strict as SMap (keys, empty) + +-- NOTE: When working on the entire AST, we should build a monad, +-- that will will avoid unnecessary checks. +-- For example if it already found a record wildcard, it won't check again + +-- Pretty easy now. Chcek wheter it is already in the ExtMap. + +type OrganizeExtensionsDomain dom = (HasModuleInfo dom, ExtDomain dom) + +organizeExtensionsRefactoring :: OrganizeExtensionsDomain dom => RefactoringChoice dom +organizeExtensionsRefactoring = ModuleRefactoring "OrganizeExtensions" (localRefactoring organizeExtensions) + +projectOrganizeExtensionsRefactoring :: OrganizeExtensionsDomain dom => RefactoringChoice dom +projectOrganizeExtensionsRefactoring = ProjectRefactoring "ProjectOrganizeExtensions" projectOrganizeExtensions + +projectOrganizeExtensions :: forall dom . OrganizeExtensionsDomain dom => ProjectRefactoring dom +projectOrganizeExtensions = + mapM (\(k, m) -> ContentChanged . (k,) <$> localRefactoringRes id m (organizeExtensions m)) + +tryOut :: String -> String -> IO () +tryOut = tryRefactor (localRefactoring . const organizeExtensions) + +organizeExtensions :: ExtDomain dom => LocalRefactoring dom +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 + + -- remove unused extensions (only those that are fully handled) + filePragmas & annList & lpPragmas !~ filterListSt (not . isRedundant) + -- remove empty {-# LANGUAGE #-} pragmas + >=> filePragmas !~ filterListSt (\case LanguagePragma (AnnList []) -> False; _ -> True) + $ moduleAST + +-- | Reduces default extension list (keeps unsupported extensions) +reduceExtensions :: ExtDomain dom => UnnamedModule dom -> Ghc [Extension] +reduceExtensions = \moduleAST -> do + let expanded = expandDefaults moduleAST + (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 + + +-- | Collects extensions induced by the source code (with location info) +collectExtensions :: ExtDomain dom => UnnamedModule dom -> Ghc ExtMap +collectExtensions moduleAST = do + let expanded = expandDefaults moduleAST + flip execStateT SMap.empty . flip runReaderT expanded . traverseModule $ moduleAST + +-- | Collects default extension list, and expands each extension +expandDefaults :: UnnamedModule dom -> [Extension] +expandDefaults = nub . concatMap expandExtension . collectDefaultExtensions + +-- | Collects extensions enabled by default +collectDefaultExtensions :: UnnamedModule dom -> [Extension] +collectDefaultExtensions = map toExt . getExtensions + where + getExtensions :: UnnamedModule dom -> [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." diff --git a/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs b/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/OrganizeImports.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, LambdaCase, ScopedTypeVariables, TupleSections, TypeApplications, TypeFamilies #-} +module Language.Haskell.Tools.Refactor.Builtin.OrganizeImports + ( organizeImports, OrganizeImportsDomain, projectOrganizeImports + , organizeImportsRefactoring, projectOrganizeImportsRefactoring + ) where + +import ConLike (ConLike(..)) +import DataCon (dataConTyCon) +import DynFlags (xopt) +import FamInstEnv (FamInst(..)) +import GHC (TyThing(..), lookupName) +import qualified GHC +import Id +import IdInfo (RecSelParent(..)) +import InstEnv (ClsInst(..)) +import Language.Haskell.TH.LanguageExtensions as GHC (Extension(..)) +import Name (NamedThing(..)) +import OccName (HasOccName(..), isSymOcc) +import qualified PrelNames as GHC (fromStringName, coerceKey) +import SrcLoc (SrcSpan(..), noSrcSpan) +import TyCon (TyCon(..), tyConFamInst_maybe) +import Unique (getUnique) + +import Control.Applicative ((<$>), Alternative(..)) +import Control.Monad +import Control.Reference hiding (element) +import Data.Function hiding ((&)) +import Data.Generics.Uniplate.Data (universeBi) +import Data.List +import Data.Maybe (Maybe(..), maybe, catMaybes) + +import Language.Haskell.Tools.Refactor as AST + +organizeImportsRefactoring :: OrganizeImportsDomain dom => RefactoringChoice dom +organizeImportsRefactoring = ModuleRefactoring "OrganizeImports" (localRefactoring organizeImports) + +projectOrganizeImportsRefactoring :: OrganizeImportsDomain dom => RefactoringChoice dom +projectOrganizeImportsRefactoring = ProjectRefactoring "ProjectOrganizeImports" projectOrganizeImports + +type OrganizeImportsDomain dom = ( HasNameInfo dom, HasImportInfo dom, HasModuleInfo dom, HasImplicitFieldsInfo dom ) + +projectOrganizeImports :: forall dom . OrganizeImportsDomain dom => ProjectRefactoring dom +projectOrganizeImports mods + = mapM (\(k, m) -> ContentChanged . (k,) <$> localRefactoringRes id m (organizeImports m)) mods + +organizeImports :: forall dom . OrganizeImportsDomain dom => LocalRefactoring dom +organizeImports mod + = do usedTyThings <- catMaybes <$> mapM lookupName usedNames + let dfs = semanticsDynFlags mod + noNarrowingImports + = xopt TemplateHaskell dfs -- no narrowing if TH is present (we don't know what will be used) + || xopt QuasiQuotes dfs -- no narrowing if TH quotes are present (we don't know what will be used) + || (xopt FlexibleInstances dfs && noNarrowingSubspecs) -- arbitrary ctors might be needed when using imported data families + || hasCoerce -- the presence of coerce implicitely requires the constructors to be present + noNarrowingSubspecs + = -- both standalone deriving and FFI marshalling can cause constructors to be used in the generated code + xopt GHC.StandaloneDeriving dfs || hasMarshalling + -- while pattern synonyms are not handled correctly, we disable subspec narrowing to be safe + || patternSynonymAreUsed usedTyThings + 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 + 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 + -- the declarations (used), both from the module head (re-exported) will count as usage + (universeBi (mod ^. modHead) ++ universeBi (mod ^. modDecl) :: [QualifiedName dom])) + ++ concatMap (map fst . semanticsImplicitFlds) (universeBi (mod ^. modDecl) :: [FieldWildcard dom]) + -- Prelude is not actually exported, but we don't want to remove it if it is explicitly there + -- otherwise, we might add new imported elements that cause conflicts. + exportedModules = "Prelude" : (mod ^? modHead & annJust & mhExports & annJust + & espExports & annList & exportModuleName & moduleNameString) + + -- Exported definitions must be kept imported + exports = mod ^? modHead & annJust & mhExports & annJust & espExports & annList & exportDecl + exportedNames = catMaybes $ map getExported exports + getExported e = fmap (,hasChild) name + where name = semanticsName (e ^. ieName & simpleName) + hasChild = (case e ^? ieSubspec & annJust of Just SubAll -> True; _ -> False) + || not (null @[] (e ^? ieSubspec & annJust & essList & annList)) + + -- Checks if the module uses foreign import/export that requires marshalling. In this case no + -- subspecifiers could be narrowed because constructors might be needed. + hasMarshalling = not $ null @[] (mod ^? modDecl & annList & declForeignType) + hasCoerce = GHC.coerceKey `elem` map getUnique usedNames + + -- Can this name be part of the source code? + -- isSourceName n = ':' `notElem` occNameString (occName n) + patternSynonymAreUsed tts = any (\case AConLike (PatSynCon _) -> True; _ -> False) tts + +-- | Sorts the imports in alphabetical order +sortImports :: forall dom . ImportDeclList dom -> ImportDeclList dom +sortImports ls = srcInfo & srcTmpSeparators .= filter (not . null . fst) (concatMap (\(sep,elems) -> sep : map fst elems) reordered) + $ annListElems .= concatMap (map snd . snd) reordered + $ ls + where reordered :: [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])] + reordered = map (_2 .- sortBy (compare `on` (^. _2 & importModule & AST.moduleNameString))) parts + + parts = map (_2 .- reverse) $ reverse $ breakApart [] imports + + -- break up the list of imports to import groups + breakApart :: [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])] + -> [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)] + -> [(([SourceTemplateTextElem], SrcSpan), [(([SourceTemplateTextElem], SrcSpan), ImportDecl dom)])] + breakApart res [] = res + breakApart res ((sep, e) : rest) | length (filter ('\n' ==) (sep ^? _1 & traversal & sourceTemplateText & traversal)) > 1 + || "\n#" `isInfixOf` (sep ^? _1 & traversal & sourceTemplateText & traversal) + = breakApart ((sep, [(([], noSrcSpan),e)]) : res) rest + breakApart ((lastSep, lastRes) : res) (elem : rest) + = breakApart ((lastSep, elem : lastRes) : res) rest + breakApart [] ((sep, e) : rest) + = breakApart [(sep, [(([], noSrcSpan),e)])] rest + + imports = zipWithSeparators ls + +-- | Modify an import to only import names that are used. +narrowImports :: forall dom . OrganizeImportsDomain dom + => Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> [ClsInst] -> [FamInst] -> ImportDeclList dom -> LocalRefactor dom (ImportDeclList dom) +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) + +-- | Reduces the number of definitions used from an import +narrowImport :: OrganizeImportsDomain dom + => Bool -> [String] -> [GHC.Name] -> [(GHC.Name, Bool)] -> ImportDecl dom -> LocalRefactor dom (ImportDecl dom) +narrowImport noNarrowSubspecs exportedModules usedNames exportedNames imp + | (imp ^. importModule & moduleNameString) `elem` exportedModules + || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) + = return imp -- dont change an import if it is exported as-is (module export) + | importIsExact imp + = importSpec&annJust&importSpecList !~ narrowImportSpecs noNarrowSubspecs usedNames exportedNames $ imp + | importIsHiding imp + = return imp -- a hiding import is not changed, because the wildcard importing of class and datatype + -- members could bring into scope the exact definition that was hidden + | otherwise + = do namedThings <- mapM lookupName actuallyImported + let -- to explicitly import pattern synonyms or type operators we need to enable an extension, and the user might not expect this + hasRiskyDef = any isRiskyDef namedThings + groups = groupThings noNarrowSubspecs (semanticsImported imp) + (filter ((`elem` semanticsImported imp) . fst) exportedNames) (catMaybes namedThings) + return $ if not hasRiskyDef && length groups < 4 + then importSpec .- replaceWithJust (createImportSpec groups) $ imp + else imp + where actuallyImported = semanticsImported imp `intersect` usedNames + isRiskyDef (Just (AConLike (PatSynCon _))) = True + isRiskyDef (Just (ATyCon tc)) = isSymOcc (occName (tyConName tc)) + isRiskyDef _ = False + +-- | Group things as importable definitions. The second member of the pair will be true, when there is a sub-name +-- that should be imported apart from the name of the importable definition. +groupThings :: Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> [TyThing] -> [(GHC.Name, Bool)] +groupThings noNarrowSubspecs importable exported + = map last . groupBy ((==) `on` fst) . sort . (exported ++) . map createImportFromTyThing + where createImportFromTyThing :: TyThing -> (GHC.Name, Bool) + createImportFromTyThing tt | Just (td, isDataType) <- getTopDef tt + = if (td `elem` importable || isDataType) then (td, True) + else (getName tt, False) + createImportFromTyThing tt@(ATyCon {}) = (getName tt, noNarrowSubspecs) + createImportFromTyThing tt = (getName tt, False) + +-- | Gets the importable definition for a (looked up) name. The bool flag tells if it is from +-- a data type. +getTopDef :: TyThing -> Maybe (GHC.Name, Bool) +getTopDef (AnId id) | isRecordSelector id + = case recordSelectorTyCon id of RecSelData tc -> Just (getName tc, True) + RecSelPatSyn ps -> Just (getName ps, False) +getTopDef (AnId id) + | Just n <- fmap (getName . dataConTyCon) (isDataConWorkId_maybe id <|> isDataConId_maybe id) + = Just (n, True) +getTopDef (AnId id) = fmap ((,False) . getName) (isClassOpId_maybe id) +getTopDef (AConLike (RealDataCon dc)) + = case tyConFamInst_maybe (dataConTyCon dc) of + Just (dataFam, _) -> Just (getName dataFam, True) + _ -> Just (getName $ dataConTyCon dc, True) +getTopDef (AConLike (PatSynCon _)) = error "getTopDef: should not be called with pattern synonyms" +getTopDef (ATyCon _) = Nothing + +createImportSpec :: [(GHC.Name, Bool)] -> ImportSpec dom +createImportSpec elems = mkImportSpecList $ map createIESpec elems + where createIESpec (n, False) = mkIESpec (mkUnqualName' (GHC.getName n)) Nothing + createIESpec (n, True) = mkIESpec (mkUnqualName' (GHC.getName n)) (Just mkSubAll) + +-- | Check each import if it is actually needed +neededImports :: OrganizeImportsDomain dom + => [String] -> [GHC.Name] -> [ClsInst] -> [FamInst] -> [ImportDecl dom] -> [Bool] +neededImports exportedModules usedNames prelInsts prelFamInsts imps = neededImports' usedNames [] imps + where neededImports' _ _ [] = [] + -- keep the import if any definition is needed from it + neededImports' usedNames kept (imp : rest) + | not (null actuallyImported) + || (imp ^. importModule & moduleNameString) `elem` exportedModules + || maybe False (`elem` exportedModules) (imp ^? importAs & annJust & importRename & moduleNameString) + = True : neededImports' usedNames (imp : kept) 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) + +-- | Narrows the import specification (explicitly imported elements) +narrowImportSpecs :: forall dom . OrganizeImportsDomain dom + => Bool -> [GHC.Name] -> [(GHC.Name, Bool)] -> IESpecList dom -> LocalRefactor dom (IESpecList dom) +narrowImportSpecs noNarrowSubspecs usedNames exportedNames + = (if noNarrowSubspecs then return else annList !~ narrowImportSubspecs neededNames exportedNames) + >=> filterListSt isNeededSpec + where neededNames = usedNames ++ map fst exportedNames + + isNeededSpec :: IESpec dom -> Bool + isNeededSpec ie = + (semanticsName (ie ^. ieName&simpleName)) `elem` map Just neededNames + -- if the name is not used, but some of its constructors are used, it is needed + || ((ie ^? ieSubspec&annJust&essList&annList) /= []) + -- its a bit hard to decide if there is an element inside (for example bundled pattern synonyms) + || (case ie ^? ieSubspec&annJust of Just SubAll -> True; _ -> False) + +-- | Reduces the number of definitions imported from a sub-specifier. +narrowImportSubspecs :: OrganizeImportsDomain dom => [GHC.Name] -> [(GHC.Name, Bool)] -> IESpec dom -> LocalRefactor dom (IESpec dom) +narrowImportSubspecs neededNames exportedNames ss | noNarrowingForThis = return ss + | otherwise + = ieSubspec & annJust & essList !~ filterListSt (\n -> (semanticsName (n ^. simpleName)) `elem` map Just neededNames) $ ss + where noNarrowingForThis = case semanticsName (ss ^. ieName&simpleName) of + Just name -> lookup name exportedNames == Just True + _ -> False diff --git a/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs b/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/Refactor/Builtin/RenameDefinition.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, MultiWayIf, ScopedTypeVariables, TupleSections, TypeApplications, TypeFamilies, ViewPatterns #-} +module Language.Haskell.Tools.Refactor.Builtin.RenameDefinition + (renameDefinition, renameDefinition', DomainRenameDefinition, renameDefinitionRefactoring) where + +import DataCon (dataConFieldLabels, FieldLbl(..), dataConFieldType) +import qualified GHC +import Id +import IdInfo (RecSelParent(..)) +import Name (OccName(..), NamedThing(..), occNameString) +import SrcLoc (RealSrcSpan) +import TyCon (tyConDataCons) +import Type (funResultTy, eqType) + +import Control.Monad.State +import Control.Reference as Ref +import Data.Generics.Uniplate.Data () +import Data.List +import Data.List.Split (splitOn) +import Data.Maybe +import Language.Haskell.Tools.Refactor + +renameDefinitionRefactoring :: DomainRenameDefinition dom => RefactoringChoice dom +renameDefinitionRefactoring = NamingRefactoring "RenameDefinition" renameDefinition' + +type DomainRenameDefinition dom = ( HasNameInfo dom, HasScopeInfo dom, HasDefiningInfo dom + , HasImplicitFieldsInfo dom, HasModuleInfo dom ) + +renameDefinition' :: forall dom . DomainRenameDefinition dom => RealSrcSpan -> String -> Refactoring dom +renameDefinition' sp str mod mods + = case (getNodeContaining sp (snd mod) :: Maybe (QualifiedName dom)) >>= (fmap getName . semanticsName) of + Just name -> do let sameNames = bindsWithSameName name (snd mod ^? biplateRef) + renameDefinition name sameNames str mod mods + where bindsWithSameName :: GHC.Name -> [FieldWildcard dom] -> [GHC.Name] + bindsWithSameName name wcs = catMaybes $ map ((lookup name) . semanticsImplicitFlds) wcs + Nothing -> case getNodeContaining sp (snd mod) of + Just modName -> renameModule (any @[] (sp `isInside`) ((snd mod) ^? modImports&annList&importAs)) + (modName ^. moduleNameString) str mod mods + Nothing -> refactError "No name is selected" + +renameModule :: forall dom . DomainRenameDefinition dom => Bool -> String -> String -> Refactoring dom +renameModule isAlias from to m mods + | any (nameConflict to) (map snd $ m:mods) = refactError "Name conflict when renaming module" + | isJust (validModuleName to) = refactError $ "The given name is not a valid module name: " ++ fromJust (validModuleName to) + | otherwise = -- here it is important that the delete is the last, because rename + -- can still use the info about the deleted module + (if isAlias then id else (fmap (\ls -> map (alterChange from to) ls ++ [ModuleRemoved from]))) + $ mapM (\(name,mod) -> ContentChanged . (name,) <$> localRefactoringRes id mod (replaceModuleNames =<< alterNormalNames mod)) (m:mods) + where alterChange from to (ContentChanged (mod,res)) + | (mod ^. sfkModuleName) == from + = ModuleCreated to res mod + alterChange _ _ c = c + + replaceModuleNames :: LocalRefactoring dom + replaceModuleNames = modNames & filtered (\e -> (e ^. moduleNameString) == from) != mkModuleName to + where modNames = modHead & annJust & (mhName &+& mhExports & annJust & espExports & annList & exportModuleName) + &+& modImports & annList & ( importModule + &+& importAs & annJust & importRename ) + + alterNormalNames :: LocalRefactoring dom + alterNormalNames mod = + biplateRef @_ @(QualifiedName dom) & filtered (\e -> concat (intersperse "." (e ^? qualifiers&annList&simpleNameStr)) == from) + !- (\e -> mkQualifiedName (splitOn "." to) (e ^. unqualifiedName&simpleNameStr)) $ mod + + nameConflict :: String -> Module dom -> Bool + nameConflict to mod + = let modName = mod ^? modHead&annJust&mhName&moduleNameString + imports = mod ^? modImports&annList + importNames = map (\imp -> fromMaybe (imp ^. importModule) (imp ^? importAs&annJust&importRename) ^. moduleNameString) imports + in modName == Just to || to `elem` importNames + +renameDefinition :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> Refactoring dom +renameDefinition toChangeOrig toChangeWith newName mod mods + = do nameCls <- classifyName toChangeOrig + (changedModules,defFound) <- runStateT (catMaybes <$> mapM (renameInAModule toChangeOrig toChangeWith newName) (mod:mods)) False + if | isJust (nameValid nameCls newName) -> refactError $ "The new name is not valid: " ++ fromJust (nameValid nameCls newName) + | not defFound -> refactError "The definition to rename was not found. Maybe it is in another package." + | otherwise -> return $ map ContentChanged changedModules + where + renameInAModule :: DomainRenameDefinition dom => GHC.Name -> [GHC.Name] -> String -> ModuleDom dom -> StateT Bool Refactor (Maybe (ModuleDom dom)) + renameInAModule toChangeOrig toChangeWith newName (name, mod) + = mapStateT (localRefactoringRes (\f (a,s) -> (fmap (\(n,r) -> (n, f r)) a,s)) mod) $ + do origTT <- GHC.lookupName toChangeOrig + let origId = case origTT of + Just (GHC.AnId id) -> Just id + _ -> Nothing + (res, isChanged) <- runStateT (biplateRef !~ changeName toChangeOrig origId toChangeWith newName $ mod) False + if isChanged then return $ Just (name, res) + else return Nothing + + changeName :: DomainRenameDefinition dom => GHC.Name -> Maybe Id -> [GHC.Name] -> String -> QualifiedName dom + -> StateT Bool (StateT Bool (LocalRefactor dom)) (QualifiedName dom) + changeName toChangeOrig origId toChangeWith str name + | maybe False (`elem` toChange) actualName + && semanticsDefining name == False + && any @[] (\n -> str == occNameString (getOccName (n ^. _1)) && not (mergeableFields origId (n ^. _1)) + && notQualified (n ^. _2)) + (scopeUpToDef (semanticsScope name) ^? traversal & traversal & filtered (sameNamespace toChangeOrig . (^. _1))) + = refactError $ "The definition clashes with an existing one at: " ++ shortShowSpanWithFile (getRange name) -- name clash with an external definition + | maybe False (`elem` toChange) actualName + = do put True -- state that something is changed in the local state + when (actualName == Just toChangeOrig) + $ lift $ modify (|| semanticsDefining name) -- state that the definition is renamed in the global state + return $ unqualifiedName .= mkNamePart str $ name -- found the changed name (or a name that have to be changed too) + | let namesInScope = map (map (^. _1)) $ semanticsScope name + in case semanticsName name of + Just (getName -> exprName) -> str == occNameString (getOccName exprName) + && sameNamespace toChangeOrig exprName + && conflicts toChangeOrig exprName namesInScope + && not (mergeableFields origId exprName) + Nothing -> False -- ambiguous names + = refactError $ "The definition clashes with an existing one: " ++ shortShowSpanWithFile (getRange name) -- local name clash + | otherwise = return name -- not the changed name, leave as before + where toChange = toChangeOrig : toChangeWith + actualName = fmap getName (semanticsName name) + scopeUpToDef sc = let (inside, outside) = span (null . (toChange `intersect`) . map (^. _1)) sc + in inside ++ take 1 outside + mergeableFields (Just orig) conflict + | isRecordSelector orig + , RecSelData tc <- recordSelectorTyCon orig + = let selectorsWithTypes = concatMap (\dc -> map (\fld -> (flSelector fld, dataConFieldType dc (flLabel fld))) (dataConFieldLabels dc)) + (filter (\dc -> toChangeOrig `notElem` map flSelector (dataConFieldLabels dc)) (tyConDataCons tc)) + in maybe False (`eqType` funResultTy (idType orig)) (lookup conflict selectorsWithTypes) + mergeableFields _ _ = False + notQualified usage = isNothing usage || any @[] (not . usageQualified) (usage ^? just & traversal) + +conflicts :: GHC.Name -> GHC.Name -> [[GHC.Name]] -> Bool +conflicts overwrites overwritten (scopeBlock : scope) + | overwritten `elem` scopeBlock && overwrites `notElem` scopeBlock = False + | overwrites `elem` scopeBlock = True + | otherwise = conflicts overwrites overwritten scope +conflicts _ _ [] = False + +sameNamespace :: GHC.Name -> GHC.Name -> Bool +sameNamespace n1 n2 = occNameSpace (getOccName n1) == occNameSpace (getOccName n2) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/CPP/BetweenImports.hs b/examples/CPP/BetweenImports.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/BetweenImports.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +module CPP.BetweenImports where + +import Data.List +#if !(MIN_VERSION_text(1,2,1)) +#endif +import Data.Maybe + +x = Just diff --git a/examples/CPP/BetweenImports_res.hs b/examples/CPP/BetweenImports_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/BetweenImports_res.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +module CPP.BetweenImports where + +import Data.Maybe (Maybe(..)) +#if !(MIN_VERSION_text(1,2,1)) +#endif + + +x = Just diff --git a/examples/CPP/ConditionalCode.hs b/examples/CPP/ConditionalCode.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalCode.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImport where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif +import Data.List + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportBegin.hs b/examples/CPP/ConditionalImportBegin.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportBegin.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportBegin where + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Data.List +import Data.List + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportBegin_res.hs b/examples/CPP/ConditionalImportBegin_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportBegin_res.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportBegin where + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportEnd.hs b/examples/CPP/ConditionalImportEnd.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportEnd.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportEnd where + +import Data.List +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportEnd_res.hs b/examples/CPP/ConditionalImportEnd_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportEnd_res.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportEnd where + + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalImportHalfRemoved.hs b/examples/CPP/ConditionalImportHalfRemoved.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportHalfRemoved.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportHalfRemoved where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Control.Applicative ((<$>)) + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportHalfRemoved_res.hs b/examples/CPP/ConditionalImportHalfRemoved_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportHalfRemoved_res.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportHalfRemoved where + + +#ifndef USE_DATA_LIST +import Control.Monad ((>>)) +#endif +import Control.Applicative ((<$>)) + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportMulti.hs b/examples/CPP/ConditionalImportMulti.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportMulti.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportMulti where + +import Data.List +#ifndef USE_DATA_LIST +import Control.Applicative ((<$>)) +import Control.Monad ((>>)) +#endif +import Data.List + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportMulti_res.hs b/examples/CPP/ConditionalImportMulti_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportMulti_res.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportMulti where + + +#ifndef USE_DATA_LIST +import Control.Applicative ((<$>)) +import Control.Monad ((>>)) +#endif + + +a = id <$> (Nothing >> Nothing) diff --git a/examples/CPP/ConditionalImportOrder.hs b/examples/CPP/ConditionalImportOrder.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportOrder.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportOrder where + +import Data.List (intersperse) +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif +import Control.Applicative ((<$>)) + +a = Nothing >> Nothing + +b = id <$> Nothing +c = intersperse "," ["a","b"] diff --git a/examples/CPP/ConditionalImportOrder_res.hs b/examples/CPP/ConditionalImportOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImportOrder_res.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImportOrder where + +import Data.List (intersperse) +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif +import Control.Applicative ((<$>)) + +a = Nothing >> Nothing + +b = id <$> Nothing +c = intersperse "," ["a","b"] diff --git a/examples/CPP/ConditionalImport_res.hs b/examples/CPP/ConditionalImport_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalImport_res.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalImport where + + +#ifndef USE_DATA_LIST +import Control.Monad (Monad(..)) +#endif + + +a = Nothing >> Nothing diff --git a/examples/CPP/ConditionalSubImport.hs b/examples/CPP/ConditionalSubImport.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalSubImport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalSubImport where + +import Data.List(findIndex,intersperse,nub,sort,sortBy +#if __GLASGOW_HASKELL__ >= 710 + , sortOn +#endif + ) + +a = sortOn fst [("a","x")] diff --git a/examples/CPP/ConditionalSubImport_res.hs b/examples/CPP/ConditionalSubImport_res.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/ConditionalSubImport_res.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module CPP.ConditionalSubImport where + +import Data.List( +#if __GLASGOW_HASKELL__ >= 710 + + sortOn +#endif + ) + +a = sortOn fst [("a","x")] diff --git a/examples/CPP/JustEnabled.hs b/examples/CPP/JustEnabled.hs new file mode 100644 --- /dev/null +++ b/examples/CPP/JustEnabled.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE CPP #-} +module CPP.JustEnabled where diff --git a/examples/CppHs/Language/Preprocessor/Cpphs.hs b/examples/CppHs/Language/Preprocessor/Cpphs.hs new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs @@ -0,0 +1,416 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/Options.hs @@ -0,0 +1,156 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/Position.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs @@ -0,0 +1,82 @@ +{- +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs @@ -0,0 +1,281 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/examples/CppHs/Language/Preprocessor/Unlit.hs @@ -0,0 +1,72 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/AmbiguousFields.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/AnnPragma.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/ClassInfix.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/ClosedTypeFamily.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/CompletePragma.hs @@ -0,0 +1,16 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/CtorOp.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/DataFamily.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/DataInstanceGADT.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/DataType.hs @@ -0,0 +1,5 @@ +module Decl.DataType where + +data EmptyData + +data A = B Int | C diff --git a/examples/Decl/DataTypeDerivings.hs b/examples/Decl/DataTypeDerivings.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/DataTypeDerivings.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/DefaultDecl.hs @@ -0,0 +1,3 @@ +module Decl.DefaultDecl where + +default () diff --git a/examples/Decl/FunBind.hs b/examples/Decl/FunBind.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/FunBind.hs @@ -0,0 +1,4 @@ +module Decl.FunBind where + +f 0 = 1 +f x = x diff --git a/examples/Decl/FunFixity.hs b/examples/Decl/FunFixity.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/FunFixity.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/FunGuards.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/FunctionalDeps.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/GADT.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/GadtConWithCtx.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixAssertion.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixInstances.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InfixPatSyn.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InjectiveTypeFamily.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InlinePragma.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InstanceFamily.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InstanceOverlaps.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/InstanceSpec.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/LocalBindingInDo.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/LocalBindings.hs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/LocalFixity.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/MinimalPragma.hs @@ -0,0 +1,23 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/MixedInstance.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/MultipleFixity.hs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/MultipleSigs.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/OperatorBind.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/OperatorDecl.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/ParamDataType.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/PatternBind.hs @@ -0,0 +1,3 @@ +module Decl.PatternBind where + +(x,y) | 1 == 1 = (1,2) diff --git a/examples/Decl/PatternSynonym.hs b/examples/Decl/PatternSynonym.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/PatternSynonym.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/RecordPatternSynonyms.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/RecordType.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/RewriteRule.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/SpecializePragma.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/StandaloneDeriving.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeClass.hs @@ -0,0 +1,13 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeClassMinimal.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeFamily.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeFamilyKindSig.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeInstance.hs @@ -0,0 +1,14 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeRole.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Decl/TypeSynonym.hs @@ -0,0 +1,3 @@ +module Decl.TypeSynonym where + +type List = Int diff --git a/examples/Decl/ValBind.hs b/examples/Decl/ValBind.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/ValBind.hs @@ -0,0 +1,3 @@ +module Decl.ValBind where + +x = 1 diff --git a/examples/Decl/ViewPatternSynonym.hs b/examples/Decl/ViewPatternSynonym.hs new file mode 100644 --- /dev/null +++ b/examples/Decl/ViewPatternSynonym.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/ArrowNotation.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/Case.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/DoNotation.hs @@ -0,0 +1,15 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/EmptyCase.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/EmptyLet.hs @@ -0,0 +1,6 @@ +module Expr.EmptyLet where + +a = let in () + +m = do let + putStrLn "hello" diff --git a/examples/Expr/FunSection.hs b/examples/Expr/FunSection.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/FunSection.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/GeneralizedListComp.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/If.hs @@ -0,0 +1,4 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/LambdaCase.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/ListComp.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/MultiwayIf.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/Negate.hs @@ -0,0 +1,4 @@ +module Expr.Negate where + +y = 1 +x = -y diff --git a/examples/Expr/Operator.hs b/examples/Expr/Operator.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/Operator.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/ParListComp.hs @@ -0,0 +1,4 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/ParenName.hs @@ -0,0 +1,3 @@ +module Expr.ParenName where + +a x y = (mod) x y diff --git a/examples/Expr/PatternAndDo.hs b/examples/Expr/PatternAndDo.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/PatternAndDo.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/RecordPuns.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/RecordWildcards.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/RecursiveDo.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/SccPragma.hs @@ -0,0 +1,4 @@ +module Expr.SccPragma where + +f x = {-# SCC "drawComponent" #-} + case x of () -> () diff --git a/examples/Expr/Sections.hs b/examples/Expr/Sections.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/Sections.hs @@ -0,0 +1,4 @@ +module Expr.Sections where + +x = (1+) +y = (+1) diff --git a/examples/Expr/SemicolonDo.hs b/examples/Expr/SemicolonDo.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/SemicolonDo.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Expr/StaticPtr.hs @@ -0,0 +1,16 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/TupleSections.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TupleSections #-} +module Expr.TupleSections where + +f1 = (1,,) +f2 = (,1) + +x = (,("x", [])) diff --git a/examples/Expr/UnboxedSum.hs b/examples/Expr/UnboxedSum.hs new file mode 100644 --- /dev/null +++ b/examples/Expr/UnboxedSum.hs @@ -0,0 +1,13 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Expr/UnicodeSyntax.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/InstanceControl/Control/Instances/Morph.hs @@ -0,0 +1,149 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/InstanceControl/Control/Instances/ShortestPath.hs @@ -0,0 +1,69 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/InstanceControl/Control/Instances/Test.hs @@ -0,0 +1,23 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/InstanceControl/Control/Instances/TypeLevelPrelude.hs @@ -0,0 +1,88 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Module/DeprecatedPragma.hs @@ -0,0 +1,1 @@ +module Module.DeprecatedPragma {-# DEPRECATED "this module is deprecated" #-} where diff --git a/examples/Module/Export.hs b/examples/Module/Export.hs new file mode 100644 --- /dev/null +++ b/examples/Module/Export.hs @@ -0,0 +1,2 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Module/ExportModifiers.hs @@ -0,0 +1,4 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Module/ExportSubs.hs @@ -0,0 +1,3 @@ +module Module.ExportSubs (T(Cons, name)) where + +data T = Cons { name :: String } diff --git a/examples/Module/GhcOptionsPragma.hs b/examples/Module/GhcOptionsPragma.hs new file mode 100644 --- /dev/null +++ b/examples/Module/GhcOptionsPragma.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Module.GhcOptionsPragma where diff --git a/examples/Module/Import.hs b/examples/Module/Import.hs new file mode 100644 --- /dev/null +++ b/examples/Module/Import.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Module/ImportOp.hs @@ -0,0 +1,3 @@ +module Module.ImportOp where + +import Module.Imported ((:-)(..)) diff --git a/examples/Module/Imported.hs b/examples/Module/Imported.hs new file mode 100644 --- /dev/null +++ b/examples/Module/Imported.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Module/LangPragmas.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} +{-#LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase#-} +module Module.LangPragmas where diff --git a/examples/Module/NamespaceExport.hs b/examples/Module/NamespaceExport.hs new file mode 100644 --- /dev/null +++ b/examples/Module/NamespaceExport.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeOperators #-} +module Module.NamespaceExport (type (++)) where + +data a ++ b = Ctor diff --git a/examples/Module/PatternImport.hs b/examples/Module/PatternImport.hs new file mode 100644 --- /dev/null +++ b/examples/Module/PatternImport.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module Module.PatternImport where + +import Decl.PatternSynonym (pattern Arrow) diff --git a/examples/Module/Simple.hs b/examples/Module/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Module/Simple.hs @@ -0,0 +1,1 @@ +module Module.Simple where diff --git a/examples/Module/WarningPragma.hs b/examples/Module/WarningPragma.hs new file mode 100644 --- /dev/null +++ b/examples/Module/WarningPragma.hs @@ -0,0 +1,1 @@ +module Module.WarningPragma {-# WARNING "this module is dangerous" #-} where diff --git a/examples/Pattern/Backtick.hs b/examples/Pattern/Backtick.hs new file mode 100644 --- /dev/null +++ b/examples/Pattern/Backtick.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/Constructor.hs @@ -0,0 +1,3 @@ +module Pattern.Constructor where + +Just x = Just 1 diff --git a/examples/Pattern/ImplicitParams.hs b/examples/Pattern/ImplicitParams.hs new file mode 100644 --- /dev/null +++ b/examples/Pattern/ImplicitParams.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/Infix.hs @@ -0,0 +1,5 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/NPlusK.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/NestedWildcard.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/OperatorPattern.hs @@ -0,0 +1,3 @@ +module Pattern.OperatorPattern where + +child r (_:ps) = r ps diff --git a/examples/Pattern/Record.hs b/examples/Pattern/Record.hs new file mode 100644 --- /dev/null +++ b/examples/Pattern/Record.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Pattern/UnboxedSum.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE UnboxedSums #-} +module Pattern.UnboxedSum where + +f :: (# Int | Bool #) -> () +f (# i | #) = () +f (# | b #) = () diff --git a/examples/Refactor/CommentHandling/BlockComments.hs b/examples/Refactor/CommentHandling/BlockComments.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/CommentHandling/BlockComments.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Refactor/CommentHandling/CommentTypes.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Refactor/CommentHandling/Crosslinking.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Refactor/CommentHandling/FunctionArgs.hs @@ -0,0 +1,6 @@ +module Refactor.CommentHandling.FunctionArgs where + +f :: Int -- something + -> {-| result -} Int + -> Int -- ^ other thing +f = undefined diff --git a/examples/Refactor/ExtractBinding/AddToExisting.hs b/examples/Refactor/ExtractBinding/AddToExisting.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AddToExisting.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.AddToExisting where + +x = a ++ [] + where a = [] diff --git a/examples/Refactor/ExtractBinding/AddToExisting_res.hs b/examples/Refactor/ExtractBinding/AddToExisting_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AddToExisting_res.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.AddToExisting where + +x = a ++ b + where a = [] + b = [] diff --git a/examples/Refactor/ExtractBinding/AssocOp.hs b/examples/Refactor/ExtractBinding/AssocOp.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOp.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.AssocOp where + +a = 1 + 2 + 3 diff --git a/examples/Refactor/ExtractBinding/AssocOpMiddle.hs b/examples/Refactor/ExtractBinding/AssocOpMiddle.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOpMiddle.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.AssocOpMiddle where + +a = 1 * 2 * 3 * 4 diff --git a/examples/Refactor/ExtractBinding/AssocOpMiddle_res.hs b/examples/Refactor/ExtractBinding/AssocOpMiddle_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOpMiddle_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.AssocOpMiddle where + +a = 1 * b * 4 + where b = 2 * 3 diff --git a/examples/Refactor/ExtractBinding/AssocOpRightAssoc.hs b/examples/Refactor/ExtractBinding/AssocOpRightAssoc.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOpRightAssoc.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.AssocOpRightAssoc where + +f = id . id . id diff --git a/examples/Refactor/ExtractBinding/AssocOpRightAssoc_res.hs b/examples/Refactor/ExtractBinding/AssocOpRightAssoc_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOpRightAssoc_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.AssocOpRightAssoc where + +f = g . id + where g = id . id diff --git a/examples/Refactor/ExtractBinding/AssocOp_res.hs b/examples/Refactor/ExtractBinding/AssocOp_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/AssocOp_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.AssocOp where + +a = 1 + b + where b = 2 + 3 diff --git a/examples/Refactor/ExtractBinding/Case.hs b/examples/Refactor/ExtractBinding/Case.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Case.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.Case where + +f a = case a of (x,y) -> x + y diff --git a/examples/Refactor/ExtractBinding/Case_res.hs b/examples/Refactor/ExtractBinding/Case_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Case_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.Case where + +f a = case a of (x,y) -> g x y + where g x y = x + y diff --git a/examples/Refactor/ExtractBinding/ClassInstance.hs b/examples/Refactor/ExtractBinding/ClassInstance.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ClassInstance.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.ClassInstance where + +data Better a = Better a + +instance Functor Better where + fmap f (Better a) = Better (f a) diff --git a/examples/Refactor/ExtractBinding/ClassInstance_res.hs b/examples/Refactor/ExtractBinding/ClassInstance_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ClassInstance_res.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.ClassInstance where + +data Better a = Better a + +instance Functor Better where + fmap f (Better a) = Better g + where g = f a diff --git a/examples/Refactor/ExtractBinding/ExistingLocalDef.hs b/examples/Refactor/ExtractBinding/ExistingLocalDef.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ExistingLocalDef.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.ExistingLocalDef where + +f = 1 + 2 + 3 + where diff --git a/examples/Refactor/ExtractBinding/ExistingLocalDef_res.hs b/examples/Refactor/ExtractBinding/ExistingLocalDef_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ExistingLocalDef_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.ExistingLocalDef where + +f = a + 3 + where a = 1 + 2 diff --git a/examples/Refactor/ExtractBinding/ExtractedFormatting.hs b/examples/Refactor/ExtractBinding/ExtractedFormatting.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ExtractedFormatting.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.ExtractedFormatting where + +stms + = id + . id diff --git a/examples/Refactor/ExtractBinding/ExtractedFormatting_res.hs b/examples/Refactor/ExtractBinding/ExtractedFormatting_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ExtractedFormatting_res.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.ExtractedFormatting where + +stms + = extracted + where extracted = id + . id diff --git a/examples/Refactor/ExtractBinding/Indentation.hs b/examples/Refactor/ExtractBinding/Indentation.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Indentation.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.Indentation where + +f a = case Just a of + Nothing -> 0 + Just x -> x diff --git a/examples/Refactor/ExtractBinding/IndentationMultiLine.hs b/examples/Refactor/ExtractBinding/IndentationMultiLine.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/IndentationMultiLine.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.IndentationMultiLine where + +f a = case Just a of + Nothing + -> 0 + Just x + -> x diff --git a/examples/Refactor/ExtractBinding/IndentationMultiLine_res.hs b/examples/Refactor/ExtractBinding/IndentationMultiLine_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/IndentationMultiLine_res.hs @@ -0,0 +1,8 @@ +module Refactor.ExtractBinding.IndentationMultiLine where + +f a = case extracted of + Nothing + -> 0 + Just x + -> x + where extracted = Just a diff --git a/examples/Refactor/ExtractBinding/IndentationOperator.hs b/examples/Refactor/ExtractBinding/IndentationOperator.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/IndentationOperator.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.IndentationOperator where + +f aaa bbb = id . id $ + aaa + ++ bbb diff --git a/examples/Refactor/ExtractBinding/IndentationOperator_res.hs b/examples/Refactor/ExtractBinding/IndentationOperator_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/IndentationOperator_res.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.IndentationOperator where + +f aaa bbb = extracted $ + aaa + ++ bbb + where extracted = id . id diff --git a/examples/Refactor/ExtractBinding/Indentation_res.hs b/examples/Refactor/ExtractBinding/Indentation_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Indentation_res.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.Indentation where + +f a = case extracted of + Nothing -> 0 + Just x -> x + where extracted = Just a diff --git a/examples/Refactor/ExtractBinding/LeftSection.hs b/examples/Refactor/ExtractBinding/LeftSection.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/LeftSection.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.LeftSection where + +a = 1 + 2 diff --git a/examples/Refactor/ExtractBinding/LeftSection_res.hs b/examples/Refactor/ExtractBinding/LeftSection_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/LeftSection_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.LeftSection where + +a = f 2 + where f = (1 +) diff --git a/examples/Refactor/ExtractBinding/ListComprehension.hs b/examples/Refactor/ExtractBinding/ListComprehension.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ListComprehension.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.ListComprehension where + +filterPrime (p:xs) = + p : filterPrime [ x | x <- xs + , x `mod` p /= 0 ] diff --git a/examples/Refactor/ExtractBinding/ListComprehension_res.hs b/examples/Refactor/ExtractBinding/ListComprehension_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ListComprehension_res.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.ListComprehension where + +filterPrime (p:xs) = + p : filterPrime [ x | x <- xs + , notDivisible x ] + where notDivisible x = x `mod` p /= 0 diff --git a/examples/Refactor/ExtractBinding/LocalDefinition.hs b/examples/Refactor/ExtractBinding/LocalDefinition.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/LocalDefinition.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.LocalDefinition where + +stms = x + where x = "s" diff --git a/examples/Refactor/ExtractBinding/LocalDefinition_res.hs b/examples/Refactor/ExtractBinding/LocalDefinition_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/LocalDefinition_res.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.LocalDefinition where + +stms = x + where x = y + where y = "s" diff --git a/examples/Refactor/ExtractBinding/NameConflict.hs b/examples/Refactor/ExtractBinding/NameConflict.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/NameConflict.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.NameConflict where + +stms = map (\s -> s ++ bang) ["a", "b"] + where bang = "!" diff --git a/examples/Refactor/ExtractBinding/Parentheses.hs b/examples/Refactor/ExtractBinding/Parentheses.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Parentheses.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.Parentheses where + +distance p1 p2 = sqrt ((x p1 - x p2) ^ 2 + (y p1 - y p2) ^ 2) + +-- try to rename the type, the constructor or the fields +data Point = Point { x :: Double, y :: Double } diff --git a/examples/Refactor/ExtractBinding/Parentheses_res.hs b/examples/Refactor/ExtractBinding/Parentheses_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Parentheses_res.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.Parentheses where + +distance p1 p2 = sqrt sqDistance + where sqDistance = (x p1 - x p2) ^ 2 + (y p1 - y p2) ^ 2 + +-- try to rename the type, the constructor or the fields +data Point = Point { x :: Double, y :: Double } diff --git a/examples/Refactor/ExtractBinding/RecordWildcards.hs b/examples/Refactor/ExtractBinding/RecordWildcards.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/RecordWildcards.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} +module Refactor.ExtractBinding.RecordWildcards where + +data Point = Point { x :: Double, y :: Double } + +d = (\(Point {..}) -> x + y) (Point 1 2) diff --git a/examples/Refactor/ExtractBinding/RecordWildcards_res.hs b/examples/Refactor/ExtractBinding/RecordWildcards_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/RecordWildcards_res.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +module Refactor.ExtractBinding.RecordWildcards where + +data Point = Point { x :: Double, y :: Double } + +d = plus (Point 1 2) + where plus (Point {..}) = x + y diff --git a/examples/Refactor/ExtractBinding/Records.hs b/examples/Refactor/ExtractBinding/Records.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Records.hs @@ -0,0 +1,5 @@ +module Refactor.ExtractBinding.Records where + +data Point = Point { x :: Double, y :: Double } + +d = (\(Point {x = x, y = y}) -> x + y) (Point 1 2) diff --git a/examples/Refactor/ExtractBinding/Records_res.hs b/examples/Refactor/ExtractBinding/Records_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Records_res.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.Records where + +data Point = Point { x :: Double, y :: Double } + +d = plus (Point 1 2) + where plus (Point {x = x, y = y}) = x + y diff --git a/examples/Refactor/ExtractBinding/RightSection.hs b/examples/Refactor/ExtractBinding/RightSection.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/RightSection.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.RightSection where + +a = 1 + 2 diff --git a/examples/Refactor/ExtractBinding/RightSection_res.hs b/examples/Refactor/ExtractBinding/RightSection_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/RightSection_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.RightSection where + +a = f 1 + where f = (+ 2) diff --git a/examples/Refactor/ExtractBinding/SectionInfix.hs b/examples/Refactor/ExtractBinding/SectionInfix.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SectionInfix.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.SectionInfix where + +a = 1 + 2 + 3 diff --git a/examples/Refactor/ExtractBinding/SectionInfix_res.hs b/examples/Refactor/ExtractBinding/SectionInfix_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SectionInfix_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.SectionInfix where + +a = f 3 + where f = ((1 + 2) +) diff --git a/examples/Refactor/ExtractBinding/SectionWithLocals.hs b/examples/Refactor/ExtractBinding/SectionWithLocals.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SectionWithLocals.hs @@ -0,0 +1,6 @@ +module Refactor.ExtractBinding.SectionWithLocals where + +a x = let y = 2 + z = 3 + (<->) = (-) + in x <-> (y + z) diff --git a/examples/Refactor/ExtractBinding/SectionWithLocals_res.hs b/examples/Refactor/ExtractBinding/SectionWithLocals_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SectionWithLocals_res.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.SectionWithLocals where + +a x = let y = 2 + z = 3 + (<->) = (-) + in f y z (<->) x + where f y z (<->) = (<-> (y + z)) diff --git a/examples/Refactor/ExtractBinding/SiblingDefs.hs b/examples/Refactor/ExtractBinding/SiblingDefs.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SiblingDefs.hs @@ -0,0 +1,7 @@ +module Refactor.ExtractBinding.SiblingDefs where + +f = 1 + where + g = a + where a = 1 + h = 2 diff --git a/examples/Refactor/ExtractBinding/SiblingDefs_res.hs b/examples/Refactor/ExtractBinding/SiblingDefs_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/SiblingDefs_res.hs @@ -0,0 +1,8 @@ +module Refactor.ExtractBinding.SiblingDefs where + +f = 1 + where + g = a + where a = 1 + h = a + where a = 2 diff --git a/examples/Refactor/ExtractBinding/Simple.hs b/examples/Refactor/ExtractBinding/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Simple.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.Simple where + +stms = map (\s -> s ++ "!") ["a", "b"] diff --git a/examples/Refactor/ExtractBinding/Simple_res.hs b/examples/Refactor/ExtractBinding/Simple_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/Simple_res.hs @@ -0,0 +1,4 @@ +module Refactor.ExtractBinding.Simple where + +stms = map (\s -> exaggerate s) ["a", "b"] + where exaggerate s = s ++ "!" diff --git a/examples/Refactor/ExtractBinding/TooSimple.hs b/examples/Refactor/ExtractBinding/TooSimple.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/TooSimple.hs @@ -0,0 +1,3 @@ +module Refactor.ExtractBinding.TooSimple where + +stms = map (\s -> s ++ "!") ["a", "b"] diff --git a/examples/Refactor/ExtractBinding/ViewPattern.hs b/examples/Refactor/ExtractBinding/ViewPattern.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/ExtractBinding/ViewPattern.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} +module Refactor.ExtractBinding.ViewPattern where + +f (id . id -> x) = x diff --git a/examples/Refactor/FloatOut/FloatLocals.hs b/examples/Refactor/FloatOut/FloatLocals.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/FloatLocals.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.FloatLocals where + +f = g + where g = h + where h = id diff --git a/examples/Refactor/FloatOut/FloatLocals_res.hs b/examples/Refactor/FloatOut/FloatLocals_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/FloatLocals_res.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.FloatLocals where + +f = g + where g = h + h = id diff --git a/examples/Refactor/FloatOut/ImplicitLocal.hs b/examples/Refactor/FloatOut/ImplicitLocal.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/ImplicitLocal.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.ImplicitLocal where + +f = g + where g = h + h = () diff --git a/examples/Refactor/FloatOut/ImplicitParam.hs b/examples/Refactor/FloatOut/ImplicitParam.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/ImplicitParam.hs @@ -0,0 +1,4 @@ +module Refactor.FloatOut.ImplicitParam where + +f a = g + where g = a diff --git a/examples/Refactor/FloatOut/MoveFixity.hs b/examples/Refactor/FloatOut/MoveFixity.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/MoveFixity.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.MoveFixity where + +f = 3 <+> 4 + where infixl 6 <+> + a <+> b = a + b diff --git a/examples/Refactor/FloatOut/MoveFixity_res.hs b/examples/Refactor/FloatOut/MoveFixity_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/MoveFixity_res.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.MoveFixity where + +f = 3 <+> 4 +infixl 6 <+> +a <+> b = a + b diff --git a/examples/Refactor/FloatOut/MoveSignature.hs b/examples/Refactor/FloatOut/MoveSignature.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/MoveSignature.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.MoveSignature where + +f = g + where g :: a -> a + g = id diff --git a/examples/Refactor/FloatOut/MoveSignature_res.hs b/examples/Refactor/FloatOut/MoveSignature_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/MoveSignature_res.hs @@ -0,0 +1,5 @@ +module Refactor.FloatOut.MoveSignature where + +f = g +g :: a -> a +g = id diff --git a/examples/Refactor/FloatOut/NameCollosion.hs b/examples/Refactor/FloatOut/NameCollosion.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/NameCollosion.hs @@ -0,0 +1,6 @@ +module Refactor.FloatOut.NameCollosion where + +f = g + where g = id + +g = () diff --git a/examples/Refactor/FloatOut/NameCollosionWithImport.hs b/examples/Refactor/FloatOut/NameCollosionWithImport.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/NameCollosionWithImport.hs @@ -0,0 +1,4 @@ +module Refactor.FloatOut.NameCollosionWithImport where + +f = id + where id = () diff --git a/examples/Refactor/FloatOut/NameCollosionWithLocal.hs b/examples/Refactor/FloatOut/NameCollosionWithLocal.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/NameCollosionWithLocal.hs @@ -0,0 +1,6 @@ +module Refactor.FloatOut.NameCollosionWithLocal where + +f = g + where g = h + where h = id + h = () diff --git a/examples/Refactor/FloatOut/NoCollosion.hs b/examples/Refactor/FloatOut/NoCollosion.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/NoCollosion.hs @@ -0,0 +1,7 @@ +module Refactor.FloatOut.NoCollosion where + +f = g + where g = h + where h = id + +h = () diff --git a/examples/Refactor/FloatOut/NoCollosion_res.hs b/examples/Refactor/FloatOut/NoCollosion_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/NoCollosion_res.hs @@ -0,0 +1,7 @@ +module Refactor.FloatOut.NoCollosion where + +f = g + where g = h + h = id + +h = () diff --git a/examples/Refactor/FloatOut/SharedSignature.hs b/examples/Refactor/FloatOut/SharedSignature.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/SharedSignature.hs @@ -0,0 +1,6 @@ +module Refactor.FloatOut.SharedSignature where + +f = g + where g, h :: a -> a + g = id + h = id diff --git a/examples/Refactor/FloatOut/ToTopLevel.hs b/examples/Refactor/FloatOut/ToTopLevel.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/ToTopLevel.hs @@ -0,0 +1,4 @@ +module Refactor.FloatOut.ToTopLevel where + +f = g + where g = id diff --git a/examples/Refactor/FloatOut/ToTopLevel_res.hs b/examples/Refactor/FloatOut/ToTopLevel_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/FloatOut/ToTopLevel_res.hs @@ -0,0 +1,4 @@ +module Refactor.FloatOut.ToTopLevel where + +f = g +g = id diff --git a/examples/Refactor/GenerateExports/Normal.hs b/examples/Refactor/GenerateExports/Normal.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateExports/Normal.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +module Refactor.GenerateExports.Normal where + +function :: Int -> Int +function a = a + +data TypeCtor = DataCtor { recordName :: Int } + +class TypeClass a where + classFunction :: a -> a + +type family TypeFamily a :: * + +data family DataFamily a :: * + +foreign import ccall "exp" c_exp :: Double -> Double + diff --git a/examples/Refactor/GenerateExports/Normal_res.hs b/examples/Refactor/GenerateExports/Normal_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateExports/Normal_res.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +module Refactor.GenerateExports.Normal (function, TypeCtor(..), TypeClass(..), TypeFamily, DataFamily, c_exp) where + +function :: Int -> Int +function a = a + +data TypeCtor = DataCtor { recordName :: Int } + +class TypeClass a where + classFunction :: a -> a + +type family TypeFamily a :: * + +data family DataFamily a :: * + +foreign import ccall "exp" c_exp :: Double -> Double + diff --git a/examples/Refactor/GenerateExports/Operators.hs b/examples/Refactor/GenerateExports/Operators.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateExports/Operators.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeOperators #-} +module Refactor.GenerateExports.Operators where + +(|=>|) :: Int -> Int -> Int +a |=>| b = a + b + +data a :+: b = a :+: b diff --git a/examples/Refactor/GenerateExports/Operators_res.hs b/examples/Refactor/GenerateExports/Operators_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateExports/Operators_res.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeOperators #-} +module Refactor.GenerateExports.Operators ((|=>|), (:+:)(..)) where + +(|=>|) :: Int -> Int -> Int +a |=>| b = a + b + +data a :+: b = a :+: b diff --git a/examples/Refactor/GenerateTypeSignature/BringToScope/A.hs b/examples/Refactor/GenerateTypeSignature/BringToScope/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/BringToScope/A.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.BringToScope.A where + +data T = T +data S = S diff --git a/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport.hs b/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.BringToScope.AlreadyQualImport where + +import Refactor.GenerateTypeSignature.BringToScope.B +import qualified Refactor.GenerateTypeSignature.BringToScope.A as AAA (S) + +g = f diff --git a/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport_res.hs b/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/BringToScope/AlreadyQualImport_res.hs @@ -0,0 +1,8 @@ +module Refactor.GenerateTypeSignature.BringToScope.AlreadyQualImport where + +import Refactor.GenerateTypeSignature.BringToScope.B +import qualified Refactor.GenerateTypeSignature.BringToScope.A as AAA (S) +import qualified Refactor.GenerateTypeSignature.BringToScope.A(T) + +g :: Refactor.GenerateTypeSignature.BringToScope.A.T -> AAA.S +g = f diff --git a/examples/Refactor/GenerateTypeSignature/BringToScope/B.hs b/examples/Refactor/GenerateTypeSignature/BringToScope/B.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/BringToScope/B.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.BringToScope.B where + +import Refactor.GenerateTypeSignature.BringToScope.A + +f :: T -> S +f = const S diff --git a/examples/Refactor/GenerateTypeSignature/CanCaptureVariable.hs b/examples/Refactor/GenerateTypeSignature/CanCaptureVariable.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CanCaptureVariable.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Refactor.GenerateTypeSignature.CanCaptureVariable where + +import qualified Data.Map as Map + +insertMany :: forall k v . (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 (k,v) m = Map.insertWith accf k v m diff --git a/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef.hs b/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Refactor.GenerateTypeSignature.CanCaptureVariableHasOtherDef where + +import qualified Data.Map as Map + +insertMany :: forall k v . (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 (k,v) m = Map.insertWith accf k v m + +someOtherFun :: (k,v) -> (k,v) +someOtherFun = id diff --git a/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef_res.hs b/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CanCaptureVariableHasOtherDef_res.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Refactor.GenerateTypeSignature.CanCaptureVariableHasOtherDef where + +import qualified Data.Map as Map + +insertMany :: forall k v . (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 :: Ord k => (k, v) -> Map.Map k v -> Map.Map k v + f1 (k,v) m = Map.insertWith accf k v m + +someOtherFun :: (k,v) -> (k,v) +someOtherFun = id diff --git a/examples/Refactor/GenerateTypeSignature/CanCaptureVariable_res.hs b/examples/Refactor/GenerateTypeSignature/CanCaptureVariable_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CanCaptureVariable_res.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Refactor.GenerateTypeSignature.CanCaptureVariable where + +import qualified Data.Map as Map + +insertMany :: forall k v . (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 :: Ord k => (k, v) -> Map.Map k v -> Map.Map k v + f1 (k,v) m = Map.insertWith accf k v m diff --git a/examples/Refactor/GenerateTypeSignature/CannotCaptureVariable.hs b/examples/Refactor/GenerateTypeSignature/CannotCaptureVariable.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CannotCaptureVariable.hs @@ -0,0 +1,7 @@ +module Refactor.GenerateTypeSignature.CannotCaptureVariable where + +import qualified Data.Map as Map + +insertMany :: (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 (k,v) m = Map.insertWith accf k v m diff --git a/examples/Refactor/GenerateTypeSignature/CannotCaptureVariableNoExt.hs b/examples/Refactor/GenerateTypeSignature/CannotCaptureVariableNoExt.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/CannotCaptureVariableNoExt.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} +module Refactor.GenerateTypeSignature.CannotCaptureVariableNoExt where + +import qualified Data.Map as Map + +insertMany :: forall k v . (Ord k) => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany accf vs m = foldr f1 m vs + where f1 (k,v) m = Map.insertWith accf k v m diff --git a/examples/Refactor/GenerateTypeSignature/Complex.hs b/examples/Refactor/GenerateTypeSignature/Complex.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Complex.hs @@ -0,0 +1,3 @@ +module Refactor.GenerateTypeSignature.Complex where + +app f x = f (Just x) diff --git a/examples/Refactor/GenerateTypeSignature/ComplexLhs.hs b/examples/Refactor/GenerateTypeSignature/ComplexLhs.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/ComplexLhs.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.ComplexLhs where + +(x) = 3 +Just y = Just 4 +(a,b) = (1,2) +[c,d,e] = [1,2,3] diff --git a/examples/Refactor/GenerateTypeSignature/Complex_res.hs b/examples/Refactor/GenerateTypeSignature/Complex_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Complex_res.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Complex where + +app :: (Maybe a -> t) -> a -> t +app f x = f (Just x) diff --git a/examples/Refactor/GenerateTypeSignature/Function.hs b/examples/Refactor/GenerateTypeSignature/Function.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Function.hs @@ -0,0 +1,3 @@ +module Refactor.GenerateTypeSignature.Function where + +identity x = x diff --git a/examples/Refactor/GenerateTypeSignature/Function_res.hs b/examples/Refactor/GenerateTypeSignature/Function_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Function_res.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Function where + +identity :: p -> p +identity x = x diff --git a/examples/Refactor/GenerateTypeSignature/HigherOrder.hs b/examples/Refactor/GenerateTypeSignature/HigherOrder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/HigherOrder.hs @@ -0,0 +1,3 @@ +module Refactor.GenerateTypeSignature.HigherOrder where + +app f x = f x diff --git a/examples/Refactor/GenerateTypeSignature/HigherOrder_res.hs b/examples/Refactor/GenerateTypeSignature/HigherOrder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/HigherOrder_res.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.HigherOrder where + +app :: (t1 -> t2) -> t1 -> t2 +app f x = f x diff --git a/examples/Refactor/GenerateTypeSignature/Let.hs b/examples/Refactor/GenerateTypeSignature/Let.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Let.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Let where + +x = let unit = () + in () diff --git a/examples/Refactor/GenerateTypeSignature/Let_res.hs b/examples/Refactor/GenerateTypeSignature/Let_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Let_res.hs @@ -0,0 +1,5 @@ +module Refactor.GenerateTypeSignature.Let where + +x = let unit :: () + unit = () + in () diff --git a/examples/Refactor/GenerateTypeSignature/Local.hs b/examples/Refactor/GenerateTypeSignature/Local.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Local.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Local where + +x = () where + unit = () diff --git a/examples/Refactor/GenerateTypeSignature/Local_res.hs b/examples/Refactor/GenerateTypeSignature/Local_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Local_res.hs @@ -0,0 +1,5 @@ +module Refactor.GenerateTypeSignature.Local where + +x = () where + unit :: () + unit = () diff --git a/examples/Refactor/GenerateTypeSignature/Placement.hs b/examples/Refactor/GenerateTypeSignature/Placement.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Placement.hs @@ -0,0 +1,5 @@ +module Refactor.GenerateTypeSignature.Placement where + +otherThing = () +unit = () +anotherThing = () diff --git a/examples/Refactor/GenerateTypeSignature/Placement_res.hs b/examples/Refactor/GenerateTypeSignature/Placement_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Placement_res.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.Placement where + +otherThing = () +unit :: () +unit = () +anotherThing = () diff --git a/examples/Refactor/GenerateTypeSignature/Polymorph.hs b/examples/Refactor/GenerateTypeSignature/Polymorph.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Polymorph.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.Polymorph where + +three = 3 + +four :: Int +four = three + 1 diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSub.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSub.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSub.hs @@ -0,0 +1,5 @@ +module Refactor.GenerateTypeSignature.PolymorphSub where + +f :: Num a => a -> a +f a = g a where + g a = a + 1 diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti.hs @@ -0,0 +1,5 @@ +module Refactor.GenerateTypeSignature.PolymorphSubMulti where + +f :: (Num a, Ord a) => a -> a +f a = g a where + g a = if a > 0 then a + 1 else a diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSubMulti_res.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.PolymorphSubMulti where + +f :: (Num a, Ord a) => a -> a +f a = g a where + g :: (Num p, Ord p) => p -> p + g a = if a > 0 then a + 1 else a diff --git a/examples/Refactor/GenerateTypeSignature/PolymorphSub_res.hs b/examples/Refactor/GenerateTypeSignature/PolymorphSub_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/PolymorphSub_res.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.PolymorphSub where + +f :: Num a => a -> a +f a = g a where + g :: Num a => a -> a + g a = a + 1 diff --git a/examples/Refactor/GenerateTypeSignature/Polymorph_res.hs b/examples/Refactor/GenerateTypeSignature/Polymorph_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Polymorph_res.hs @@ -0,0 +1,7 @@ +module Refactor.GenerateTypeSignature.Polymorph where + +three :: Int +three = 3 + +four :: Int +four = three + 1 diff --git a/examples/Refactor/GenerateTypeSignature/Simple.hs b/examples/Refactor/GenerateTypeSignature/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Simple.hs @@ -0,0 +1,3 @@ +module Refactor.GenerateTypeSignature.Simple where + +unit = () diff --git a/examples/Refactor/GenerateTypeSignature/Simple_res.hs b/examples/Refactor/GenerateTypeSignature/Simple_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Simple_res.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Simple where + +unit :: () +unit = () diff --git a/examples/Refactor/GenerateTypeSignature/Tuple.hs b/examples/Refactor/GenerateTypeSignature/Tuple.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Tuple.hs @@ -0,0 +1,3 @@ +module Refactor.GenerateTypeSignature.Tuple where + +tuple x y = (x,y) diff --git a/examples/Refactor/GenerateTypeSignature/Tuple_res.hs b/examples/Refactor/GenerateTypeSignature/Tuple_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/Tuple_res.hs @@ -0,0 +1,4 @@ +module Refactor.GenerateTypeSignature.Tuple where + +tuple :: a -> b -> (a, b) +tuple x y = (x,y) diff --git a/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule.hs b/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule.hs @@ -0,0 +1,6 @@ +module Refactor.GenerateTypeSignature.TypeDefinedInModule where + +distance p1 p2 = sqrt ((x p1 - x p2) ^ 2 + (y p1 - y p2) ^ 2) + +data Point = Point { x :: Double, y :: Double } + diff --git a/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule_res.hs b/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/GenerateTypeSignature/TypeDefinedInModule_res.hs @@ -0,0 +1,7 @@ +module Refactor.GenerateTypeSignature.TypeDefinedInModule where + +distance :: Point -> Point -> Double +distance p1 p2 = sqrt ((x p1 - x p2) ^ 2 + (y p1 - y p2) ^ 2) + +data Point = Point { x :: Double, y :: Double } + diff --git a/examples/Refactor/InlineBinding/AlreadyApplied.hs b/examples/Refactor/InlineBinding/AlreadyApplied.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AlreadyApplied.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.AlreadyApplied where + +b u v = a u v +a x y = x ++ y diff --git a/examples/Refactor/InlineBinding/AlreadyApplied_res.hs b/examples/Refactor/InlineBinding/AlreadyApplied_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AlreadyApplied_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.AlreadyApplied where + +b u v = (u ++ v) diff --git a/examples/Refactor/InlineBinding/AppearsInAnother/A.hs b/examples/Refactor/InlineBinding/AppearsInAnother/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AppearsInAnother/A.hs @@ -0,0 +1,3 @@ +module A where + +a = () diff --git a/examples/Refactor/InlineBinding/AppearsInAnother/B.hs b/examples/Refactor/InlineBinding/AppearsInAnother/B.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AppearsInAnother/B.hs @@ -0,0 +1,5 @@ +module B where + +import A + +b = a diff --git a/examples/Refactor/InlineBinding/AutoNaming.hs b/examples/Refactor/InlineBinding/AutoNaming.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AutoNaming.hs @@ -0,0 +1,5 @@ +module Refactor.InlineBinding.Simplest where + +b = a +a x = x +x1 = () diff --git a/examples/Refactor/InlineBinding/AutoNaming_res.hs b/examples/Refactor/InlineBinding/AutoNaming_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/AutoNaming_res.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Simplest where + +b = (\x2 -> x2) +x1 = () diff --git a/examples/Refactor/InlineBinding/FilterSignatures.hs b/examples/Refactor/InlineBinding/FilterSignatures.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/FilterSignatures.hs @@ -0,0 +1,7 @@ +module Refactor.InlineBinding.FilterSignatures where + +b u v = u <++> v +(<++>), (<**>) :: String -> String -> String +x <++> y = x ++ y +x <**> y = y ++ x +infixl 7 <++>, <**> diff --git a/examples/Refactor/InlineBinding/FilterSignatures_res.hs b/examples/Refactor/InlineBinding/FilterSignatures_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/FilterSignatures_res.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.FilterSignatures where + +b u v = (u ++ v) +(<**>) :: String -> String -> String +x <**> y = y ++ x +infixl 7 <**> diff --git a/examples/Refactor/InlineBinding/InExportList.hs b/examples/Refactor/InlineBinding/InExportList.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/InExportList.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.InExportList (a) where + +b = a +a = () diff --git a/examples/Refactor/InlineBinding/LetBind.hs b/examples/Refactor/InlineBinding/LetBind.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetBind.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.LetBind where + +a = let x = () in x diff --git a/examples/Refactor/InlineBinding/LetBind_res.hs b/examples/Refactor/InlineBinding/LetBind_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetBind_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.LetBind where + +a = () diff --git a/examples/Refactor/InlineBinding/LetGuard.hs b/examples/Refactor/InlineBinding/LetGuard.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetGuard.hs @@ -0,0 +1,5 @@ +module Refactor.InlineBinding.LetGuard where + +a | let x = 3 + , x == 3 + = () diff --git a/examples/Refactor/InlineBinding/LetGuard_res.hs b/examples/Refactor/InlineBinding/LetGuard_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetGuard_res.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.LetGuard where + +a | 3 == 3 + = () diff --git a/examples/Refactor/InlineBinding/LetStmt.hs b/examples/Refactor/InlineBinding/LetStmt.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetStmt.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.LetStmt where + +a = do let x = () + putStrLn (show x) diff --git a/examples/Refactor/InlineBinding/LetStmt_res.hs b/examples/Refactor/InlineBinding/LetStmt_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LetStmt_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.LetStmt where + +a = do putStrLn (show ()) diff --git a/examples/Refactor/InlineBinding/Local.hs b/examples/Refactor/InlineBinding/Local.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Local.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Local where + +b = a + where a = () diff --git a/examples/Refactor/InlineBinding/LocalNested.hs b/examples/Refactor/InlineBinding/LocalNested.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LocalNested.hs @@ -0,0 +1,5 @@ +module Refactor.InlineBinding.LocalNested where + +a = b + where b = c + where c = () diff --git a/examples/Refactor/InlineBinding/LocalNested_res.hs b/examples/Refactor/InlineBinding/LocalNested_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/LocalNested_res.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.LocalNested where + +a = b + where b = () diff --git a/examples/Refactor/InlineBinding/Local_res.hs b/examples/Refactor/InlineBinding/Local_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Local_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.Local where + +b = () diff --git a/examples/Refactor/InlineBinding/MultiApplied.hs b/examples/Refactor/InlineBinding/MultiApplied.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiApplied.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.MultiApplied where + +b u v = a u v +a x "a" = x +a "a" y = y +a x y = x ++ y diff --git a/examples/Refactor/InlineBinding/MultiApplied_res.hs b/examples/Refactor/InlineBinding/MultiApplied_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiApplied_res.hs @@ -0,0 +1,5 @@ +module Refactor.InlineBinding.MultiApplied where + +b u v = (case (u, v) of (x, "a") -> x + ("a", y) -> y + (x, y) -> x ++ y) diff --git a/examples/Refactor/InlineBinding/MultiMatch.hs b/examples/Refactor/InlineBinding/MultiMatch.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiMatch.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.MultiMatch where + +b = a +a x "a" = x +a "a" y = y +a x y = x ++ y diff --git a/examples/Refactor/InlineBinding/MultiMatchGuarded.hs b/examples/Refactor/InlineBinding/MultiMatchGuarded.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiMatchGuarded.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.MultiMatchGuarded where + +b u v = a u v +a x y | x == y + = x +a x y = x ++ y diff --git a/examples/Refactor/InlineBinding/MultiMatchGuarded_res.hs b/examples/Refactor/InlineBinding/MultiMatchGuarded_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiMatchGuarded_res.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.MultiMatchGuarded where + +b u v = (case (u, v) of (x, y) | x == y -> x + (x, y) -> x ++ y) diff --git a/examples/Refactor/InlineBinding/MultiMatch_res.hs b/examples/Refactor/InlineBinding/MultiMatch_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/MultiMatch_res.hs @@ -0,0 +1,5 @@ +module Refactor.InlineBinding.MultiMatch where + +b = (\x1 x2 -> case (x1, x2) of (x, "a") -> x + ("a", y) -> y + (x, y) -> x ++ y) diff --git a/examples/Refactor/InlineBinding/Nested.hs b/examples/Refactor/InlineBinding/Nested.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Nested.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Nested where + +b = f (f ()) +f a = a diff --git a/examples/Refactor/InlineBinding/Nested_res.hs b/examples/Refactor/InlineBinding/Nested_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Nested_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.Nested where + +b = (()) diff --git a/examples/Refactor/InlineBinding/NotOccurring.hs b/examples/Refactor/InlineBinding/NotOccurring.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/NotOccurring.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.NotOccurring where + +a = () diff --git a/examples/Refactor/InlineBinding/Operator.hs b/examples/Refactor/InlineBinding/Operator.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Operator.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Operator where + +b u v = u <++> v +x <++> y = x ++ y diff --git a/examples/Refactor/InlineBinding/Operator_res.hs b/examples/Refactor/InlineBinding/Operator_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Operator_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.Operator where + +b u v = (u ++ v) diff --git a/examples/Refactor/InlineBinding/PatternMatched.hs b/examples/Refactor/InlineBinding/PatternMatched.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/PatternMatched.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.PatternMatched where + +b u v = a (Just u) v +a (Just x) (Just y) = x ++ y diff --git a/examples/Refactor/InlineBinding/PatternMatched_res.hs b/examples/Refactor/InlineBinding/PatternMatched_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/PatternMatched_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.PatternMatched where + +b u v = ((\(Just y) -> u ++ y) v) diff --git a/examples/Refactor/InlineBinding/Recursive.hs b/examples/Refactor/InlineBinding/Recursive.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Recursive.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Recursive where + +b = f () +f a = f a diff --git a/examples/Refactor/InlineBinding/RemoveSignatures.hs b/examples/Refactor/InlineBinding/RemoveSignatures.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/RemoveSignatures.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.RemoveSignatures where + +b u v = u <++> v +(<++>) :: String -> String -> String +x <++> y = x ++ y +infixl 7 <++> diff --git a/examples/Refactor/InlineBinding/RemoveSignatures_res.hs b/examples/Refactor/InlineBinding/RemoveSignatures_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/RemoveSignatures_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.RemoveSignatures where + +b u v = (u ++ v) diff --git a/examples/Refactor/InlineBinding/SimpleMultiMatch.hs b/examples/Refactor/InlineBinding/SimpleMultiMatch.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/SimpleMultiMatch.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.SimpleMultiMatch where + +b = a +a x y = x ++ y diff --git a/examples/Refactor/InlineBinding/SimpleMultiMatch_res.hs b/examples/Refactor/InlineBinding/SimpleMultiMatch_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/SimpleMultiMatch_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.SimpleMultiMatch where + +b = (\x y -> x ++ y) diff --git a/examples/Refactor/InlineBinding/Simplest.hs b/examples/Refactor/InlineBinding/Simplest.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Simplest.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.Simplest where + +b = a +a = () diff --git a/examples/Refactor/InlineBinding/Simplest_res.hs b/examples/Refactor/InlineBinding/Simplest_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/Simplest_res.hs @@ -0,0 +1,3 @@ +module Refactor.InlineBinding.Simplest where + +b = () diff --git a/examples/Refactor/InlineBinding/WithLocals.hs b/examples/Refactor/InlineBinding/WithLocals.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/WithLocals.hs @@ -0,0 +1,6 @@ +module Refactor.InlineBinding.WithLocals where + +b = a +a = x y + where x = id + y = () diff --git a/examples/Refactor/InlineBinding/WithLocals_res.hs b/examples/Refactor/InlineBinding/WithLocals_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/InlineBinding/WithLocals_res.hs @@ -0,0 +1,4 @@ +module Refactor.InlineBinding.WithLocals where + +b = (let x = id + y = () in x y) diff --git a/examples/Refactor/OrganizeImports/Class.hs b/examples/Refactor/OrganizeImports/Class.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Class.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Class where + +import Decl.TypeClass (C(f)) +import Decl.TypeInstance + +test = f A diff --git a/examples/Refactor/OrganizeImports/Class_res.hs b/examples/Refactor/OrganizeImports/Class_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Class_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Class where + +import Decl.TypeClass (C(f)) +import Decl.TypeInstance (A(..)) + +test = f A diff --git a/examples/Refactor/OrganizeImports/Coerce.hs b/examples/Refactor/OrganizeImports/Coerce.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Coerce.hs @@ -0,0 +1,11 @@ +module Refactor.OrganizeImports.Coerce where + +import Prelude () +import Data.Maybe (Maybe(Just, Nothing)) +import Data.List +import Data.Coerce (coerce) + +newtype Mayb' a = Mayb' (Maybe a) + +a :: Mayb' a -> Maybe a +a = coerce diff --git a/examples/Refactor/OrganizeImports/Coerce_res.hs b/examples/Refactor/OrganizeImports/Coerce_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Coerce_res.hs @@ -0,0 +1,11 @@ +module Refactor.OrganizeImports.Coerce where + +import Data.Coerce (coerce) +import Data.List +import Data.Maybe (Maybe(Just, Nothing)) +import Prelude () + +newtype Mayb' a = Mayb' (Maybe a) + +a :: Mayb' a -> Maybe a +a = coerce diff --git a/examples/Refactor/OrganizeImports/Ctor.hs b/examples/Refactor/OrganizeImports/Ctor.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Ctor.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Ctor where + +import Data.Maybe (Maybe(Nothing, Just)) + +test = Just 3 diff --git a/examples/Refactor/OrganizeImports/Ctor_res.hs b/examples/Refactor/OrganizeImports/Ctor_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Ctor_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Ctor where + +import Data.Maybe (Maybe(Just)) + +test = Just 3 diff --git a/examples/Refactor/OrganizeImports/Fields.hs b/examples/Refactor/OrganizeImports/Fields.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Fields.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Fields where + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (Monad(..), StateT(runStateT)) + +x = runStateT (lift putStrLn >> return ()) () diff --git a/examples/Refactor/OrganizeImports/Fields_res.hs b/examples/Refactor/OrganizeImports/Fields_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Fields_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.Fields where + +import Control.Monad.State (Monad(..), StateT(runStateT)) +import Control.Monad.Trans (MonadTrans(..)) + +x = runStateT (lift putStrLn >> return ()) () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/DataType.hs b/examples/Refactor/OrganizeImports/InstanceCarry/DataType.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/DataType.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.InstanceCarry.DataType where + +data A = A diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan.hs b/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan where + +import Refactor.OrganizeImports.InstanceCarry.TCWithInst () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan_res.hs b/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/ImportNonOrphan_res.hs @@ -0,0 +1,2 @@ +module Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan where + diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan.hs b/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.InstanceCarry.ImportOrphan where + +import Refactor.OrganizeImports.InstanceCarry.OrphanInstance () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan_res.hs b/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/ImportOrphan_res.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.InstanceCarry.ImportOrphan where + +import Refactor.OrganizeImports.InstanceCarry.OrphanInstance () diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/OrphanInstance.hs b/examples/Refactor/OrganizeImports/InstanceCarry/OrphanInstance.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/OrphanInstance.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.InstanceCarry.OrphanInstance where + +import Refactor.OrganizeImports.InstanceCarry.DataType +import Refactor.OrganizeImports.InstanceCarry.TypeClass + +instance C A where + f = id diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/TCWithInst.hs b/examples/Refactor/OrganizeImports/InstanceCarry/TCWithInst.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/TCWithInst.hs @@ -0,0 +1,9 @@ +module Refactor.OrganizeImports.InstanceCarry.TCWithInst where + +import Refactor.OrganizeImports.InstanceCarry.DataType + +class D t where + g :: t -> t + +instance D A where + g = id diff --git a/examples/Refactor/OrganizeImports/InstanceCarry/TypeClass.hs b/examples/Refactor/OrganizeImports/InstanceCarry/TypeClass.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/InstanceCarry/TypeClass.hs @@ -0,0 +1,4 @@ +module Refactor.OrganizeImports.InstanceCarry.TypeClass where + +class C t where + f :: t -> t diff --git a/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepCtorOfMarshalled where + +import Foreign.C.String + +foreign import ccall unsafe "abc" abc :: CString -> IO () diff --git a/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepCtorOfMarshalled_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepCtorOfMarshalled where + +import Foreign.C.String (CString(..)) + +foreign import ccall unsafe "abc" abc :: CString -> IO () diff --git a/examples/Refactor/OrganizeImports/KeepExplicit.hs b/examples/Refactor/OrganizeImports/KeepExplicit.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepExplicit.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepExplicit where + +import Data.Functor.Identity (Identity (runIdentity)) + +x = runIdentity diff --git a/examples/Refactor/OrganizeImports/KeepExplicit_res.hs b/examples/Refactor/OrganizeImports/KeepExplicit_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepExplicit_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.KeepExplicit where + +import Data.Functor.Identity (Identity (runIdentity)) + +x = runIdentity diff --git a/examples/Refactor/OrganizeImports/KeepHiding.hs b/examples/Refactor/OrganizeImports/KeepHiding.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepHiding.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.KeepHiding where + +import Data.Map hiding (map) + +m :: Map Int String +m = empty diff --git a/examples/Refactor/OrganizeImports/KeepHiding_res.hs b/examples/Refactor/OrganizeImports/KeepHiding_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepHiding_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.KeepHiding where + +import Data.Map hiding (map) + +m :: Map Int String +m = empty diff --git a/examples/Refactor/OrganizeImports/KeepPrelude.hs b/examples/Refactor/OrganizeImports/KeepPrelude.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepPrelude.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepPrelude where + +import Prelude () diff --git a/examples/Refactor/OrganizeImports/KeepPrelude_res.hs b/examples/Refactor/OrganizeImports/KeepPrelude_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepPrelude_res.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepPrelude where + +import Prelude () diff --git a/examples/Refactor/OrganizeImports/KeepReexported.hs b/examples/Refactor/OrganizeImports/KeepReexported.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepReexported.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepReexported (module Control.Monad) where + +import Control.Monad diff --git a/examples/Refactor/OrganizeImports/KeepReexported_res.hs b/examples/Refactor/OrganizeImports/KeepReexported_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepReexported_res.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.KeepReexported (module Control.Monad) where + +import Control.Monad diff --git a/examples/Refactor/OrganizeImports/KeepRenamedReexported.hs b/examples/Refactor/OrganizeImports/KeepRenamedReexported.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepRenamedReexported.hs @@ -0,0 +1,4 @@ +module Refactor.OrganizeImports.KeepRenamedReexported (module X) where + +import Control.Monad as X +import Data.Maybe as X diff --git a/examples/Refactor/OrganizeImports/KeepRenamedReexported_res.hs b/examples/Refactor/OrganizeImports/KeepRenamedReexported_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/KeepRenamedReexported_res.hs @@ -0,0 +1,4 @@ +module Refactor.OrganizeImports.KeepRenamedReexported (module X) where + +import Control.Monad as X +import Data.Maybe as X diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ClassSource.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ClassSource.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ClassSource.hs @@ -0,0 +1,11 @@ +module Refactor.OrganizeImports.MakeExplicit.ClassSource where + +class D a where + f :: a + +instance D () where + f = () + +g :: D a => a +g = f + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ConSourceHiddenType.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType (A(B)) where + +import Refactor.OrganizeImports.MakeExplicit.Source diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/FunSource.hs b/examples/Refactor/OrganizeImports/MakeExplicit/FunSource.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/FunSource.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.MakeExplicit.FunSource (f) where + +import Refactor.OrganizeImports.MakeExplicit.ClassSource diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportClassFun where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x :: () +x = f + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportClassFun_res.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportClassFun where + +import Refactor.OrganizeImports.MakeExplicit.Source (D(..)) + +x :: () +x = f + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportCon where + +import Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType + +x = B diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportCon_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportCon where + +import Refactor.OrganizeImports.MakeExplicit.ConSourceHiddenType (A(..)) + +x = B diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFour where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = (a,b,e,g) + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFour_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFour where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = (a,b,e,g) + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFunHiddenClass where + +import Refactor.OrganizeImports.MakeExplicit.FunSource + +h :: () +h = f diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunHiddenClass_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFunHiddenClass where + +import Refactor.OrganizeImports.MakeExplicit.FunSource (f) + +h :: () +h = f diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFunOutOfClass where + +import Refactor.OrganizeImports.MakeExplicit.ClassSource + +h :: () +h = g diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportFunOutOfClass_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportFunOutOfClass where + +import Refactor.OrganizeImports.MakeExplicit.ClassSource (g) + +h :: () +h = g diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportOne where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = a + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportOne_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportOne where + +import Refactor.OrganizeImports.MakeExplicit.Source (a) + +x = a + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportRecordSel where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = b + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportRecordSel_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportRecordSel where + +import Refactor.OrganizeImports.MakeExplicit.Source (A(..)) + +x = b + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportThree where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = (a,e,g) diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportThree_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportThree where + +import Refactor.OrganizeImports.MakeExplicit.Source (g, e, a) + +x = (a,e,g) diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportUnited where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = B () +y = b x + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount.hs @@ -0,0 +1,8 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportUnitedCount where + +import Refactor.OrganizeImports.MakeExplicit.Source + +x = B () +y = b x +z = a +w = e diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnitedCount_res.hs @@ -0,0 +1,8 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportUnitedCount where + +import Refactor.OrganizeImports.MakeExplicit.Source (A(..), e, a) + +x = B () +y = b x +z = a +w = e diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/ImportUnited_res.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.MakeExplicit.ImportUnited where + +import Refactor.OrganizeImports.MakeExplicit.Source (A(..)) + +x = B () +y = b x + diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.Renamed where + +import Refactor.OrganizeImports.MakeExplicit.Source as Src + +x = B diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/Renamed_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.MakeExplicit.Renamed where + +import Refactor.OrganizeImports.MakeExplicit.Source as Src (A(..)) + +x = B diff --git a/examples/Refactor/OrganizeImports/MakeExplicit/Source.hs b/examples/Refactor/OrganizeImports/MakeExplicit/Source.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/MakeExplicit/Source.hs @@ -0,0 +1,15 @@ +module Refactor.OrganizeImports.MakeExplicit.Source where + +a = () +e = () +g = () + +data A = B { b :: () } + | C + +class D a where + f :: a + +instance D () where + f = () + diff --git a/examples/Refactor/OrganizeImports/Narrow.hs b/examples/Refactor/OrganizeImports/Narrow.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Narrow.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Narrow where + +import Data.List (map, null) + +test = map (+1) [1..10] diff --git a/examples/Refactor/OrganizeImports/NarrowQual.hs b/examples/Refactor/OrganizeImports/NarrowQual.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowQual.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.NarrowQual where + +import Data.List +import Data.List as L + +test = intersperse 0 $ L.map (+1) [1..10] diff --git a/examples/Refactor/OrganizeImports/NarrowQual_res.hs b/examples/Refactor/OrganizeImports/NarrowQual_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowQual_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.NarrowQual where + +import Data.List (map, intersperse) +import Data.List as L (map, intersperse) + +test = intersperse 0 $ L.map (+1) [1..10] diff --git a/examples/Refactor/OrganizeImports/NarrowSpec.hs b/examples/Refactor/OrganizeImports/NarrowSpec.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowSpec.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.NarrowSpec where + +import Control.Monad.State (State(..)) + +type St = State () diff --git a/examples/Refactor/OrganizeImports/NarrowSpec_res.hs b/examples/Refactor/OrganizeImports/NarrowSpec_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowSpec_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.NarrowSpec where + +import Control.Monad.State (State(..)) + +type St = State () diff --git a/examples/Refactor/OrganizeImports/NarrowType.hs b/examples/Refactor/OrganizeImports/NarrowType.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowType.hs @@ -0,0 +1,8 @@ +module Refactor.OrganizeImports.NarrowType where + +import Control.Monad.State + +type St = State () +type StT = StateT () IO + +f = runStateT diff --git a/examples/Refactor/OrganizeImports/NarrowType_res.hs b/examples/Refactor/OrganizeImports/NarrowType_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/NarrowType_res.hs @@ -0,0 +1,8 @@ +module Refactor.OrganizeImports.NarrowType where + +import Control.Monad.State (StateT(..), State) + +type St = State () +type StT = StateT () IO + +f = runStateT diff --git a/examples/Refactor/OrganizeImports/Narrow_res.hs b/examples/Refactor/OrganizeImports/Narrow_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Narrow_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Narrow where + +import Data.List (map) + +test = map (+1) [1..10] diff --git a/examples/Refactor/OrganizeImports/Operator.hs b/examples/Refactor/OrganizeImports/Operator.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Operator.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Operator where + +import Data.List ((\\), intersect) + +test = [1,2,3] \\ [1,2] diff --git a/examples/Refactor/OrganizeImports/Operator_res.hs b/examples/Refactor/OrganizeImports/Operator_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Operator_res.hs @@ -0,0 +1,5 @@ +module Refactor.OrganizeImports.Operator where + +import Data.List ((\\)) + +test = [1,2,3] \\ [1,2] diff --git a/examples/Refactor/OrganizeImports/Removed.hs b/examples/Refactor/OrganizeImports/Removed.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Removed.hs @@ -0,0 +1,3 @@ +module Refactor.OrganizeImports.Removed where + +import Control.Monad () diff --git a/examples/Refactor/OrganizeImports/Removed_res.hs b/examples/Refactor/OrganizeImports/Removed_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Removed_res.hs @@ -0,0 +1,2 @@ +module Refactor.OrganizeImports.Removed where + diff --git a/examples/Refactor/OrganizeImports/Reorder.hs b/examples/Refactor/OrganizeImports/Reorder.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Reorder.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.Reorder where + +import Data.List (intersperse) +import Control.Monad ((>>=)) + +x = intersperse '-' "abc" +y = Just () >>= \_ -> Nothing diff --git a/examples/Refactor/OrganizeImports/ReorderComment.hs b/examples/Refactor/OrganizeImports/ReorderComment.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/ReorderComment.hs @@ -0,0 +1,12 @@ +module Refactor.OrganizeImports.ReorderComment where + +import Data.List (intersperse) +import Control.Monad ((>>=)) +-- some comment +import Data.Tuple (swap) +import Data.Maybe (catMaybes) + +a = intersperse '-' "abc" +b = Just () >>= \_ -> Nothing +c = catMaybes [Just ()] +d = swap ("a","b") diff --git a/examples/Refactor/OrganizeImports/ReorderComment_res.hs b/examples/Refactor/OrganizeImports/ReorderComment_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/ReorderComment_res.hs @@ -0,0 +1,12 @@ +module Refactor.OrganizeImports.ReorderComment where + +import Control.Monad ((>>=)) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +-- some comment +import Data.Tuple (swap) + +a = intersperse '-' "abc" +b = Just () >>= \_ -> Nothing +c = catMaybes [Just ()] +d = swap ("a","b") diff --git a/examples/Refactor/OrganizeImports/ReorderGroups.hs b/examples/Refactor/OrganizeImports/ReorderGroups.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/ReorderGroups.hs @@ -0,0 +1,12 @@ +module Refactor.OrganizeImports.ReorderGroups where + +import Data.List (intersperse) +import Control.Monad ((>>=)) + +import Data.Tuple (swap) +import Data.Maybe (catMaybes) + +a = intersperse '-' "abc" +b = Just () >>= \_ -> Nothing +c = catMaybes [Just ()] +d = swap ("a","b") diff --git a/examples/Refactor/OrganizeImports/ReorderGroups_res.hs b/examples/Refactor/OrganizeImports/ReorderGroups_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/ReorderGroups_res.hs @@ -0,0 +1,12 @@ +module Refactor.OrganizeImports.ReorderGroups where + +import Control.Monad ((>>=)) +import Data.List (intersperse) + +import Data.Maybe (catMaybes) +import Data.Tuple (swap) + +a = intersperse '-' "abc" +b = Just () >>= \_ -> Nothing +c = catMaybes [Just ()] +d = swap ("a","b") diff --git a/examples/Refactor/OrganizeImports/Reorder_res.hs b/examples/Refactor/OrganizeImports/Reorder_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/Reorder_res.hs @@ -0,0 +1,7 @@ +module Refactor.OrganizeImports.Reorder where + +import Control.Monad ((>>=)) +import Data.List (intersperse) + +x = intersperse '-' "abc" +y = Just () >>= \_ -> Nothing diff --git a/examples/Refactor/OrganizeImports/SameName.hs b/examples/Refactor/OrganizeImports/SameName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/SameName.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.SameName where + +import Data.List (map, null) + +test = map (+1) [1..null] + where null = 10 diff --git a/examples/Refactor/OrganizeImports/SameName_res.hs b/examples/Refactor/OrganizeImports/SameName_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/SameName_res.hs @@ -0,0 +1,6 @@ +module Refactor.OrganizeImports.SameName where + +import Data.List (map) + +test = map (+1) [1..null] + where null = 10 diff --git a/examples/Refactor/OrganizeImports/StandaloneDeriving.hs b/examples/Refactor/OrganizeImports/StandaloneDeriving.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/StandaloneDeriving.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE StandaloneDeriving #-} +module Refactor.OrganizeImports.StandaloneDeriving where + +import Control.Monad.State (State(..), StateT) + +type St = State () diff --git a/examples/Refactor/OrganizeImports/StandaloneDeriving_res.hs b/examples/Refactor/OrganizeImports/StandaloneDeriving_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/StandaloneDeriving_res.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE StandaloneDeriving #-} +module Refactor.OrganizeImports.StandaloneDeriving where + +import Control.Monad.State (State(..)) + +type St = State () diff --git a/examples/Refactor/OrganizeImports/TemplateHaskell.hs b/examples/Refactor/OrganizeImports/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/TemplateHaskell.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.OrganizeImports.TemplateHaskell where + +import Control.Monad.Writer +import Control.Monad.State (State(..)) diff --git a/examples/Refactor/OrganizeImports/TemplateHaskell_res.hs b/examples/Refactor/OrganizeImports/TemplateHaskell_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/OrganizeImports/TemplateHaskell_res.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.OrganizeImports.TemplateHaskell where + +import Control.Monad.State (State(..)) +import Control.Monad.Writer diff --git a/examples/Refactor/RenameDefinition/AccentName.hs b/examples/Refactor/RenameDefinition/AccentName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/AccentName.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.AccentName where + +f :: Int -> Int +f x = x + +g = f diff --git a/examples/Refactor/RenameDefinition/AccentName_res.hs b/examples/Refactor/RenameDefinition/AccentName_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/AccentName_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.AccentName where + +á :: Int -> Int +á x = x + +g = á diff --git a/examples/Refactor/RenameDefinition/AmbiguousFields.hs b/examples/Refactor/RenameDefinition/AmbiguousFields.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/AmbiguousFields.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module Refactor.RenameDefinition.AmbiguousFields where + +data A = A { x, y :: Int } +data B = B { x, y :: Int } + +f :: A -> Int +f = x + +g :: B -> Int +g = x diff --git a/examples/Refactor/RenameDefinition/AmbiguousFields_res.hs b/examples/Refactor/RenameDefinition/AmbiguousFields_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/AmbiguousFields_res.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module Refactor.RenameDefinition.AmbiguousFields where + +data A = A { xx, y :: Int } +data B = B { x, y :: Int } + +f :: A -> Int +f = xx + +g :: B -> Int +g = x diff --git a/examples/Refactor/RenameDefinition/Arg.hs b/examples/Refactor/RenameDefinition/Arg.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Arg.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.Arg where + +f :: Int -> Int +f x = x diff --git a/examples/Refactor/RenameDefinition/Arg_res.hs b/examples/Refactor/RenameDefinition/Arg_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Arg_res.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.Arg where + +f :: Int -> Int +f y = y diff --git a/examples/Refactor/RenameDefinition/BacktickName.hs b/examples/Refactor/RenameDefinition/BacktickName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/BacktickName.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.BacktickName where + +f :: Int -> Int -> Int +f = (+) + +x = 3 `f` 4 diff --git a/examples/Refactor/RenameDefinition/BacktickName_res.hs b/examples/Refactor/RenameDefinition/BacktickName_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/BacktickName_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.BacktickName where + +g :: Int -> Int -> Int +g = (+) + +x = 3 `g` 4 diff --git a/examples/Refactor/RenameDefinition/ClassMember.hs b/examples/Refactor/RenameDefinition/ClassMember.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ClassMember.hs @@ -0,0 +1,7 @@ +module Refactor.RenameDefinition.ClassMember where + +class C t where + f :: t -> t + +instance C Int where + f i = i diff --git a/examples/Refactor/RenameDefinition/ClassMember_res.hs b/examples/Refactor/RenameDefinition/ClassMember_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ClassMember_res.hs @@ -0,0 +1,7 @@ +module Refactor.RenameDefinition.ClassMember where + +class C t where + q :: t -> t + +instance C Int where + q i = i diff --git a/examples/Refactor/RenameDefinition/ClassTypeVar.hs b/examples/Refactor/RenameDefinition/ClassTypeVar.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ClassTypeVar.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.ClassTypeVar where + +class C t where + f :: t -> t diff --git a/examples/Refactor/RenameDefinition/ClassTypeVar_res.hs b/examples/Refactor/RenameDefinition/ClassTypeVar_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ClassTypeVar_res.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.ClassTypeVar where + +class C f where + f :: f -> f diff --git a/examples/Refactor/RenameDefinition/Constructor.hs b/examples/Refactor/RenameDefinition/Constructor.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Constructor.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Constructor where + +data Point = Point Double Double + +distance :: Point -> Point -> Double +distance (Point x1 y1) (Point x2 y2) = sqrt ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/Constructor_res.hs b/examples/Refactor/RenameDefinition/Constructor_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Constructor_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Constructor where + +data Point = Point2D Double Double + +distance :: Point -> Point -> Double +distance (Point2D x1 y1) (Point2D x2 y2) = sqrt ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/CrossRename.hs b/examples/Refactor/RenameDefinition/CrossRename.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/CrossRename.hs @@ -0,0 +1,8 @@ +module Refactor.RenameDefinition.CrossRename where + +-- Renaming f to g should fail +f x = x + +ff x = g + where + g = f 'g' diff --git a/examples/Refactor/RenameDefinition/DefineSplices.hs b/examples/Refactor/RenameDefinition/DefineSplices.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/DefineSplices.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.DefineSplices where + +import Language.Haskell.TH + +nameOf :: Name -> Q [Dec] +nameOf n = return [] diff --git a/examples/Refactor/RenameDefinition/FormattingAware.hs b/examples/Refactor/RenameDefinition/FormattingAware.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FormattingAware.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.FormattingAware where + +a = [ "a" + , "b" + , "c" + ] diff --git a/examples/Refactor/RenameDefinition/FormattingAware_res.hs b/examples/Refactor/RenameDefinition/FormattingAware_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FormattingAware_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.FormattingAware where + +aa = [ "a" + , "b" + , "c" + ] diff --git a/examples/Refactor/RenameDefinition/FunTypeVar.hs b/examples/Refactor/RenameDefinition/FunTypeVar.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunTypeVar.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.FunTypeVar where + +f :: a -> a +f x = x diff --git a/examples/Refactor/RenameDefinition/FunTypeVarLocal.hs b/examples/Refactor/RenameDefinition/FunTypeVarLocal.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunTypeVarLocal.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.FunTypeVarLocal where + +g = f () + where + f :: a -> a + f x = x diff --git a/examples/Refactor/RenameDefinition/FunTypeVarLocal_res.hs b/examples/Refactor/RenameDefinition/FunTypeVarLocal_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunTypeVarLocal_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.FunTypeVarLocal where + +g = f () + where + f :: b -> b + f x = x diff --git a/examples/Refactor/RenameDefinition/FunTypeVar_res.hs b/examples/Refactor/RenameDefinition/FunTypeVar_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunTypeVar_res.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.FunTypeVar where + +f :: x -> x +f x = x diff --git a/examples/Refactor/RenameDefinition/Function.hs b/examples/Refactor/RenameDefinition/Function.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Function.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Function where + +f :: Int -> Int +f x = x + +g = f diff --git a/examples/Refactor/RenameDefinition/Function_res.hs b/examples/Refactor/RenameDefinition/Function_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Function_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Function where + +q :: Int -> Int +q x = x + +g = q diff --git a/examples/Refactor/RenameDefinition/FunnyDo.hs b/examples/Refactor/RenameDefinition/FunnyDo.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunnyDo.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.FunnyDo where + +a = do return (); return () + Just 3; return () + Nothing diff --git a/examples/Refactor/RenameDefinition/FunnyDo_res.hs b/examples/Refactor/RenameDefinition/FunnyDo_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/FunnyDo_res.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.FunnyDo where + +aaa = do return (); return () + Just 3; return () + Nothing diff --git a/examples/Refactor/RenameDefinition/IllegalQualRename.hs b/examples/Refactor/RenameDefinition/IllegalQualRename.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/IllegalQualRename.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds #-} +module Refactor.RenameDefinition.IllegalQualRename where + +type family IfThenElse (b :: Bool) (th :: x) (el :: x) :: x where + IfThenElse True th el = th + IfThenElse False th el = el diff --git a/examples/Refactor/RenameDefinition/LayoutAware.hs b/examples/Refactor/RenameDefinition/LayoutAware.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/LayoutAware.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.LayoutAware where + +a = do putStrLn "a" + putStrLn "b" + putStrLn "c" diff --git a/examples/Refactor/RenameDefinition/LayoutAware_res.hs b/examples/Refactor/RenameDefinition/LayoutAware_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/LayoutAware_res.hs @@ -0,0 +1,5 @@ +module Refactor.RenameDefinition.LayoutAware where + +main = do putStrLn "a" + putStrLn "b" + putStrLn "c" diff --git a/examples/Refactor/RenameDefinition/LibraryFunction.hs b/examples/Refactor/RenameDefinition/LibraryFunction.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/LibraryFunction.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.LibraryFunction where + +f :: Int -> Int +f = id diff --git a/examples/Refactor/RenameDefinition/LocalFunction.hs b/examples/Refactor/RenameDefinition/LocalFunction.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/LocalFunction.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.LocalFunction where + +f :: Int -> Int +f = x + where x :: Int -> Int + x = id + + +g :: Int -> Int +g = id diff --git a/examples/Refactor/RenameDefinition/LocalFunction_res.hs b/examples/Refactor/RenameDefinition/LocalFunction_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/LocalFunction_res.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.LocalFunction where + +f :: Int -> Int +f = g + where g :: Int -> Int + g = id + + +g :: Int -> Int +g = id diff --git a/examples/Refactor/RenameDefinition/MergeFields.hs b/examples/Refactor/RenameDefinition/MergeFields.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.MergeFields where + +data A = B { x :: Double } | C { y :: Double } + +data A2 = A2 { x2 :: Double, y2 :: Double } + +data A3 = B3 { x3 :: Double } | C3 { y3 :: Int } + +f a = case a of B {} -> x a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs b/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_RenameY.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.MergeFields_RenameY where + +data A = B { x :: Double } | C { y :: Double } + +f a = case a of B {} -> x a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs b/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_RenameY_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.MergeFields_RenameY where + +data A = B { x :: Double } | C { x :: Double } + +f a = case a of B {} -> x a + C {} -> x a diff --git a/examples/Refactor/RenameDefinition/MergeFields_res.hs b/examples/Refactor/RenameDefinition/MergeFields_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MergeFields_res.hs @@ -0,0 +1,10 @@ +module Refactor.RenameDefinition.MergeFields where + +data A = B { y :: Double } | C { y :: Double } + +data A2 = A2 { x2 :: Double, y2 :: Double } + +data A3 = B3 { x3 :: Double } | C3 { y3 :: Int } + +f a = case a of B {} -> y a + C {} -> y a diff --git a/examples/Refactor/RenameDefinition/MultiModule/A.hs b/examples/Refactor/RenameDefinition/MultiModule/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MultiModule/A.hs @@ -0,0 +1,5 @@ +module A where + +import B + +a = b diff --git a/examples/Refactor/RenameDefinition/MultiModule/B.hs b/examples/Refactor/RenameDefinition/MultiModule/B.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MultiModule/B.hs @@ -0,0 +1,3 @@ +module B where + +b = () diff --git a/examples/Refactor/RenameDefinition/MultiModule_res/A.hs b/examples/Refactor/RenameDefinition/MultiModule_res/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MultiModule_res/A.hs @@ -0,0 +1,5 @@ +module A where + +import B + +a = bb diff --git a/examples/Refactor/RenameDefinition/MultiModule_res/B.hs b/examples/Refactor/RenameDefinition/MultiModule_res/B.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/MultiModule_res/B.hs @@ -0,0 +1,3 @@ +module B where + +bb = () diff --git a/examples/Refactor/RenameDefinition/NameClash.hs b/examples/Refactor/RenameDefinition/NameClash.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/NameClash.hs @@ -0,0 +1,11 @@ +module Refactor.RenameDefinition.NameClash where + +f :: Int -> Int +f = g + where g :: Int -> Int + g = id + + h :: Int -> Int + h = id + +test = f diff --git a/examples/Refactor/RenameDefinition/NoPrelude.hs b/examples/Refactor/RenameDefinition/NoPrelude.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/NoPrelude.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.RenameDefinition.NoPrelude where + +f = () +test = f diff --git a/examples/Refactor/RenameDefinition/NoPrelude_res.hs b/examples/Refactor/RenameDefinition/NoPrelude_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/NoPrelude_res.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Refactor.RenameDefinition.NoPrelude where + +map = () +test = map diff --git a/examples/Refactor/RenameDefinition/ParenName.hs b/examples/Refactor/RenameDefinition/ParenName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ParenName.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.ParenName where + +(<>) :: Int -> Int -> Int +a <> b = a + b + +x = (<>) 3 4 diff --git a/examples/Refactor/RenameDefinition/ParenName_res.hs b/examples/Refactor/RenameDefinition/ParenName_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ParenName_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.ParenName where + +(<->) :: Int -> Int -> Int +a <-> b = a + b + +x = (<->) 3 4 diff --git a/examples/Refactor/RenameDefinition/PatternSynonym.hs b/examples/Refactor/RenameDefinition/PatternSynonym.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/PatternSynonym.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.PatternSynonym where + +data Type = App String [Type] + +pattern Arrow t1 t2 = App "->" [t1, t2] diff --git a/examples/Refactor/RenameDefinition/PatternSynonymTypeSig.hs b/examples/Refactor/RenameDefinition/PatternSynonymTypeSig.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/PatternSynonymTypeSig.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.PatternSynonymTypeSig where + +data Type = App String [Type] + +pattern Arrow :: Type -> Type -> Type +pattern Arrow t1 t2 = App "->" [t1, t2] diff --git a/examples/Refactor/RenameDefinition/PatternSynonymTypeSig_res.hs b/examples/Refactor/RenameDefinition/PatternSynonymTypeSig_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/PatternSynonymTypeSig_res.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.PatternSynonymTypeSig where + +data Type = App String [Type] + +pattern ArrowAppl :: Type -> Type -> Type +pattern ArrowAppl t1 t2 = App "->" [t1, t2] diff --git a/examples/Refactor/RenameDefinition/PatternSynonym_res.hs b/examples/Refactor/RenameDefinition/PatternSynonym_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/PatternSynonym_res.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.PatternSynonym where + +data Type = App String [Type] + +pattern ArrowAppl t1 t2 = App "->" [t1, t2] diff --git a/examples/Refactor/RenameDefinition/QualImport.hs b/examples/Refactor/RenameDefinition/QualImport.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/QualImport.hs @@ -0,0 +1,7 @@ +module Refactor.RenameDefinition.QualImport where + +import qualified Data.List (intercalate) + +g = () + +f = g diff --git a/examples/Refactor/RenameDefinition/QualImportAlso.hs b/examples/Refactor/RenameDefinition/QualImportAlso.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/QualImportAlso.hs @@ -0,0 +1,8 @@ +module Refactor.RenameDefinition.QualImportAlso where + +import qualified Data.List (intercalate) +import Data.List (intercalate) + +g = () + +f = g diff --git a/examples/Refactor/RenameDefinition/QualImport_res.hs b/examples/Refactor/RenameDefinition/QualImport_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/QualImport_res.hs @@ -0,0 +1,7 @@ +module Refactor.RenameDefinition.QualImport where + +import qualified Data.List (intercalate) + +intercalate = () + +f = intercalate diff --git a/examples/Refactor/RenameDefinition/QualName.hs b/examples/Refactor/RenameDefinition/QualName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/QualName.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.QualName where + +f :: Int -> Int +f x = x + +g = Refactor.RenameDefinition.QualName.f diff --git a/examples/Refactor/RenameDefinition/QualName_res.hs b/examples/Refactor/RenameDefinition/QualName_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/QualName_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.QualName where + +q :: Int -> Int +q x = x + +g = Refactor.RenameDefinition.QualName.q diff --git a/examples/Refactor/RenameDefinition/RecordField.hs b/examples/Refactor/RenameDefinition/RecordField.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordField.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.RecordField where + +data Point = Point { x :: Double, y :: Double } + +distance :: Point -> Point -> Double +distance p1 p2 = sqrt ((x p1 - x p2) ^ 2 + (y p1 - y p2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/RecordField_res.hs b/examples/Refactor/RenameDefinition/RecordField_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordField_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.RecordField where + +data Point = Point { xCoord :: Double, y :: Double } + +distance :: Point -> Point -> Double +distance p1 p2 = sqrt ((xCoord p1 - xCoord p2) ^ 2 + (y p1 - y p2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/RecordPatternSynonyms.hs b/examples/Refactor/RenameDefinition/RecordPatternSynonyms.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordPatternSynonyms.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.RecordPatternSynonyms where + +pattern Point {x, y} = (x, y) + +r = (0, 0) { x = 1 } diff --git a/examples/Refactor/RenameDefinition/RecordPatternSynonyms_res.hs b/examples/Refactor/RenameDefinition/RecordPatternSynonyms_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordPatternSynonyms_res.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Refactor.RenameDefinition.RecordPatternSynonyms where + +pattern Point {xx, y} = (xx, y) + +r = (0, 0) { xx = 1 } diff --git a/examples/Refactor/RenameDefinition/RecordWildcards.hs b/examples/Refactor/RenameDefinition/RecordWildcards.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordWildcards.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} +module Refactor.RenameDefinition.RecordWildcards where + +data Point = Point { x :: Int, y :: Int } + +p1 = let x = 3; y = 4 in Point { x = 1, .. } + +p2 = let Point { .. } = Point 1 2 in y diff --git a/examples/Refactor/RenameDefinition/RecordWildcards_res.hs b/examples/Refactor/RenameDefinition/RecordWildcards_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RecordWildcards_res.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} +module Refactor.RenameDefinition.RecordWildcards where + +data Point = Point { x :: Int, yy :: Int } + +p1 = let x = 3; yy = 4 in Point { x = 1, .. } + +p2 = let Point { .. } = Point 1 2 in yy diff --git a/examples/Refactor/RenameDefinition/RenameModule/A.hs b/examples/Refactor/RenameDefinition/RenameModule/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModule/A.hs @@ -0,0 +1,5 @@ +module A where + +import B + +a = b diff --git a/examples/Refactor/RenameDefinition/RenameModule/B.hs b/examples/Refactor/RenameDefinition/RenameModule/B.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModule/B.hs @@ -0,0 +1,3 @@ +module B where + +b = () diff --git a/examples/Refactor/RenameDefinition/RenameModuleAlias.hs b/examples/Refactor/RenameDefinition/RenameModuleAlias.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModuleAlias.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.RenameModuleAlias where + +import Data.List as LL +foo = LL.intersperse "," ["a","b"] diff --git a/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs b/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModuleAlias_res.hs @@ -0,0 +1,4 @@ +module Refactor.RenameDefinition.RenameModuleAlias where + +import Data.List as L +foo = L.intersperse "," ["a","b"] diff --git a/examples/Refactor/RenameDefinition/RenameModule_res/A.hs b/examples/Refactor/RenameDefinition/RenameModule_res/A.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModule_res/A.hs @@ -0,0 +1,5 @@ +module A where + +import C + +a = b diff --git a/examples/Refactor/RenameDefinition/RenameModule_res/C.hs b/examples/Refactor/RenameDefinition/RenameModule_res/C.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RenameModule_res/C.hs @@ -0,0 +1,3 @@ +module C where + +b = () diff --git a/examples/Refactor/RenameDefinition/RoleAnnotation.hs b/examples/Refactor/RenameDefinition/RoleAnnotation.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RoleAnnotation.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module Refactor.RenameDefinition.RoleAnnotation where + +type role A nominal nominal +data A a b = A a b diff --git a/examples/Refactor/RenameDefinition/RoleAnnotation_res.hs b/examples/Refactor/RenameDefinition/RoleAnnotation_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/RoleAnnotation_res.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module Refactor.RenameDefinition.RoleAnnotation where + +type role AA nominal nominal +data AA a b = A a b diff --git a/examples/Refactor/RenameDefinition/SameCtorAndType.hs b/examples/Refactor/RenameDefinition/SameCtorAndType.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SameCtorAndType.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.SameCtorAndType where + +data Point2D = P2D Double Double + +origo :: Point2D +origo = P2D 0.0 0.0 diff --git a/examples/Refactor/RenameDefinition/SameCtorAndType_res.hs b/examples/Refactor/RenameDefinition/SameCtorAndType_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SameCtorAndType_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.SameCtorAndType where + +data P2D = P2D Double Double + +origo :: P2D +origo = P2D 0.0 0.0 diff --git a/examples/Refactor/RenameDefinition/SpliceDecls/Define.hs b/examples/Refactor/RenameDefinition/SpliceDecls/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceDecls/Define.hs @@ -0,0 +1,9 @@ +module Define where + +import Language.Haskell.TH + +defHello :: Q [Dec] +defHello = def "hello" + +def :: String -> Q [Dec] +def name = return [ ValD (VarP (mkName name)) (NormalB $ LitE $ IntegerL 3) [] ] diff --git a/examples/Refactor/RenameDefinition/SpliceDecls/Use.hs b/examples/Refactor/RenameDefinition/SpliceDecls/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceDecls/Use.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +defHello + +$(let x = return [] in x) diff --git a/examples/Refactor/RenameDefinition/SpliceDecls_res/Define.hs b/examples/Refactor/RenameDefinition/SpliceDecls_res/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceDecls_res/Define.hs @@ -0,0 +1,9 @@ +module Define where + +import Language.Haskell.TH + +hello :: Q [Dec] +hello = def "hello" + +def :: String -> Q [Dec] +def name = return [ ValD (VarP (mkName name)) (NormalB $ LitE $ IntegerL 3) [] ] diff --git a/examples/Refactor/RenameDefinition/SpliceDecls_res/Use.hs b/examples/Refactor/RenameDefinition/SpliceDecls_res/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceDecls_res/Use.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +hello + +$(let x = return [] in x) diff --git a/examples/Refactor/RenameDefinition/SpliceExpr/Define.hs b/examples/Refactor/RenameDefinition/SpliceExpr/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceExpr/Define.hs @@ -0,0 +1,6 @@ +module Define where + +import Language.Haskell.TH + +expr :: Q Exp +expr = return $ LitE $ IntegerL 3 diff --git a/examples/Refactor/RenameDefinition/SpliceExpr/Use.hs b/examples/Refactor/RenameDefinition/SpliceExpr/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceExpr/Use.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +e :: Int +e = $(expr) diff --git a/examples/Refactor/RenameDefinition/SpliceExpr_res/Define.hs b/examples/Refactor/RenameDefinition/SpliceExpr_res/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceExpr_res/Define.hs @@ -0,0 +1,6 @@ +module Define where + +import Language.Haskell.TH + +exprSplice :: Q Exp +exprSplice = return $ LitE $ IntegerL 3 diff --git a/examples/Refactor/RenameDefinition/SpliceExpr_res/Use.hs b/examples/Refactor/RenameDefinition/SpliceExpr_res/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceExpr_res/Use.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +e :: Int +e = $(exprSplice) diff --git a/examples/Refactor/RenameDefinition/SpliceType/Define.hs b/examples/Refactor/RenameDefinition/SpliceType/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceType/Define.hs @@ -0,0 +1,6 @@ +module Define where + +import Language.Haskell.TH + +typ :: Q Type +typ = return $ TupleT 0 diff --git a/examples/Refactor/RenameDefinition/SpliceType/Use.hs b/examples/Refactor/RenameDefinition/SpliceType/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceType/Use.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +a :: $typ +a = () diff --git a/examples/Refactor/RenameDefinition/SpliceType_res/Define.hs b/examples/Refactor/RenameDefinition/SpliceType_res/Define.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceType_res/Define.hs @@ -0,0 +1,6 @@ +module Define where + +import Language.Haskell.TH + +spliceTyp :: Q Type +spliceTyp = return $ TupleT 0 diff --git a/examples/Refactor/RenameDefinition/SpliceType_res/Use.hs b/examples/Refactor/RenameDefinition/SpliceType_res/Use.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/SpliceType_res/Use.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module Use where + +import Define + +a :: $spliceTyp +a = () diff --git a/examples/Refactor/RenameDefinition/Type.hs b/examples/Refactor/RenameDefinition/Type.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Type.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Type where + +data Point = Point Double Double + +distance :: Point -> Point -> Double +distance (Point x1 y1) (Point x2 y2) = sqrt ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/TypeBracket.hs b/examples/Refactor/RenameDefinition/TypeBracket.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/TypeBracket.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.RenameDefinition.TypeBracket where + +import TH.Splice.Define + +data A = A + +nameOf ''A diff --git a/examples/Refactor/RenameDefinition/TypeBracket_res.hs b/examples/Refactor/RenameDefinition/TypeBracket_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/TypeBracket_res.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.RenameDefinition.TypeBracket where + +import TH.Splice.Define + +data B = A + +nameOf ''B diff --git a/examples/Refactor/RenameDefinition/TypeOperators.hs b/examples/Refactor/RenameDefinition/TypeOperators.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/TypeOperators.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators #-} +module Refactor.RenameDefinition.TypeOperators where + +type family l1 :++: l2 where + '[] :++: l2 = l2 + (e ': r1) :++: l2 = e ': (r1 :++: l2) + diff --git a/examples/Refactor/RenameDefinition/TypeOperators_res.hs b/examples/Refactor/RenameDefinition/TypeOperators_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/TypeOperators_res.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators #-} +module Refactor.RenameDefinition.TypeOperators where + +type family x1 :++: l2 where + '[] :++: l2 = l2 + (e ': r1) :++: l2 = e ': (r1 :++: l2) + diff --git a/examples/Refactor/RenameDefinition/Type_res.hs b/examples/Refactor/RenameDefinition/Type_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/Type_res.hs @@ -0,0 +1,6 @@ +module Refactor.RenameDefinition.Type where + +data Point2D = Point Double Double + +distance :: Point2D -> Point2D -> Double +distance (Point x1 y1) (Point x2 y2) = sqrt ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) diff --git a/examples/Refactor/RenameDefinition/UnusedDef.hs b/examples/Refactor/RenameDefinition/UnusedDef.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/UnusedDef.hs @@ -0,0 +1,3 @@ +module Refactor.RenameDefinition.UnusedDef where + +f = () diff --git a/examples/Refactor/RenameDefinition/UnusedDef_res.hs b/examples/Refactor/RenameDefinition/UnusedDef_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/UnusedDef_res.hs @@ -0,0 +1,3 @@ +module Refactor.RenameDefinition.UnusedDef where + +map = () diff --git a/examples/Refactor/RenameDefinition/ValBracket.hs b/examples/Refactor/RenameDefinition/ValBracket.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ValBracket.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.RenameDefinition.ValBracket where + +import TH.Splice.Define + +data A = A + +$(nameOf 'A) diff --git a/examples/Refactor/RenameDefinition/ValBracket_res.hs b/examples/Refactor/RenameDefinition/ValBracket_res.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/ValBracket_res.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Refactor.RenameDefinition.ValBracket where + +import TH.Splice.Define + +data A = B + +$(nameOf 'B) diff --git a/examples/Refactor/RenameDefinition/WrongName.hs b/examples/Refactor/RenameDefinition/WrongName.hs new file mode 100644 --- /dev/null +++ b/examples/Refactor/RenameDefinition/WrongName.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} +module Refactor.RenameDefinition.WrongName where + +f :: Int -> Int +f x = x + +data X = X + +data a .+. b = a :+: b + +(+++) = (+) diff --git a/examples/TH/Brackets.hs b/examples/TH/Brackets.hs new file mode 100644 --- /dev/null +++ b/examples/TH/Brackets.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/ClassUse.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/CrossDef.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH.CrossDef where + +$([d| x = 3 |]) diff --git a/examples/TH/DoubleSplice.hs b/examples/TH/DoubleSplice.hs new file mode 100644 --- /dev/null +++ b/examples/TH/DoubleSplice.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH.DoubleSplice where + +$($(id [| return [] |])) diff --git a/examples/TH/GADTFields.hs b/examples/TH/GADTFields.hs new file mode 100644 --- /dev/null +++ b/examples/TH/GADTFields.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/LocalDefinition.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/MultiImport.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/NestedSplices.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/QuasiQuote/Define.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/QuasiQuote/Use.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Quoted.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/Define.hs @@ -0,0 +1,24 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/Names.hs @@ -0,0 +1,12 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/Use.hs @@ -0,0 +1,22 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/UseImported.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/UseQual.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/Splice/UseQualMulti.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/TH/WithWildcards.hs @@ -0,0 +1,8 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/Bang.hs @@ -0,0 +1,4 @@ +module Type.Bang where + +data X = X !Int + diff --git a/examples/Type/Builtin.hs b/examples/Type/Builtin.hs new file mode 100644 --- /dev/null +++ b/examples/Type/Builtin.hs @@ -0,0 +1,20 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/Ctx.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/examples/Type/ExplicitTypeApplication.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/Forall.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/Primitives.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/TupleAssert.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/TypeOperators.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/examples/Type/Unpack.hs @@ -0,0 +1,4 @@ +module Type.Unpack where + +data X = X {-# UNPACK #-} !Int {-# NOUNPACK #-} !Int + diff --git a/examples/Type/Wildcard.hs b/examples/Type/Wildcard.hs new file mode 100644 --- /dev/null +++ b/examples/Type/Wildcard.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/haskell-tools-builtin-refactorings.cabal @@ -0,0 +1,176 @@ +name: haskell-tools-builtin-refactorings +version: 1.0.0.0 +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 +license: BSD3 +license-file: LICENSE +author: Boldizsar Nemeth +maintainer: nboldi@elte.hu +category: Language +build-type: Simple +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/GenerateExports/*.hs + , examples/Refactor/GenerateTypeSignature/*.hs + , examples/Refactor/GenerateTypeSignature/BringToScope/*.hs + , examples/Refactor/InlineBinding/*.hs + , examples/Refactor/InlineBinding/AppearsInAnother/*.hs + , examples/Refactor/OrganizeImports/*.hs + , examples/Refactor/OrganizeImports/MakeExplicit/*.hs + , examples/Refactor/OrganizeImports/InstanceCarry/*.hs + , examples/Refactor/RenameDefinition/*.hs + , examples/Refactor/RenameDefinition/MultiModule/*.hs + , examples/Refactor/RenameDefinition/MultiModule_res/*.hs + , examples/Refactor/RenameDefinition/RenameModule/*.hs + , examples/Refactor/RenameDefinition/RenameModule_res/*.hs + , examples/Refactor/RenameDefinition/SpliceDecls/*.hs + , examples/Refactor/RenameDefinition/SpliceDecls_res/*.hs + , examples/Refactor/RenameDefinition/SpliceExpr/*.hs + , 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 + , test/ExtensionOrganizerTest/BangPatternsTest/*.hs + , test/ExtensionOrganizerTest/PatternSynonymsTest/*.hs + , test/ExtensionOrganizerTest/ViewPatternsTest/*.hs + , test/ExtensionOrganizerTest/LambdaCaseTest/*.hs + , test/ExtensionOrganizerTest/TupleSectionsTest/*.hs + --, test/ExtensionOrganizerTest/UnboxedTuplesTest/*.hs + +library + ghc-options: -O2 + exposed-modules: Language.Haskell.Tools.Refactor.Builtin + , Language.Haskell.Tools.Refactor.Builtin.GenerateTypeSignature + , Language.Haskell.Tools.Refactor.Builtin.OrganizeImports + , Language.Haskell.Tools.Refactor.Builtin.GenerateExports + , Language.Haskell.Tools.Refactor.Builtin.RenameDefinition + , Language.Haskell.Tools.Refactor.Builtin.ExtractBinding + , Language.Haskell.Tools.Refactor.Builtin.InlineBinding + , Language.Haskell.Tools.Refactor.Builtin.FloatOut + , Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMonad + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.ExtMap + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.TraverseAST + + + other-modules: Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers + , Language.Haskell.Tools.Refactor.Builtin.ExtensionOrganizer.Checkers.DerivingsChecker + , 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.PatternSynonymsChecker + , 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.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 + + + + build-depends: base >= 4.10 && < 4.11 + , mtl >= 2.2 && < 2.3 + , uniplate >= 1.6 && < 1.7 + , ghc-paths >= 0.1 && < 0.2 + , containers >= 0.5 && < 0.6 + , directory >= 1.2 && < 1.4 + , transformers >= 0.5 && < 0.6 + , references >= 0.3 && < 0.4 + , split >= 0.2 && < 0.3 + , filepath >= 1.4 && < 1.5 + , template-haskell >= 2.12 && < 2.13 + , ghc >= 8.2 && < 8.3 + , Cabal >= 2.0 && < 2.1 + , 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 + default-language: Haskell2010 + +test-suite haskell-tools-builtin-refactorings-test + type: exitcode-stdio-1.0 + ghc-options: -with-rtsopts=-M2g + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.10 && < 4.11 + , tasty >= 0.11 && < 0.12 + , tasty-hunit >= 0.9 && < 0.10 + , transformers >= 0.5 && < 0.6 + , either >= 4.4 && < 4.5 + , 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.1 + , 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 + -- stack test haskell-tools-builtin-refactorings:ht-extension-organizer-test + type: exitcode-stdio-1.0 + ghc-options: -with-rtsopts=-M2g + other-modules: ExtensionOrganizerTest.AnnotationParser + hs-source-dirs: test + main-is: ExtensionOrganizerTest/Main.hs + build-depends: base >= 4.10 && < 4.11 + , tasty >= 0.11 && < 0.12 + , tasty-hunit >= 0.9 && < 0.10 + , transformers >= 0.5 && < 0.6 + , either >= 4.4 && < 4.5 + , 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.1 + , 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 new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/AnnotationParser.hs @@ -0,0 +1,41 @@ +module ExtensionOrganizerTest.AnnotationParser where + +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 + +{-# ANN module "HLint: ignore Use zipWith" #-} + + +getExtensionAnnotations :: String -> SMap.Map (LogicalRelation Extension) [Int] +getExtensionAnnotations 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' + +parseFile :: String -> [(Int, [Extension])] -- SMap.Map Extension [Int] +parseFile = map parseLine . zip [1..] . lines + +parseLine :: (Int, String) -> (Int, [Extension]) +parseLine (num, line) = (num, parseAnnot line) + +parseAnnot :: String -> [Extension] +parseAnnot = map read . delimit (== ',') . getAnnot + +getAnnot :: String -> String +getAnnot = concat . takeWhile (not . isPrefixOf "*-}") . tail' . dropWhile (not . isPrefixOf "{-*" ) . words + where tail' [] = [] + tail' xs = tail xs + +delimit :: (a -> Bool) -> [a] -> [[a]] +delimit pred xs = delimit' pred xs [] + +delimit' :: (a -> Bool) -> [a] -> [[a]] -> [[a]] +delimit' _ [] acc = acc +delimit' pred xs acc = delimit' pred l2 (acc ++ [l1]) + where (l1, l2) = break' pred xs + +-- exludes the elemnt 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) diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/Combined.hs b/test/ExtensionOrganizerTest/BangPatternsTest/Combined.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/Combined.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE BangPatterns, + PatternSynonyms + #-} + +module Combined where + + +asd = [1..] + where + f !x {-* BangPatterns *-} + | ((!y):ys) <- x = case y of {-* BangPatterns *-} + (!z):zs -> 5 {-* BangPatterns *-} + where (_,!a) = (1,2) {-* BangPatterns *-} + + m = do + (!a,_) <- Just (1,2) {-* BangPatterns *-} + return a diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InAlt.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InAlt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InAlt.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE BangPatterns #-} + +module InAlt where + +f x = case x of + (!a,!b) -> a + b {-* BangPatterns, BangPatterns *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InExpr.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InExpr.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE BangPatterns #-} + +module InExpr where + +{-# ANN module "HLint: ignore Redundant lambda" #-} + +x = let (!a,!b) = (0,0) in a + b {-* BangPatterns, BangPatterns *-} + +f = \(!x,y) -> x + y {-* BangPatterns *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InMatchLhs.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InMatchLhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InMatchLhs.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + +module InMatchLhs where + +f !x = x {-* BangPatterns *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InPatSynRhs.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InPatSynRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InPatSynRhs.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, + BangPatterns + #-} + +module InPatSynRhs where + +pattern Bi a b = (!a,b) {-* BangPatterns, PatternSynonyms *-} + +pattern Uni x <- (!x):xs {-* BangPatterns *-} + where Uni !x = [x] {-* BangPatterns, PatternSynonyms *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InPattern.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InPattern.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE BangPatterns, + ViewPatterns + #-} + +module InPattern where + + +data Rec = Rec { num :: Int} + +(!x):(!xs) = [1..] {-* BangPatterns, BangPatterns *-} + +Just (Just !y) = Just $ Just 5 {-* BangPatterns *-} + +(!a1,!a2,!a3) = (1, 2, 3) {-* BangPatterns, BangPatterns, BangPatterns *-} + +[!b1, !b2] = [1,2] {-* BangPatterns, BangPatterns *-} + +f :: Rec -> Int +f Rec { num = !num } = num {-* BangPatterns *-} + +g x@(!y) = () {-* BangPatterns *-} + +h (id -> !x) = () {-* BangPatterns, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InRhsGuard.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InRhsGuard.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InRhsGuard.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE BangPatterns #-} + +module InRhsGuard where + +f x + | [!y] <- x = 5 {-* BangPatterns *-} diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InStmt.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InStmt.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE BangPatterns #-} + +module InStmt where + +f = do + let !x = 5 {-* BangPatterns *-} + (!a,_) <- Just (1,2) {-* BangPatterns *-} + return a diff --git a/test/ExtensionOrganizerTest/BangPatternsTest/InValueBind.hs b/test/ExtensionOrganizerTest/BangPatternsTest/InValueBind.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/BangPatternsTest/InValueBind.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + +module InValueBind where + +((!x):xs) = [1..] {-* BangPatterns *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/DataDeriving.hs b/test/ExtensionOrganizerTest/DerivingsTest/DataDeriving.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/DataDeriving.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass + #-} + +module DataDeriving where + +import Definitions + + +data D1 a = D1 a + deriving Show + +data D2 a = D2 a + deriving Eq + +data D3 a = D3 a + deriving Data {-* DeriveDataTypeable *-} + +data D4 a = D4 a + deriving Functor {-* DeriveFunctor *-} + +data D5 a = D5 a + deriving (Eq, Ord, Typeable, Foldable, C1) {-* DeriveDataTypeable, DeriveFoldable, DeriveAnyClass *-} + +data D6 a = D6 + deriving (Eq, Ord, Enum, Ix, Bounded, Show, Read, + Data, Typeable, Functor, Foldable, Traversable, {-* DeriveDataTypeable, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable *-} + Generic, Lift) {-* DeriveGeneric, DeriveLift *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/DataDerivingStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/DataDerivingStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/DataDerivingStrategies.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass, + DerivingStrategies + #-} + +module DataDerivingStrategies where + +import Definitions + + +data D1 a = D1 a + deriving Show + +data D2 a = D2 a + deriving stock Eq {-* DerivingStrategies *-} + +data D3 a = D3 a + deriving Data {-* DeriveDataTypeable *-} + +data D4 a = D4 a + deriving Functor {-* DeriveFunctor *-} + +data D5 a = D5 a + deriving stock (Eq, Ord, Typeable, Foldable) {-* DerivingStrategies, DeriveDataTypeable, DeriveFoldable *-} + deriving anyclass C1 {-* DerivingStrategies, DeriveAnyClass *-} + +data D6 a = D6 + deriving (Eq, Ord, Enum, Ix, Bounded, Show, Read, + Data, Typeable, Functor, Foldable, Traversable, {-* DeriveDataTypeable, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable *-} + Generic, Lift) {-* DeriveGeneric, DeriveLift *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/Definitions.hs b/test/ExtensionOrganizerTest/DerivingsTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/Definitions.hs @@ -0,0 +1,14 @@ +module Definitions + ( module Definitions + , module X + ) where + +import Data.Data as X (Data) +import Data.Typeable as X (Typeable) +import Data.Ix as X (Ix) +import GHC.Generics as X (Generic) +import Language.Haskell.TH.Syntax as X (Lift) + +class C1 a where + f1 :: a -> () + f1 _ = () diff --git a/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDeriving.hs b/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDeriving.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDeriving.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving + #-} + +module NewtypeDeriving where + +import Definitions +import DataDeriving + +newtype T1 a = T1 (D6 a) + deriving Data {-* DeriveDataTypeable *-} + +newtype T2 a = T2 (D6 a) + deriving (Show, Read, Data, Typeable) {-* DeriveDataTypeable, DeriveDataTypeable *-} + +newtype T3 a = T3 (D6 a) + deriving Eq + +newtype T4 a = T4 (D6 a) + deriving Functor {-* GeneralizedNewtypeDeriving *-} + +newtype T5 a = T5 (D6 a) + deriving (Eq, Ord, Ix, Bounded, + Show, Read, + Enum, Functor, Foldable, {-* GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving *-} + Data, Typeable, Traversable, Generic, Lift) {-* DeriveDataTypeable, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDerivingStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDerivingStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/NewtypeDerivingStrategies.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveFunctor, + DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving, + DerivingStrategies + #-} + +module NewtypeDerivingStrategies where + +import Definitions +import DataDeriving + +newtype T1 a = T1 (D6 a) + deriving Data {-* DeriveDataTypeable *-} + +newtype T2 a = T2 (D6 a) + deriving stock (Show, Read, Data) {-* DerivingStrategies, DeriveDataTypeable *-} + deriving newtype Typeable {-* DerivingStrategies, GeneralizedNewtypeDeriving *-} + +newtype T3 a = T3 (D6 a) + deriving Eq + +newtype T4 a = T4 (D6 a) + deriving stock Functor {-* DerivingStrategies, DeriveFunctor *-} + deriving newtype (Foldable, Show) {-* DerivingStrategies, GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving *-} + +newtype T5 a = T5 (D6 a) + deriving (Eq, Ord, Ix, Bounded, + Show, Read, + Enum, Functor, Foldable, {-* GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving, GeneralizedNewtypeDeriving *-} + Data, Typeable, Traversable, Generic, Lift) {-* DeriveDataTypeable, DeriveDataTypeable, DeriveTraversable, DeriveGeneric, DeriveLift *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneData.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneData.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneData.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass, + StandaloneDeriving + #-} + +module StandaloneData where + +import SynonymDefinitions + +deriving instance Show (D0' a) {-* StandaloneDeriving *-} +deriving instance Read (D0' a) {-* StandaloneDeriving *-} +deriving instance Eq (D0' a) {-* StandaloneDeriving *-} +deriving instance Enum (D0' a) {-* StandaloneDeriving *-} +deriving instance Ord (D0' a) {-* StandaloneDeriving *-} +deriving instance Bounded (D0' a) {-* StandaloneDeriving *-} +deriving instance Ix (D0' a) {-* StandaloneDeriving *-} + +deriving instance Data a => Data (D0' a) {-* StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (D0' a) {-* StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Generic a => Generic (D0' a) {-* StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (D0' a) {-* StandaloneDeriving, DeriveLift *-} +deriving instance Functor D0' {-* StandaloneDeriving, DeriveFunctor *-} +deriving instance Foldable D0' {-* StandaloneDeriving, DeriveFoldable *-} +deriving instance Traversable D0' {-* StandaloneDeriving, DeriveTraversable *-} + +deriving instance C1 (D0' a) {-* StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataStrategies.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass, + StandaloneDeriving, + DerivingStrategies + #-} + +module StandaloneDataStrategies where + +import SynonymDefinitions + +deriving stock instance Show (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Read (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Eq (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Enum (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Ord (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Bounded (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving stock instance Ix (D0' a) {-* DerivingStrategies, StandaloneDeriving *-} + +deriving stock instance Data a => Data (D0' a) {-* DerivingStrategies, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (D0' a) {-* StandaloneDeriving, DeriveDataTypeable *-} +deriving stock instance Generic a => Generic (D0' a) {-* DerivingStrategies, StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (D0' a) {-* StandaloneDeriving, DeriveLift *-} +deriving stock instance Functor D0' {-* DerivingStrategies, StandaloneDeriving, DeriveFunctor *-} +deriving instance Foldable D0' {-* StandaloneDeriving, DeriveFoldable *-} +deriving stock instance Traversable D0' {-* DerivingStrategies,StandaloneDeriving, DeriveTraversable *-} + +deriving anyclass instance C1 (D0' a) {-* DerivingStrategies, StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonyms.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonyms.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass, + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances + #-} + +module StandaloneDataSynonyms where + +import SynonymDefinitions + +deriving instance Show (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Read (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Eq (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Enum (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Ord (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Bounded (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Ix (D0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} + +deriving instance Data a => Data (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Generic a => Generic (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveLift *-} +deriving instance Functor D0 {-* TypeSynonymInstances, StandaloneDeriving, DeriveFunctor *-} +deriving instance Foldable D0 {-* TypeSynonymInstances, StandaloneDeriving, DeriveFoldable *-} +deriving instance Traversable D0 {-* TypeSynonymInstances, StandaloneDeriving, DeriveTraversable *-} + +deriving instance C1 (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonymsStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonymsStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneDataSynonymsStrategies.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveFunctor, + DeriveFoldable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + DeriveAnyClass, + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances, + DerivingStrategies + #-} + +module StandaloneDataSynonymsStrategies where + +import SynonymDefinitions + +deriving stock instance Show (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Read (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Eq (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Enum (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Ord (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Bounded (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving stock instance Ix (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} + +deriving stock instance Data a => Data (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving stock instance Generic a => Generic (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (D0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveLift *-} +deriving stock instance Functor D0 {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveFunctor *-} +deriving instance Foldable D0 {-* TypeSynonymInstances, StandaloneDeriving, DeriveFoldable *-} +deriving stock instance Traversable D0 {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveTraversable *-} + +deriving anyclass instance C1 (D0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtype.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtype.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtype.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving, + StandaloneDeriving + #-} + +module StandaloneNewtype where + +import SynonymDefinitions +import StandaloneData + + +deriving instance Show (T0' a) {-* StandaloneDeriving *-} +deriving instance Read (T0' a) {-* StandaloneDeriving *-} + +deriving instance Eq (T0' a) {-* StandaloneDeriving *-} +deriving instance Ord (T0' a) {-* StandaloneDeriving *-} +deriving instance Bounded (T0' a) {-* StandaloneDeriving *-} +deriving instance Ix (T0' a) {-* StandaloneDeriving *-} + +deriving instance Data a => Data (T0' a) {-* StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (T0' a) {-* StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Generic a => Generic (T0' a) {-* StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (T0' a) {-* StandaloneDeriving, DeriveLift *-} + +deriving instance Functor T0' {-* StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Foldable T0' {-* StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Traversable T0' {-* StandaloneDeriving, DeriveTraversable *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeAny.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeAny.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeAny.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StandaloneDeriving, + DeriveAnyClass + #-} + +module StandaloneNewtypeAny where + +import SynonymDefinitions +import StandaloneDataSynonyms + +deriving instance C1 (T0' a) {-* StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeStrategies.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveFunctor, + DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving, + DeriveAnyClass, + StandaloneDeriving, + DerivingStrategies + #-} + +module StandaloneNewtypeStrategies where + +import SynonymDefinitions +import StandaloneData + + +deriving stock instance Show (T0' a) {-* DerivingStrategies, StandaloneDeriving *-} +deriving newtype instance Read (T0' a) {-* DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving *-} + +deriving instance Eq (T0' a) {-* StandaloneDeriving *-} +deriving instance Ord (T0' a) {-* StandaloneDeriving *-} +deriving newtype instance Bounded (T0' a) {-* DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving newtype instance Ix (T0' a) {-* DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Enum (T0' a) {-* StandaloneDeriving, GeneralizedNewtypeDeriving *-} + +deriving stock instance Data a => Data (T0' a) {-* DerivingStrategies, StandaloneDeriving, DeriveDataTypeable *-} +deriving newtype instance Typeable a => Typeable (T0' a) {-* DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving stock instance Traversable T0' {-* DerivingStrategies, StandaloneDeriving, DeriveTraversable *-} +deriving instance Generic a => Generic (T0' a) {-* StandaloneDeriving, DeriveGeneric *-} +deriving stock instance Lift a => Lift (T0' a) {-* DerivingStrategies, StandaloneDeriving, DeriveLift *-} + +deriving stock instance Functor T0' {-* DerivingStrategies, StandaloneDeriving, DeriveFunctor *-} +deriving instance Foldable T0' {-* StandaloneDeriving, GeneralizedNewtypeDeriving *-} + +deriving newtype instance C1 a => C1 (T0' a) {-* DerivingStrategies, StandaloneDeriving, GeneralizedNewtypeDeriving *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonyms.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonyms.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonyms.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances + #-} + +module StandaloneNewtypeSynonyms where + +import SynonymDefinitions +import StandaloneDataSynonyms + + +deriving instance Show (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Read (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} + +deriving instance Eq (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Ord (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Bounded (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Ix (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} + +deriving instance Data a => Data (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Typeable a => Typeable (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving instance Generic a => Generic (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveGeneric *-} +deriving instance Lift a => Lift (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveLift *-} + +deriving instance Functor T0 {-* TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Foldable T0 {-* TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Traversable T0 {-* TypeSynonymInstances, StandaloneDeriving, DeriveTraversable *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsAny.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsAny.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsAny.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE StandaloneDeriving, + DeriveAnyClass, + TypeSynonymInstances + #-} + +module StandaloneNewtypeSynonymsAny where + +import SynonymDefinitions +import StandaloneDataSynonyms + +deriving instance C1 (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveAnyClass *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsStrategies.hs b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsStrategies.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/StandaloneNewtypeSynonymsStrategies.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveDataTypeable, + DeriveTraversable, + DeriveGeneric, + DeriveLift, + GeneralizedNewtypeDeriving, + DeriveAnyClass, + StandaloneDeriving, + TypeSynonymInstances, + DerivingStrategies + #-} + +module StandaloneNewtypeSynonymsStrategies where + +import SynonymDefinitions +import StandaloneDataSynonyms + + +deriving stock instance Show (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving *-} +deriving newtype instance Read (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} + +deriving instance Eq (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving instance Ord (T0 a) {-* TypeSynonymInstances, StandaloneDeriving *-} +deriving newtype instance Bounded (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving newtype instance Ix (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Enum (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} + + +deriving stock instance Data a => Data (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveDataTypeable *-} +deriving newtype instance Typeable a => Typeable (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving stock instance Traversable T0 {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveTraversable *-} +deriving instance Generic a => Generic (T0 a) {-* TypeSynonymInstances, StandaloneDeriving, DeriveGeneric *-} +deriving stock instance Lift a => Lift (T0 a) {-* DerivingStrategies, TypeSynonymInstances, StandaloneDeriving, DeriveLift *-} + +deriving instance Functor T0 {-* TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} +deriving instance Foldable T0 {-* TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving *-} diff --git a/test/ExtensionOrganizerTest/DerivingsTest/SynonymDefinitions.hs b/test/ExtensionOrganizerTest/DerivingsTest/SynonymDefinitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/DerivingsTest/SynonymDefinitions.hs @@ -0,0 +1,15 @@ +module SynonymDefinitions + ( module SynonymDefinitions + , module Definitions + ) where + +import Definitions + + +data D0' a = D0' + +type D0 = D0' + +newtype T0' a = T0 (D0' a) + +type T0 = T0' diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/Combined.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Combined.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Combined.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleInstances, + MultiParamTypeClasses + #-} + +module Combined where + +import Definitions + +-- NOTE: runs really slowly + +-- same TyVars and TopLevelTyVar + +instance C2 a (T2 c c) where {-* FlexibleInstances, FlexibleInstances, MultiParamTypeClasses *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/Definitions.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses, + TypeOperators + #-} + +module Definitions where + +class C1 a where + f1 :: a -> Bool + +class C2 a b where + f2 :: a -> b -> Bool + +class a :?: b where + h :: a -> b -> Bool + +class a :!: b where + j :: a -> b -> Bool + + +data T4 a b c d = T4 a b c d +data T3 a b c = T3 a b c +data T2 a b = T2 a b +data T1 a = T1 a +data T0 = T0 + +data a :+: b = Plus a b +data (a :++: b) c = PPlus a b c +data a :-: b = Minus a b diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedTypes.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeOperators, + FlexibleInstances + #-} + +module NestedTypes where + +import Definitions + +{-# ANN module "HLint: ignore Redundant bracket" #-} + + +instance C1 (T1 a) where + f1 _ = True + +instance C1 (T1 (T1 a)) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 (T2 a (T1 b)) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 (T2 (T1 a) b) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 ((T1 a) :+: b) where {-* FlexibleInstances, TypeOperators *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedUnitTyCon.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedUnitTyCon.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedUnitTyCon.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FlexibleInstances + #-} + +module NestedUnitTyCon where + +import Definitions + + +instance C1 (T3 a b T0) where {-* FlexibleInstances *-} + f1 _ = True + +-- FlexibleInstances +instance C1 (T3 a T0 c) where {-* FlexibleInstances *-} + f1 _ = True + + -- FlexibleInstances +instance C1 (T3 T0 b c) where {-* FlexibleInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedWiredInType.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedWiredInType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NestedWiredInType.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FlexibleInstances #-} + +module NestedWiredInType where + +import Definitions + + +instance C1 (T3 a b Int) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 (T3 a Int c) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 (T3 Int b c) where {-* FlexibleInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceOFF.hs @@ -0,0 +1,54 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/NoOccurenceON.hs @@ -0,0 +1,57 @@ +{-# 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/SameTyVars.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SameTyVars.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/SameTyVars.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleInstances + #-} + +module SameTyVars where + +import Definitions + + +instance C1 (T2 a a) where {-* FlexibleInstances *-} + f1 _ = True + +instance C1 (T4 a b d d) where {-* FlexibleInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelTyVar.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelTyVar.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelTyVar.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses, + TypeOperators, + FlexibleInstances + #-} + +module TopLevelTyVar 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 ((a :++: b) c) (d) where {-* FlexibleInstances, MultiParamTypeClasses, TypeOperators *-} + f2 _ _ = True diff --git a/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelWiredInType.hs b/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelWiredInType.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/FlexibleInstancesTest/TopLevelWiredInType.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} + +module TopLevelWiredInType where + +import Definitions + + +instance C1 Int where {-* FlexibleInstances *-} + f1 _ = True diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/Definitions.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/Definitions.hs @@ -0,0 +1,3 @@ +module Definitions where + +data Rec = Rec { num :: Int } diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InCaseRhs.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InCaseRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InCaseRhs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LambdaCase #-} + +module InCaseRhs where + +f x = case x of + [] -> \case {() -> ()} {-* LambdaCase *-} + xs -> \case {() -> ()} {-* LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InCompStmt.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InCompStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InCompStmt.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LambdaCase #-} + +module InCompStmt where + +xs = [ (\case {_ -> ()}) x | x <- [1..10] ] {-* LambdaCase *-} + +ys = [ 2*y | y <- (\case {x -> x}) [1..10] ] {-* LambdaCase *-} + +zs = [ (\case {_ -> ()}) z | z <- (\case {x -> x}) [1..10] ] {-* LambdaCase, LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InExpr.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE LambdaCase, + MultiWayIf, + TupleSections + #-} + +module InExpr where + +import Definitions + +{-# ANN module "HLint: ignore Redundant lambda" #-} +{-# ANN module "HLint: ignore Redundant bracket" #-} + +x1 = (\case {() -> ()}) : [\case {() -> ()}] {-* LambdaCase, LambdaCase *-} + +x2 = - ((\case {_ -> 5}) 6) {-* LambdaCase *-} + +f1 g = g (\case {_ -> ()}) {-* LambdaCase *-} + +f2 g h = h g (\case {_ -> ()}) {-* LambdaCase *-} + +f3 = \x -> \case {_ -> ()} {-* LambdaCase *-} + +x3 = let x = (\case {_ -> ()}) 5 in x {-* LambdaCase *-} + +x4 = if (\case {_ -> True}) 5 {-* LambdaCase *-} + then (\case {_ -> True}) {-* LambdaCase *-} + else (\case {_ -> False}) {-* LambdaCase *-} + +x5 = if | (\case {_ -> False}) 5 -> 20 {-* LambdaCase *-} + | (\case {_ -> True}) 5 -> (\case {_ -> 10}) () {-* LambdaCase, LambdaCase *-} + | otherwise -> (\case {_ -> 10}) () {-* LambdaCase *-} --MultiWayIf + +x6 = case (\case {_ -> [1..10]}) () of {-* LambdaCase *-} + [] -> \case {_ -> 5} {-* LambdaCase *-} + xs -> \case {_ -> 7} {-* LambdaCase *-} + +x7 = (\case {_ -> ()}, 5) {-* LambdaCase *-} + +x8 = (\case {_ -> ()},) {-* LambdaCase, TupleSections *-} + +x9 = ([(\case {_ -> ()})]) {-* LambdaCase *-} + +f4 = (((\case {_ -> 5}) 0) +) {-* LambdaCase *-} + +f5 = (+ ((\case {_ -> 5}) 0)) {-* LambdaCase *-} + +x10 = Rec { num = (\case {_ -> 5}) 0 } {-* LambdaCase *-} + +x11 r = r { num = (\case {_ -> 5}) 0 } {-* LambdaCase *-} + +x12 = [(\case {_ -> 1}) 0, ((\case {_ -> 2}) 0) .. ((\case {_ -> 10}) 0) ] {-* LambdaCase, LambdaCase, LambdaCase *-} + +x13 = ((\case {_ -> 5}) 0) :: Int {-* LambdaCase *-} + +-- x14 = (\case {_ -> 5}) @Int ((\case {_ -> 5}) 5) diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InFieldUpdate.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InFieldUpdate.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InFieldUpdate.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LambdaCase #-} + +module InFieldUpdate where + +import Definitions + +f Rec { num = num } = Rec {num = (\case {n -> 2*n}) num} {-* LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InPattern.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InPattern.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LambdaCase, + ViewPatterns + #-} + +module InPattern where + +f (\case {[] -> []} -> []) = () {-* LambdaCase, ViewPatterns *-} +f (\case {xs -> xs} -> ys) = () {-* LambdaCase, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InRhs.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InRhs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LambdaCase #-} + +module InRhs where + +f [] = \case { [] -> ()} {-* LambdaCase *-} +f x = \case { [] -> ()} {-* LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InRhsGuard.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InRhsGuard.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InRhsGuard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LambdaCase #-} + +module InRhsGuard where + +f x + | y1 <- (\case {() -> ()}) x, {-* LambdaCase *-} + y2 <- (\case {() -> ()}) y1 {-* LambdaCase *-} + = () + | z1 <- (\case {() -> ()}) x {-* LambdaCase *-} + = () diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InStmt.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InStmt.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LambdaCase #-} + +module InStmt where + +f x = do + let k = \case {_ -> 5} {-* LambdaCase *-} + (\case {_ -> Just ()}) 5 {-* LambdaCase *-} + y <- (\case {_ -> Just 5}) x {-* LambdaCase *-} + z <- (\case {_ -> Just 5}) y {-* LambdaCase *-} + return $ (\case {_ -> 5}) z {-* LambdaCase *-} diff --git a/test/ExtensionOrganizerTest/LambdaCaseTest/InTupSecElem.hs b/test/ExtensionOrganizerTest/LambdaCaseTest/InTupSecElem.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/LambdaCaseTest/InTupSecElem.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LambdaCase, + TupleSections + #-} + +module InTupSecElem where + +f = (,\case {[] -> ()}) {-* LambdaCase, TupleSections *-} diff --git a/test/ExtensionOrganizerTest/Main.hs b/test/ExtensionOrganizerTest/Main.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/Main.hs @@ -0,0 +1,237 @@ +module Main where + +import Test.Tasty (TestTree, testGroup, defaultMain) +import Test.Tasty.HUnit (assertEqual, testCase) + +import GHC hiding (loadModule, ModuleName) +import GHC.Paths (libdir) +import Language.Haskell.TH.LanguageExtensions (Extension) +import SrcLoc (SrcSpan(..), srcSpanEndLine) + +import Data.List (sort) +import qualified Data.Map.Strict as SMap (Map, map) +import System.FilePath (FilePath, addExtension, ()) + +import ExtensionOrganizerTest.AnnotationParser (getExtensionAnnotations) +import Language.Haskell.Tools.Refactor hiding (ModuleName) +import Language.Haskell.Tools.Refactor.Builtin.OrganizeExtensions + +import Control.Reference (_1, (.-)) + + +{- NOTE: + Exhaustive checks for Pattern type AST nodes are not given for each check. + We only give exhaustive test cases for nested patterns in bangPatternsTest. +-} + +main :: IO () +main = defaultMain extensionOrganizerTestGroup + +extensionOrganizerTestGroup = testGroup "ExtensionOrganizerTest" + [ mkTests recordWildCardsTest + , mkTests flexibleInstancesTest + , mkTests derivingsTest + , mkTests patternSynonymsTest + , mkTests bangPatternsTest + , mkTests templateHaskellTest + , mkTests viewPatternsTest + , mkTests lambdaCaseTest + , mkTests tupleSectionsTest + , mkNestedTests magicHashTest + ] + +testRoot = "test/ExtensionOrganizerTest" + +mkModulePath :: FilePath -> ModuleName -> FilePath +mkModulePath testDir testName = testRoot testDir testName + +type NestedTestSuite = (FilePath, [TestSuite]) +type TestSuite = (FilePath, [TestName]) +type TestName = String +type ModuleName = String +type Line = Int +type SimpleMap = SMap.Map (LogicalRelation Extension) [Line] + +spanToLine :: SrcSpan -> Line +spanToLine (RealSrcSpan s) = srcSpanEndLine s + +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 + exts <- collectExtensions modAST + return $! simplifyExtMap exts + +getExtAnnotsFrom :: FilePath -> ModuleName -> IO SimpleMap +getExtAnnotsFrom dir moduleName = do + s <- readFile $ addExtension (mkModulePath dir moduleName) ".hs" + return $! getExtensionAnnotations s + + +mkTest :: FilePath -> ModuleName -> TestTree +mkTest dir moduleName = testCase moduleName $ mkAssertion dir moduleName + +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 + +mkTests :: TestSuite -> TestTree +mkTests (testDir, tests) = testGroup testDir (map (mkTest testDir) tests) + +mkNestedTests :: NestedTestSuite -> TestTree +mkNestedTests (parentDir, suites) = testGroup parentDir nestedTests + where nestedSuites = map (_1 .- (parentDir )) suites + nestedTests = map mkTests nestedSuites + + + + +recordWildCardsTest :: TestSuite +recordWildCardsTest = (recordWildCardsRoot, recordWildCardsModules) +recordWildCardsRoot = "RecordWildCardsTest" +recordWildCardsModules = [ "InExpression" + , "InPattern" + ] + +flexibleInstancesTest :: TestSuite +flexibleInstancesTest = (flexibleInstancesRoot, flexibleInstancesModules) +flexibleInstancesRoot = "FlexibleInstancesTest" +flexibleInstancesModules = [ "Combined" + , "NestedTypes" + , "NestedUnitTyCon" + , "NestedWiredInType" + , "NoOccurenceON" + , "NoOccurenceOFF" + , "SameTyVars" + , "TopLevelTyVar" + , "TopLevelWiredInType" + ] + +derivingsTest :: TestSuite +derivingsTest = (derivingsRoot, derivingsModules) +derivingsRoot = "DerivingsTest" +derivingsModules = [ "DataDeriving" + , "DataDerivingStrategies" + , "NewtypeDeriving" + , "NewtypeDerivingStrategies" + , "StandaloneData" + , "StandaloneDataStrategies" + , "StandaloneDataSynonyms" + , "StandaloneDataSynonymsStrategies" + , "StandaloneNewtype" + , "StandaloneNewtypeStrategies" + , "StandaloneNewtypeAny" + , "StandaloneNewtypeSynonyms" + , "StandaloneNewtypeSynonymsStrategies" + , "StandaloneNewtypeSynonymsAny" + ] + +patternSynonymsTest :: TestSuite +patternSynonymsTest = (patSynRoot, patSynModules) +patSynRoot = "PatternSynonymsTest" +patSynModules = [ "UniDirectional" + , "BiDirectional" + ] + +bangPatternsTest :: TestSuite +bangPatternsTest = (bangPatternsRoot, bangPatternsModules) +bangPatternsRoot = "BangPatternsTest" +bangPatternsModules = [ "Combined" + , "InAlt" + , "InExpr" + , "InMatchLhs" + , "InPatSynRhs" + , "InPattern" + , "InRhsGuard" + , "InStmt" + , "InValueBind" + ] + +templateHaskellTest :: TestSuite +templateHaskellTest = (thRoot, thModules) +thRoot = "TemplateHaskellTest" +thModules = [ "Quote" + , "Splice" + ] + +viewPatternsTest :: TestSuite +viewPatternsTest = (vpRoot, vpModules) +vpRoot = "ViewPatternsTest" +vpModules = [ "InAlt" + , "InExpr" + , "InMatchLhs" + , "InMatchLhsNested" + ] + +lambdaCaseTest :: TestSuite +lambdaCaseTest = (lcRoot, lcModules) +lcRoot = "LambdaCaseTest" +lcModules = [ "InCaseRhs" + , "InCompStmt" + , "InExpr" + , "InFieldUpdate" + , "InPattern" + , "InRhs" + , "InRhsGuard" + , "InStmt" + , "InTupSecElem" + ] + +tupleSectionsTest :: TestSuite +tupleSectionsTest = (tsRoot, tsModules) +tsRoot = "TupleSectionsTest" +tsModules = [ "InCaseRhs" + , "InCompStmt" + , "InExpr" + , "InFieldUpdate" + , "InPattern" + , "InRhs" + , "InRhsGuard" + , "InStmt" + , "InTupSecElem" + , "NoTupleSections" + ] + + +magicHashTest :: NestedTestSuite +magicHashTest = (mhRoot, [magicHashLiteralTest, magicHashNameTest]) +mhRoot = "MagicHashTest" + + +magicHashNameTest :: TestSuite +magicHashNameTest = (mhNameRoot, mhNameModules) +mhNameRoot = "Name" +mhNameModules = [ "InAssertion" + , "InClassElement" + , "InDecl" + , "InDeclHead" + , "InExpr" + , "InFieldDecl" + , "InFieldUpdate" + , "InFunDeps" + , "InInstanceHead" + --, "InKind" NO PARSE + , "InMatchLhs" + , "InPatSynLhs" + , "InPattern" + , "InPatternField" + , "InType" + --, "InTypeFamily" NO PARSE + , "InTypeSig" + ] + +magicHashLiteralTest :: TestSuite +magicHashLiteralTest = (mhLiteralRoot, mhLiteralModules) +mhLiteralRoot = "Literal" +mhLiteralModules = [ "InExpr" ] diff --git a/test/ExtensionOrganizerTest/PatternSynonymsTest/BiDirectional.hs b/test/ExtensionOrganizerTest/PatternSynonymsTest/BiDirectional.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/PatternSynonymsTest/BiDirectional.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} + +module BiDirectional where + +pattern X :: a -> [a] {-* PatternSynonyms *-} +pattern X a = [a] {-* PatternSynonyms *-} diff --git a/test/ExtensionOrganizerTest/PatternSynonymsTest/UniDirectional.hs b/test/ExtensionOrganizerTest/PatternSynonymsTest/UniDirectional.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/PatternSynonymsTest/UniDirectional.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} + +module UniDirectional where + +pattern X :: a -> b -> c -> (a,b,c) {-* PatternSynonyms *-} +pattern X a b c <- (a,b,c) {-* PatternSynonyms *-} diff --git a/test/ExtensionOrganizerTest/RecordWildCardsTest/Definitions.hs b/test/ExtensionOrganizerTest/RecordWildCardsTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/RecordWildCardsTest/Definitions.hs @@ -0,0 +1,6 @@ +module Definitions where + +data T = T { a :: Int + , b :: Int -> Bool + , c :: Double + } diff --git a/test/ExtensionOrganizerTest/RecordWildCardsTest/InExpression.hs b/test/ExtensionOrganizerTest/RecordWildCardsTest/InExpression.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/RecordWildCardsTest/InExpression.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} + +module InExpression where + +import Definitions + +g :: T +g = let a = 3 + b = const True + c = 3.14 + in T{..} {-* RecordWildCards *-} diff --git a/test/ExtensionOrganizerTest/RecordWildCardsTest/InPattern.hs b/test/ExtensionOrganizerTest/RecordWildCardsTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/RecordWildCardsTest/InPattern.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RecordWildCards #-} + +module InPattern where + +import Definitions + +f :: T -> Bool +f T{a=1,c=1,..} = True {-* RecordWildCards *-} +f T{..} = True {-* RecordWildCards *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/Definitions.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/Definitions.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/Definitions.hs @@ -0,0 +1,3 @@ +module Definitions where + +data Rec = Rec { tup :: (Int, Int) } diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InCaseRhs.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InCaseRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InCaseRhs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TupleSections #-} + +module InCaseRhs where + +f x = case x of + [] -> (0,) {-* TupleSections *-} + xs -> (0,) {-* TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InCompStmt.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InCompStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InCompStmt.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TupleSections #-} + +module InCompStmt where + +xs = [ (0,) x | x <- [1..10] ] {-* TupleSections *-} + +ys = [ fst y | y <- [(0,) 1] ] {-* TupleSections *-} + +zs = [ (0,) z | z <- [(0,) 1] ] {-* TupleSections, TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InExpr.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MultiWayIf, + TupleSections + #-} + +module InExpr where + +import Definitions + +{-# ANN module "HLint: ignore Redundant lambda" #-} +{-# ANN module "HLint: ignore Redundant bracket" #-} + +x1 = (0,) : [(0,)] {-* TupleSections, TupleSections *-} + +x2 = - (fst $ (0,) 6) {-* TupleSections *-} + +f1 g = g (0,) {-* TupleSections *-} + +f2 g h = h g (0,) {-* TupleSections *-} + +f3 = \x -> fst . (0,) {-* TupleSections *-} + +x3 = let x = (0,) 0 in x {-* TupleSections *-} + +x4 = if fst $ (True,) 0 {-* TupleSections *-} + then (0,) {-* TupleSections *-} + else (,0) {-* TupleSections *-} + +x5 = if | fst $ (True,) 0 -> 20 {-* TupleSections *-} + | snd $ (,True) 0 -> fst $ (0,) 5 {-* TupleSections, TupleSections *-} + | otherwise -> fst $ (0,) 5 {-* TupleSections *-} --MultiWayIf + +x6 = case fst $ ([],) () of {-* TupleSections *-} + [] -> (0,) {-* TupleSections *-} + xs -> (0,) {-* TupleSections *-} + +x7 = ((0,) , 5) {-* TupleSections *-} + +x8 = ((0,),(0,)) {-* TupleSections, TupleSections *-} + +x9 = ([(0,)]) {-* TupleSections *-} + +f4 = ((fst $ (0,) 5) +) {-* TupleSections *-} + +f5 = (+ (fst $ (0,) 5)) {-* TupleSections *-} + +x10 = Rec { tup = (0,) 0 } {-* TupleSections *-} + +x11 r = r { tup = (0,) 0 } {-* TupleSections *-} + +x12 = [fst $ (0,) 0, fst $ (2,) 0 .. fst $ (10,) 0 ] {-* TupleSections, TupleSections, TupleSections *-} + +x13 = ((0,) 0) :: (Int,Int) {-* TupleSections *-} + +-- x14 = (\case {_ -> 5}) @Int ((\case {_ -> 5}) 5) diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InFieldUpdate.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InFieldUpdate.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InFieldUpdate.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TupleSections #-} + +module InFieldUpdate where + +import Definitions + +f Rec { tup = tup } = Rec {tup = (0,) 0} {-* TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InPattern.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InPattern.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InPattern.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TupleSections, + ViewPatterns + #-} + +module InPattern where + +f (fst . (,0) -> []) = () {-* TupleSections, ViewPatterns *-} +f (fst . (,0) -> ys) = () {-* TupleSections, ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InRhs.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InRhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InRhs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TupleSections #-} + +module InRhs where + +f [] = (0,) {-* TupleSections *-} +f x = (0,) {-* TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InRhsGuard.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InRhsGuard.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InRhsGuard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TupleSections #-} + +module InRhsGuard where + +f x + | y1 <- (0,) x, {-* TupleSections *-} + y2 <- (0,) y1 {-* TupleSections *-} + = () + | z1 <- (0,) x {-* TupleSections *-} + = () diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InStmt.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InStmt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InStmt.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TupleSections #-} + +module InStmt where + +f x = do + let k = (0,) {-* TupleSections *-} + fst $ (Just 5,) 0 {-* TupleSections *-} + y <- fst $ (Just 5,) 0 {-* TupleSections *-} + z <- fst $ (Just 5,) 0 {-* TupleSections *-} + return $ (0,) z {-* TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/InTupSecElem.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/InTupSecElem.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/InTupSecElem.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TupleSections + #-} + +module InTupSecElem where + +f = ((1,),(1,)) {-* TupleSections, TupleSections *-} diff --git a/test/ExtensionOrganizerTest/TupleSectionsTest/NoTupleSections.hs b/test/ExtensionOrganizerTest/TupleSectionsTest/NoTupleSections.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/TupleSectionsTest/NoTupleSections.hs @@ -0,0 +1,5 @@ +module NoTupleSections where + +x = (,) +y = (,,) +z = (,,,) diff --git a/test/ExtensionOrganizerTest/ViewPatternsTest/InAlt.hs b/test/ExtensionOrganizerTest/ViewPatternsTest/InAlt.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ViewPatternsTest/InAlt.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ViewPatterns #-} + +module InAlt where + +f g x = case x of + (g -> []) -> () {-* ViewPatterns *-} + (g -> x:xs) -> () {-* ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/ViewPatternsTest/InExpr.hs b/test/ExtensionOrganizerTest/ViewPatternsTest/InExpr.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ViewPatternsTest/InExpr.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ViewPatterns #-} + +module InExpr where + +{-# ANN module "HLint: ignore Redundant lambda" #-} + +f g = let (g -> (a,b)) = (0,0) in a + b {-* ViewPatterns *-} + +h j = \(j -> (x,y)) -> x + y {-* ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhs.hs b/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhs.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ViewPatterns #-} + +module InMatchLhs where + +f (id -> []) = () {-* ViewPatterns *-} +f (id -> x:xs) = () {-* ViewPatterns *-} diff --git a/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhsNested.hs b/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhsNested.hs new file mode 100644 --- /dev/null +++ b/test/ExtensionOrganizerTest/ViewPatternsTest/InMatchLhsNested.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ViewPatterns #-} + +module InMatchLhsNested where + +f x = () + where g h (h -> []) = () {-* ViewPatterns *-} + g h (h -> x:xs) = () {-* ViewPatterns *-} + + h (j, j -> []) = () {-* ViewPatterns *-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE LambdaCase, TypeFamilies #-} + +module Main where + +import Test.Tasty (TestTree, testGroup, defaultMain) +import Test.Tasty.HUnit + +import DynFlags (xopt) +import GHC hiding (loadModule, ParsedModule) +import GHC.Paths ( libdir ) +import Module as GHC (mkModuleName) +import StringBuffer (hGetStringBuffer) + +import Control.Monad (Monad(..), mapM, (=<<)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Reference ((^.)) +import Data.Either.Combinators (mapRight, isLeft) +import Data.List +import Data.List.Split (splitOn) +import Data.Maybe (Maybe(..), fromJust) +import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import System.Directory (listDirectory) +import System.FilePath +import System.IO + +import Language.Haskell.Tools.AST as AST +import Language.Haskell.Tools.BackendGHC (runTrf, trfModule, trfModuleRename) +import Language.Haskell.Tools.PrettyPrint (prettyPrint) +import Language.Haskell.Tools.PrettyPrint.Prepare +import Language.Haskell.Tools.Refactor +import Language.Haskell.Tools.Refactor.Builtin (builtinRefactorings) + +--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 + +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" + , "Refactor.OrganizeImports.Ctor" + , "Refactor.OrganizeImports.Class" + , "Refactor.OrganizeImports.Coerce" + , "Refactor.OrganizeImports.Fields" + , "Refactor.OrganizeImports.Operator" + , "Refactor.OrganizeImports.SameName" + , "Refactor.OrganizeImports.Removed" + , "Refactor.OrganizeImports.ReorderGroups" + , "Refactor.OrganizeImports.ReorderComment" + , "Refactor.OrganizeImports.KeepCtorOfMarshalled" + , "Refactor.OrganizeImports.KeepHiding" + , "Refactor.OrganizeImports.KeepPrelude" + , "Refactor.OrganizeImports.KeepReexported" + , "Refactor.OrganizeImports.KeepRenamedReexported" + , "Refactor.OrganizeImports.KeepExplicit" + , "Refactor.OrganizeImports.MakeExplicit.ImportOne" + , "Refactor.OrganizeImports.MakeExplicit.ImportThree" + , "Refactor.OrganizeImports.MakeExplicit.ImportClassFun" + , "Refactor.OrganizeImports.MakeExplicit.ImportCon" + , "Refactor.OrganizeImports.MakeExplicit.ImportRecordSel" + , "Refactor.OrganizeImports.MakeExplicit.ImportUnited" + , "Refactor.OrganizeImports.MakeExplicit.ImportUnitedCount" + , "Refactor.OrganizeImports.MakeExplicit.ImportFour" + , "Refactor.OrganizeImports.MakeExplicit.ImportFunHiddenClass" + , "Refactor.OrganizeImports.MakeExplicit.ImportFunOutOfClass" + , "Refactor.OrganizeImports.MakeExplicit.Renamed" + , "Refactor.OrganizeImports.InstanceCarry.ImportOrphan" + , "Refactor.OrganizeImports.InstanceCarry.ImportNonOrphan" + , "Refactor.OrganizeImports.NarrowQual" + , "Refactor.OrganizeImports.NarrowSpec" + , "Refactor.OrganizeImports.StandaloneDeriving" + , "Refactor.OrganizeImports.TemplateHaskell" + , "Refactor.OrganizeImports.NarrowType" + , "CPP.BetweenImports" + , "CPP.ConditionalImport" + , "CPP.ConditionalImportBegin" + , "CPP.ConditionalImportEnd" + , "CPP.ConditionalSubImport" + , "CPP.ConditionalImportHalfRemoved" + , "CPP.ConditionalImportMulti" + , "CPP.ConditionalImportOrder" + ] + +generateSignatureTests = + [ ("Refactor.GenerateTypeSignature.Simple", "3:1-3:10") + , ("Refactor.GenerateTypeSignature.Function", "3:1-3:15") + , ("Refactor.GenerateTypeSignature.HigherOrder", "3:1-3:14") + , ("Refactor.GenerateTypeSignature.Polymorph", "3:1-3:10") + , ("Refactor.GenerateTypeSignature.PolymorphSub", "5:3-5:4") + , ("Refactor.GenerateTypeSignature.PolymorphSubMulti", "5:3-5:4") + , ("Refactor.GenerateTypeSignature.Placement", "4:1-4:10") + , ("Refactor.GenerateTypeSignature.Tuple", "3:1-3:18") + , ("Refactor.GenerateTypeSignature.Complex", "3:1-3:21") + , ("Refactor.GenerateTypeSignature.Local", "4:3-4:12") + , ("Refactor.GenerateTypeSignature.Let", "3:9-3:18") + , ("Refactor.GenerateTypeSignature.TypeDefinedInModule", "3:1-3:1") + , ("Refactor.GenerateTypeSignature.BringToScope.AlreadyQualImport", "6:1-6:2") + , ("Refactor.GenerateTypeSignature.CanCaptureVariable", "8:10-8:10") + , ("Refactor.GenerateTypeSignature.CanCaptureVariableHasOtherDef", "8:10-8:10") + ] + +wrongGenerateSigTests = + [ ("Refactor.GenerateTypeSignature.CannotCaptureVariable", "7:10-7:10") + , ("Refactor.GenerateTypeSignature.CannotCaptureVariableNoExt", "8:10-8:10") + , ("Refactor.GenerateTypeSignature.ComplexLhs", "3:1") + , ("Refactor.GenerateTypeSignature.ComplexLhs", "4:1") + , ("Refactor.GenerateTypeSignature.ComplexLhs", "5:1") + , ("Refactor.GenerateTypeSignature.ComplexLhs", "6:1") + ] + +generateExportsTests = + [ "Refactor.GenerateExports.Normal" + , "Refactor.GenerateExports.Operators" + ] + +renameDefinitionTests = + [ ("Refactor.RenameDefinition.AmbiguousFields", "4:14-4:15", "xx") + , ("Refactor.RenameDefinition.RecordField", "3:22-3:23", "xCoord") + , ("Refactor.RenameDefinition.Constructor", "3:14-3:19", "Point2D") + , ("Refactor.RenameDefinition.Type", "5:16-5:16", "Point2D") + , ("Refactor.RenameDefinition.Function", "3:1-3:2", "q") + , ("Refactor.RenameDefinition.AccentName", "3:1-3:2", "á") + , ("Refactor.RenameDefinition.QualName", "3:1-3:2", "q") + , ("Refactor.RenameDefinition.BacktickName", "3:1-3:2", "g") + , ("Refactor.RenameDefinition.ParenName", "4:3-4:5", "<->") + , ("Refactor.RenameDefinition.RecordWildcards", "4:32-4:33", "yy") + , ("Refactor.RenameDefinition.RecordPatternSynonyms", "4:16-4:17", "xx") + , ("Refactor.RenameDefinition.ClassMember", "7:3-7:4", "q") + , ("Refactor.RenameDefinition.LocalFunction", "4:5-4:6", "g") + , ("Refactor.RenameDefinition.LayoutAware", "3:1-3:2", "main") + , ("Refactor.RenameDefinition.FormattingAware", "3:1-3:2", "aa") + , ("Refactor.RenameDefinition.Arg", "4:3-4:4", "y") + , ("Refactor.RenameDefinition.FunTypeVar", "3:6-3:7", "x") + , ("Refactor.RenameDefinition.FunTypeVarLocal", "5:10-5:11", "b") + , ("Refactor.RenameDefinition.ClassTypeVar", "3:9-3:10", "f") + , ("Refactor.RenameDefinition.TypeOperators", "4:13-4:15", "x1") + , ("Refactor.RenameDefinition.NoPrelude", "4:1-4:2", "map") + , ("Refactor.RenameDefinition.UnusedDef", "3:1-3:2", "map") + , ("Refactor.RenameDefinition.SameCtorAndType", "3:6-3:13", "P2D") + , ("Refactor.RenameDefinition.RoleAnnotation", "4:11-4:12", "AA") + , ("Refactor.RenameDefinition.TypeBracket", "6:6-6:7", "B") + , ("Refactor.RenameDefinition.ValBracket", "8:11-8:12", "B") + , ("Refactor.RenameDefinition.FunnyDo", "3:1-3:2", "aaa") + , ("Refactor.RenameDefinition.RenameModuleAlias", "3:21-3:23", "L") + , ("Refactor.RenameDefinition.MergeFields", "3:14-3:15", "y") + , ("Refactor.RenameDefinition.MergeFields_RenameY", "3:34-3:35", "x") + , ("Refactor.RenameDefinition.PatternSynonym", "6:9", "ArrowAppl") + , ("Refactor.RenameDefinition.PatternSynonymTypeSig", "6:9", "ArrowAppl") + , ("Refactor.RenameDefinition.QualImport", "5:1", "intercalate") + ] + +wrongRenameDefinitionTests = + [ ("Refactor.RenameDefinition.LibraryFunction", "4:5-4:7", "identity") + , ("Refactor.RenameDefinition.NameClash", "5:9-5:10", "h") + , ("Refactor.RenameDefinition.NameClash", "3:1-3:2", "map") + , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "F") + , ("Refactor.RenameDefinition.WrongName", "4:1-4:2", "++") + , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", "x") + , ("Refactor.RenameDefinition.WrongName", "7:6-7:7", ":+:") + , ("Refactor.RenameDefinition.WrongName", "7:10-7:11", "x") + , ("Refactor.RenameDefinition.WrongName", "9:6-9:7", "A") + , ("Refactor.RenameDefinition.WrongName", "9:19-9:19", ".+++.") + , ("Refactor.RenameDefinition.WrongName", "11:3-11:3", ":+++:") + , ("Refactor.RenameDefinition.IllegalQualRename", "4:30-4:34", "Bl") + , ("Refactor.RenameDefinition.CrossRename", "4:1-4:2", "g") + , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y2") -- fld in the same ctor + , ("Refactor.RenameDefinition.MergeFields", "5:30-5:32", "x2") -- fld in the same ctor + , ("Refactor.RenameDefinition.MergeFields", "5:16-5:18", "y") -- fld belongs to other type + , ("Refactor.RenameDefinition.MergeFields", "7:16-7:18", "y3") -- types does not match + , ("Refactor.RenameDefinition.MergeFields", "7:38-7:40", "x3") -- types does not match + , ("Refactor.RenameDefinition.QualImportAlso", "6:1", "intercalate") -- there is a non-qualified import + ] + +extractBindingTests = + [ ("Refactor.ExtractBinding.Simple", "3:19-3:27", "exaggerate") + , ("Refactor.ExtractBinding.Parentheses", "3:23-3:62", "sqDistance") + , ("Refactor.ExtractBinding.AddToExisting", "3:10-3:12", "b") + , ("Refactor.ExtractBinding.LocalDefinition", "4:13-4:16", "y") + , ("Refactor.ExtractBinding.ClassInstance", "6:30-6:35", "g") + , ("Refactor.ExtractBinding.ListComprehension", "5:25-5:39", "notDivisible") + , ("Refactor.ExtractBinding.Records", "5:5-5:39", "plus") + , ("Refactor.ExtractBinding.RecordWildcards", "6:5-6:27", "plus") + , ("Refactor.ExtractBinding.ExistingLocalDef", "3:5-3:10", "a") + , ("Refactor.ExtractBinding.Indentation", "3:12-3:18", "extracted") + , ("Refactor.ExtractBinding.IndentationMultiLine", "3:12-3:18", "extracted") + , ("Refactor.ExtractBinding.IndentationOperator", "3:13-3:20", "extracted") + , ("Refactor.ExtractBinding.ExtractedFormatting", "4:5-5:7", "extracted") + , ("Refactor.ExtractBinding.LeftSection", "3:5-3:8", "f") + , ("Refactor.ExtractBinding.RightSection", "3:7-3:10", "f") + , ("Refactor.ExtractBinding.SectionWithLocals", "6:13-6:24", "f") + , ("Refactor.ExtractBinding.SectionInfix", "3:5-3:12", "f") + , ("Refactor.ExtractBinding.AssocOp", "3:9-3:14", "b") + , ("Refactor.ExtractBinding.AssocOpRightAssoc", "3:5-3:12", "g") + , ("Refactor.ExtractBinding.AssocOpMiddle", "3:9-3:14", "b") + , ("Refactor.ExtractBinding.SiblingDefs", "7:9-7:10", "a") + , ("Refactor.ExtractBinding.Case", "3:26-3:31", "g") + ] + +wrongExtractBindingTests = + [ ("Refactor.ExtractBinding.TooSimple", "3:19-3:20", "x") + , ("Refactor.ExtractBinding.NameConflict", "3:19-3:27", "stms") + , ("Refactor.ExtractBinding.ViewPattern", "4:4-4:11", "idid") + ] + +inlineBindingTests = + [ ("Refactor.InlineBinding.Simplest", "4:1-4:2") + , ("Refactor.InlineBinding.Nested", "4:1-4:2") + , ("Refactor.InlineBinding.Local", "4:9-4:10") + , ("Refactor.InlineBinding.LocalNested", "5:17-5:18") + , ("Refactor.InlineBinding.WithLocals", "4:1-4:2") + , ("Refactor.InlineBinding.MultiMatch", "4:1-4:2") + , ("Refactor.InlineBinding.SimpleMultiMatch", "4:1-4:2") + , ("Refactor.InlineBinding.AlreadyApplied", "4:1-4:2") + , ("Refactor.InlineBinding.PatternMatched", "4:1-4:2") + , ("Refactor.InlineBinding.MultiApplied", "4:1-4:2") + , ("Refactor.InlineBinding.Operator", "4:1-4:2") + , ("Refactor.InlineBinding.MultiMatchGuarded", "4:1-4:2") + , ("Refactor.InlineBinding.RemoveSignatures", "5:1-5:2") + , ("Refactor.InlineBinding.FilterSignatures", "5:1-5:2") + , ("Refactor.InlineBinding.LetBind", "3:9-3:10") + , ("Refactor.InlineBinding.LetStmt", "3:12-3:13") + , ("Refactor.InlineBinding.LetGuard", "3:9-3:10") + ] + +wrongInlineBindingTests = + [ ("Refactor.InlineBinding.Recursive", "4:1-4:2") + , ("Refactor.InlineBinding.InExportList", "4:1-4:2") + , ("Refactor.InlineBinding.NotOccurring", "3:1") + ] + +floatOutTests = + [ ("Refactor.FloatOut.ToTopLevel", "4:10") + , ("Refactor.FloatOut.FloatLocals", "5:18") + , ("Refactor.FloatOut.MoveSignature", "5:10") + , ("Refactor.FloatOut.MoveFixity", "5:11-5:14") + , ("Refactor.FloatOut.NoCollosion", "5:18") + ] + +wrongFloatOutTests = + [ ("Refactor.FloatOut.NameCollosion", "4:10") + , ("Refactor.FloatOut.NameCollosionWithImport", "4:11") + , ("Refactor.FloatOut.NameCollosionWithLocal", "5:18") + , ("Refactor.FloatOut.SharedSignature", "5:10") + , ("Refactor.FloatOut.ImplicitLocal", "4:10") + , ("Refactor.FloatOut.ImplicitParam", "4:10") + ] + +multiModuleTests = + [ ("RenameDefinition 5:5-5:6 bb", "A", "Refactor" "RenameDefinition" "MultiModule", []) + , ("RenameDefinition 1:8-1:9 C", "B", "Refactor" "RenameDefinition" "RenameModule", ["B"]) + , ("RenameDefinition 3:8-3:9 C", "A", "Refactor" "RenameDefinition" "RenameModule", ["B"]) + , ("RenameDefinition 6:1-6:9 hello", "Use", "Refactor" "RenameDefinition" "SpliceDecls", []) + , ("RenameDefinition 5:1-5:5 exprSplice", "Define", "Refactor" "RenameDefinition" "SpliceExpr", []) + , ("RenameDefinition 6:1-6:4 spliceTyp", "Define", "Refactor" "RenameDefinition" "SpliceType", []) + ] + +wrongMultiModuleTests = + [ ("InlineBinding 3:1-3:2", "A", "Refactor" "InlineBinding" "AppearsInAnother", []) + ] + +makeMultiModuleTest :: ((String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO ()) + -> (String, String, String, [String]) -> TestTree +makeMultiModuleTest checker test@(refact, mod, root, _) + = testCase (root ++ ":" ++ mod) + $ do res <- performRefactors refact (rootDir root) [] mod + checker test res + +checkMultiResults :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () +checkMultiResults _ (Left err) = assertFailure $ "The transformation failed : " ++ err +checkMultiResults test@(_,_,root,_) (Right ((name, Just mod):rest)) = + do expected <- loadExpected False ((rootDir root) ++ "_res") name + assertEqual "The transformed result is not what is expected" (standardizeLineEndings expected) + (standardizeLineEndings mod) + checkMultiResults test (Right rest) +checkMultiResults (r,m,root,removed) (Right ((name, Nothing) : rest)) = checkMultiResults (r,m,root,delete name removed) (Right rest) +checkMultiResults (_,_,_,[]) (Right []) = return () +checkMultiResults (_,_,_,removed) (Right []) + = assertFailure $ "Modules has not been marked as removed: " ++ concat (intersperse ", " removed) + +checkMultiFail :: (String, String, String, [String]) -> Either String [(String, Maybe String)] -> IO () +checkMultiFail _ (Left _) = return () +checkMultiFail _ (Right _) = assertFailure "The transformation should fail." + +createTest :: String -> [String] -> String -> TestTree +createTest refactoring args mod + = testCase mod $ checkCorrectlyTransformed (refactoring ++ (concatMap (" "++) args)) rootDir mod + +createFailTest :: String -> [String] -> String -> TestTree +createFailTest refactoring args mod + = testCase mod $ checkTransformFails (refactoring ++ (concatMap (" "++) args)) rootDir mod + +makeOrganizeImportsTest :: String -> TestTree +makeOrganizeImportsTest = createTest "OrganizeImports" [] + +makeGenerateSignatureTest :: (String, String) -> TestTree +makeGenerateSignatureTest (mod, rng) = createTest "GenerateSignature" [rng] mod + +makeGenerateExportsTest :: String -> TestTree +makeGenerateExportsTest mod = createTest "GenerateExports" [] mod + +makeRenameDefinitionTest :: (String, String, String) -> TestTree +makeRenameDefinitionTest (mod, rng, newName) = createTest "RenameDefinition" [rng, newName] mod + +makeWrongRenameDefinitionTest :: (String, String, String) -> TestTree +makeWrongRenameDefinitionTest (mod, rng, newName) = createFailTest "RenameDefinition" [rng, newName] mod + +makeWrongGenerateSigTest :: (String, String) -> TestTree +makeWrongGenerateSigTest (mod, rng) = createFailTest "GenerateSignature" [rng] mod + +makeExtractBindingTest :: (String, String, String) -> TestTree +makeExtractBindingTest (mod, rng, newName) = createTest "ExtractBinding" [rng, newName] mod + +makeWrongExtractBindingTest :: (String, String, String) -> TestTree +makeWrongExtractBindingTest (mod, rng, newName) = createFailTest "ExtractBinding" [rng, newName] mod + +makeInlineBindingTest :: (String, String) -> TestTree +makeInlineBindingTest (mod, rng) = createTest "InlineBinding" [rng] mod + +makeWrongInlineBindingTest :: (String, String) -> TestTree +makeWrongInlineBindingTest (mod, rng) = createFailTest "InlineBinding" [rng] mod + +makeFloatOutTest :: (String, String) -> TestTree +makeFloatOutTest (mod, rng) = createTest "FloatOut" [rng] mod + +makeWrongFloatOutTest :: (String, String) -> TestTree +makeWrongFloatOutTest (mod, rng) = createFailTest "FloatOut" [rng] mod + +checkCorrectlyTransformed :: String -> String -> String -> IO () +checkCorrectlyTransformed command workingDir moduleName + = do expected <- loadExpected True workingDir moduleName + res <- performRefactor command workingDir [] moduleName + assertEqual "The transformed result is not what is expected" (Right (standardizeLineEndings expected)) + (mapRight standardizeLineEndings res) + +testRefactor :: (UnnamedModule IdDom -> LocalRefactoring IdDom) -> String -> IO (Either String String) +testRefactor refact moduleName + = runGhc (Just libdir) $ do + initGhcFlags + useDirs [rootDir] + mod <- loadModule rootDir moduleName >>= parseTyped + res <- runRefactor (SourceFileKey (rootDir moduleSourceFile moduleName) moduleName, mod) [] (localRefactoring $ refact mod) + case res of Right r -> return $ Right $ prettyPrint $ snd $ fromContentChanged $ head r + Left err -> return $ Left err + +checkTransformFails :: String -> String -> String -> IO () +checkTransformFails command workingDir moduleName + = do res <- performRefactor command workingDir [] moduleName + assertBool "The transform should fail for the given input" (isLeft res) + +loadExpected :: Bool -> String -> String -> IO String +loadExpected resSuffix workingDir moduleName = + do -- need to use binary or line endings will be translated + expectedHandle <- openBinaryFile (workingDir map (\case '.' -> pathSeparator; c -> c) moduleName ++ (if resSuffix then "_res" else "") ++ ".hs") ReadMode + hSetEncoding expectedHandle utf8 + 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 + sourceFiles <- filter ((== ".hs") . takeExtension) <$> listDirectory workingDir + let sourceModules = map dropExtension sourceFiles + runGhc (Just libdir) $ do + initGhcFlagsForTest + useFlags flags + useDirs [workingDir] + setTargets $ map (\mod -> (Target (TargetModule (GHC.mkModuleName mod)) True Nothing)) sourceModules + load LoadAllTargets + allMods <- getModuleGraph + selectedMod <- getModSummary (GHC.mkModuleName target) + let otherModules = filter (not . (\ms -> ms_mod ms == ms_mod selectedMod && ms_hsc_src ms == ms_hsc_src selectedMod)) allMods + targetMod <- parseTyped selectedMod + otherMods <- mapM parseTyped otherModules + res <- performCommand builtinRefactorings (splitOn " " command) + (Right (SourceFileKey (workingDir moduleSourceFile target) target, targetMod)) + (zip (map keyFromMS otherModules) otherMods) + return $ (\case Right r -> Right $ (map (\case ContentChanged (n,m) -> (n ^. sfkModuleName, Just $ prettyPrint m) + ModuleCreated n m _ -> (n, Just $ prettyPrint m) + ModuleRemoved m -> (m, Nothing) + )) r + Left l -> Left l) + $ res + +type ParsedModule = Ann AST.UModule (Dom RdrName) SrcTemplateStage + +parseAST :: ModSummary -> Ghc ParsedModule +parseAST modSum = do + let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum + hasCppExtension = Cpp `xopt` ms_hspp_opts modSum + ms = if hasStaticFlags then forceAsmGen modSum else modSum + p <- parseModule ms + sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) + let annots = pm_annotations p + (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) + <$> (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms $ pm_parsed_source p) + +type RenamedModule = Ann AST.UModule (Dom GHC.Name) SrcTemplateStage + +parseRenamed :: ModSummary -> Ghc RenamedModule +parseRenamed modSum = do + let hasStaticFlags = StaticPointers `xopt` ms_hspp_opts modSum + hasCppExtension = Cpp `xopt` ms_hspp_opts modSum + ms = if hasStaticFlags then forceAsmGen modSum else modSum + p <- parseModule ms + sourceOrigin <- if hasCppExtension then liftIO $ hGetStringBuffer (getModSumOrig ms) + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) + tc <- typecheckModule p + let annots = pm_annotations p + (if hasCppExtension then prepareASTCpp else prepareAST) sourceOrigin . placeComments (fst annots) (getNormalComments $ snd annots) + <$> (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p) + runTrf (fst annots) (getPragmaComments $ snd annots) + $ trfModuleRename ms parseTrf + (fromJust $ tm_renamed_source tc) + (pm_parsed_source p)) + +performRefactor :: String -> FilePath -> [String] -> String -> IO (Either String String) +performRefactor command workingDir flags target = + runGhc (Just libdir) $ do + useFlags flags + ((\case Right r -> Right (newContent r); Left l -> Left l) <$> (refact =<< parseTyped =<< loadModule workingDir target)) + where refact m = performCommand builtinRefactorings (splitOn " " command) + (Right (SourceFileKey (workingDir moduleSourceFile target) target,m)) [] + newContent (ContentChanged (_, newContent) : _) = prettyPrint newContent + newContent ((ModuleCreated _ newContent _) : _) = prettyPrint newContent + newContent (_ : ress) = newContent ress